module Text.Pandoc.Readers.CustomCreole
( readCustomCreole
, onLeft
, onRight
)
where
import Text.Pandoc
import Text.Pandoc.Error
import Text.Parsec
import Data.List (intersperse, intercalate, lookup)
import Data.Maybe (fromMaybe)
onLeft :: (a -> b) -> Either a c -> Either b c
onLeft f (Left x) = Left (f x)
onLeft _ (Right r) = Right r
onRight :: (b -> c) -> Either a b -> Either a c
onRight f (Right x) = Right (f x)
onRight _ (Left r) = Left r
readCustomCreole :: ReaderOptions -> String -> Either PandocError Pandoc
readCustomCreole options input =
onLeft (PandocParsecError input) $
runParser wikipage () "creole source" input
wikipage = Pandoc nullMeta <$> (spaces *> manyTill paragraph eof)
paragraph = nowikiBlock
<|> division nullAttr
<|> horizontalLine
<|> heading nullAttr
<|> annotatedParagraph
<|> emptyParagraph
<|> unorderedList 1
<|> textParagraph
unorderedList level = BulletList <$> many1 (unorderedListItem level)
unorderedListItem level = do
unorderedListBullet level
unorderedListItemContent level
unorderedListBullet level = do
try (lookAhead $ char '*')
try (count level (char '*') *> whitespace1)
unorderedListItemContent :: Int -> Parsec String () [Block]
unorderedListItemContent level =
(:) <$> textItem <*> many anyItem
where
textItem = Para . concat <$> many1 (unorderedListLine level)
anyItem = unorderedList (succ level) <|> textItem
unorderedListLine level = do
notFollowedBy $
(ignore . try $ many1 (char '*') *> whitespace1) <|>
(ignore . try $ whitespace *> string "----") <|>
(ignore . try $ whitespace *> char '=') <|>
(ignore . try $ whitespace *> string "]]]" *> notFollowedBy (char ']')) <|>
(ignore eol) <|>
(ignore eof)
many1 (notFollowedBy eol *> textItem) <* (eol <|> eof)
annotatedParagraph = do
attr <- try preAnnotation
division attr <|> heading attr
annotation = do
string "@("
whitespace
kvp <- sepBy attribute (char ',')
let idVal = fromMaybe "" . lookup "id" $ kvp
classes = words . fromMaybe "" . lookup "class" $ kvp
kvp' = [ (k,v) | (k,v) <- kvp, k /= "id" && k /= "class" ]
char ')'
return (idVal, classes, kvp')
where
attribute = do
k <- many (noneOf ")= \t\r\n")
whitespace
char '='
whitespace
v <- many (noneOf "),\r\n")
whitespace
return (k,v)
preAnnotation = annotation <* char ':' <* (eol <|> eof)
postAnnotation = optional eol *> annotation <* notFollowedBy (char ':')
heading attr = do
leader <- many1 (char '=')
whitespace
inner <- manyTill textItem endOfHeading
attr' <- option attr (try postAnnotation)
return $ Header (length leader) attr' inner
endOfHeading = eof
<|> try
(do
whitespace
many (char '=')
whitespace
ignore eol <|> eof
)
division attr = do
try (string "[[[" *> (eol <|> eof))
inner <- manyTill paragraph endOfDiv
return $ Div attr inner
endOfDiv = eof
<|> try
(do
whitespace
string "]]]"
notFollowedBy (char ']')
whitespace
ignore eol <|> eof
)
nowikiBlock = do
try (string "{{{" *> (eol <|> eof))
lns <- many nowikiLine
string "}}}" *> (eol <|> eof)
return $ CodeBlock nullAttr (intercalate "\n" lns)
nowikiLine = nowikiEscapedEndMarker <|> nowikiRegularLine
nowikiEscapedEndMarker = try $ do
oneOf " \t"
many (noneOf "\r\n") <* (eol <|> eof)
nowikiRegularLine = do
notFollowedBy . try $ string "}}}" *> (eol <|> eof)
many (noneOf "\r\n") <* (eol <|> eof)
emptyParagraph = try (endOfParagraph *> return Null)
horizontalLine = try (string "----") *> (eol <|> eof) *> return HorizontalRule
textParagraph = Para . concat . intersperse [Space] <$>
many1 textLine <* endOfParagraph
textLine = do
notFollowedBy $
(ignore . try $ unorderedListBullet 1) <|>
(ignore . try $ whitespace *> string "----") <|>
(ignore . try $ whitespace *> char '=') <|>
(ignore . try $ whitespace *> string "]]]" *> notFollowedBy (char ']')) <|>
(ignore eol) <|>
(ignore eof)
many1 (notFollowedBy eol *> textItem) <* (eol <|> eof)
textItem =
nowikiTextItem <|>
newlineTextItem <|>
link <|>
image <|>
boldTextItem <|>
italTextItem <|>
whitespaceTextItem <|>
rawTextItem
link = do
try $ string "[[" *> notFollowedBy (char '[')
url <- many $ noneOf "|]"
label <- option url $ do
char '|'
many $ noneOf "]"
string "]]"
attr <- option nullAttr (try postAnnotation)
return $ Link attr [ Str label ] (url, label)
image = do
try $ string "{{" *> notFollowedBy (char '{')
url <- many $ noneOf "|}"
label <- option url $ do
char '|'
many $ noneOf "}"
string "}}"
attr <- option nullAttr (try postAnnotation)
return $ Image attr [ Str label ] (url, label)
newlineTextItem = do
try $ whitespace *> string "\\\\"
whitespace
optional eol
whitespace
return LineBreak
boldTextItem = Strong <$>
(
try (string "**" *> notFollowedBy whitespace1) *>
many1 boldItalTextItem <*
(
eof <|>
(lookAhead . try $ eol *> endOfParagraph) <|>
(ignore . try . string $ "**")
)
)
italTextItem = Emph <$>
(
try (string "//") *>
many1 italBoldTextItem <*
(
eof <|>
(lookAhead . try $ eol *> endOfParagraph) <|>
(ignore . try . string $ "//")
)
)
boldItalTextItem =
nowikiTextItem <|>
newlineTextItem <|>
link <|>
image <|>
italTextItem <|>
whitespaceTextItem <|>
rawTextItem
italBoldTextItem =
nowikiTextItem <|>
newlineTextItem <|>
link <|>
image <|>
boldTextItem <|>
whitespaceTextItem <|>
rawTextItem
rawTextItem = Str <$> many1 textChar
whitespaceTextItem = Space <$ many1 irrelevantWhitespace
irrelevantWhitespace =
(ignore . many1) (oneOf " \t") <|> try (eol *> notFollowedBy eol)
nowikiTextItem =
Code nullAttr <$>
(inlineNowikiStart *> manyTill inlineNowikiItem inlineNowikiEnd)
inlineNowikiEnd = try (string "}}}" *> notFollowedBy (char '}'))
inlineNowikiStart = try (string "{{{")
inlineNowikiItem = anyChar
textChar = escapedChar <|> safeChar <|> allowedSpecialChar
escapedChar = char '~' *> anyChar
safeChar = noneOf " \n\r\t~*/[]\\{}@"
allowedSpecialChar =
try (char '/' <* notFollowedBy (char '/')) <|>
try (char '*' <* notFollowedBy (char '*')) <|>
try (char '[' <* notFollowedBy (char '[')) <|>
try (char '{' <* notFollowedBy (char '{')) <|>
try (char '\\' <* notFollowedBy (char '\\')) <|>
try (char ']' <* notFollowedBy (char ']')) <|>
try (char '}' <* notFollowedBy (char '}')) <|>
try (char '@' <* notFollowedBy (char '('))
eol = (try (string "\r\n") <|> string "\n") *> return ()
whitespaceChar = oneOf " \t"
whitespace1 = many1 whitespaceChar
whitespace = many whitespaceChar
ignore :: Parsec s u a -> Parsec s u ()
ignore = (*> return ())
endOfParagraph = (ignore . lookAhead . try $ whitespace *> string "----")
<|> (ignore . lookAhead . try $ whitespace *> char '=')
<|> (ignore . lookAhead . try $ whitespace *> string "]]]" *> notFollowedBy (char ']'))
<|> ignore eof
<|> ignore eol