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