Rakka/Wiki/Parser.hs

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