module Rakka.Wiki.Parser
- ( wikiPage
+ ( CommandTypeOf
+ , wikiPage
)
where
+import Control.Monad
+import Data.Maybe
+import Network.URI hiding (fragment)
import Rakka.Wiki
-import Text.ParserCombinators.Parsec
+import Text.ParserCombinators.Parsec hiding (label)
-wikiPage :: Parser WikiPage
-wikiPage = do xs <- many (try blockElement)
- skipMany ( comment
- <|>
- (newline >> return ())
- )
- eof
- return xs
+type CommandTypeOf = String -> Maybe CommandType
-blockElement :: Parser BlockElement
-blockElement = skipMany ( comment
+wikiPage :: CommandTypeOf -> Parser WikiPage
+wikiPage cmdTypeOf
+ = do xs <- many (blockElement cmdTypeOf)
+ skipMany ( comment
+ <|>
+ (newline >> return ())
+ )
+ eof
+ return xs
+
+
+blockElement :: CommandTypeOf -> Parser BlockElement
+blockElement cmdTypeOf
+ = try $ do skipMany ( comment
<|>
(newline >> return ())
)
- >>
- ( heading
- <|>
- paragraph
- )
+ foldr (<|>) pzero [ heading
+ , horizontalLine
+ , listElement cmdTypeOf
+ , definitionList cmdTypeOf
+ , verbatim
+ , leadingSpaced cmdTypeOf
+ , paragraph cmdTypeOf
+ , blockCmd cmdTypeOf
+ ]
heading :: Parser BlockElement
"heading"
where
heading' :: Int -> Parser BlockElement
- heading' n = do try $ do count n (char '=')
+ heading' n = do try $ do _ <- count n (char '=')
notFollowedBy (char '=')
ws
x <- notFollowedBy (char '=') >> anyChar
xs <- manyTill anyChar (try $ ws >> ( count n (char '=')
<?>
- ("trailing " ++ take n (repeat '='))
+ ("trailing " ++ replicate n '=')
)
)
ws
return (Heading n (x:xs))
-paragraph :: Parser BlockElement
-paragraph = paragraph' >>= return . Paragraph
+horizontalLine :: Parser BlockElement
+horizontalLine = try ( do _ <- count 4 (char '-')
+ _ <- many (char '-')
+ ws
+ eol
+ return HorizontalLine
+ )
+ <?>
+ "horizontal line"
+
+
+listElement :: CommandTypeOf -> Parser BlockElement
+listElement cmdTypeOf = listElement' []
+ where
+ listElement' :: [Char] -> Parser BlockElement
+ listElement' stack
+ = do t <- oneOf "*#"
+ ws
+ xs <- items (stack ++ [t])
+ return (List (toType t) xs)
+
+ items :: [Char] -> Parser [ListItem]
+ items stack = do xs <- many1 $ inlineElement cmdTypeOf
+ nested <- option Nothing
+ $ try $ do skipMany comment
+ _ <- newline
+ _ <- string stack
+ liftM Just (listElement' stack)
+ rest <- items stack
+ return $ (map Inline xs ++ map Block (catMaybes [nested])) : rest
+ <|>
+ (try $ do skipMany comment
+ _ <- newline
+ _ <- string stack
+ ws
+ items stack
+ )
+ <|>
+ return []
+
+ toType :: Char -> ListType
+ toType '*' = Bullet
+ toType '#' = Numbered
+ toType _ = undefined
+
+
+definitionList :: CommandTypeOf -> Parser BlockElement
+definitionList cmdTypeOf = liftM DefinitionList (many1 definition)
+ where
+ definition :: Parser Definition
+ definition = do _ <- char ';'
+ _ <- ws
+ tHead <- inlineElement cmdTypeOf
+ tRest <- term
+ d <- description
+ return (Definition (tHead:tRest) d)
+ <?>
+ "definition list"
+
+ term :: Parser [InlineElement]
+ term = (char ':' >> ws >> return [])
+ <|>
+ (newline >> char ':' >> ws >> return [])
+ <|>
+ do x <- inlineElement cmdTypeOf
+ xs <- term
+ return (x:xs)
+ <?>
+ "term to be defined"
+
+ description :: Parser [InlineElement]
+ description = do x <- inlineElement cmdTypeOf
+ xs <- description
+ return (x:xs)
+ <|>
+ try ( do _ <- newline
+ _ <- char ':'
+ _ <- ws
+ xs <- description
+ return (Text "\n" : xs)
+ )
+ <|>
+ (newline >> return [])
+ <|>
+ (eof >> return [])
+ <?>
+ "description of term"
+
+
+verbatim :: Parser BlockElement
+verbatim = do _ <- try (string "<!verbatim[")
+ _ <- many (oneOf " \t\n")
+ x <- verbatim'
+ return (Preformatted [Text x])
+ where
+ verbatim' :: Parser String
+ verbatim' = do _ <- try (many (oneOf " \t\n") >> string "]>")
+ return []
+ <|>
+ do x <- anyChar
+ xs <- verbatim'
+ return (x:xs)
+
+
+leadingSpaced :: CommandTypeOf -> Parser BlockElement
+leadingSpaced cmdTypeOf = liftM Preformatted (char ' ' >> leadingSpaced')
+ <?>
+ "leading space"
+ where
+ leadingSpaced' :: Parser [InlineElement]
+ leadingSpaced' = do x <- inlineElement cmdTypeOf
+ xs <- leadingSpaced'
+ return (x:xs)
+ <|>
+ try ( liftM (Text "\n" :) ( newline
+ >>
+ char ' '
+ >>
+ leadingSpaced'
+ )
+ )
+ <|>
+ return []
+
+
+paragraph :: CommandTypeOf -> Parser BlockElement
+paragraph cmdTypeOf = liftM Paragraph paragraph'
where
paragraph' :: Parser [InlineElement]
- paragraph' = do x <- inlineElement
- xs <- try ( do newline
- eof
+ paragraph' = do x <- inlineElement cmdTypeOf
+ xs <- try ( do _ <- newline
+ _ <- eof
return []
-- \n で文字列が終はってゐたら、ここ
-- で終了。
)
<|>
- try ( do newline
- ((oneOf ('\n':blockSymbols) >> pzero) <|> return ())
+ try ( do _ <- newline
+ _ <- ((oneOf ('\n':blockSymbols) >> pzero) <|> return ())
ys <- (paragraph' <|> return [])
return (Text "\n" : ys)
-- \n があり、その次に \n または
-- blockSymbols があれば、fail して
-- 最初の newline を讀んだ所まで卷き
-- 戻す。
+
+ -- FIXME: 本當にそのやうな動作になつ
+ -- てゐるか?偶然動いてゐるだけではな
+ -- いか?確かにこの實裝でユニットテス
+ -- トは通るのだが、私の理解を越えてし
+ -- まったやうだ。
)
<|>
- try paragraph'
+ paragraph'
-- それ以外の場合は次の inlineElement から
-- を讀んで見る。但し一つも無くても良い。
<|>
return (x:xs)
-inlineElement :: Parser InlineElement
-inlineElement = skipMany comment
- >>
- ( try text
- <|>
- try pageLink
- )
+blockCmd :: CommandTypeOf -> Parser BlockElement
+blockCmd cmdTypeOf
+ = (try $ do (tagName, tagAttrs) <- openTag
+ case cmdTypeOf tagName of
+ Just BlockCommandType
+ -> do xs <- contents
+ closeTag tagName
+ return $ BlockCmd BlockCommand {
+ bCmdName = tagName
+ , bCmdAttributes = tagAttrs
+ , bCmdContents = xs
+ }
+
+ Just InlineCommandType
+ -> pzero
+
+ _ -> return $ undefinedCmdErr tagName
+ )
+ <|>
+ (try $ do (tagName, tagAttrs) <- emptyTag
+ case cmdTypeOf tagName of
+ Just BlockCommandType
+ -> return $ BlockCmd BlockCommand {
+ bCmdName = tagName
+ , bCmdAttributes = tagAttrs
+ , bCmdContents = []
+ }
+
+ Just InlineCommandType
+ -> pzero
+
+ _ -> return $ undefinedCmdErr tagName
+ )
+ <?>
+ "block command"
+ where
+ contents :: Parser [BlockElement]
+ contents = do x <- blockElement cmdTypeOf
+ xs <- contents
+ return (x:xs)
+ <|>
+ (newline >> contents)
+ <|>
+ (comment >> contents)
+ <|>
+ return []
+
+ undefinedCmdErr :: String -> BlockElement
+ undefinedCmdErr name
+ = Div [("class", "error")]
+ [ Block (Paragraph [Text ("The command `" ++ name ++ "' is not defined. " ++
+ "Make sure you haven't mistyped.")
+ ])
+ ]
+
+
+inlineElement :: CommandTypeOf -> Parser InlineElement
+inlineElement cmdTypeOf
+ = try $ do skipMany comment
+ foldr (<|>) pzero [ nowiki
+ , apostrophes cmdTypeOf
+ , text
+ , objLink
+ , pageLink
+ , extLink
+ , inlineCmd cmdTypeOf
+ ]
+
+
+nowiki :: Parser InlineElement
+nowiki = liftM Text (try (string "<!nowiki[") >> nowiki')
+ where
+ nowiki' :: Parser String
+ nowiki' = do _ <- try (string "]>")
+ return []
+ <|>
+ do x <- anyChar
+ xs <- nowiki'
+ return (x:xs)
text :: Parser InlineElement
-text = many1 (noneOf ('\n':inlineSymbols)) >>= return . Text
+text = liftM (Text . (':' :)) ( char ':'
+ >>
+ many (noneOf ('\n':inlineSymbols))
+ )
+ -- 定義リストとの關係上、コロンは先頭にしか來られない。
+ <|>
+ liftM Text (many1 (noneOf ('\n':inlineSymbols)))
+ <?>
+ "text"
+
+
+apostrophes :: CommandTypeOf -> Parser InlineElement
+apostrophes cmdTypeOf = foldr (<|>) pzero (map try [apos1, apos2, apos3, apos4, apos5])
+ where
+ apos1 = apos 1 >> return (Text "'")
+
+ apos2 = do apos 2
+ xs <- many1 $ inlineElement cmdTypeOf
+ apos 2
+ return (Italic xs)
+
+ apos3 = do apos 3
+ xs <- many1 $ inlineElement cmdTypeOf
+ apos 3
+ return (Bold xs)
+
+ apos4 = apos 4 >> return (Text "'")
+
+ apos5 = do apos 5
+ xs <- many1 $ inlineElement cmdTypeOf
+ apos 5
+ return (Italic [Bold xs])
+
+ apos :: Int -> Parser ()
+ apos n = count n (char '\'') >> notFollowedBy (char '\'')
+
+
+objLink :: Parser InlineElement
+objLink = do _ <- try (string "[[[")
+ page <- many1 (noneOf "|]")
+ label <- option Nothing
+ (liftM Just (char '|' >> many1 (satisfy (/= ']'))))
+ _ <- string "]]]"
+ return $ ObjectLink page label
+ <?>
+ "object link"
pageLink :: Parser InlineElement
-pageLink = do string "[["
+pageLink = do _ <- try (string "[[")
page <- option Nothing
- (many1 (noneOf "#|]") >>= return . Just)
+ (liftM Just (many1 (noneOf "#|]")))
fragment <- option Nothing
- (char '#' >> many1 (noneOf "|]") >>= return . Just)
- text <- option Nothing
- (char '|' >> many1 (noneOf "]") >>= return . Just)
+ (liftM Just (char '#' >> many1 (noneOf "|]")))
+ label <- option Nothing
+ (liftM Just (char '|' >> many1 (satisfy (/= ']'))))
case (page, fragment) of
(Nothing, Nothing) -> pzero
(_, _) -> return ()
- string "]]"
- return $ PageLink page fragment text
+ _ <- string "]]"
+ return $ PageLink page fragment label
<?>
"page link"
+extLink :: Parser InlineElement
+extLink = do _ <- char '['
+ uriStr <- many1 (noneOf " \t]")
+ _ <- skipMany (oneOf " \t")
+ label <- option Nothing
+ (liftM Just (many1 (noneOf "]")))
+
+ case parseURI uriStr of
+ Just uri -> char ']' >> return (ExternalLink uri label)
+ Nothing -> pzero <?> "absolute URI"
+ <?>
+ "external link"
+
+
+inlineCmd :: CommandTypeOf -> Parser InlineElement
+inlineCmd cmdTypeOf
+ = (try $ do (tagName, tagAttrs) <- openTag
+ case cmdTypeOf tagName of
+ Just InlineCommandType
+ -> do xs <- contents
+ closeTag tagName
+ return $ InlineCmd InlineCommand {
+ iCmdName = tagName
+ , iCmdAttributes = tagAttrs
+ , iCmdContents = xs
+ }
+ _ -> pzero
+ )
+ <|>
+ (try $ do (tagName, tagAttrs) <- emptyTag
+ case cmdTypeOf tagName of
+ Just InlineCommandType
+ -> return $ InlineCmd InlineCommand {
+ iCmdName = tagName
+ , iCmdAttributes = tagAttrs
+ , iCmdContents = []
+ }
+ _ -> pzero
+ )
+ <?>
+ "inline command"
+ where
+ contents :: Parser [InlineElement]
+ contents = do x <- inlineElement cmdTypeOf
+ xs <- contents
+ return (x:xs)
+ <|>
+ (comment >> contents)
+ <|>
+ liftM (Text "\n" :) (newline >> contents)
+ <|>
+ return []
+
+
+openTag :: Parser (String, [Attribute])
+openTag = try $ do _ <- char '<'
+ _ <- many space
+ name <- many1 letter
+ _ <- many space
+ attrs <- many $ do attr <- tagAttr
+ _ <- many space
+ return attr
+ _ <- char '>'
+ return (name, attrs)
+
+
+emptyTag :: Parser (String, [Attribute])
+emptyTag = try $ do _ <- char '<'
+ _ <- many space
+ name <- many1 letter
+ _ <- many space
+ attrs <- many $ do attr <- tagAttr
+ _ <- many space
+ return attr
+ _ <- char '/'
+ _ <- many space
+ _ <- char '>'
+ return (name, attrs)
+
+
+closeTag :: String -> Parser ()
+closeTag name = try $ do _ <- char '<'
+ _ <- many space
+ _ <- char '/'
+ _ <- many space
+ _ <- string name
+ _ <- many space
+ _ <- char '>'
+ return ()
+
+
+tagAttr :: Parser (String, String)
+tagAttr = do name <- many1 letter
+ _ <- char '='
+ _ <- char '"'
+ value <- many (satisfy (/= '"'))
+ _ <- char '"'
+ return (name, value)
+
+
comment :: Parser ()
comment = (try (string "<!--") >> skipTillEnd 1)
<?>
"comment"
where
skipTillEnd :: Int -> Parser ()
- skipTillEnd level = ( (try (string "<!--") >> skipTillEnd (level + 1))
- <|>
- (try (string "-->") >> case level of
- 1 -> return ()
- n -> skipTillEnd (n - 1))
- <|>
- (anyChar >> skipTillEnd level)
- )
+ skipTillEnd level = (try (string "<!--") >> skipTillEnd (level + 1))
+ <|>
+ (try (string "-->") >> case level of
+ 1 -> return ()
+ n -> skipTillEnd (n - 1))
+ <|>
+ (anyChar >> skipTillEnd level)
blockSymbols :: [Char]
-blockSymbols = "="
+blockSymbols = " =-*#;<"
inlineSymbols :: [Char]
-inlineSymbols = "<["
+inlineSymbols = "<[:'"
-- white space
ws :: Parser ()
-- end of line
eol :: Parser ()
-eol = ( (newline >> return ())
- <|>
- eof
- )
+eol = (newline >> return ())
+ <|>
+ eof