Rakka/Wiki/Parser.hs

   1 module Rakka.Wiki.Parser
   2     ( CommandTypeOf
   3     , wikiPage
   4     )
   5     where
   6
   7 import           Data.Maybe
   8 import           Rakka.Wiki
   9 import           Text.ParserCombinators.Parsec
  10
  11
  12 type CommandTypeOf = String -> Maybe CommandType
  13
  14
  15 wikiPage :: CommandTypeOf -> Parser WikiPage
  16 wikiPage cmdTypeOf
  17     = do xs <- many (blockElement cmdTypeOf)
  18          skipMany ( comment
  19                     <|>
  20                     (newline >> return ())
  21                   )
  22          eof
  23          return xs
  24
  25
  26 blockElement :: CommandTypeOf -> Parser BlockElement
  27 blockElement cmdTypeOf
  28     = try $ do skipMany ( comment
  29                           <|>
  30                           (newline >> return ())
  31                         )
  32                foldr (<|>) pzero [ heading
  33                                  , horizontalLine
  34                                  , listElement cmdTypeOf
  35                                  , definitionList cmdTypeOf
  36                                  , pdata
  37                                  , leadingSpaced cmdTypeOf
  38                                  , paragraph cmdTypeOf
  39                                  , blockCmd cmdTypeOf
  40                                  ]
  41
  42
  43 heading :: Parser BlockElement
  44 heading = foldr (<|>) pzero (map heading' [1..5])
  45           <?>
  46           "heading"
  47     where
  48       heading' :: Int -> Parser BlockElement
  49       heading' n = do try $ do count n (char '=')
  50                                notFollowedBy (char '=')
  51                       ws
  52                       x  <- notFollowedBy (char '=') >> anyChar
  53                       xs <- manyTill anyChar (try $ ws >> ( count n (char '=')
  54                                                             <?>
  55                                                             ("trailing " ++ take n (repeat '='))
  56                                                           )
  57                                              )
  58                       ws
  59                       eol
  60                       return (Heading n (x:xs))
  61
  62
  63 horizontalLine :: Parser BlockElement
  64 horizontalLine = try ( do count 4 (char '-')
  65                           many (char '-')
  66                           ws
  67                           eol
  68                           return HorizontalLine
  69                      )
  70                  <?>
  71                  "horizontal line"
  72
  73
  74 listElement :: CommandTypeOf -> Parser BlockElement
  75 listElement cmdTypeOf = listElement' [] >>= return . List
  76     where
  77       listElement' :: [Char] -> Parser ListElement
  78       listElement' stack
  79           = do t  <- oneOf "*#"
  80                ws
  81                xs <- items (stack ++ [t])
  82                return (ListElement (toType t) xs)
  83
  84       -- ListItem の終了條件は、
  85       items :: [Char] -> Parser [ListItem]
  86       items stack = do xs     <- many1 $ inlineElement cmdTypeOf
  87                        nested <- option Nothing
  88                                  $ try $ do skipMany comment
  89                                             newline
  90                                             string stack
  91                                             listElement' stack >>= return . Just
  92                        rest <- items stack
  93                        return $ (map Right xs ++ map Left (catMaybes [nested])) : rest
  94                     <|>
  95                     (try $ do skipMany comment
  96                               newline
  97                               string stack
  98                               ws
  99                               items stack
 100                     )
 101                     <|>
 102                     return []
 103
 104       toType :: Char -> ListType
 105       toType '*' = Bullet
 106       toType '#' = Numbered
 107
 108
 109 definitionList :: CommandTypeOf -> Parser BlockElement
 110 definitionList cmdTypeOf = many1 definition >>= return . DefinitionList
 111     where
 112       definition :: Parser Definition
 113       definition = do char ';'
 114                       ws
 115                       tHead <- inlineElement cmdTypeOf
 116                       tRest <- term
 117                       d     <- description
 118                       return (Definition (tHead:tRest) d)
 119                    <?>
 120                    "definition list"
 121
 122       term :: Parser [InlineElement]
 123       term = (char ':' >> ws >> return [])
 124              <|>
 125              (newline >> char ':' >> ws >> return [])
 126              <|>
 127              do x  <- inlineElement cmdTypeOf
 128                 xs <- term
 129                 return (x:xs)
 130              <?>
 131              "term to be defined"
 132
 133       description :: Parser [InlineElement]
 134       description = do x  <- inlineElement cmdTypeOf
 135                        xs <- description
 136                        return (x:xs)
 137                     <|>
 138                     try ( do newline
 139                              char ':'
 140                              ws
 141                              xs <- description
 142                              return (Text "\n" : xs)
 143                         )
 144                     <|>
 145                     (newline >> return [])
 146                     <|>
 147                     (eof >> return [])
 148                     <?>
 149                     "description of term"
 150
 151
 152 pdata :: Parser BlockElement
 153 pdata = do try (string "<![PDATA[")
 154            many (oneOf " \t\n")
 155            x <- pdata'
 156            return (Preformatted [Text x])
 157     where
 158       pdata' :: Parser String
 159       pdata' = do try (many (oneOf " \t\n") >> string "]]>")
 160                   return []
 161                <|>
 162                do x  <- anyChar
 163                   xs <- pdata'
 164                   return (x:xs)
 165
 166
 167 leadingSpaced :: CommandTypeOf -> Parser BlockElement
 168 leadingSpaced cmdTypeOf = (char ' ' >> leadingSpaced' >>= return . Preformatted)
 169                           <?>
 170                           "leading space"
 171     where
 172       leadingSpaced' :: Parser [InlineElement]
 173       leadingSpaced' = do x  <- inlineElement cmdTypeOf
 174                           xs <- leadingSpaced'
 175                           return (x:xs)
 176                        <|>
 177                        try ( newline
 178                              >>
 179                              char ' '
 180                              >>
 181                              leadingSpaced'
 182                              >>=
 183                              return . (Text "\n" :)
 184                            )
 185                        <|>
 186                        return []
 187
 188
 189 blockCommand :: Parser BlockElement
 190 blockCommand = pzero -- not implemented
 191
 192
 193 paragraph :: CommandTypeOf -> Parser BlockElement
 194 paragraph cmdTypeOf = paragraph' >>= return . Paragraph
 195     where
 196       paragraph' :: Parser [InlineElement]
 197       paragraph' = do x  <- inlineElement cmdTypeOf
 198                       xs <- try ( do newline
 199                                      eof
 200                                      return []
 201                                   -- \n で文字列が終はってゐたら、ここ
 202                                   -- で終了。
 203                                 )
 204                             <|>
 205                             try ( do newline
 206                                      ((oneOf ('\n':blockSymbols) >> pzero) <|> return ())
 207                                      ys <- (paragraph' <|> return [])
 208                                      return (Text "\n" : ys)
 209                                   -- \n があり、その次に \n または
 210                                   -- blockSymbols があれば、fail して
 211                                   -- 最初の newline を讀んだ所まで卷き
 212                                   -- 戻す。
 213                                 )
 214                             <|>
 215                             paragraph'
 216                             -- それ以外の場合は次の inlineElement から
 217                             -- を讀んで見る。但し一つも無くても良い。
 218                             <|>
 219                             return [] -- 全部失敗したらここで終了。
 220                       return (x:xs)
 221
 222
 223 blockCmd :: CommandTypeOf -> Parser BlockElement
 224 blockCmd cmdTypeOf
 225     = (try $ do (tagName, tagAttrs) <- openTag
 226                 case cmdTypeOf tagName of
 227                   Just BlockCommandType
 228                       -> do xs <- contents
 229                             closeTag tagName
 230                             return $ BlockCmd $ BlockCommand {
 231                                          bCmdName       = tagName
 232                                        , bCmdAttributes = tagAttrs
 233                                        , bCmdContents   = xs
 234                                        }
 235                   _   -> pzero
 236       )
 237       <|>
 238       (try $ do (tagName, tagAttrs) <- emptyTag
 239                 case cmdTypeOf tagName of
 240                   Just BlockCommandType
 241                       -> return $ BlockCmd $ BlockCommand {
 242                                          bCmdName       = tagName
 243                                        , bCmdAttributes = tagAttrs
 244                                        , bCmdContents   = []
 245                                        }
 246                   _   -> pzero
 247       )
 248       <?>
 249       "block command"
 250     where
 251       contents :: Parser [BlockElement]
 252       contents = do x  <- blockElement cmdTypeOf
 253                     xs <- contents
 254                     return (x:xs)
 255                  <|>
 256                  (newline >> contents)
 257                  <|>
 258                  (comment >> contents)
 259                  <|>
 260                  return []
 261
 262
 263 inlineElement :: CommandTypeOf -> Parser InlineElement
 264 inlineElement cmdTypeOf
 265     = try $ do skipMany comment
 266                foldr (<|>) pzero [ cdata
 267                                  , apostrophes cmdTypeOf
 268                                  , text
 269                                  , pageLink
 270                                  , inlineCmd cmdTypeOf
 271                                  ]
 272
 273
 274 cdata :: Parser InlineElement
 275 cdata = try (string "<![CDATA[") >> cdata' >>= return . Text
 276     where
 277       cdata' :: Parser String
 278       cdata' = do try (string "]]>")
 279                   return []
 280                <|>
 281                do x  <- anyChar
 282                   xs <- cdata'
 283                   return (x:xs)
 284
 285
 286 text :: Parser InlineElement
 287 text = ( char ':'
 288          >>
 289          many (noneOf ('\n':inlineSymbols))
 290          >>=
 291          return . Text . (':' :)
 292          -- 定義リストとの關係上、コロンは先頭にしか來れない。
 293        )
 294        <|>
 295        ( many1 (noneOf ('\n':inlineSymbols))
 296          >>=
 297          return . Text
 298        )
 299        <?>
 300        "text"
 301
 302
 303 apostrophes :: CommandTypeOf -> Parser InlineElement
 304 apostrophes cmdTypeOf = foldr (<|>) pzero (map try [apos1, apos2, apos3, apos4, apos5])
 305     where
 306       apos1 = apos 1 >> return (Text "'")
 307
 308       apos2 = do apos 2
 309                  xs <- many1 $ inlineElement cmdTypeOf
 310                  apos 2
 311                  return (Italic xs)
 312
 313       apos3 = do apos 3
 314                  xs <- many1 $ inlineElement cmdTypeOf
 315                  apos 3
 316                  return (Bold xs)
 317
 318       apos4 = apos 4 >> return (Text "'")
 319
 320       apos5 = do apos 5
 321                  xs <- many1 $ inlineElement cmdTypeOf
 322                  apos 5
 323                  return (Italic [Bold xs])
 324
 325       apos :: Int -> Parser ()
 326       apos n = count n (char '\'') >> notFollowedBy (char '\'')
 327
 328
 329 pageLink :: Parser InlineElement
 330 pageLink = do try (string "[[")
 331               page     <- option Nothing
 332                           (many1 (noneOf "#|]") >>= return . Just)
 333               fragment <- option Nothing
 334                           (char '#' >> many1 (noneOf "|]") >>= return . Just)
 335               text     <- option Nothing
 336                           (char '|' >> many1 (satisfy (/= ']')) >>= return . Just)
 337
 338               case (page, fragment) of
 339                 (Nothing, Nothing) -> pzero
 340                 (_, _)             -> return ()
 341
 342               string "]]"
 343               return $ PageLink page fragment text
 344            <?>
 345            "page link"
 346
 347
 348 inlineCmd :: CommandTypeOf -> Parser InlineElement
 349 inlineCmd cmdTypeOf
 350     = (try $ do (tagName, tagAttrs) <- openTag
 351                 case cmdTypeOf tagName of
 352                   Just InlineCommandType
 353                       -> do xs <- contents
 354                             closeTag tagName
 355                             return $ InlineCmd $ InlineCommand {
 356                                          iCmdName       = tagName
 357                                        , iCmdAttributes = tagAttrs
 358                                        , iCmdContents   = xs
 359                                        }
 360                   _   -> pzero
 361       )
 362       <|>
 363       (try $ do (tagName, tagAttrs) <- emptyTag
 364                 case cmdTypeOf tagName of
 365                   Just InlineCommandType
 366                       -> return $ InlineCmd $ InlineCommand {
 367                                          iCmdName       = tagName
 368                                        , iCmdAttributes = tagAttrs
 369                                        , iCmdContents   = []
 370                                        }
 371                   _   -> pzero
 372       )
 373       <?>
 374       "inline command"
 375     where
 376       contents :: Parser [InlineElement]
 377       contents = do x  <- inlineElement cmdTypeOf
 378                     xs <- contents
 379                     return (x:xs)
 380                  <|>
 381                  (comment >> contents)
 382                  <|>
 383                  (newline >> contents >>= return . (Text "\n" :))
 384                  <|>
 385                  return []
 386
 387
 388 openTag :: Parser (String, [Attribute])
 389 openTag = try $ do char '<'
 390                    many space
 391                    name  <- many1 letter
 392                    many space
 393                    attrs <- many $ do attr <- tagAttr
 394                                       many space
 395                                       return attr
 396                    char '>'
 397                    return (name, attrs)
 398
 399
 400 emptyTag :: Parser (String, [Attribute])
 401 emptyTag = try $ do char '<'
 402                     many space
 403                     name  <- many1 letter
 404                     many space
 405                     attrs <- many $ do attr <- tagAttr
 406                                        many space
 407                                        return attr
 408                     char '/'
 409                     many space
 410                     char '>'
 411                     return (name, attrs)
 412
 413
 414 closeTag :: String -> Parser ()
 415 closeTag name = try $ do char '<'
 416                          many space
 417                          char '/'
 418                          many space
 419                          string name
 420                          many space
 421                          char '>'
 422                          return ()
 423
 424
 425 tagAttr :: Parser (String, String)
 426 tagAttr = do name  <- many1 letter
 427              char '='
 428              char '"'
 429              value <- many (satisfy (/= '"'))
 430              char '"'
 431              return (name, value)
 432
 433
 434 comment :: Parser ()
 435 comment = (try (string "<!--") >> skipTillEnd 1)
 436           <?>
 437           "comment"
 438     where
 439       skipTillEnd :: Int -> Parser ()
 440       skipTillEnd level = ( (try (string "<!--") >> skipTillEnd (level + 1))
 441                             <|>
 442                             (try (string "-->") >> case level of
 443                                                      1 -> return ()
 444                                                      n -> skipTillEnd (n - 1))
 445                             <|>
 446                             (anyChar >> skipTillEnd level)
 447                           )
 448
 449
 450 blockSymbols :: [Char]
 451 blockSymbols = " =-*#;<"
 452
 453
 454 inlineSymbols :: [Char]
 455 inlineSymbols = "<[:'"
 456
 457 -- white space
 458 ws :: Parser ()
 459 ws = skipMany ( (oneOf " \t" >> return ())
 460                 <|>
 461                 comment
 462               )
 463
 464 -- end of line
 465 eol :: Parser ()
 466 eol = ( (newline >> return ())
 467         <|>
 468         eof
 469       )