1 module Rakka.Wiki.Parser
10 import Text.ParserCombinators.Parsec
13 type CommandTypeOf = String -> Maybe CommandType
16 wikiPage :: CommandTypeOf -> Parser WikiPage
18 = do xs <- many (blockElement cmdTypeOf)
21 (newline >> return ())
27 blockElement :: CommandTypeOf -> Parser BlockElement
28 blockElement cmdTypeOf
29 = try $ do skipMany ( comment
31 (newline >> return ())
33 foldr (<|>) pzero [ heading
35 , listElement cmdTypeOf
36 , definitionList cmdTypeOf
38 , leadingSpaced cmdTypeOf
44 heading :: Parser BlockElement
45 heading = foldr (<|>) pzero (map heading' [1..5])
49 heading' :: Int -> Parser BlockElement
50 heading' n = do try $ do count n (char '=')
51 notFollowedBy (char '=')
53 x <- notFollowedBy (char '=') >> anyChar
54 xs <- manyTill anyChar (try $ ws >> ( count n (char '=')
56 ("trailing " ++ take n (repeat '='))
61 return (Heading n (x:xs))
64 horizontalLine :: Parser BlockElement
65 horizontalLine = try ( do count 4 (char '-')
75 listElement :: CommandTypeOf -> Parser BlockElement
76 listElement cmdTypeOf = listElement' [] >>= return . List
78 listElement' :: [Char] -> Parser ListElement
82 xs <- items (stack ++ [t])
83 return (ListElement (toType t) xs)
86 items :: [Char] -> Parser [ListItem]
87 items stack = do xs <- many1 $ inlineElement cmdTypeOf
88 nested <- option Nothing
89 $ try $ do skipMany comment
92 listElement' stack >>= return . Just
94 return $ (map Right xs ++ map Left (catMaybes [nested])) : rest
96 (try $ do skipMany comment
105 toType :: Char -> ListType
107 toType '#' = Numbered
110 definitionList :: CommandTypeOf -> Parser BlockElement
111 definitionList cmdTypeOf = many1 definition >>= return . DefinitionList
113 definition :: Parser Definition
114 definition = do char ';'
116 tHead <- inlineElement cmdTypeOf
119 return (Definition (tHead:tRest) d)
123 term :: Parser [InlineElement]
124 term = (char ':' >> ws >> return [])
126 (newline >> char ':' >> ws >> return [])
128 do x <- inlineElement cmdTypeOf
134 description :: Parser [InlineElement]
135 description = do x <- inlineElement cmdTypeOf
143 return (Text "\n" : xs)
146 (newline >> return [])
150 "description of term"
153 pdata :: Parser BlockElement
154 pdata = do try (string "<![PDATA[")
157 return (Preformatted [Text x])
159 pdata' :: Parser String
160 pdata' = do try (many (oneOf " \t\n") >> string "]]>")
168 leadingSpaced :: CommandTypeOf -> Parser BlockElement
169 leadingSpaced cmdTypeOf = (char ' ' >> leadingSpaced' >>= return . Preformatted)
173 leadingSpaced' :: Parser [InlineElement]
174 leadingSpaced' = do x <- inlineElement cmdTypeOf
184 return . (Text "\n" :)
190 blockCommand :: Parser BlockElement
191 blockCommand = pzero -- not implemented
194 paragraph :: CommandTypeOf -> Parser BlockElement
195 paragraph cmdTypeOf = paragraph' >>= return . Paragraph
197 paragraph' :: Parser [InlineElement]
198 paragraph' = do x <- inlineElement cmdTypeOf
199 xs <- try ( do newline
202 -- \n で文字列が終はってゐたら、ここ
207 ((oneOf ('\n':blockSymbols) >> pzero) <|> return ())
208 ys <- (paragraph' <|> return [])
209 return (Text "\n" : ys)
210 -- \n があり、その次に \n または
211 -- blockSymbols があれば、fail して
212 -- 最初の newline を讀んだ所まで卷き
217 -- それ以外の場合は次の inlineElement から
218 -- を讀んで見る。但し一つも無くても良い。
220 return [] -- 全部失敗したらここで終了。
224 blockCmd :: CommandTypeOf -> Parser BlockElement
226 = (try $ do (tagName, tagAttrs) <- openTag
227 case cmdTypeOf tagName of
228 Just BlockCommandType
231 return $ BlockCmd $ BlockCommand {
233 , bCmdAttributes = tagAttrs
237 Just InlineCommandType
240 _ -> return $ undefinedCmdErr tagName
243 (try $ do (tagName, tagAttrs) <- emptyTag
244 case cmdTypeOf tagName of
245 Just BlockCommandType
246 -> return $ BlockCmd $ BlockCommand {
248 , bCmdAttributes = tagAttrs
252 Just InlineCommandType
255 _ -> return $ undefinedCmdErr tagName
260 contents :: Parser [BlockElement]
261 contents = do x <- blockElement cmdTypeOf
265 (newline >> contents)
267 (comment >> contents)
271 undefinedCmdErr :: String -> BlockElement
273 = Div [("class", "error")]
274 [ Paragraph [Text ("The command `" ++ name ++ "' is not defined. " ++
275 "Ensure that you haven't mistyped and the module " ++
276 "providing the command is actually loaded.")
281 inlineElement :: CommandTypeOf -> Parser InlineElement
282 inlineElement cmdTypeOf
283 = try $ do skipMany comment
284 foldr (<|>) pzero [ cdata
285 , apostrophes cmdTypeOf
289 , inlineCmd cmdTypeOf
293 cdata :: Parser InlineElement
294 cdata = try (string "<![CDATA[") >> cdata' >>= return . Text
296 cdata' :: Parser String
297 cdata' = do try (string "]]>")
305 text :: Parser InlineElement
308 many (noneOf ('\n':inlineSymbols))
310 return . Text . (':' :)
311 -- 定義リストとの關係上、コロンは先頭にしか來れない。
314 ( many1 (noneOf ('\n':inlineSymbols))
322 apostrophes :: CommandTypeOf -> Parser InlineElement
323 apostrophes cmdTypeOf = foldr (<|>) pzero (map try [apos1, apos2, apos3, apos4, apos5])
325 apos1 = apos 1 >> return (Text "'")
328 xs <- many1 $ inlineElement cmdTypeOf
333 xs <- many1 $ inlineElement cmdTypeOf
337 apos4 = apos 4 >> return (Text "'")
340 xs <- many1 $ inlineElement cmdTypeOf
342 return (Italic [Bold xs])
344 apos :: Int -> Parser ()
345 apos n = count n (char '\'') >> notFollowedBy (char '\'')
348 pageLink :: Parser InlineElement
349 pageLink = do try (string "[[")
350 page <- option Nothing
351 (many1 (noneOf "#|]") >>= return . Just)
352 fragment <- option Nothing
353 (char '#' >> many1 (noneOf "|]") >>= return . Just)
354 text <- option Nothing
355 (char '|' >> many1 (satisfy (/= ']')) >>= return . Just)
357 case (page, fragment) of
358 (Nothing, Nothing) -> pzero
362 return $ PageLink page fragment text
367 extLink :: Parser InlineElement
368 extLink = do char '['
369 uriStr <- many1 (noneOf " \t]")
370 skipMany (oneOf " \t")
371 text <- option Nothing
372 (many1 (noneOf "]") >>= return . Just)
374 case parseURI uriStr of
375 Just uri -> char ']' >> return (ExternalLink uri text)
376 Nothing -> pzero <?> "absolute URI"
381 inlineCmd :: CommandTypeOf -> Parser InlineElement
383 = (try $ do (tagName, tagAttrs) <- openTag
384 case cmdTypeOf tagName of
385 Just InlineCommandType
388 return $ InlineCmd $ InlineCommand {
390 , iCmdAttributes = tagAttrs
396 (try $ do (tagName, tagAttrs) <- emptyTag
397 case cmdTypeOf tagName of
398 Just InlineCommandType
399 -> return $ InlineCmd $ InlineCommand {
401 , iCmdAttributes = tagAttrs
409 contents :: Parser [InlineElement]
410 contents = do x <- inlineElement cmdTypeOf
414 (comment >> contents)
416 (newline >> contents >>= return . (Text "\n" :))
421 openTag :: Parser (String, [Attribute])
422 openTag = try $ do char '<'
426 attrs <- many $ do attr <- tagAttr
433 emptyTag :: Parser (String, [Attribute])
434 emptyTag = try $ do char '<'
438 attrs <- many $ do attr <- tagAttr
447 closeTag :: String -> Parser ()
448 closeTag name = try $ do char '<'
458 tagAttr :: Parser (String, String)
459 tagAttr = do name <- many1 letter
462 value <- many (satisfy (/= '"'))
468 comment = (try (string "<!--") >> skipTillEnd 1)
472 skipTillEnd :: Int -> Parser ()
473 skipTillEnd level = ( (try (string "<!--") >> skipTillEnd (level + 1))
475 (try (string "-->") >> case level of
477 n -> skipTillEnd (n - 1))
479 (anyChar >> skipTillEnd level)
483 blockSymbols :: [Char]
484 blockSymbols = " =-*#;<"
487 inlineSymbols :: [Char]
488 inlineSymbols = "<[:'"
492 ws = skipMany ( (oneOf " \t" >> return ())
499 eol = ( (newline >> return ())