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
144 return (Text "\n" : xs)
147 (newline >> return [])
151 "description of term"
154 verbatim :: Parser BlockElement
155 verbatim = do try (string "<!verbatim[")
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 で文字列が終はってゐたら、ここ
203 ((oneOf ('\n':blockSymbols) >> pzero) <|> return ())
204 ys <- (paragraph' <|> return [])
205 return (Text "\n" : ys)
206 -- \n があり、その次に \n または
207 -- blockSymbols があれば、fail して
208 -- 最初の newline を讀んだ所まで卷き
213 -- それ以外の場合は次の inlineElement から
214 -- を讀んで見る。但し一つも無くても良い。
216 return [] -- 全部失敗したらここで終了。
220 blockCmd :: CommandTypeOf -> Parser BlockElement
222 = (try $ do (tagName, tagAttrs) <- openTag
223 case cmdTypeOf tagName of
224 Just BlockCommandType
227 return $ BlockCmd BlockCommand {
229 , bCmdAttributes = tagAttrs
233 Just InlineCommandType
236 _ -> return $ undefinedCmdErr tagName
239 (try $ do (tagName, tagAttrs) <- emptyTag
240 case cmdTypeOf tagName of
241 Just BlockCommandType
242 -> return $ BlockCmd BlockCommand {
244 , bCmdAttributes = tagAttrs
248 Just InlineCommandType
251 _ -> return $ undefinedCmdErr tagName
256 contents :: Parser [BlockElement]
257 contents = do x <- blockElement cmdTypeOf
261 (newline >> contents)
263 (comment >> contents)
267 undefinedCmdErr :: String -> BlockElement
269 = Div [("class", "error")]
270 [ Block (Paragraph [Text ("The command `" ++ name ++ "' is not defined. " ++
271 "Make sure you haven't mistyped.")
276 inlineElement :: CommandTypeOf -> Parser InlineElement
277 inlineElement cmdTypeOf
278 = try $ do skipMany comment
279 foldr (<|>) pzero [ nowiki
280 , apostrophes cmdTypeOf
285 , inlineCmd cmdTypeOf
289 nowiki :: Parser InlineElement
290 nowiki = liftM Text (try (string "<!nowiki[") >> nowiki')
292 nowiki' :: Parser String
293 nowiki' = do try (string "]>")
301 text :: Parser InlineElement
302 text = liftM (Text . (':' :)) ( char ':'
304 many (noneOf ('\n':inlineSymbols))
306 -- 定義リストとの關係上、コロンは先頭にしか來られない。
308 liftM Text (many1 (noneOf ('\n':inlineSymbols)))
313 apostrophes :: CommandTypeOf -> Parser InlineElement
314 apostrophes cmdTypeOf = foldr (<|>) pzero (map try [apos1, apos2, apos3, apos4, apos5])
316 apos1 = apos 1 >> return (Text "'")
319 xs <- many1 $ inlineElement cmdTypeOf
324 xs <- many1 $ inlineElement cmdTypeOf
328 apos4 = apos 4 >> return (Text "'")
331 xs <- many1 $ inlineElement cmdTypeOf
333 return (Italic [Bold xs])
335 apos :: Int -> Parser ()
336 apos n = count n (char '\'') >> notFollowedBy (char '\'')
339 objLink :: Parser InlineElement
340 objLink = do try (string "[[[")
341 page <- many1 (noneOf "|]")
342 label <- option Nothing
343 (liftM Just (char '|' >> many1 (satisfy (/= ']'))))
345 return $ ObjectLink page label
350 pageLink :: Parser InlineElement
351 pageLink = do try (string "[[")
352 page <- option Nothing
353 (liftM Just (many1 (noneOf "#|]")))
354 fragment <- option Nothing
355 (liftM Just (char '#' >> many1 (noneOf "|]")))
356 label <- option Nothing
357 (liftM Just (char '|' >> many1 (satisfy (/= ']'))))
359 case (page, fragment) of
360 (Nothing, Nothing) -> pzero
364 return $ PageLink page fragment label
369 extLink :: Parser InlineElement
370 extLink = do char '['
371 uriStr <- many1 (noneOf " \t]")
372 skipMany (oneOf " \t")
373 label <- option Nothing
374 (liftM Just (many1 (noneOf "]")))
376 case parseURI uriStr of
377 Just uri -> char ']' >> return (ExternalLink uri label)
378 Nothing -> pzero <?> "absolute URI"
383 inlineCmd :: CommandTypeOf -> Parser InlineElement
385 = (try $ do (tagName, tagAttrs) <- openTag
386 case cmdTypeOf tagName of
387 Just InlineCommandType
390 return $ InlineCmd InlineCommand {
392 , iCmdAttributes = tagAttrs
398 (try $ do (tagName, tagAttrs) <- emptyTag
399 case cmdTypeOf tagName of
400 Just InlineCommandType
401 -> return $ InlineCmd InlineCommand {
403 , iCmdAttributes = tagAttrs
411 contents :: Parser [InlineElement]
412 contents = do x <- inlineElement cmdTypeOf
416 (comment >> contents)
418 liftM (Text "\n" :) (newline >> contents)
423 openTag :: Parser (String, [Attribute])
424 openTag = try $ do char '<'
428 attrs <- many $ do attr <- tagAttr
435 emptyTag :: Parser (String, [Attribute])
436 emptyTag = try $ do char '<'
440 attrs <- many $ do attr <- tagAttr
449 closeTag :: String -> Parser ()
450 closeTag name = try $ do char '<'
460 tagAttr :: Parser (String, String)
461 tagAttr = do name <- many1 letter
464 value <- many (satisfy (/= '"'))
470 comment = (try (string "<!--") >> skipTillEnd 1)
474 skipTillEnd :: Int -> Parser ()
475 skipTillEnd level = (try (string "<!--") >> skipTillEnd (level + 1))
477 (try (string "-->") >> case level of
479 n -> skipTillEnd (n - 1))
481 (anyChar >> skipTillEnd level)
484 blockSymbols :: [Char]
485 blockSymbols = " =-*#;<"
488 inlineSymbols :: [Char]
489 inlineSymbols = "<[:'"
493 ws = skipMany ( (oneOf " \t" >> return ())
500 eol = (newline >> return ())