1 module Rakka.Wiki.Parser
9 import Network.URI hiding (fragment)
11 import Text.ParserCombinators.Parsec hiding (label)
14 type CommandTypeOf = String -> Maybe CommandType
17 wikiPage :: CommandTypeOf -> Parser WikiPage
19 = do xs <- many (blockElement cmdTypeOf)
22 (newline >> return ())
28 blockElement :: CommandTypeOf -> Parser BlockElement
29 blockElement cmdTypeOf
30 = try $ do skipMany ( comment
32 (newline >> return ())
34 foldr (<|>) pzero [ heading
36 , listElement cmdTypeOf
37 , definitionList cmdTypeOf
39 , leadingSpaced cmdTypeOf
45 heading :: Parser BlockElement
46 heading = foldr (<|>) pzero (map heading' [1..5])
50 heading' :: Int -> Parser BlockElement
51 heading' n = do try $ do _ <- count n (char '=')
52 notFollowedBy (char '=')
54 x <- notFollowedBy (char '=') >> anyChar
55 xs <- manyTill anyChar (try $ ws >> ( count n (char '=')
57 ("trailing " ++ replicate n '=')
62 return (Heading n (x:xs))
65 horizontalLine :: Parser BlockElement
66 horizontalLine = try ( do _ <- count 4 (char '-')
76 listElement :: CommandTypeOf -> Parser BlockElement
77 listElement cmdTypeOf = listElement' []
79 listElement' :: [Char] -> Parser BlockElement
83 xs <- items (stack ++ [t])
84 return (List (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 liftM Just (listElement' stack)
94 return $ (map Inline xs ++ map Block (catMaybes [nested])) : rest
96 (try $ do skipMany comment
105 toType :: Char -> ListType
107 toType '#' = Numbered
111 definitionList :: CommandTypeOf -> Parser BlockElement
112 definitionList cmdTypeOf = liftM DefinitionList (many1 definition)
114 definition :: Parser Definition
115 definition = do _ <- char ';'
117 tHead <- inlineElement cmdTypeOf
120 return (Definition (tHead:tRest) d)
124 term :: Parser [InlineElement]
125 term = (char ':' >> ws >> return [])
127 (newline >> char ':' >> ws >> return [])
129 do x <- inlineElement cmdTypeOf
135 description :: Parser [InlineElement]
136 description = do x <- inlineElement cmdTypeOf
140 try ( do _ <- newline
144 return (Text "\n" : xs)
147 (newline >> return [])
151 "description of term"
154 verbatim :: Parser BlockElement
155 verbatim = do _ <- try (string "<!verbatim[")
156 _ <- many (oneOf " \t\n")
158 return (Preformatted [Text x])
160 verbatim' :: Parser String
161 verbatim' = do _ <- try (many (oneOf " \t\n") >> string "]>")
169 leadingSpaced :: CommandTypeOf -> Parser BlockElement
170 leadingSpaced cmdTypeOf = liftM Preformatted (char ' ' >> leadingSpaced')
174 leadingSpaced' :: Parser [InlineElement]
175 leadingSpaced' = do x <- inlineElement cmdTypeOf
179 try ( liftM (Text "\n" :) ( newline
190 paragraph :: CommandTypeOf -> Parser BlockElement
191 paragraph cmdTypeOf = liftM Paragraph paragraph'
193 paragraph' :: Parser [InlineElement]
194 paragraph' = do x <- inlineElement cmdTypeOf
195 xs <- try ( do _ <- newline
198 -- \n で文字列が終はってゐたら、ここ
202 try ( do _ <- newline
203 _ <- ((oneOf ('\n':blockSymbols) >> pzero) <|> return ())
204 ys <- (paragraph' <|> return [])
205 return (Text "\n" : ys)
206 -- \n があり、その次に \n または
207 -- blockSymbols があれば、fail して
208 -- 最初の newline を讀んだ所まで卷き
211 -- FIXME: 本當にそのやうな動作になつ
219 -- それ以外の場合は次の inlineElement から
220 -- を讀んで見る。但し一つも無くても良い。
222 return [] -- 全部失敗したらここで終了。
226 blockCmd :: CommandTypeOf -> Parser BlockElement
228 = (try $ do (tagName, tagAttrs) <- openTag
229 case cmdTypeOf tagName of
230 Just BlockCommandType
233 return $ BlockCmd BlockCommand {
235 , bCmdAttributes = tagAttrs
239 Just InlineCommandType
242 _ -> return $ undefinedCmdErr tagName
245 (try $ do (tagName, tagAttrs) <- emptyTag
246 case cmdTypeOf tagName of
247 Just BlockCommandType
248 -> return $ BlockCmd BlockCommand {
250 , bCmdAttributes = tagAttrs
254 Just InlineCommandType
257 _ -> return $ undefinedCmdErr tagName
262 contents :: Parser [BlockElement]
263 contents = do x <- blockElement cmdTypeOf
267 (newline >> contents)
269 (comment >> contents)
273 undefinedCmdErr :: String -> BlockElement
275 = Div [("class", "error")]
276 [ Block (Paragraph [Text ("The command `" ++ name ++ "' is not defined. " ++
277 "Make sure you haven't mistyped.")
282 inlineElement :: CommandTypeOf -> Parser InlineElement
283 inlineElement cmdTypeOf
284 = try $ do skipMany comment
285 foldr (<|>) pzero [ nowiki
286 , apostrophes cmdTypeOf
291 , inlineCmd cmdTypeOf
295 nowiki :: Parser InlineElement
296 nowiki = liftM Text (try (string "<!nowiki[") >> nowiki')
298 nowiki' :: Parser String
299 nowiki' = do _ <- try (string "]>")
307 text :: Parser InlineElement
308 text = liftM (Text . (':' :)) ( char ':'
310 many (noneOf ('\n':inlineSymbols))
312 -- 定義リストとの關係上、コロンは先頭にしか來られない。
314 liftM Text (many1 (noneOf ('\n':inlineSymbols)))
319 apostrophes :: CommandTypeOf -> Parser InlineElement
320 apostrophes cmdTypeOf = foldr (<|>) pzero (map try [apos1, apos2, apos3, apos4, apos5])
322 apos1 = apos 1 >> return (Text "'")
325 xs <- many1 $ inlineElement cmdTypeOf
330 xs <- many1 $ inlineElement cmdTypeOf
334 apos4 = apos 4 >> return (Text "'")
337 xs <- many1 $ inlineElement cmdTypeOf
339 return (Italic [Bold xs])
341 apos :: Int -> Parser ()
342 apos n = count n (char '\'') >> notFollowedBy (char '\'')
345 objLink :: Parser InlineElement
346 objLink = do _ <- try (string "[[[")
347 page <- many1 (noneOf "|]")
348 label <- option Nothing
349 (liftM Just (char '|' >> many1 (satisfy (/= ']'))))
351 return $ ObjectLink page label
356 pageLink :: Parser InlineElement
357 pageLink = do _ <- try (string "[[")
358 page <- option Nothing
359 (liftM Just (many1 (noneOf "#|]")))
360 fragment <- option Nothing
361 (liftM Just (char '#' >> many1 (noneOf "|]")))
362 label <- option Nothing
363 (liftM Just (char '|' >> many1 (satisfy (/= ']'))))
365 case (page, fragment) of
366 (Nothing, Nothing) -> pzero
370 return $ PageLink page fragment label
375 extLink :: Parser InlineElement
376 extLink = do _ <- char '['
377 uriStr <- many1 (noneOf " \t]")
378 _ <- skipMany (oneOf " \t")
379 label <- option Nothing
380 (liftM Just (many1 (noneOf "]")))
382 case parseURI uriStr of
383 Just uri -> char ']' >> return (ExternalLink uri label)
384 Nothing -> pzero <?> "absolute URI"
389 inlineCmd :: CommandTypeOf -> Parser InlineElement
391 = (try $ do (tagName, tagAttrs) <- openTag
392 case cmdTypeOf tagName of
393 Just InlineCommandType
396 return $ InlineCmd InlineCommand {
398 , iCmdAttributes = tagAttrs
404 (try $ do (tagName, tagAttrs) <- emptyTag
405 case cmdTypeOf tagName of
406 Just InlineCommandType
407 -> return $ InlineCmd InlineCommand {
409 , iCmdAttributes = tagAttrs
417 contents :: Parser [InlineElement]
418 contents = do x <- inlineElement cmdTypeOf
422 (comment >> contents)
424 liftM (Text "\n" :) (newline >> contents)
429 openTag :: Parser (String, [Attribute])
430 openTag = try $ do _ <- char '<'
434 attrs <- many $ do attr <- tagAttr
441 emptyTag :: Parser (String, [Attribute])
442 emptyTag = try $ do _ <- char '<'
446 attrs <- many $ do attr <- tagAttr
455 closeTag :: String -> Parser ()
456 closeTag name = try $ do _ <- char '<'
466 tagAttr :: Parser (String, String)
467 tagAttr = do name <- many1 letter
470 value <- many (satisfy (/= '"'))
476 comment = (try (string "<!--") >> skipTillEnd 1)
480 skipTillEnd :: Int -> Parser ()
481 skipTillEnd level = (try (string "<!--") >> skipTillEnd (level + 1))
483 (try (string "-->") >> case level of
485 n -> skipTillEnd (n - 1))
487 (anyChar >> skipTillEnd level)
490 blockSymbols :: [Char]
491 blockSymbols = " =-*#;<"
494 inlineSymbols :: [Char]
495 inlineSymbols = "<[:'"
499 ws = skipMany ( (oneOf " \t" >> return ())
506 eol = (newline >> return ())