X-Git-Url: http://git.cielonegro.org/gitweb.cgi?p=Rakka.git;a=blobdiff_plain;f=Rakka%2FWiki%2FParser.hs;h=e7ca8ebbc456e063587cfed6767e0ee1bff92adb;hp=aae3a78eb6b1e1fe9a6c60f277f5b2d4c40939c2;hb=45bce2c29948649f74ada71f2fa851bdb812e96c;hpb=9932fbe6504e8b812703291e2497a5f010880d3b diff --git a/Rakka/Wiki/Parser.hs b/Rakka/Wiki/Parser.hs index aae3a78..e7ca8eb 100644 --- a/Rakka/Wiki/Parser.hs +++ b/Rakka/Wiki/Parser.hs @@ -1,18 +1,30 @@ +{-# LANGUAGE + OverloadedStrings + , RankNTypes + , UnicodeSyntax + , ViewPatterns + #-} module Rakka.Wiki.Parser ( CommandTypeOf , wikiPage ) where - -import Control.Monad -import Data.Maybe -import Network.URI hiding (fragment) -import Rakka.Wiki -import Text.ParserCombinators.Parsec hiding (label) - - -type CommandTypeOf = String -> Maybe CommandType - +-- FIXME: use attoparsec +import Control.Applicative hiding ((<|>), many) +import Control.Applicative.Unicode +import Control.Monad +import Data.CaseInsensitive (CI) +import qualified Data.CaseInsensitive as CI +import Data.Maybe +import Data.Monoid.Unicode ((⊕)) +import Data.Text (Text) +import qualified Data.Text as T +import Network.URI hiding (fragment) +import Prelude.Unicode +import Rakka.Wiki +import Text.ParserCombinators.Parsec hiding (label) + +type CommandTypeOf = Alternative f ⇒ Text → f CommandType wikiPage :: CommandTypeOf -> Parser WikiPage wikiPage cmdTypeOf @@ -41,26 +53,25 @@ blockElement cmdTypeOf , blockCmd cmdTypeOf ] - -heading :: Parser BlockElement +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 '=') + heading' ∷ Int → Parser BlockElement + heading' n = do try ( void (count n (char '=')) *> + notFollowedBy (char '=') + ) ws - x <- notFollowedBy (char '=') >> anyChar - xs <- manyTill anyChar (try $ ws >> ( count n (char '=') - - ("trailing " ++ replicate n '=') - ) - ) + x ← notFollowedBy (char '=') *> anyChar + xs ← manyTill anyChar (try $ ws *> ( count n (char '=') + + ("trailing " ++ replicate n '=') + ) + ) ws eol - return (Heading n (x:xs)) - + pure ∘ Heading n $ T.pack (x:xs) horizontalLine :: Parser BlockElement horizontalLine = try ( do _ <- count 4 (char '-') @@ -151,19 +162,15 @@ definitionList cmdTypeOf = liftM DefinitionList (many1 definition) "description of term" -verbatim :: Parser BlockElement -verbatim = do _ <- try (string " + many (oneOf " \t\n") *> + (Preformatted ∘ (:[]) ∘ Text ∘ T.pack <$> verbatim') where verbatim' :: Parser String - verbatim' = do _ <- try (many (oneOf " \t\n") >> string "]>") - return [] + verbatim' = try (many (oneOf " \t\n") *> string "]>") *> pure [] <|> - do x <- anyChar - xs <- verbatim' - return (x:xs) + ((:) <$> anyChar ⊛ verbatim') leadingSpaced :: CommandTypeOf -> Parser BlockElement @@ -231,10 +238,8 @@ blockCmd cmdTypeOf , bCmdAttributes = tagAttrs , bCmdContents = xs } - Just InlineCommandType -> pzero - _ -> return $ undefinedCmdErr tagName ) <|> @@ -246,35 +251,30 @@ blockCmd cmdTypeOf , 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) + contents ∷ Parser [BlockElement] + contents = ((:) <$> blockElement cmdTypeOf ⊛ contents) <|> - (newline >> contents) + (newline *> contents) <|> - (comment >> contents) + (comment *> contents) <|> - return [] + pure [] - undefinedCmdErr :: String -> BlockElement + undefinedCmdErr ∷ Text → BlockElement undefinedCmdErr name = Div [("class", "error")] - [ Block (Paragraph [Text ("The command `" ++ name ++ "' is not defined. " ++ + [ 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 @@ -287,31 +287,24 @@ inlineElement cmdTypeOf , inlineCmd cmdTypeOf ] - -nowiki :: Parser InlineElement -nowiki = liftM Text (try (string "> nowiki') +nowiki ∷ Parser InlineElement +nowiki = Text ∘ T.pack <$> (try (string " nowiki') where - nowiki' :: Parser String - nowiki' = do _ <- try (string "]>") - return [] + nowiki' ∷ Parser String + nowiki' = (try (string "]>") *> pure []) <|> - do x <- anyChar - xs <- nowiki' - return (x:xs) + ((:) <$> anyChar ⊛ nowiki') - -text :: Parser InlineElement -text = liftM (Text . (':' :)) ( char ':' - >> - many (noneOf ('\n':inlineSymbols)) - ) +text ∷ Parser InlineElement +text = (Text ∘ T.pack ∘ (':' :) <$> ( char ':' *> + many (noneOf ('\n':inlineSymbols)) + )) -- 定義リストとの關係上、コロンは先頭にしか來られない。 <|> - liftM Text (many1 (noneOf ('\n':inlineSymbols))) + (Text ∘ T.pack <$> (many1 (noneOf ('\n':inlineSymbols)))) "text" - apostrophes :: CommandTypeOf -> Parser InlineElement apostrophes cmdTypeOf = foldr (<|>) pzero (map try [apos1, apos2, apos3, apos4, apos5]) where @@ -338,63 +331,57 @@ 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 +objLink ∷ Parser InlineElement +objLink = do void $ try (string "[[[") + page ← many1 (noneOf "|]") + label ← option Nothing $ + Just <$> (char '|' *> many1 (satisfy (≠ ']'))) + void $ string "]]]" + pure $ ObjectLink (T.pack page) (T.pack <$> 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 +pageLink ∷ Parser InlineElement +pageLink = do void $ try (string "[[") + page ← option Nothing $ + Just <$> many1 (noneOf "#|]") + fragment ← option Nothing $ + Just <$> (char '#' *> many1 (noneOf "|]")) + label ← option Nothing $ + Just <$> (char '|' *> many1 (satisfy (≠ ']'))) + when (isNothing page ∧ isNothing fragment) (∅) + void $ string "]]" + pure $ PageLink (T.pack <$> page ) + (T.pack <$> fragment) + (T.pack <$> label ) "page link" - -extLink :: Parser InlineElement -extLink = do _ <- char '[' - uriStr <- many1 (noneOf " \t]") - _ <- skipMany (oneOf " \t") - label <- option Nothing - (liftM Just (many1 (noneOf "]"))) - +extLink ∷ Parser InlineElement +extLink = do void $ char '[' + uriStr ← many1 (noneOf " \t]") + void $ skipMany (oneOf " \t") + label ← option Nothing $ + Just <$> many1 (noneOf "]") case parseURI uriStr of - Just uri -> char ']' >> return (ExternalLink uri label) - Nothing -> pzero "absolute URI" + Just uri → char ']' *> pure (ExternalLink uri (T.pack <$> label)) + Nothing → pzero "absolute URI" "external link" - -inlineCmd :: CommandTypeOf -> Parser InlineElement +inlineCmd ∷ CommandTypeOf → Parser InlineElement inlineCmd cmdTypeOf - = (try $ do (tagName, tagAttrs) <- openTag + = (try $ do (tagName, tagAttrs) ← openTag case cmdTypeOf tagName of Just InlineCommandType - -> do xs <- contents - closeTag tagName - return $ InlineCmd InlineCommand { + → do xs ← contents + closeTag tagName + pure $ InlineCmd InlineCommand { iCmdName = tagName , iCmdAttributes = tagAttrs , iCmdContents = xs } - _ -> pzero + _ → pzero ) <|> (try $ do (tagName, tagAttrs) <- emptyTag @@ -410,62 +397,58 @@ inlineCmd cmdTypeOf "inline command" where - contents :: Parser [InlineElement] - contents = do x <- inlineElement cmdTypeOf - xs <- contents - return (x:xs) + contents ∷ Parser [InlineElement] + contents = ((:) <$> inlineElement cmdTypeOf ⊛ contents) <|> - (comment >> contents) + (comment *> contents) <|> - liftM (Text "\n" :) (newline >> contents) + ((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) + pure [] + +openTag ∷ Parser (Text, [Attribute]) +openTag = try $ do void $ char '<' + void $ many space + name ← many1 letter + void $ many space + attrs ← many $ do attr ← tagAttr + void $ many space + pure attr + void $ char '>' + return (T.pack name, attrs) + +emptyTag ∷ Parser (Text, [Attribute]) +emptyTag = try $ do void $ char '<' + void $ many space + name ← many1 letter + void $ many space + attrs ← many $ do attr ← tagAttr + void $ many space + pure attr + void $ char '/' + void $ many space + void $ char '>' + return (T.pack name, attrs) + +closeTag ∷ Text → Parser () +closeTag (T.unpack → name) + = try ( char '<' *> + many space *> + char '/' *> + many space *> + string name *> + many space *> + char '>' *> + pure () + ) + +tagAttr ∷ Parser (CI Text, Text) +tagAttr = do name ← many1 letter + void $ char '=' + void $ char '"' + value ← many (satisfy (≠ '"')) + void $ char '"' + return (CI.mk $ T.pack name, T.pack value) comment :: Parser ()