X-Git-Url: http://git.cielonegro.org/gitweb.cgi?a=blobdiff_plain;f=Rakka%2FWiki%2FParser.hs;h=19170b1fb1a941a9709968d24b2ae007c7563d37;hb=a4b849476ee3a204ea91dee8f3fd235b0b33a10a;hp=dd87751d29f53e65de60a06e1a404565941b846b;hpb=2ad43b49ecc25bdf87dd19037fd63c12428992ae;p=Rakka.git diff --git a/Rakka/Wiki/Parser.hs b/Rakka/Wiki/Parser.hs index dd87751..19170b1 100644 --- a/Rakka/Wiki/Parser.hs +++ b/Rakka/Wiki/Parser.hs @@ -4,9 +4,11 @@ module Rakka.Wiki.Parser ) 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 @@ -14,7 +16,7 @@ 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 ()) @@ -25,20 +27,19 @@ wikiPage cmdTypeOf 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 @@ -53,7 +54,7 @@ heading = foldr (<|>) pzero (map heading' [1..5]) x <- notFollowedBy (char '=') >> anyChar xs <- manyTill anyChar (try $ ws >> ( count n (char '=') - ("trailing " ++ take n (repeat '=')) + ("trailing " ++ replicate n '=') ) ) ws @@ -73,25 +74,24 @@ horizontalLine = try ( do count 4 (char '-') 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 @@ -105,10 +105,11 @@ listElement cmdTypeOf = listElement' [] >>= return . List 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 ';' @@ -150,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 @@ -175,24 +176,19 @@ 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 @@ -205,16 +201,15 @@ paragraph cmdTypeOf = paragraph' >>= return . Paragraph <|> try ( do newline ((oneOf ('\n':blockSymbols) >> pzero) <|> return ()) - ((blockCommand >> pzero) <|> return ()) ys <- (paragraph' <|> return []) return (Text "\n" : ys) - -- \n があり、その次に \n、ブロックタ - -- グまたは blockSymbols があれば、 - -- fail して 最初の newline を讀んだ - -- 所まで卷き戻す。 + -- \n があり、その次に \n または + -- blockSymbols があれば、fail して + -- 最初の newline を讀んだ所まで卷き + -- 戻す。 ) <|> - try paragraph' + paragraph' -- それ以外の場合は次の inlineElement から -- を讀んで見る。但し一つも無くても良い。 <|> @@ -222,42 +217,95 @@ paragraph cmdTypeOf = paragraph' >>= return . Paragraph 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' >>= 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" @@ -288,25 +336,50 @@ apostrophes cmdTypeOf = foldr (<|>) pzero (map try [apos1, apos2, apos3, apos4, 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 @@ -314,10 +387,10 @@ inlineCmd cmdTypeOf Just InlineCommandType -> do xs <- contents closeTag tagName - return $ InlineCmd $ InlineCommand { + return $ InlineCmd InlineCommand { iCmdName = tagName , iCmdAttributes = tagAttrs - , iCmdContents = xs + , iCmdContents = xs } _ -> pzero ) @@ -325,13 +398,15 @@ inlineCmd cmdTypeOf (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 @@ -340,7 +415,7 @@ inlineCmd cmdTypeOf <|> (comment >> contents) <|> - (newline >> contents >>= return . (Text "\n" :)) + liftM (Text "\n" :) (newline >> contents) <|> return [] @@ -397,18 +472,17 @@ 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] -blockSymbols = " =-*#;" +blockSymbols = " =-*#;<" inlineSymbols :: [Char] @@ -423,7 +497,6 @@ ws = skipMany ( (oneOf " \t" >> return ()) -- end of line eol :: Parser () -eol = ( (newline >> return ()) - <|> - eof - ) +eol = (newline >> return ()) + <|> + eof