Rakka/Wiki/Parser.hs

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