X-Git-Url: http://git.cielonegro.org/gitweb.cgi?a=blobdiff_plain;f=Rakka%2FWiki%2FParser.hs;h=aae3a78eb6b1e1fe9a6c60f277f5b2d4c40939c2;hb=223d4df57fa1371945075d4d2714e5f36c1fc5dd;hp=6e4edeb4bc5c604aab1f6e97c0080471c1ebeff4;hpb=e43bb104a7313dd696b8bb8aa3bafff94706a187;p=Rakka.git diff --git a/Rakka/Wiki/Parser.hs b/Rakka/Wiki/Parser.hs index 6e4edeb..aae3a78 100644 --- a/Rakka/Wiki/Parser.hs +++ b/Rakka/Wiki/Parser.hs @@ -4,10 +4,11 @@ module Rakka.Wiki.Parser ) where +import Control.Monad import Data.Maybe -import Network.URI +import Network.URI hiding (fragment) import Rakka.Wiki -import Text.ParserCombinators.Parsec +import Text.ParserCombinators.Parsec hiding (label) type CommandTypeOf = String -> Maybe CommandType @@ -34,7 +35,7 @@ blockElement cmdTypeOf , horizontalLine , listElement cmdTypeOf , definitionList cmdTypeOf - , pdata + , verbatim , leadingSpaced cmdTypeOf , paragraph cmdTypeOf , blockCmd cmdTypeOf @@ -47,13 +48,13 @@ heading = foldr (<|>) pzero (map heading' [1..5]) "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 @@ -62,8 +63,8 @@ heading = foldr (<|>) pzero (map heading' [1..5]) horizontalLine :: Parser BlockElement -horizontalLine = try ( do count 4 (char '-') - many (char '-') +horizontalLine = try ( do _ <- count 4 (char '-') + _ <- many (char '-') ws eol return HorizontalLine @@ -86,15 +87,15 @@ listElement cmdTypeOf = listElement' [] items stack = do xs <- many1 $ inlineElement cmdTypeOf nested <- option Nothing $ try $ do skipMany comment - newline - string stack - listElement' stack >>= return . Just + _ <- 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 + _ <- newline + _ <- string stack ws items stack ) @@ -104,14 +105,15 @@ listElement cmdTypeOf = listElement' [] 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 ';' - ws + definition = do _ <- char ';' + _ <- ws tHead <- inlineElement cmdTypeOf tRest <- term d <- description @@ -135,9 +137,9 @@ definitionList cmdTypeOf = many1 definition >>= return . DefinitionList xs <- description return (x:xs) <|> - try ( do newline - char ':' - ws + try ( do _ <- newline + _ <- char ':' + _ <- ws xs <- description return (Text "\n" : xs) ) @@ -149,23 +151,23 @@ definitionList cmdTypeOf = many1 definition >>= return . DefinitionList "description of term" -pdata :: Parser BlockElement -pdata = do try (string "> 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 @@ -174,42 +176,39 @@ leadingSpaced cmdTypeOf = (char ' ' >> leadingSpaced' >>= return . Preformatted) 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 - xs <- try ( do newline - eof + 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 を讀んだ所まで卷き - -- 戻す。 + -- blockSymbols があれば、fail して最 + -- 初の newline を讀んだ所まで卷き戻 + -- す。oneOf が一文字消費しているので、 + -- <|> は右辺を適用せずに try まで戻 + -- る。 ) <|> paragraph' @@ -227,7 +226,7 @@ blockCmd cmdTypeOf Just BlockCommandType -> do xs <- contents closeTag tagName - return $ BlockCmd $ BlockCommand { + return $ BlockCmd BlockCommand { bCmdName = tagName , bCmdAttributes = tagAttrs , bCmdContents = xs @@ -242,7 +241,7 @@ blockCmd cmdTypeOf (try $ do (tagName, tagAttrs) <- emptyTag case cmdTypeOf tagName of Just BlockCommandType - -> return $ BlockCmd $ BlockCommand { + -> return $ BlockCmd BlockCommand { bCmdName = tagName , bCmdAttributes = tagAttrs , bCmdContents = [] @@ -279,7 +278,7 @@ blockCmd cmdTypeOf inlineElement :: CommandTypeOf -> Parser InlineElement inlineElement cmdTypeOf = try $ do skipMany comment - foldr (<|>) pzero [ cdata + foldr (<|>) pzero [ nowiki , apostrophes cmdTypeOf , text , objLink @@ -289,31 +288,26 @@ inlineElement cmdTypeOf ] -cdata :: Parser InlineElement -cdata = try (string "> cdata' >>= return . Text +nowiki :: Parser InlineElement +nowiki = liftM Text (try (string "> 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" @@ -345,44 +339,44 @@ apostrophes cmdTypeOf = foldr (<|>) pzero (map try [apos1, apos2, apos3, apos4, objLink :: Parser InlineElement -objLink = do try (string "[[[") - page <- many1 (noneOf "|]") - text <- option Nothing - (char '|' >> many1 (satisfy (/= ']')) >>= return . Just) - string "]]]" - return $ ObjectLink page text +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 "[[") +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 + _ <- string "]]" + return $ PageLink page fragment label "page link" extLink :: Parser InlineElement -extLink = do char '[' +extLink = do _ <- char '[' uriStr <- many1 (noneOf " \t]") - skipMany (oneOf " \t") - text <- option Nothing - (many1 (noneOf "]") >>= return . Just) + _ <- skipMany (oneOf " \t") + label <- option Nothing + (liftM Just (many1 (noneOf "]"))) case parseURI uriStr of - Just uri -> char ']' >> return (ExternalLink uri text) + Just uri -> char ']' >> return (ExternalLink uri label) Nothing -> pzero "absolute URI" "external link" @@ -395,7 +389,7 @@ inlineCmd cmdTypeOf Just InlineCommandType -> do xs <- contents closeTag tagName - return $ InlineCmd $ InlineCommand { + return $ InlineCmd InlineCommand { iCmdName = tagName , iCmdAttributes = tagAttrs , iCmdContents = xs @@ -406,7 +400,7 @@ inlineCmd cmdTypeOf (try $ do (tagName, tagAttrs) <- emptyTag case cmdTypeOf tagName of Just InlineCommandType - -> return $ InlineCmd $ InlineCommand { + -> return $ InlineCmd InlineCommand { iCmdName = tagName , iCmdAttributes = tagAttrs , iCmdContents = [] @@ -423,54 +417,54 @@ inlineCmd cmdTypeOf <|> (comment >> contents) <|> - (newline >> contents >>= return . (Text "\n" :)) + liftM (Text "\n" :) (newline >> contents) <|> return [] openTag :: Parser (String, [Attribute]) -openTag = try $ do char '<' - many space +openTag = try $ do _ <- char '<' + _ <- many space name <- many1 letter - many space + _ <- many space attrs <- many $ do attr <- tagAttr - many space + _ <- many space return attr - char '>' + _ <- char '>' return (name, attrs) emptyTag :: Parser (String, [Attribute]) -emptyTag = try $ do char '<' - many space +emptyTag = try $ do _ <- char '<' + _ <- many space name <- many1 letter - many space + _ <- many space attrs <- many $ do attr <- tagAttr - many space + _ <- many space return attr - char '/' - many space - char '>' + _ <- 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 '>' +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 '"' + _ <- char '=' + _ <- char '"' value <- many (satisfy (/= '"')) - char '"' + _ <- char '"' return (name, value) @@ -480,14 +474,13 @@ comment = (try (string "") >> case level of - 1 -> return () - n -> skipTillEnd (n - 1)) - <|> - (anyChar >> skipTillEnd level) - ) + skipTillEnd level = (try (string "") >> case level of + 1 -> return () + n -> skipTillEnd (n - 1)) + <|> + (anyChar >> skipTillEnd level) blockSymbols :: [Char] @@ -506,7 +499,6 @@ ws = skipMany ( (oneOf " \t" >> return ()) -- end of line eol :: Parser () -eol = ( (newline >> return ()) - <|> - eof - ) +eol = (newline >> return ()) + <|> + eof