+{-# 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
, 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 '-')
"description of term"
-verbatim :: Parser BlockElement
-verbatim = do _ <- try (string "<!verbatim[")
- _ <- many (oneOf " \t\n")
- x <- verbatim'
- return (Preformatted [Text x])
+verbatim ∷ Parser BlockElement
+verbatim = try (string "<!verbatim[") *>
+ 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
, bCmdAttributes = tagAttrs
, bCmdContents = xs
}
-
Just InlineCommandType
-> pzero
-
_ -> return $ undefinedCmdErr 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)
+ 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
, inlineCmd cmdTypeOf
]
-
-nowiki :: Parser InlineElement
-nowiki = liftM Text (try (string "<!nowiki[") >> nowiki')
+nowiki ∷ Parser InlineElement
+nowiki = Text ∘ T.pack <$> (try (string "<!nowiki[") *> 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
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
<?>
"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 ()
projects / Rakka.git / blobdiff