1 module Rakka.Wiki.Parser
8 import Network.URI hiding (fragment)
10 import Text.ParserCombinators.Parsec hiding (label)
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 " ++ replicate n '=')
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' []
78 listElement' :: [Char] -> Parser BlockElement
82 xs <- items (stack ++ [t])
83 return (List (toType t) xs)
85 items :: [Char] -> Parser [ListItem]
86 items stack = do xs <- many1 $ inlineElement cmdTypeOf
87 nested <- option Nothing
88 $ try $ do skipMany comment
91 liftM Just (listElement' stack)
93 return $ (map Inline xs ++ map Block (catMaybes [nested])) : rest
95 (try $ do skipMany comment
104 toType :: Char -> ListType
106 toType '#' = Numbered
110 definitionList :: CommandTypeOf -> Parser BlockElement
111 definitionList cmdTypeOf = liftM DefinitionList (many1 definition)
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 verbatim :: Parser BlockElement
154 verbatim = do try (string "<!verbatim[")
157 return (Preformatted [Text x])
159 verbatim' :: Parser String
160 verbatim' = do try (many (oneOf " \t\n") >> string "]>")
168 leadingSpaced :: CommandTypeOf -> Parser BlockElement
169 leadingSpaced cmdTypeOf = liftM Preformatted (char ' ' >> leadingSpaced')
173 leadingSpaced' :: Parser [InlineElement]
174 leadingSpaced' = do x <- inlineElement cmdTypeOf
178 try ( liftM (Text "\n" :) ( newline
189 paragraph :: CommandTypeOf -> Parser BlockElement
190 paragraph cmdTypeOf = liftM Paragraph paragraph'
192 paragraph' :: Parser [InlineElement]
193 paragraph' = do x <- inlineElement cmdTypeOf
194 xs <- try ( do newline
197 -- \n で文字列が終はってゐたら、ここ
202 ((oneOf ('\n':blockSymbols) >> pzero) <|> return ())
203 ys <- (paragraph' <|> return [])
204 return (Text "\n" : ys)
205 -- \n があり、その次に \n または
206 -- blockSymbols があれば、fail して
207 -- 最初の newline を讀んだ所まで卷き
212 -- それ以外の場合は次の inlineElement から
213 -- を讀んで見る。但し一つも無くても良い。
215 return [] -- 全部失敗したらここで終了。
219 blockCmd :: CommandTypeOf -> Parser BlockElement
221 = (try $ do (tagName, tagAttrs) <- openTag
222 case cmdTypeOf tagName of
223 Just BlockCommandType
226 return $ BlockCmd BlockCommand {
228 , bCmdAttributes = tagAttrs
232 Just InlineCommandType
235 _ -> return $ undefinedCmdErr tagName
238 (try $ do (tagName, tagAttrs) <- emptyTag
239 case cmdTypeOf tagName of
240 Just BlockCommandType
241 -> return $ BlockCmd BlockCommand {
243 , bCmdAttributes = tagAttrs
247 Just InlineCommandType
250 _ -> return $ undefinedCmdErr tagName
255 contents :: Parser [BlockElement]
256 contents = do x <- blockElement cmdTypeOf
260 (newline >> contents)
262 (comment >> contents)
266 undefinedCmdErr :: String -> BlockElement
268 = Div [("class", "error")]
269 [ Block (Paragraph [Text ("The command `" ++ name ++ "' is not defined. " ++
270 "Make sure you haven't mistyped.")
275 inlineElement :: CommandTypeOf -> Parser InlineElement
276 inlineElement cmdTypeOf
277 = try $ do skipMany comment
278 foldr (<|>) pzero [ nowiki
279 , apostrophes cmdTypeOf
284 , inlineCmd cmdTypeOf
288 nowiki :: Parser InlineElement
289 nowiki = liftM Text (try (string "<!nowiki[") >> nowiki')
291 nowiki' :: Parser String
292 nowiki' = do try (string "]>")
300 text :: Parser InlineElement
301 text = liftM (Text . (':' :)) ( char ':'
303 many (noneOf ('\n':inlineSymbols))
305 -- 定義リストとの關係上、コロンは先頭にしか來られない。
307 liftM Text (many1 (noneOf ('\n':inlineSymbols)))
312 apostrophes :: CommandTypeOf -> Parser InlineElement
313 apostrophes cmdTypeOf = foldr (<|>) pzero (map try [apos1, apos2, apos3, apos4, apos5])
315 apos1 = apos 1 >> return (Text "'")
318 xs <- many1 $ inlineElement cmdTypeOf
323 xs <- many1 $ inlineElement cmdTypeOf
327 apos4 = apos 4 >> return (Text "'")
330 xs <- many1 $ inlineElement cmdTypeOf
332 return (Italic [Bold xs])
334 apos :: Int -> Parser ()
335 apos n = count n (char '\'') >> notFollowedBy (char '\'')
338 objLink :: Parser InlineElement
339 objLink = do try (string "[[[")
340 page <- many1 (noneOf "|]")
341 label <- option Nothing
342 (liftM Just (char '|' >> many1 (satisfy (/= ']'))))
344 return $ ObjectLink page label
349 pageLink :: Parser InlineElement
350 pageLink = do try (string "[[")
351 page <- option Nothing
352 (liftM Just (many1 (noneOf "#|]")))
353 fragment <- option Nothing
354 (liftM Just (char '#' >> many1 (noneOf "|]")))
355 label <- option Nothing
356 (liftM Just (char '|' >> many1 (satisfy (/= ']'))))
358 case (page, fragment) of
359 (Nothing, Nothing) -> pzero
363 return $ PageLink page fragment label
368 extLink :: Parser InlineElement
369 extLink = do char '['
370 uriStr <- many1 (noneOf " \t]")
371 skipMany (oneOf " \t")
372 label <- option Nothing
373 (liftM Just (many1 (noneOf "]")))
375 case parseURI uriStr of
376 Just uri -> char ']' >> return (ExternalLink uri label)
377 Nothing -> pzero <?> "absolute URI"
382 inlineCmd :: CommandTypeOf -> Parser InlineElement
384 = (try $ do (tagName, tagAttrs) <- openTag
385 case cmdTypeOf tagName of
386 Just InlineCommandType
389 return $ InlineCmd InlineCommand {
391 , iCmdAttributes = tagAttrs
397 (try $ do (tagName, tagAttrs) <- emptyTag
398 case cmdTypeOf tagName of
399 Just InlineCommandType
400 -> return $ InlineCmd InlineCommand {
402 , iCmdAttributes = tagAttrs
410 contents :: Parser [InlineElement]
411 contents = do x <- inlineElement cmdTypeOf
415 (comment >> contents)
417 liftM (Text "\n" :) (newline >> contents)
422 openTag :: Parser (String, [Attribute])
423 openTag = try $ do char '<'
427 attrs <- many $ do attr <- tagAttr
434 emptyTag :: Parser (String, [Attribute])
435 emptyTag = try $ do char '<'
439 attrs <- many $ do attr <- tagAttr
448 closeTag :: String -> Parser ()
449 closeTag name = try $ do char '<'
459 tagAttr :: Parser (String, String)
460 tagAttr = do name <- many1 letter
463 value <- many (satisfy (/= '"'))
469 comment = (try (string "<!--") >> skipTillEnd 1)
473 skipTillEnd :: Int -> Parser ()
474 skipTillEnd level = (try (string "<!--") >> skipTillEnd (level + 1))
476 (try (string "-->") >> case level of
478 n -> skipTillEnd (n - 1))
480 (anyChar >> skipTillEnd level)
483 blockSymbols :: [Char]
484 blockSymbols = " =-*#;<"
487 inlineSymbols :: [Char]
488 inlineSymbols = "<[:'"
492 ws = skipMany ( (oneOf " \t" >> return ())
499 eol = (newline >> return ())