X-Git-Url: http://git.cielonegro.org/gitweb.cgi?a=blobdiff_plain;f=Rakka%2FWiki%2FParser.hs;h=19170b1fb1a941a9709968d24b2ae007c7563d37;hb=a4b849476ee3a204ea91dee8f3fd235b0b33a10a;hp=b5ec74d509f9ec8e2f840bbf8f9851499e0a1406;hpb=8a7556db44cd91ac0bb52279472bcc2abaa3f18e;p=Rakka.git diff --git a/Rakka/Wiki/Parser.hs b/Rakka/Wiki/Parser.hs index b5ec74d..19170b1 100644 --- a/Rakka/Wiki/Parser.hs +++ b/Rakka/Wiki/Parser.hs @@ -1,71 +1,502 @@ 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 wikiElement - eof - return xs +type CommandTypeOf = String -> Maybe CommandType -wikiElement :: Parser WikiElement -wikiElement = ( try (blockElement >>= return . Block) - <|> - try (inlineElement >>= return . Inline) - ) +wikiPage :: CommandTypeOf -> Parser WikiPage +wikiPage cmdTypeOf + = do xs <- many (blockElement cmdTypeOf) + skipMany ( comment + <|> + (newline >> return ()) + ) + eof + return xs -blockElement :: Parser BlockElement -blockElement = ( try header - <|> - try emptyLine - ) +blockElement :: CommandTypeOf -> Parser BlockElement +blockElement 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 +heading = foldr (<|>) pzero (map heading' [1..5]) + + "heading" + where + heading' :: Int -> Parser BlockElement + heading' n = do try $ do count n (char '=') + notFollowedBy (char '=') + ws + x <- notFollowedBy (char '=') >> anyChar + xs <- manyTill anyChar (try $ ws >> ( count n (char '=') + + ("trailing " ++ replicate n '=') + ) + ) + ws + eol + return (Heading n (x:xs)) + + +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" -header :: Parser BlockElement -header = foldr (<|>) pzero (map (try . header') [1..5]) +verbatim :: Parser BlockElement +verbatim = do try (string " Parser BlockElement - header' n = do count n (char '=') - notFollowedBy (char '=') - ws - x <- notFollowedBy (char '=') >> anyChar - xs <- manyTill anyChar (try $ ws >> (count n (char '='))) - ws - eol - return (Header n (x:xs)) + verbatim' :: Parser String + verbatim' = do try (many (oneOf " \t\n") >> string "]>") + return [] + <|> + do x <- anyChar + xs <- verbatim' + return (x:xs) -emptyLine :: Parser BlockElement -emptyLine = newline >> return EmptyLine +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 [] -inlineElement :: Parser InlineElement -inlineElement = text +paragraph :: CommandTypeOf -> Parser BlockElement +paragraph cmdTypeOf = liftM Paragraph paragraph' + where + paragraph' :: Parser [InlineElement] + paragraph' = do x <- inlineElement cmdTypeOf + xs <- try ( do newline + eof + return [] + -- \n で文字列が終はってゐたら、ここ + -- で終了。 + ) + <|> + try ( do newline + ((oneOf ('\n':blockSymbols) >> pzero) <|> return ()) + ys <- (paragraph' <|> return []) + return (Text "\n" : ys) + -- \n があり、その次に \n または + -- blockSymbols があれば、fail して + -- 最初の newline を讀んだ所まで卷き + -- 戻す。 + ) + <|> + paragraph' + -- それ以外の場合は次の inlineElement から + -- を讀んで見る。但し一つも無くても良い。 + <|> + return [] -- 全部失敗したらここで終了。 + 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 [ nowiki + , apostrophes cmdTypeOf + , text + , objLink + , pageLink + , extLink + , inlineCmd cmdTypeOf + ] + + +nowiki :: Parser InlineElement +nowiki = liftM Text (try (string "> nowiki') + where + nowiki' :: Parser String + nowiki' = do try (string "]>") + return [] + <|> + do x <- anyChar + xs <- nowiki' + return (x:xs) text :: Parser InlineElement -text = do xs <- many1 (noneOf symbols) - nl <- option "" (count 1 newline) - return $ Text (xs ++ nl) +text = liftM (Text . (':' :)) ( char ':' + >> + many (noneOf ('\n':inlineSymbols)) + ) + -- 定義リストとの關係上、コロンは先頭にしか來られない。 + <|> + liftM Text (many1 (noneOf ('\n':inlineSymbols))) + + "text" -symbols :: [Char] -symbols = "\n" +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 try (string "[[") + page <- option Nothing + (liftM Just (many1 (noneOf "#|]"))) + fragment <- option Nothing + (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 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 "") >> case level of + 1 -> return () + n -> skipTillEnd (n - 1)) + <|> + (anyChar >> skipTillEnd level) + + +blockSymbols :: [Char] +blockSymbols = " =-*#;<" + + +inlineSymbols :: [Char] +inlineSymbols = "<[:'" -- white space -ws :: Parser String -ws = many (oneOf " \t") +ws :: Parser () +ws = skipMany ( (oneOf " \t" >> return ()) + <|> + comment + ) -- end of line eol :: Parser () -eol = ( (newline >> return ()) - <|> - eof - ) +eol = (newline >> return ()) + <|> + eof