Rakka/Wiki/Parser.hs

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