)
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)
type CommandTypeOf = String -> Maybe CommandType
wikiPage :: CommandTypeOf -> Parser WikiPage
wikiPage cmdTypeOf
- = do xs <- many $ try (blockElement cmdTypeOf)
+ = do xs <- many (blockElement cmdTypeOf)
skipMany ( comment
<|>
(newline >> return ())
blockElement :: CommandTypeOf -> Parser BlockElement
blockElement cmdTypeOf
- = skipMany ( comment
- <|>
- (newline >> return ())
- )
- >>
- ( foldr (<|>) pzero [ heading
- , horizontalLine
- , listElement cmdTypeOf
- , definitionList cmdTypeOf
- , pdata
- , leadingSpaced cmdTypeOf
- , paragraph cmdTypeOf
- ]
- )
+ = try $ do skipMany ( comment
+ <|>
+ (newline >> return ())
+ )
+ foldr (<|>) pzero [ heading
+ , horizontalLine
+ , listElement cmdTypeOf
+ , definitionList cmdTypeOf
+ , verbatim
+ , leadingSpaced cmdTypeOf
+ , paragraph cmdTypeOf
+ , blockCmd cmdTypeOf
+ ]
heading :: Parser BlockElement
x <- notFollowedBy (char '=') >> anyChar
xs <- manyTill anyChar (try $ ws >> ( count n (char '=')
<?>
- ("trailing " ++ take n (repeat '='))
+ ("trailing " ++ replicate n '=')
)
)
ws
listElement :: CommandTypeOf -> Parser BlockElement
-listElement cmdTypeOf = listElement' [] >>= return . List
+listElement cmdTypeOf = listElement' []
where
- listElement' :: [Char] -> Parser ListElement
+ listElement' :: [Char] -> Parser BlockElement
listElement' stack
= do t <- oneOf "*#"
ws
xs <- items (stack ++ [t])
- return (ListElement (toType t) xs)
+ return (List (toType t) xs)
- -- ListItem の終了條件は、
items :: [Char] -> Parser [ListItem]
items stack = do xs <- many1 $ inlineElement cmdTypeOf
nested <- option Nothing
$ try $ do skipMany comment
newline
string stack
- listElement' stack >>= return . Just
+ liftM Just (listElement' stack)
rest <- items stack
- return $ (map Right xs ++ map Left (catMaybes [nested])) : rest
+ return $ (map Inline xs ++ map Block (catMaybes [nested])) : rest
<|>
(try $ do skipMany comment
newline
toType :: Char -> ListType
toType '*' = Bullet
toType '#' = Numbered
+ toType _ = undefined
definitionList :: CommandTypeOf -> Parser BlockElement
-definitionList cmdTypeOf = many1 definition >>= return . DefinitionList
+definitionList cmdTypeOf = liftM DefinitionList (many1 definition)
where
definition :: Parser Definition
definition = do char ';'
"description of term"
-pdata :: Parser BlockElement
-pdata = do try (string "<![PDATA[")
- many (oneOf " \t\n")
- x <- pdata'
- return (Preformatted [Text x])
+verbatim :: Parser BlockElement
+verbatim = do try (string "<!verbatim[")
+ many (oneOf " \t\n")
+ x <- verbatim'
+ return (Preformatted [Text x])
where
- pdata' :: Parser String
- pdata' = do try (many (oneOf " \t\n") >> string "]]>")
- return []
- <|>
- do x <- anyChar
- xs <- pdata'
- return (x:xs)
+ 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 = (char ' ' >> leadingSpaced' >>= return . Preformatted)
+leadingSpaced cmdTypeOf = liftM Preformatted (char ' ' >> leadingSpaced')
<?>
"leading space"
where
xs <- leadingSpaced'
return (x:xs)
<|>
- try ( newline
- >>
- char ' '
- >>
- leadingSpaced'
- >>=
- return . (Text "\n" :)
+ try ( liftM (Text "\n" :) ( newline
+ >>
+ char ' '
+ >>
+ leadingSpaced'
+ )
)
<|>
return []
-blockCommand :: Parser BlockElement
-blockCommand = pzero -- not implemented
-
-
paragraph :: CommandTypeOf -> Parser BlockElement
-paragraph cmdTypeOf = paragraph' >>= return . Paragraph
+paragraph cmdTypeOf = liftM Paragraph paragraph'
where
paragraph' :: Parser [InlineElement]
paragraph' = do x <- inlineElement cmdTypeOf
<|>
try ( do newline
((oneOf ('\n':blockSymbols) >> pzero) <|> return ())
- ((blockCommand >> pzero) <|> return ())
ys <- (paragraph' <|> return [])
return (Text "\n" : ys)
- -- \n があり、その次に \n、ブロックタ
- -- グまたは blockSymbols があれば、
- -- fail して 最初の newline を讀んだ
- -- æ\89\80ã\81¾ã\81§å\8d·ã\81\8dæ\88»ã\81\99ã\80\82
+ -- \n があり、その次に \n または
+ -- blockSymbols があれば、fail して
+ -- 最初の newline を讀んだ所まで卷き
+ -- 戻す。
)
<|>
- try paragraph'
+ paragraph'
-- それ以外の場合は次の inlineElement から
-- を讀んで見る。但し一つも無くても良い。
<|>
return (x:xs)
+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 [ cdata
+ foldr (<|>) pzero [ nowiki
, apostrophes cmdTypeOf
, text
+ , objLink
, pageLink
+ , extLink
, inlineCmd cmdTypeOf
]
-cdata :: Parser InlineElement
-cdata = try (string "<![CDATA[") >> cdata' >>= return . Text
+nowiki :: Parser InlineElement
+nowiki = liftM Text (try (string "<!nowiki[") >> nowiki')
where
- cdata' :: Parser String
- cdata' = do try (string "]]>")
- return []
- <|>
- do x <- anyChar
- xs <- cdata'
- return (x:xs)
+ nowiki' :: Parser String
+ nowiki' = do try (string "]>")
+ return []
+ <|>
+ do x <- anyChar
+ xs <- nowiki'
+ return (x:xs)
text :: Parser InlineElement
-text = ( char ':'
- >>
- many (noneOf ('\n':inlineSymbols))
- >>=
- return . Text . (':' :)
- -- 定義リストとの關係上、コロンは先頭にしか來れない。
- )
+text = liftM (Text . (':' :)) ( char ':'
+ >>
+ many (noneOf ('\n':inlineSymbols))
+ )
+ -- 定義リストとの關係上、コロンは先頭にしか來られない。
<|>
- ( many1 (noneOf ('\n':inlineSymbols))
- >>=
- return . Text
- )
+ liftM Text (many1 (noneOf ('\n':inlineSymbols)))
<?>
"text"
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 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 (satisfy (/= ']')) >>= 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
+ 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
Just InlineCommandType
-> do xs <- contents
closeTag tagName
- return $ InlineCmd $ InlineCommand {
+ return $ InlineCmd InlineCommand {
iCmdName = tagName
, iCmdAttributes = tagAttrs
- , iCmdContents = xs
+ , iCmdContents = xs
}
_ -> pzero
)
(try $ do (tagName, tagAttrs) <- emptyTag
case cmdTypeOf tagName of
Just InlineCommandType
- -> return $ InlineCmd $ InlineCommand {
+ -> return $ InlineCmd InlineCommand {
iCmdName = tagName
, iCmdAttributes = tagAttrs
, iCmdContents = []
}
_ -> pzero
)
+ <?>
+ "inline command"
where
contents :: Parser [InlineElement]
contents = do x <- inlineElement cmdTypeOf
<|>
(comment >> contents)
<|>
- (newline >> contents >>= return . (Text "\n" :))
+ liftM (Text "\n" :) (newline >> contents)
<|>
return []
"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]
-- end of line
eol :: Parser ()
-eol = ( (newline >> return ())
- <|>
- eof
- )
+eol = (newline >> return ())
+ <|>
+ eof
projects / Rakka.git / blobdiff