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                                   -- 戻す。
 210
 211                                   -- FIXME: 本當にそのやうな動作になつ
 212                                   -- てゐるか？偶然動いてゐるだけではな
 213                                   -- いか？確かにこの實裝でユニットテス
 214                                   -- トは通るのだが、私の理解を越えてし
 215                                   -- まったやうだ。
 216                                 )
 217                             <|>
 218                             paragraph'
 219                             -- それ以外の場合は次の inlineElement から
 220                             -- を讀んで見る。但し一つも無くても良い。
 221                             <|>
 222                             return [] -- 全部失敗したらここで終了。
 223                       return (x:xs)
 224
 225
 226 blockCmd :: CommandTypeOf -> Parser BlockElement
 227 blockCmd cmdTypeOf
 228     = (try $ do (tagName, tagAttrs) <- openTag
 229                 case cmdTypeOf tagName of
 230                   Just BlockCommandType
 231                       -> do xs <- contents
 232                             closeTag tagName
 233                             return $ BlockCmd BlockCommand {
 234                                          bCmdName       = tagName
 235                                        , bCmdAttributes = tagAttrs
 236                                        , bCmdContents   = xs
 237                                        }
 238
 239                   Just InlineCommandType
 240                       -> pzero
 241
 242                   _   -> return $ undefinedCmdErr tagName
 243       )
 244       <|>
 245       (try $ do (tagName, tagAttrs) <- emptyTag
 246                 case cmdTypeOf tagName of
 247                   Just BlockCommandType
 248                       -> return $ BlockCmd BlockCommand {
 249                                          bCmdName       = tagName
 250                                        , bCmdAttributes = tagAttrs
 251                                        , bCmdContents   = []
 252                                        }
 253
 254                   Just InlineCommandType
 255                       -> pzero
 256
 257                   _   -> return $ undefinedCmdErr tagName
 258       )
 259       <?>
 260       "block command"
 261     where
 262       contents :: Parser [BlockElement]
 263       contents = do x  <- blockElement cmdTypeOf
 264                     xs <- contents
 265                     return (x:xs)
 266                  <|>
 267                  (newline >> contents)
 268                  <|>
 269                  (comment >> contents)
 270                  <|>
 271                  return []
 272
 273       undefinedCmdErr :: String -> BlockElement
 274       undefinedCmdErr name
 275           = Div [("class", "error")]
 276             [ Block (Paragraph [Text ("The command `" ++ name ++ "' is not defined. " ++
 277                                       "Make sure you haven't mistyped.")
 278                                ])
 279             ]
 280
 281
 282 inlineElement :: CommandTypeOf -> Parser InlineElement
 283 inlineElement cmdTypeOf
 284     = try $ do skipMany comment
 285                foldr (<|>) pzero [ nowiki
 286                                  , apostrophes cmdTypeOf
 287                                  , text
 288                                  , objLink
 289                                  , pageLink
 290                                  , extLink
 291                                  , inlineCmd cmdTypeOf
 292                                  ]
 293
 294
 295 nowiki :: Parser InlineElement
 296 nowiki = liftM Text (try (string "<!nowiki[") >> nowiki')
 297     where
 298       nowiki' :: Parser String
 299       nowiki' = do _ <- try (string "]>")
 300                    return []
 301                 <|>
 302                 do x  <- anyChar
 303                    xs <- nowiki'
 304                    return (x:xs)
 305
 306
 307 text :: Parser InlineElement
 308 text = liftM (Text . (':' :)) ( char ':'
 309                                 >>
 310                                 many (noneOf ('\n':inlineSymbols))
 311                               )
 312        -- 定義リストとの關係上、コロンは先頭にしか來られない。
 313        <|>
 314        liftM Text (many1 (noneOf ('\n':inlineSymbols)))
 315        <?>
 316        "text"
 317
 318
 319 apostrophes :: CommandTypeOf -> Parser InlineElement
 320 apostrophes cmdTypeOf = foldr (<|>) pzero (map try [apos1, apos2, apos3, apos4, apos5])
 321     where
 322       apos1 = apos 1 >> return (Text "'")
 323
 324       apos2 = do apos 2
 325                  xs <- many1 $ inlineElement cmdTypeOf
 326                  apos 2
 327                  return (Italic xs)
 328
 329       apos3 = do apos 3
 330                  xs <- many1 $ inlineElement cmdTypeOf
 331                  apos 3
 332                  return (Bold xs)
 333
 334       apos4 = apos 4 >> return (Text "'")
 335
 336       apos5 = do apos 5
 337                  xs <- many1 $ inlineElement cmdTypeOf
 338                  apos 5
 339                  return (Italic [Bold xs])
 340
 341       apos :: Int -> Parser ()
 342       apos n = count n (char '\'') >> notFollowedBy (char '\'')
 343
 344
 345 objLink :: Parser InlineElement
 346 objLink = do _     <- try (string "[[[")
 347              page  <- many1 (noneOf "|]")
 348              label <- option Nothing
 349                       (liftM Just (char '|' >> many1 (satisfy (/= ']'))))
 350              _     <- string "]]]"
 351              return $ ObjectLink page label
 352           <?>
 353           "object link"
 354
 355
 356 pageLink :: Parser InlineElement
 357 pageLink = do _        <- try (string "[[")
 358               page     <- option Nothing
 359                           (liftM Just (many1 (noneOf "#|]")))
 360               fragment <- option Nothing
 361                           (liftM Just (char '#' >> many1 (noneOf "|]")))
 362               label    <- option Nothing
 363                           (liftM Just (char '|' >> many1 (satisfy (/= ']'))))
 364
 365               case (page, fragment) of
 366                 (Nothing, Nothing) -> pzero
 367                 (_, _)             -> return ()
 368
 369               _ <- string "]]"
 370               return $ PageLink page fragment label
 371            <?>
 372            "page link"
 373
 374
 375 extLink :: Parser InlineElement
 376 extLink = do _      <- char '['
 377              uriStr <- many1 (noneOf " \t]")
 378              _      <- skipMany (oneOf " \t")
 379              label  <- option Nothing
 380                        (liftM Just (many1 (noneOf "]")))
 381
 382              case parseURI uriStr of
 383                Just uri -> char ']' >> return (ExternalLink uri label)
 384                Nothing  -> pzero <?> "absolute URI"
 385           <?>
 386           "external link"
 387
 388
 389 inlineCmd :: CommandTypeOf -> Parser InlineElement
 390 inlineCmd cmdTypeOf
 391     = (try $ do (tagName, tagAttrs) <- openTag
 392                 case cmdTypeOf tagName of
 393                   Just InlineCommandType
 394                       -> do xs <- contents
 395                             closeTag tagName
 396                             return $ InlineCmd InlineCommand {
 397                                          iCmdName       = tagName
 398                                        , iCmdAttributes = tagAttrs
 399                                        , iCmdContents   = xs
 400                                        }
 401                   _   -> pzero
 402       )
 403       <|>
 404       (try $ do (tagName, tagAttrs) <- emptyTag
 405                 case cmdTypeOf tagName of
 406                   Just InlineCommandType
 407                       -> return $ InlineCmd InlineCommand {
 408                                          iCmdName       = tagName
 409                                        , iCmdAttributes = tagAttrs
 410                                        , iCmdContents   = []
 411                                        }
 412                   _   -> pzero
 413       )
 414       <?>
 415       "inline command"
 416     where
 417       contents :: Parser [InlineElement]
 418       contents = do x  <- inlineElement cmdTypeOf
 419                     xs <- contents
 420                     return (x:xs)
 421                  <|>
 422                  (comment >> contents)
 423                  <|>
 424                  liftM (Text "\n" :) (newline >> contents)
 425                  <|>
 426                  return []
 427
 428
 429 openTag :: Parser (String, [Attribute])
 430 openTag = try $ do _     <- char '<'
 431                    _     <- many space
 432                    name  <- many1 letter
 433                    _     <- many space
 434                    attrs <- many $ do attr <- tagAttr
 435                                       _    <- many space
 436                                       return attr
 437                    _     <- char '>'
 438                    return (name, attrs)
 439
 440
 441 emptyTag :: Parser (String, [Attribute])
 442 emptyTag = try $ do _     <- char '<'
 443                     _     <- many space
 444                     name  <- many1 letter
 445                     _     <- many space
 446                     attrs <- many $ do attr <- tagAttr
 447                                        _    <- many space
 448                                        return attr
 449                     _     <- char '/'
 450                     _     <- many space
 451                     _     <- char '>'
 452                     return (name, attrs)
 453
 454
 455 closeTag :: String -> Parser ()
 456 closeTag name = try $ do _ <- char '<'
 457                          _ <- many space
 458                          _ <- char '/'
 459                          _ <- many space
 460                          _ <- string name
 461                          _ <- many space
 462                          _ <- char '>'
 463                          return ()
 464
 465
 466 tagAttr :: Parser (String, String)
 467 tagAttr = do name  <- many1 letter
 468              _     <- char '='
 469              _     <- char '"'
 470              value <- many (satisfy (/= '"'))
 471              _     <- char '"'
 472              return (name, value)
 473
 474
 475 comment :: Parser ()
 476 comment = (try (string "<!--") >> skipTillEnd 1)
 477           <?>
 478           "comment"
 479     where
 480       skipTillEnd :: Int -> Parser ()
 481       skipTillEnd level = (try (string "<!--") >> skipTillEnd (level + 1))
 482                           <|>
 483                           (try (string "-->") >> case level of
 484                                                    1 -> return ()
 485                                                    n -> skipTillEnd (n - 1))
 486                           <|>
 487                           (anyChar >> skipTillEnd level)
 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