Tissevert/pandoc
1
0
Fork 0
Code Issues Pull requests Projects Releases Packages Wiki Activity Actions 1

TWiki reader: hlint

Browse source
This commit is contained in:
Alexander Krotov 2018-10-03 19:42:08 +03:00
parent fbc733d3a8
commit 05d52eb9bb
1 changed files with 50 additions and 61 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

111
src/Text/Pandoc/Readers/TWiki.hs
View file

@ -74,9 +74,6 @@ type TWParser = ParserT [Char] ParserState
tryMsg :: String -> TWParser m a -> TWParser m a tryMsg :: String -> TWParser m a -> TWParser m a
tryMsg msg p = try p <?> msg tryMsg msg p = try p <?> msg
skip :: TWParser m a -> TWParser m ()
skip parser = parser >> return ()
nested :: PandocMonad m => TWParser m a -> TWParser m a nested :: PandocMonad m => TWParser m a -> TWParser m a
nested p = do nested p = do
nestlevel <- stateMaxNestingLevel <$> getState nestlevel <- stateMaxNestingLevel <$> getState
@ -92,7 +89,7 @@ htmlElement tag = tryMsg tag $ do
content <- manyTill anyChar (endtag <|> endofinput) content <- manyTill anyChar (endtag <|> endofinput)
return (htmlAttrToPandoc attr, trim content) return (htmlAttrToPandoc attr, trim content)
where where
endtag = skip $ htmlTag (~== TagClose tag) endtag = void $ htmlTag (~== TagClose tag)
endofinput = lookAhead $ try $ skipMany blankline >> skipSpaces >> eof endofinput = lookAhead $ try $ skipMany blankline >> skipSpaces >> eof
trim = dropWhile (=='\n') . reverse . dropWhile (=='\n') . reverse trim = dropWhile (=='\n') . reverse . dropWhile (=='\n') . reverse
@ -114,18 +111,15 @@ parseHtmlContentWithAttrs tag parser = do
endOfContent = try $ skipMany blankline >> skipSpaces >> eof endOfContent = try $ skipMany blankline >> skipSpaces >> eof
parseHtmlContent :: PandocMonad m => String -> TWParser m a -> TWParser m [a] parseHtmlContent :: PandocMonad m => String -> TWParser m a -> TWParser m [a]
parseHtmlContent tag p = parseHtmlContentWithAttrs tag p >>= return . snd parseHtmlContent tag p = snd <$> parseHtmlContentWithAttrs tag p
-- --
-- main parser -- main parser
-- --
parseTWiki :: PandocMonad m => TWParser m Pandoc parseTWiki :: PandocMonad m => TWParser m Pandoc
parseTWiki = do parseTWiki =
bs <- mconcat <$> many block B.doc . mconcat <$> many block <* spaces <* eof
spaces
eof
return $ B.doc bs
-- --
@ -158,7 +152,7 @@ separator = tryMsg "separator" $ string "---" >> newline >> return B.horizontalR
header :: PandocMonad m => TWParser m B.Blocks header :: PandocMonad m => TWParser m B.Blocks
header = tryMsg "header" $ do header = tryMsg "header" $ do
string "---" string "---"
level <- many1 (char '+') >>= return . length level <- length <$> many1 (char '+')
guard $ level <= 6 guard $ level <= 6
classes <- option [] $ string "!!" >> return ["unnumbered"] classes <- option [] $ string "!!" >> return ["unnumbered"]
skipSpaces skipSpaces
@ -167,11 +161,10 @@ header = tryMsg "header" $ do
return $ B.headerWith attr level content return $ B.headerWith attr level content
verbatim :: PandocMonad m => TWParser m B.Blocks verbatim :: PandocMonad m => TWParser m B.Blocks
verbatim = (htmlElement "verbatim" <|> htmlElement "pre") verbatim = uncurry B.codeBlockWith <$> (htmlElement "verbatim" <|> htmlElement "pre")
>>= return . (uncurry B.codeBlockWith)
literal :: PandocMonad m => TWParser m B.Blocks literal :: PandocMonad m => TWParser m B.Blocks
literal = htmlElement "literal" >>= return . rawBlock literal = rawBlock <$> htmlElement "literal"
where where
format (_, _, kvs) = fromMaybe "html" $ lookup "format" kvs format (_, _, kvs) = fromMaybe "html" $ lookup "format" kvs
rawBlock (attrs, content) = B.rawBlock (format attrs) content rawBlock (attrs, content) = B.rawBlock (format attrs) content
@ -183,7 +176,7 @@ list prefix = choice [ bulletList prefix
definitionList :: PandocMonad m => String -> TWParser m B.Blocks definitionList :: PandocMonad m => String -> TWParser m B.Blocks
definitionList prefix = tryMsg "definitionList" $ do definitionList prefix = tryMsg "definitionList" $ do
indent <- lookAhead $ string prefix *> (many1 $ string " ") <* string "$ " indent <- lookAhead $ string prefix *> many1 (string " ") <* string "$ "
elements <- many $ parseDefinitionListItem (prefix ++ concat indent) elements <- many $ parseDefinitionListItem (prefix ++ concat indent)
return $ B.definitionList elements return $ B.definitionList elements
where where
@ -193,7 +186,7 @@ definitionList prefix = tryMsg "definitionList" $ do
string (indent ++ "$ ") >> skipSpaces string (indent ++ "$ ") >> skipSpaces
term <- many1Till inline $ string ": " term <- many1Till inline $ string ": "
line <- listItemLine indent $ string "$ " line <- listItemLine indent $ string "$ "
return $ (mconcat term, [line]) return (mconcat term, [line])
bulletList :: PandocMonad m => String -> TWParser m B.Blocks bulletList :: PandocMonad m => String -> TWParser m B.Blocks
bulletList prefix = tryMsg "bulletList" $ bulletList prefix = tryMsg "bulletList" $
@ -227,25 +220,24 @@ parseListItem prefix marker = string prefix >> marker >> listItemLine prefix mar
listItemLine :: (PandocMonad m, Show a) listItemLine :: (PandocMonad m, Show a)
=> String -> TWParser m a -> TWParser m B.Blocks => String -> TWParser m a -> TWParser m B.Blocks
listItemLine prefix marker = lineContent >>= parseContent >>= return . mconcat listItemLine prefix marker = mconcat <$> (lineContent >>= parseContent)
where where
lineContent = do lineContent = do
content <- anyLine content <- anyLine
continuation <- optionMaybe listContinuation continuation <- optionMaybe listContinuation
return $ filterSpaces content ++ "\n" ++ (maybe "" (" " ++) continuation) return $ filterSpaces content ++ "\n" ++ maybe "" (" " ++) continuation
filterSpaces = reverse . dropWhile (== ' ') . reverse filterSpaces = reverse . dropWhile (== ' ') . reverse
listContinuation = notFollowedBy (string prefix >> marker) >> listContinuation = notFollowedBy (string prefix >> marker) >>
string " " >> lineContent string " " >> lineContent
parseContent = parseFromString' $ many1 $ nestedList <|> parseInline parseContent = parseFromString' $ many1 $ nestedList <|> parseInline
parseInline = many1Till inline (lastNewline <|> newlineBeforeNestedList) >>= parseInline = (B.plain . mconcat) <$> many1Till inline (lastNewline <|> newlineBeforeNestedList)
return . B.plain . mconcat
nestedList = list prefix nestedList = list prefix
lastNewline = try $ char '\n' <* eof lastNewline = try $ char '\n' <* eof
newlineBeforeNestedList = try $ char '\n' <* lookAhead nestedList newlineBeforeNestedList = try $ char '\n' <* lookAhead nestedList
table :: PandocMonad m => TWParser m B.Blocks table :: PandocMonad m => TWParser m B.Blocks
table = try $ do table = try $ do
tableHead <- optionMaybe $ many1Till tableParseHeader newline >>= return . unzip tableHead <- optionMaybe (unzip <$> many1Till tableParseHeader newline)
rows <- many1 tableParseRow rows <- many1 tableParseRow
return $ buildTable mempty rows $ fromMaybe (align rows, columns rows) tableHead return $ buildTable mempty rows $ fromMaybe (align rows, columns rows) tableHead
where where
@ -258,11 +250,11 @@ table = try $ do
tableParseHeader :: PandocMonad m => TWParser m ((Alignment, Double), B.Blocks) tableParseHeader :: PandocMonad m => TWParser m ((Alignment, Double), B.Blocks)
tableParseHeader = try $ do tableParseHeader = try $ do
char '|' char '|'
leftSpaces <- many spaceChar >>= return . length leftSpaces <- length <$> many spaceChar
char '*' char '*'
content <- tableColumnContent (char '*' >> skipSpaces >> char '|') content <- tableColumnContent (char '*' >> skipSpaces >> char '|')
char '*' char '*'
rightSpaces <- many spaceChar >>= return . length rightSpaces <- length <$> many spaceChar
optional tableEndOfRow optional tableEndOfRow
return (tableAlign leftSpaces rightSpaces, content) return (tableAlign leftSpaces rightSpaces, content)
where where
@ -283,13 +275,13 @@ tableEndOfRow :: PandocMonad m => TWParser m Char
tableEndOfRow = lookAhead (try $ char '|' >> char '\n') >> char '|' tableEndOfRow = lookAhead (try $ char '|' >> char '\n') >> char '|'
tableColumnContent :: PandocMonad m => TWParser m a -> TWParser m B.Blocks tableColumnContent :: PandocMonad m => TWParser m a -> TWParser m B.Blocks
tableColumnContent end = manyTill content (lookAhead $ try end) >>= return . B.plain . mconcat tableColumnContent end = (B.plain . mconcat) <$> manyTill content (lookAhead $ try end)
where where
content = continuation <|> inline content = continuation <|> inline
continuation = try $ char '\\' >> newline >> return mempty continuation = try $ char '\\' >> newline >> return mempty
blockQuote :: PandocMonad m => TWParser m B.Blocks blockQuote :: PandocMonad m => TWParser m B.Blocks
blockQuote = parseHtmlContent "blockquote" block >>= return . B.blockQuote . mconcat blockQuote = (B.blockQuote . mconcat) <$> parseHtmlContent "blockquote" block
noautolink :: PandocMonad m => TWParser m B.Blocks noautolink :: PandocMonad m => TWParser m B.Blocks
noautolink = do noautolink = do
@ -300,15 +292,15 @@ noautolink = do
setState $ st{ stateAllowLinks = True } setState $ st{ stateAllowLinks = True }
return $ mconcat blocks return $ mconcat blocks
where where
parseContent = parseFromString' $ many $ block parseContent = parseFromString' $ many block
para :: PandocMonad m => TWParser m B.Blocks para :: PandocMonad m => TWParser m B.Blocks
para = many1Till inline endOfParaElement >>= return . result . mconcat para = (result . mconcat) <$> many1Till inline endOfParaElement
where where
endOfParaElement = lookAhead $ endOfInput <|> endOfPara <|> newBlockElement endOfParaElement = lookAhead $ endOfInput <|> endOfPara <|> newBlockElement
endOfInput = try $ skipMany blankline >> skipSpaces >> eof endOfInput = try $ skipMany blankline >> skipSpaces >> eof
endOfPara = try $ blankline >> skipMany1 blankline endOfPara = try $ blankline >> skipMany1 blankline
newBlockElement = try $ blankline >> skip blockElements newBlockElement = try $ blankline >> void blockElements
result content = if F.all (==Space) content result content = if F.all (==Space) content
then mempty then mempty
else B.para $ B.trimInlines content else B.para $ B.trimInlines content
@ -340,7 +332,7 @@ inline = choice [ whitespace
] <?> "inline" ] <?> "inline"
whitespace :: PandocMonad m => TWParser m B.Inlines whitespace :: PandocMonad m => TWParser m B.Inlines
whitespace = (lb <|> regsp) >>= return whitespace = lb <|> regsp
where lb = try $ skipMany spaceChar >> linebreak >> return B.space where lb = try $ skipMany spaceChar >> linebreak >> return B.space
regsp = try $ skipMany1 spaceChar >> return B.space regsp = try $ skipMany1 spaceChar >> return B.space
@ -362,13 +354,13 @@ enclosed :: (Monoid b, PandocMonad m, Show a)
=> TWParser m a -> (TWParser m a -> TWParser m b) -> TWParser m b => TWParser m a -> (TWParser m a -> TWParser m b) -> TWParser m b
enclosed sep p = between sep (try $ sep <* endMarker) p enclosed sep p = between sep (try $ sep <* endMarker) p
where where
endMarker = lookAhead $ skip endSpace <|> skip (oneOf ".,!?:)|") <|> eof endMarker = lookAhead $ void endSpace <|> void (oneOf ".,!?:)|") <|> eof
endSpace = (spaceChar <|> newline) >> return B.space endSpace = (spaceChar <|> newline) >> return B.space
macro :: PandocMonad m => TWParser m B.Inlines macro :: PandocMonad m => TWParser m B.Inlines
macro = macroWithParameters <|> withoutParameters macro = macroWithParameters <|> withoutParameters
where where
withoutParameters = enclosed (char '%') (\_ -> macroName) >>= return . emptySpan withoutParameters = emptySpan <$> enclosed (char '%') (const macroName)
emptySpan name = buildSpan name [] mempty emptySpan name = buildSpan name [] mempty
macroWithParameters :: PandocMonad m => TWParser m B.Inlines macroWithParameters :: PandocMonad m => TWParser m B.Inlines
@ -393,13 +385,13 @@ macroName = do
return (first:rest) return (first:rest)
attributes :: PandocMonad m => TWParser m (String, [(String, String)]) attributes :: PandocMonad m => TWParser m (String, [(String, String)])
attributes = char '{' *> spnl *> many (attribute <* spnl) <* char '}' >>= attributes = foldr (either mkContent mkKvs) ([], [])
return . foldr (either mkContent mkKvs) ([], []) <$> (char '{' *> spnl *> many (attribute <* spnl) <* char '}')
where where
spnl = skipMany (spaceChar <|> newline) spnl = skipMany (spaceChar <|> newline)
mkContent c ([], kvs) = (c, kvs) mkContent c ([], kvs) = (c, kvs)
mkContent c (rest, kvs) = (c ++ " " ++ rest, kvs) mkContent c (rest, kvs) = (c ++ " " ++ rest, kvs)
mkKvs kv (cont, rest) = (cont, (kv : rest)) mkKvs kv (cont, rest) = (cont, kv : rest)
attribute :: PandocMonad m => TWParser m (Either String (String, String)) attribute :: PandocMonad m => TWParser m (Either String (String, String))
attribute = withKey <|> withoutKey attribute = withKey <|> withoutKey
@ -407,52 +399,50 @@ attribute = withKey <|> withoutKey
withKey = try $ do withKey = try $ do
key <- macroName key <- macroName
char '=' char '='
parseValue False >>= return . (curry Right key) curry Right key <$> parseValue False
withoutKey = try $ parseValue True >>= return . Left withoutKey = try $ Left <$> parseValue True
parseValue allowSpaces = (withQuotes <|> withoutQuotes allowSpaces) >>= return . fromEntities parseValue allowSpaces = fromEntities <$> (withQuotes <|> withoutQuotes allowSpaces)
withQuotes = between (char '"') (char '"') (\_ -> count 1 $ noneOf ['"']) withQuotes = between (char '"') (char '"') (\_ -> count 1 $ noneOf ['"'])
withoutQuotes allowSpaces withoutQuotes allowSpaces
| allowSpaces == True = many1 $ noneOf "}" | allowSpaces = many1 $ noneOf "}"
| otherwise = many1 $ noneOf " }" | otherwise = many1 $ noneOf " }"
nestedInlines :: (Show a, PandocMonad m) nestedInlines :: (Show a, PandocMonad m)
=> TWParser m a -> TWParser m B.Inlines => TWParser m a -> TWParser m B.Inlines
nestedInlines end = innerSpace <|> nestedInline nestedInlines end = innerSpace <|> nestedInline
where where
innerSpace = try $ whitespace <* (notFollowedBy end) innerSpace = try $ whitespace <* notFollowedBy end
nestedInline = notFollowedBy whitespace >> nested inline nestedInline = notFollowedBy whitespace >> nested inline
strong :: PandocMonad m => TWParser m B.Inlines strong :: PandocMonad m => TWParser m B.Inlines
strong = try $ enclosed (char '*') nestedInlines >>= return . B.strong strong = try $ B.strong <$> enclosed (char '*') nestedInlines
strongHtml :: PandocMonad m => TWParser m B.Inlines strongHtml :: PandocMonad m => TWParser m B.Inlines
strongHtml = (parseHtmlContent "strong" inline <|> parseHtmlContent "b" inline) strongHtml = B.strong . mconcat <$> (parseHtmlContent "strong" inline <|> parseHtmlContent "b" inline)
>>= return . B.strong . mconcat
strongAndEmph :: PandocMonad m => TWParser m B.Inlines strongAndEmph :: PandocMonad m => TWParser m B.Inlines
strongAndEmph = try $ enclosed (string "__") nestedInlines >>= return . B.emph . B.strong strongAndEmph = try $ B.emph . B.strong <$> enclosed (string "__") nestedInlines
emph :: PandocMonad m => TWParser m B.Inlines emph :: PandocMonad m => TWParser m B.Inlines
emph = try $ enclosed (char '_') nestedInlines >>= return . B.emph emph = try $ B.emph <$> enclosed (char '_') nestedInlines
emphHtml :: PandocMonad m => TWParser m B.Inlines emphHtml :: PandocMonad m => TWParser m B.Inlines
emphHtml = (parseHtmlContent "em" inline <|> parseHtmlContent "i" inline) emphHtml = B.emph . mconcat <$> (parseHtmlContent "em" inline <|> parseHtmlContent "i" inline)
>>= return . B.emph . mconcat
nestedString :: (Show a, PandocMonad m) nestedString :: (Show a, PandocMonad m)
=> TWParser m a -> TWParser m String => TWParser m a -> TWParser m String
nestedString end = innerSpace <|> (count 1 nonspaceChar) nestedString end = innerSpace <|> count 1 nonspaceChar
where where
innerSpace = try $ many1 spaceChar <* notFollowedBy end innerSpace = try $ many1 spaceChar <* notFollowedBy end
boldCode :: PandocMonad m => TWParser m B.Inlines boldCode :: PandocMonad m => TWParser m B.Inlines
boldCode = try $ enclosed (string "==") nestedString >>= return . B.strong . B.code . fromEntities boldCode = try $ (B.strong . B.code . fromEntities) <$> enclosed (string "==") nestedString
htmlComment :: PandocMonad m => TWParser m B.Inlines htmlComment :: PandocMonad m => TWParser m B.Inlines
htmlComment = htmlTag isCommentTag >> return mempty htmlComment = htmlTag isCommentTag >> return mempty
code :: PandocMonad m => TWParser m B.Inlines code :: PandocMonad m => TWParser m B.Inlines
code = try $ enclosed (char '=') nestedString >>= return . B.code . fromEntities code = try $ (B.code . fromEntities) <$> enclosed (char '=') nestedString
codeHtml :: PandocMonad m => TWParser m B.Inlines codeHtml :: PandocMonad m => TWParser m B.Inlines
codeHtml = do codeHtml = do
@ -464,7 +454,7 @@ autoLink = try $ do
state <- getState state <- getState
guard $ stateAllowLinks state guard $ stateAllowLinks state
(text, url) <- parseLink (text, url) <- parseLink
guard $ checkLink (head $ reverse url) guard $ checkLink (last url)
return $ makeLink (text, url) return $ makeLink (text, url)
where where
parseLink = notFollowedBy nop >> (uri <|> emailAddress) parseLink = notFollowedBy nop >> (uri <|> emailAddress)
@ -474,17 +464,17 @@ autoLink = try $ do
| otherwise = isAlphaNum c | otherwise = isAlphaNum c
str :: PandocMonad m => TWParser m B.Inlines str :: PandocMonad m => TWParser m B.Inlines
str = (many1 alphaNum <|> count 1 characterReference) >>= return . B.str str = B.str <$> (many1 alphaNum <|> count 1 characterReference)
nop :: PandocMonad m => TWParser m B.Inlines nop :: PandocMonad m => TWParser m B.Inlines
nop = try $ (skip exclamation <|> skip nopTag) >> followContent nop = try $ (void exclamation <|> void nopTag) >> followContent
where where
exclamation = char '!' exclamation = char '!'
nopTag = stringAnyCase "<nop>" nopTag = stringAnyCase "<nop>"
followContent = many1 nonspaceChar >>= return . B.str . fromEntities followContent = B.str . fromEntities <$> many1 nonspaceChar
symbol :: PandocMonad m => TWParser m B.Inlines symbol :: PandocMonad m => TWParser m B.Inlines
symbol = count 1 nonspaceChar >>= return . B.str symbol = B.str <$> count 1 nonspaceChar
smart :: PandocMonad m => TWParser m B.Inlines smart :: PandocMonad m => TWParser m B.Inlines
smart = do smart = do
@ -498,17 +488,16 @@ smart = do
singleQuoted :: PandocMonad m => TWParser m B.Inlines singleQuoted :: PandocMonad m => TWParser m B.Inlines
singleQuoted = try $ do singleQuoted = try $ do
singleQuoteStart singleQuoteStart
withQuoteContext InSingleQuote $ withQuoteContext InSingleQuote
many1Till inline singleQuoteEnd >>= (B.singleQuoted . B.trimInlines . mconcat <$> many1Till inline singleQuoteEnd)
(return . B.singleQuoted . B.trimInlines . mconcat)
doubleQuoted :: PandocMonad m => TWParser m B.Inlines doubleQuoted :: PandocMonad m => TWParser m B.Inlines
doubleQuoted = try $ do doubleQuoted = try $ do
doubleQuoteStart doubleQuoteStart
contents <- mconcat <$> many (try $ notFollowedBy doubleQuoteEnd >> inline) contents <- mconcat <$> many (try $ notFollowedBy doubleQuoteEnd >> inline)
(withQuoteContext InDoubleQuote $ doubleQuoteEnd >> withQuoteContext InDoubleQuote (doubleQuoteEnd >>
return (B.doubleQuoted $ B.trimInlines contents)) return (B.doubleQuoted $ B.trimInlines contents))
<|> (return $ (B.str "\8220") B.<> contents) <|> return (B.str "\8220" B.<> contents)
link :: PandocMonad m => TWParser m B.Inlines link :: PandocMonad m => TWParser m B.Inlines
link = try $ do link = try $ do
@ -527,5 +516,5 @@ linkText = do
char ']' char ']'
return (url, "", content) return (url, "", content)
where where
linkContent = (char '[') >> many1Till anyChar (char ']') >>= parseLinkContent linkContent = char '[' >> many1Till anyChar (char ']') >>= parseLinkContent
parseLinkContent = parseFromString' $ many1 inline parseLinkContent = parseFromString' $ many1 inline