Rakka/Wiki/Parser.hs

   1 module Rakka.Wiki.Parser
   2     ( wikiPage
   3     )
   4     where
   5
   6 import           Data.Maybe
   7 import           Rakka.Wiki
   8 import           Text.ParserCombinators.Parsec
   9
  10
  11 wikiPage :: Parser WikiPage
  12 wikiPage = do xs <- many (try blockElement)
  13               skipMany ( comment
  14                          <|>
  15                          (newline >> return ())
  16                        )
  17               eof
  18               return xs
  19
  20
  21 blockElement :: Parser BlockElement
  22 blockElement = skipMany ( comment
  23                           <|>
  24                           (newline >> return ())
  25                         )
  26                >>
  27                ( heading
  28                  <|>
  29                  horizontalLine
  30                  <|>
  31                  listElement
  32                  <|>
  33                  definitionList
  34                  <|>
  35                  pdata
  36                  <|>
  37                  leadingSpaced
  38                  <|>
  39                  paragraph
  40                )
  41
  42
  43 heading :: Parser BlockElement
  44 heading = foldr (<|>) pzero (map heading' [1..5])
  45           <?>
  46           "heading"
  47     where
  48       heading' :: Int -> Parser BlockElement
  49       heading' n = do try $ do count n (char '=')
  50                                notFollowedBy (char '=')
  51                       ws
  52                       x  <- notFollowedBy (char '=') >> anyChar
  53                       xs <- manyTill anyChar (try $ ws >> ( count n (char '=')
  54                                                             <?>
  55                                                             ("trailing " ++ take n (repeat '='))
  56                                                           )
  57                                              )
  58                       ws
  59                       eol
  60                       return (Heading n (x:xs))
  61
  62
  63 horizontalLine :: Parser BlockElement
  64 horizontalLine = try ( do count 4 (char '-')
  65                           many (char '-')
  66                           ws
  67                           eol
  68                           return HorizontalLine
  69                      )
  70                  <?>
  71                  "horizontal line"
  72
  73
  74 listElement :: Parser BlockElement
  75 listElement = listElement' [] >>= return . List
  76     where
  77       listElement' :: [Char] -> Parser ListElement
  78       listElement' stack
  79           = try $ do t  <- oneOf "*#"
  80                      ws
  81                      xs <- items (stack ++ [t])
  82                      return (ListElement (toType t) xs)
  83
  84       -- ListItem の終了條件は、
  85       items :: [Char] -> Parser [ListItem]
  86       items stack = do xs     <- many1 inlineElement
  87                        nested <- option Nothing
  88                                  $ try $ do newline
  89                                             string stack
  90                                             listElement' stack >>= return . Just
  91                        rest <- items stack
  92                        return $ (map Right xs ++ map Left (catMaybes [nested])) : rest
  93                     <|>
  94                     (try $ do newline
  95                               string stack
  96                               ws
  97                               items stack
  98                     )
  99                     <|>
 100                     return []
 101
 102       toType :: Char -> ListType
 103       toType '*' = Bullet
 104       toType '#' = Numbered
 105
 106
 107 definitionList :: Parser BlockElement
 108 definitionList = many1 definition >>= return . DefinitionList
 109     where
 110       definition :: Parser Definition
 111       definition = do char ';'
 112                       ws
 113                       tHead <- inlineElement
 114                       tRest <- term
 115                       d     <- description
 116                       return (Definition (tHead:tRest) d)
 117                    <?>
 118                    "definition list"
 119
 120       term :: Parser [InlineElement]
 121       term = (char ':' >> ws >> return [])
 122              <|>
 123              (newline >> char ':' >> ws >> return [])
 124              <|>
 125              do x  <- inlineElement
 126                 xs <- term
 127                 return (x:xs)
 128              <?>
 129              "term to be defined"
 130
 131       description :: Parser [InlineElement]
 132       description = do x  <- inlineElement
 133                        xs <- description
 134                        return (x:xs)
 135                     <|>
 136                     try ( do newline
 137                              char ':'
 138                              ws
 139                              xs <- description
 140                              return (Text "\n" : xs)
 141                         )
 142                     <|>
 143                     (newline >> return [])
 144                     <|>
 145                     (eof >> return [])
 146                     <?>
 147                     "description of term"
 148
 149
 150 pdata :: Parser BlockElement
 151 pdata = do try (string "<![PDATA[")
 152            many (oneOf " \t\n")
 153            x <- pdata'
 154            return (Preformatted [Text x])
 155     where
 156       pdata' :: Parser String
 157       pdata' = do try (many (oneOf " \t\n") >> string "]]>")
 158                   return []
 159                <|>
 160                do x  <- anyChar
 161                   xs <- pdata'
 162                   return (x:xs)
 163
 164
 165 leadingSpaced :: Parser BlockElement
 166 leadingSpaced = (char ' ' >> leadingSpaced' >>= return . Preformatted)
 167                 <?>
 168                 "leading space"
 169     where
 170       leadingSpaced' :: Parser [InlineElement]
 171       leadingSpaced' = do x  <- inlineElement
 172                           xs <- leadingSpaced'
 173                           return (x:xs)
 174                        <|>
 175                        try ( newline
 176                              >>
 177                              char ' '
 178                              >>
 179                              leadingSpaced'
 180                              >>=
 181                              return . (Text "\n" :)
 182                            )
 183                        <|>
 184                        return []
 185
 186
 187 blockTag :: Parser BlockElement
 188 blockTag = pzero -- not implemented
 189
 190
 191 paragraph :: Parser BlockElement
 192 paragraph = paragraph' >>= return . Paragraph
 193     where
 194       paragraph' :: Parser [InlineElement]
 195       paragraph' = do x  <- inlineElement
 196                       xs <- try ( do newline
 197                                      eof
 198                                      return []
 199                                   -- \n で文字列が終はってゐたら、ここ
 200                                   -- で終了。
 201                                 )
 202                             <|>
 203                             try ( do newline
 204                                      ((oneOf ('\n':blockSymbols) >> pzero) <|> return ())
 205                                      ((blockTag                  >> pzero) <|> return ())
 206                                      ys <- (paragraph' <|> return [])
 207                                      return (Text "\n" : ys)
 208                                   -- \n があり、その次に \n、ブロックタ
 209                                   -- グまたは blockSymbols があれば、
 210                                   -- fail して 最初の newline を讀んだ
 211                                   -- 所まで卷き戻す。
 212                                 )
 213                             <|>
 214                             try paragraph'
 215                             -- それ以外の場合は次の inlineElement から
 216                             -- を讀んで見る。但し一つも無くても良い。
 217                             <|>
 218                             return [] -- 全部失敗したらここで終了。
 219                       return (x:xs)
 220
 221
 222 inlineElement :: Parser InlineElement
 223 inlineElement = skipMany comment
 224                 >>
 225                 ( cdata
 226                   <|>
 227                   apostrophes
 228                   <|>
 229                   text
 230                   <|>
 231                   pageLink
 232                 )
 233
 234
 235 cdata :: Parser InlineElement
 236 cdata = try (string "<![CDATA[") >> cdata' >>= return . Text
 237     where
 238       cdata' :: Parser String
 239       cdata' = do try (string "]]>")
 240                   return []
 241                <|>
 242                do x  <- anyChar
 243                   xs <- cdata'
 244                   return (x:xs)
 245
 246
 247 text :: Parser InlineElement
 248 text = ( char ':'
 249          >>
 250          many (noneOf ('\n':inlineSymbols))
 251          >>=
 252          return . Text . (':' :)
 253          -- 定義リストとの關係上、コロンは先頭にしか來れない。
 254        )
 255        <|>
 256        ( many1 (noneOf ('\n':inlineSymbols))
 257          >>=
 258          return . Text
 259        )
 260        <?>
 261        "text"
 262
 263
 264 apostrophes :: Parser InlineElement
 265 apostrophes = foldr (<|>) pzero (map try [apos1, apos2, apos3, apos4, apos5])
 266     where
 267       apos1 = apos 1 >> return (Text "'")
 268
 269       apos2 = do apos 2
 270                  xs <- many1 inlineElement
 271                  apos 2
 272                  return (Italic xs)
 273
 274       apos3 = do apos 3
 275                  xs <- many1 inlineElement
 276                  apos 3
 277                  return (Bold xs)
 278
 279       apos4 = apos 4 >> return (Text "'")
 280
 281       apos5 = do apos 5
 282                  xs <- many1 inlineElement
 283                  apos 5
 284                  return (Italic [Bold xs])
 285
 286       apos :: Int -> Parser ()
 287       apos n = count n (char '\'') >> notFollowedBy (char '\'')
 288
 289
 290 pageLink :: Parser InlineElement
 291 pageLink = do try (string "[[")
 292               page     <- option Nothing
 293                           (many1 (noneOf "#|]") >>= return . Just)
 294               fragment <- option Nothing
 295                           (char '#' >> many1 (noneOf "|]") >>= return . Just)
 296               text     <- option Nothing
 297                           (char '|' >> many1 (noneOf "]") >>= return . Just)
 298
 299               case (page, fragment) of
 300                 (Nothing, Nothing) -> pzero
 301                 (_, _)             -> return ()
 302
 303               string "]]"
 304               return $ PageLink page fragment text
 305            <?>
 306            "page link"
 307
 308
 309 comment :: Parser ()
 310 comment = (try (string "<!--") >> skipTillEnd 1)
 311           <?>
 312           "comment"
 313     where
 314       skipTillEnd :: Int -> Parser ()
 315       skipTillEnd level = ( (try (string "<!--") >> skipTillEnd (level + 1))
 316                             <|>
 317                             (try (string "-->") >> case level of
 318                                                      1 -> return ()
 319                                                      n -> skipTillEnd (n - 1))
 320                             <|>
 321                             (anyChar >> skipTillEnd level)
 322                           )
 323
 324
 325 blockSymbols :: [Char]
 326 blockSymbols = " =-*#;"
 327
 328
 329 inlineSymbols :: [Char]
 330 inlineSymbols = "<[:'"
 331
 332 -- white space
 333 ws :: Parser ()
 334 ws = skipMany ( (oneOf " \t" >> return ())
 335                 <|>
 336                 comment
 337               )
 338
 339 -- end of line
 340 eol :: Parser ()
 341 eol = ( (newline >> return ())
 342         <|>
 343         eof
 344       )