7 module Rakka.Wiki.Parser
12 -- FIXME: use attoparsec
13 import Control.Applicative hiding ((<|>), many)
14 import Control.Applicative.Unicode
16 import Data.CaseInsensitive (CI)
17 import qualified Data.CaseInsensitive as CI
19 import Data.Monoid.Unicode ((⊕))
20 import Data.Text (Text)
21 import qualified Data.Text as T
22 import Network.URI hiding (fragment)
23 import Prelude.Unicode
25 import Text.ParserCombinators.Parsec hiding (label)
27 type CommandTypeOf = Alternative f ⇒ Text → f CommandType
29 wikiPage :: CommandTypeOf -> Parser WikiPage
31 = do xs <- many (blockElement cmdTypeOf)
34 (newline >> return ())
40 blockElement :: CommandTypeOf -> Parser BlockElement
41 blockElement cmdTypeOf
42 = try $ do skipMany ( comment
44 (newline >> return ())
46 foldr (<|>) pzero [ heading
48 , listElement cmdTypeOf
49 , definitionList cmdTypeOf
51 , leadingSpaced cmdTypeOf
56 heading ∷ Parser BlockElement
57 heading = foldr (<|>) pzero (map heading' [1..5])
61 heading' ∷ Int → Parser BlockElement
62 heading' n = do try ( void (count n (char '=')) *>
63 notFollowedBy (char '=')
66 x ← notFollowedBy (char '=') *> anyChar
67 xs ← manyTill anyChar (try $ ws *> ( count n (char '=')
69 ("trailing " ++ replicate n '=')
74 pure ∘ Heading n $ T.pack (x:xs)
76 horizontalLine :: Parser BlockElement
77 horizontalLine = try ( do _ <- count 4 (char '-')
87 listElement :: CommandTypeOf -> Parser BlockElement
88 listElement cmdTypeOf = listElement' []
90 listElement' :: [Char] -> Parser BlockElement
94 xs <- items (stack ++ [t])
95 return (List (toType t) xs)
97 items :: [Char] -> Parser [ListItem]
98 items stack = do xs <- many1 $ inlineElement cmdTypeOf
99 nested <- option Nothing
100 $ try $ do skipMany comment
103 liftM Just (listElement' stack)
105 return $ (map Inline xs ++ map Block (catMaybes [nested])) : rest
107 (try $ do skipMany comment
116 toType :: Char -> ListType
118 toType '#' = Numbered
122 definitionList :: CommandTypeOf -> Parser BlockElement
123 definitionList cmdTypeOf = liftM DefinitionList (many1 definition)
125 definition :: Parser Definition
126 definition = do _ <- char ';'
128 tHead <- inlineElement cmdTypeOf
131 return (Definition (tHead:tRest) d)
135 term :: Parser [InlineElement]
136 term = (char ':' >> ws >> return [])
138 (newline >> char ':' >> ws >> return [])
140 do x <- inlineElement cmdTypeOf
146 description :: Parser [InlineElement]
147 description = do x <- inlineElement cmdTypeOf
151 try ( do _ <- newline
155 return (Text "\n" : xs)
158 (newline >> return [])
162 "description of term"
165 verbatim ∷ Parser BlockElement
166 verbatim = try (string "<!verbatim[") *>
167 many (oneOf " \t\n") *>
168 (Preformatted ∘ (:[]) ∘ Text ∘ T.pack <$> verbatim')
170 verbatim' :: Parser String
171 verbatim' = try (many (oneOf " \t\n") *> string "]>") *> pure []
173 ((:) <$> anyChar ⊛ verbatim')
176 leadingSpaced :: CommandTypeOf -> Parser BlockElement
177 leadingSpaced cmdTypeOf = liftM Preformatted (char ' ' >> leadingSpaced')
181 leadingSpaced' :: Parser [InlineElement]
182 leadingSpaced' = do x <- inlineElement cmdTypeOf
186 try ( liftM (Text "\n" :) ( newline
197 paragraph :: CommandTypeOf -> Parser BlockElement
198 paragraph cmdTypeOf = liftM Paragraph paragraph'
200 paragraph' :: Parser [InlineElement]
201 paragraph' = do x <- inlineElement cmdTypeOf
202 xs <- try ( do _ <- newline
205 -- \n で文字列が終はってゐたら、ここ
209 try ( do _ <- newline
210 _ <- ((oneOf ('\n':blockSymbols) >> pzero) <|> return ())
211 ys <- (paragraph' <|> return [])
212 return (Text "\n" : ys)
213 -- \n があり、その次に \n または
214 -- blockSymbols があれば、fail して
215 -- 最初の newline を讀んだ所まで卷き
218 -- FIXME: 本當にそのやうな動作になつ
226 -- それ以外の場合は次の inlineElement から
227 -- を讀んで見る。但し一つも無くても良い。
229 return [] -- 全部失敗したらここで終了。
233 blockCmd :: CommandTypeOf -> Parser BlockElement
235 = (try $ do (tagName, tagAttrs) <- openTag
236 case cmdTypeOf tagName of
237 Just BlockCommandType
240 return $ BlockCmd BlockCommand {
242 , bCmdAttributes = tagAttrs
245 Just InlineCommandType
247 _ -> return $ undefinedCmdErr tagName
250 (try $ do (tagName, tagAttrs) <- emptyTag
251 case cmdTypeOf tagName of
252 Just BlockCommandType
253 -> return $ BlockCmd BlockCommand {
255 , bCmdAttributes = tagAttrs
258 Just InlineCommandType
260 _ -> return $ undefinedCmdErr tagName
265 contents ∷ Parser [BlockElement]
266 contents = ((:) <$> blockElement cmdTypeOf ⊛ contents)
268 (newline *> contents)
270 (comment *> contents)
274 undefinedCmdErr ∷ Text → BlockElement
276 = Div [("class", "error")]
277 [ Block (Paragraph [Text ("The command `" ⊕ name ⊕ "' is not defined. " ⊕
278 "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
294 nowiki ∷ Parser InlineElement
295 nowiki = Text ∘ T.pack <$> (try (string "<!nowiki[") *> nowiki')
297 nowiki' ∷ Parser String
298 nowiki' = (try (string "]>") *> pure [])
300 ((:) <$> anyChar ⊛ nowiki')
302 text ∷ Parser InlineElement
303 text = (Text ∘ T.pack ∘ (':' :) <$> ( char ':' *>
304 many (noneOf ('\n':inlineSymbols))
306 -- 定義リストとの關係上、コロンは先頭にしか來られない。
308 (Text ∘ T.pack <$> (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 void $ try (string "[[[")
340 page ← many1 (noneOf "|]")
341 label ← option Nothing $
342 Just <$> (char '|' *> many1 (satisfy (≠ ']')))
344 pure $ ObjectLink (T.pack page) (T.pack <$> label)
348 pageLink ∷ Parser InlineElement
349 pageLink = do void $ try (string "[[")
350 page ← option Nothing $
351 Just <$> many1 (noneOf "#|]")
352 fragment ← option Nothing $
353 Just <$> (char '#' *> many1 (noneOf "|]"))
354 label ← option Nothing $
355 Just <$> (char '|' *> many1 (satisfy (≠ ']')))
356 when (isNothing page ∧ isNothing fragment) (∅)
358 pure $ PageLink (T.pack <$> page )
359 (T.pack <$> fragment)
364 extLink ∷ Parser InlineElement
365 extLink = do void $ char '['
366 uriStr ← many1 (noneOf " \t]")
367 void $ skipMany (oneOf " \t")
368 label ← option Nothing $
369 Just <$> many1 (noneOf "]")
370 case parseURI uriStr of
371 Just uri → char ']' *> pure (ExternalLink uri (T.pack <$> label))
372 Nothing → pzero <?> "absolute URI"
376 inlineCmd ∷ CommandTypeOf → Parser InlineElement
378 = (try $ do (tagName, tagAttrs) ← openTag
379 case cmdTypeOf tagName of
380 Just InlineCommandType
383 pure $ InlineCmd InlineCommand {
385 , iCmdAttributes = tagAttrs
391 (try $ do (tagName, tagAttrs) <- emptyTag
392 case cmdTypeOf tagName of
393 Just InlineCommandType
394 -> return $ InlineCmd InlineCommand {
396 , iCmdAttributes = tagAttrs
404 contents ∷ Parser [InlineElement]
405 contents = ((:) <$> inlineElement cmdTypeOf ⊛ contents)
407 (comment *> contents)
409 ((Text "\n" :) <$> (newline *> contents))
413 openTag ∷ Parser (Text, [Attribute])
414 openTag = try $ do void $ char '<'
418 attrs ← many $ do attr ← tagAttr
422 return (T.pack name, attrs)
424 emptyTag ∷ Parser (Text, [Attribute])
425 emptyTag = try $ do void $ char '<'
429 attrs ← many $ do attr ← tagAttr
435 return (T.pack name, attrs)
437 closeTag ∷ Text → Parser ()
438 closeTag (T.unpack → name)
449 tagAttr ∷ Parser (CI Text, Text)
450 tagAttr = do name ← many1 letter
453 value ← many (satisfy (≠ '"'))
455 return (CI.mk $ T.pack name, T.pack value)
459 comment = (try (string "<!--") >> skipTillEnd 1)
463 skipTillEnd :: Int -> Parser ()
464 skipTillEnd level = (try (string "<!--") >> skipTillEnd (level + 1))
466 (try (string "-->") >> case level of
468 n -> skipTillEnd (n - 1))
470 (anyChar >> skipTillEnd level)
473 blockSymbols :: [Char]
474 blockSymbols = " =-*#;<"
477 inlineSymbols :: [Char]
478 inlineSymbols = "<[:'"
482 ws = skipMany ( (oneOf " \t" >> return ())
489 eol = (newline >> return ())