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
   9 import           Rakka.Wiki
  10 import           Text.ParserCombinators.Parsec
  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                                  , pdata
  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' [] >>= return . List
  77     where
  78       listElement' :: [Char] -> Parser ListElement
  79       listElement' stack
  80           = do t  <- oneOf "*#"
  81                ws
  82                xs <- items (stack ++ [t])
  83                return (ListElement (toType t) xs)
  84
  85       -- ListItem の終了條件は、
  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                                             listElement' stack >>= return . Just
  93                        rest <- items stack
  94                        return $ (map Right xs ++ map Left (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
 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 pdata :: Parser BlockElement
 154 pdata = do try (string "<![PDATA[")
 155            many (oneOf " \t\n")
 156            x <- pdata'
 157            return (Preformatted [Text x])
 158     where
 159       pdata' :: Parser String
 160       pdata' = do try (many (oneOf " \t\n") >> string "]]>")
 161                   return []
 162                <|>
 163                do x  <- anyChar
 164                   xs <- pdata'
 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 blockCommand :: Parser BlockElement
 191 blockCommand = pzero -- not implemented
 192
 193
 194 paragraph :: CommandTypeOf -> Parser BlockElement
 195 paragraph cmdTypeOf = paragraph' >>= return . Paragraph
 196     where
 197       paragraph' :: Parser [InlineElement]
 198       paragraph' = do x  <- inlineElement cmdTypeOf
 199                       xs <- try ( do newline
 200                                      eof
 201                                      return []
 202                                   -- \n で文字列が終はってゐたら、ここ
 203                                   -- で終了。
 204                                 )
 205                             <|>
 206                             try ( do newline
 207                                      ((oneOf ('\n':blockSymbols) >> pzero) <|> return ())
 208                                      ys <- (paragraph' <|> return [])
 209                                      return (Text "\n" : ys)
 210                                   -- \n があり、その次に \n または
 211                                   -- blockSymbols があれば、fail して
 212                                   -- 最初の newline を讀んだ所まで卷き
 213                                   -- 戻す。
 214                                 )
 215                             <|>
 216                             paragraph'
 217                             -- それ以外の場合は次の inlineElement から
 218                             -- を讀んで見る。但し一つも無くても良い。
 219                             <|>
 220                             return [] -- 全部失敗したらここで終了。
 221                       return (x:xs)
 222
 223
 224 blockCmd :: CommandTypeOf -> Parser BlockElement
 225 blockCmd cmdTypeOf
 226     = (try $ do (tagName, tagAttrs) <- openTag
 227                 case cmdTypeOf tagName of
 228                   Just BlockCommandType
 229                       -> do xs <- contents
 230                             closeTag tagName
 231                             return $ BlockCmd $ BlockCommand {
 232                                          bCmdName       = tagName
 233                                        , bCmdAttributes = tagAttrs
 234                                        , bCmdContents   = xs
 235                                        }
 236
 237                   Just InlineCommandType
 238                       -> pzero
 239
 240                   _   -> return $ undefinedCmdErr tagName
 241       )
 242       <|>
 243       (try $ do (tagName, tagAttrs) <- emptyTag
 244                 case cmdTypeOf tagName of
 245                   Just BlockCommandType
 246                       -> return $ BlockCmd $ BlockCommand {
 247                                          bCmdName       = tagName
 248                                        , bCmdAttributes = tagAttrs
 249                                        , bCmdContents   = []
 250                                        }
 251
 252                   Just InlineCommandType
 253                       -> pzero
 254
 255                   _   -> return $ undefinedCmdErr tagName
 256       )
 257       <?>
 258       "block command"
 259     where
 260       contents :: Parser [BlockElement]
 261       contents = do x  <- blockElement cmdTypeOf
 262                     xs <- contents
 263                     return (x:xs)
 264                  <|>
 265                  (newline >> contents)
 266                  <|>
 267                  (comment >> contents)
 268                  <|>
 269                  return []
 270
 271       undefinedCmdErr :: String -> BlockElement
 272       undefinedCmdErr name
 273           = Div [("class", "error")]
 274             [ Paragraph [Text ("The command `" ++ name ++ "' is not defined. " ++
 275                                "Make sure you haven't mistyped.")
 276                         ]
 277             ]
 278
 279
 280 inlineElement :: CommandTypeOf -> Parser InlineElement
 281 inlineElement cmdTypeOf
 282     = try $ do skipMany comment
 283                foldr (<|>) pzero [ cdata
 284                                  , apostrophes cmdTypeOf
 285                                  , text
 286                                  , objLink
 287                                  , pageLink
 288                                  , extLink
 289                                  , inlineCmd cmdTypeOf
 290                                  ]
 291
 292
 293 cdata :: Parser InlineElement
 294 cdata = try (string "<![CDATA[") >> cdata' >>= return . Text
 295     where
 296       cdata' :: Parser String
 297       cdata' = do try (string "]]>")
 298                   return []
 299                <|>
 300                do x  <- anyChar
 301                   xs <- cdata'
 302                   return (x:xs)
 303
 304
 305 text :: Parser InlineElement
 306 text = ( char ':'
 307          >>
 308          many (noneOf ('\n':inlineSymbols))
 309          >>=
 310          return . Text . (':' :)
 311          -- 定義リストとの關係上、コロンは先頭にしか來れない。
 312        )
 313        <|>
 314        ( many1 (noneOf ('\n':inlineSymbols))
 315          >>=
 316          return . Text
 317        )
 318        <?>
 319        "text"
 320
 321
 322 apostrophes :: CommandTypeOf -> Parser InlineElement
 323 apostrophes cmdTypeOf = foldr (<|>) pzero (map try [apos1, apos2, apos3, apos4, apos5])
 324     where
 325       apos1 = apos 1 >> return (Text "'")
 326
 327       apos2 = do apos 2
 328                  xs <- many1 $ inlineElement cmdTypeOf
 329                  apos 2
 330                  return (Italic xs)
 331
 332       apos3 = do apos 3
 333                  xs <- many1 $ inlineElement cmdTypeOf
 334                  apos 3
 335                  return (Bold xs)
 336
 337       apos4 = apos 4 >> return (Text "'")
 338
 339       apos5 = do apos 5
 340                  xs <- many1 $ inlineElement cmdTypeOf
 341                  apos 5
 342                  return (Italic [Bold xs])
 343
 344       apos :: Int -> Parser ()
 345       apos n = count n (char '\'') >> notFollowedBy (char '\'')
 346
 347
 348 objLink :: Parser InlineElement
 349 objLink = do try (string "[[[")
 350              page <- many1 (noneOf "|]")
 351              text <- option Nothing
 352                      (char '|' >> many1 (satisfy (/= ']')) >>= return . Just)
 353              string "]]]"
 354              return $ ObjectLink page text
 355           <?>
 356           "object link"
 357
 358
 359 pageLink :: Parser InlineElement
 360 pageLink = do try (string "[[")
 361               page     <- option Nothing
 362                           (many1 (noneOf "#|]") >>= return . Just)
 363               fragment <- option Nothing
 364                           (char '#' >> many1 (noneOf "|]") >>= return . Just)
 365               text     <- option Nothing
 366                           (char '|' >> many1 (satisfy (/= ']')) >>= return . Just)
 367
 368               case (page, fragment) of
 369                 (Nothing, Nothing) -> pzero
 370                 (_, _)             -> return ()
 371
 372               string "]]"
 373               return $ PageLink page fragment text
 374            <?>
 375            "page link"
 376
 377
 378 extLink :: Parser InlineElement
 379 extLink = do char '['
 380              uriStr <- many1 (noneOf " \t]")
 381              skipMany (oneOf " \t")
 382              text <- option Nothing
 383                      (many1 (noneOf "]") >>= return . Just)
 384
 385              case parseURI uriStr of
 386                Just uri -> char ']' >> return (ExternalLink uri text)
 387                Nothing  -> pzero <?> "absolute URI"
 388           <?>
 389           "external link"
 390
 391
 392 inlineCmd :: CommandTypeOf -> Parser InlineElement
 393 inlineCmd cmdTypeOf
 394     = (try $ do (tagName, tagAttrs) <- openTag
 395                 case cmdTypeOf tagName of
 396                   Just InlineCommandType
 397                       -> do xs <- contents
 398                             closeTag tagName
 399                             return $ InlineCmd $ InlineCommand {
 400                                          iCmdName       = tagName
 401                                        , iCmdAttributes = tagAttrs
 402                                        , iCmdContents   = xs
 403                                        }
 404                   _   -> pzero
 405       )
 406       <|>
 407       (try $ do (tagName, tagAttrs) <- emptyTag
 408                 case cmdTypeOf tagName of
 409                   Just InlineCommandType
 410                       -> return $ InlineCmd $ InlineCommand {
 411                                          iCmdName       = tagName
 412                                        , iCmdAttributes = tagAttrs
 413                                        , iCmdContents   = []
 414                                        }
 415                   _   -> pzero
 416       )
 417       <?>
 418       "inline command"
 419     where
 420       contents :: Parser [InlineElement]
 421       contents = do x  <- inlineElement cmdTypeOf
 422                     xs <- contents
 423                     return (x:xs)
 424                  <|>
 425                  (comment >> contents)
 426                  <|>
 427                  (newline >> contents >>= return . (Text "\n" :))
 428                  <|>
 429                  return []
 430
 431
 432 openTag :: Parser (String, [Attribute])
 433 openTag = try $ do char '<'
 434                    many space
 435                    name  <- many1 letter
 436                    many space
 437                    attrs <- many $ do attr <- tagAttr
 438                                       many space
 439                                       return attr
 440                    char '>'
 441                    return (name, attrs)
 442
 443
 444 emptyTag :: Parser (String, [Attribute])
 445 emptyTag = try $ do char '<'
 446                     many space
 447                     name  <- many1 letter
 448                     many space
 449                     attrs <- many $ do attr <- tagAttr
 450                                        many space
 451                                        return attr
 452                     char '/'
 453                     many space
 454                     char '>'
 455                     return (name, attrs)
 456
 457
 458 closeTag :: String -> Parser ()
 459 closeTag name = try $ do char '<'
 460                          many space
 461                          char '/'
 462                          many space
 463                          string name
 464                          many space
 465                          char '>'
 466                          return ()
 467
 468
 469 tagAttr :: Parser (String, String)
 470 tagAttr = do name  <- many1 letter
 471              char '='
 472              char '"'
 473              value <- many (satisfy (/= '"'))
 474              char '"'
 475              return (name, value)
 476
 477
 478 comment :: Parser ()
 479 comment = (try (string "<!--") >> skipTillEnd 1)
 480           <?>
 481           "comment"
 482     where
 483       skipTillEnd :: Int -> Parser ()
 484       skipTillEnd level = ( (try (string "<!--") >> skipTillEnd (level + 1))
 485                             <|>
 486                             (try (string "-->") >> case level of
 487                                                      1 -> return ()
 488                                                      n -> skipTillEnd (n - 1))
 489                             <|>
 490                             (anyChar >> skipTillEnd level)
 491                           )
 492
 493
 494 blockSymbols :: [Char]
 495 blockSymbols = " =-*#;<"
 496
 497
 498 inlineSymbols :: [Char]
 499 inlineSymbols = "<[:'"
 500
 501 -- white space
 502 ws :: Parser ()
 503 ws = skipMany ( (oneOf " \t" >> return ())
 504                 <|>
 505                 comment
 506               )
 507
 508 -- end of line
 509 eol :: Parser ()
 510 eol = ( (newline >> return ())
 511         <|>
 512         eof
 513       )