module Text.Pandoc.Parsing ( anyLine,
many1Till,
notFollowedBy',
oneOfStrings,
oneOfStringsCI,
spaceChar,
nonspaceChar,
skipSpaces,
blankline,
blanklines,
enclosed,
stringAnyCase,
parseFromString,
lineClump,
charsInBalanced,
romanNumeral,
emailAddress,
uri,
mathInline,
mathDisplay,
withHorizDisplacement,
withRaw,
escaped,
characterReference,
anyOrderedListMarker,
orderedListMarker,
charRef,
lineBlockLines,
tableWith,
widthsFromIndices,
gridTableWith,
readWith,
readWithWarnings,
readWithM,
testStringWith,
guardEnabled,
guardDisabled,
updateLastStrPos,
notAfterString,
ParserState (..),
HasReaderOptions (..),
HasHeaderMap (..),
HasIdentifierList (..),
HasMacros (..),
HasLastStrPosition (..),
defaultParserState,
HeaderType (..),
ParserContext (..),
QuoteContext (..),
HasQuoteContext (..),
NoteTable,
NoteTable',
KeyTable,
SubstTable,
Key (..),
toKey,
registerHeader,
smartPunctuation,
singleQuoteStart,
singleQuoteEnd,
doubleQuoteStart,
doubleQuoteEnd,
ellipses,
apostrophe,
dash,
nested,
citeKey,
macro,
applyMacros',
Parser,
ParserT,
F(..),
runF,
askF,
asksF,
token,
Stream,
runParser,
runParserT,
parse,
anyToken,
getInput,
setInput,
unexpected,
char,
letter,
digit,
alphaNum,
skipMany,
skipMany1,
spaces,
space,
anyChar,
satisfy,
newline,
string,
count,
eof,
noneOf,
oneOf,
lookAhead,
notFollowedBy,
many,
many1,
manyTill,
(<|>),
(<?>),
choice,
try,
sepBy,
sepBy1,
sepEndBy,
sepEndBy1,
endBy,
endBy1,
option,
optional,
optionMaybe,
getState,
setState,
updateState,
SourcePos,
getPosition,
setPosition,
sourceColumn,
sourceLine,
setSourceColumn,
setSourceLine,
newPos,
addWarning,
(<+?>),
extractIdClass
)
where
import Text.Pandoc.Definition
import Text.Pandoc.Options
import Text.Pandoc.Builder (Blocks, Inlines, rawBlock, HasMeta(..))
import qualified Text.Pandoc.Builder as B
import Text.Pandoc.XML (fromEntities)
import qualified Text.Pandoc.UTF8 as UTF8 (putStrLn)
import Text.Parsec hiding (token)
import Text.Parsec.Pos (newPos)
import Data.Char ( toLower, toUpper, ord, chr, isAscii, isAlphaNum,
isHexDigit, isSpace )
import Data.List ( intercalate, transpose, isSuffixOf )
import Text.Pandoc.Shared
import qualified Data.Map as M
import Text.TeXMath.Readers.TeX.Macros (applyMacros, Macro,
parseMacroDefinitions)
import Text.Pandoc.Compat.TagSoupEntity ( lookupEntity )
import Text.Pandoc.Asciify (toAsciiChar)
import Text.Pandoc.Compat.Monoid ((<>))
import Data.Default
import qualified Data.Set as Set
import Control.Monad.Reader
import Control.Monad.Identity
import Data.Maybe (catMaybes)
import Text.Pandoc.Error
type Parser t s = Parsec t s
type ParserT = ParsecT
newtype F a = F { unF :: Reader ParserState a } deriving (Monad, Applicative, Functor)
runF :: F a -> ParserState -> a
runF = runReader . unF
askF :: F ParserState
askF = F ask
asksF :: (ParserState -> a) -> F a
asksF f = F $ asks f
instance Monoid a => Monoid (F a) where
mempty = return mempty
mappend = liftM2 mappend
mconcat = liftM mconcat . sequence
anyLine :: Stream [Char] m Char => ParserT [Char] st m [Char]
anyLine = do
inp <- getInput
pos <- getPosition
case break (=='\n') inp of
(this, '\n':rest) -> do
anyChar
setInput rest
setPosition $ incSourceLine (setSourceColumn pos 1) 1
return this
_ -> mzero
many1Till :: Stream s m t
=> ParserT s st m a
-> ParserT s st m end
-> ParserT s st m [a]
many1Till p end = do
first <- p
rest <- manyTill p end
return (first:rest)
notFollowedBy' :: (Show b, Stream s m a) => ParserT s st m b -> ParserT s st m ()
notFollowedBy' p = try $ join $ do a <- try p
return (unexpected (show a))
<|>
return (return ())
oneOfStrings' :: Stream s m Char => (Char -> Char -> Bool) -> [String] -> ParserT s st m String
oneOfStrings' _ [] = fail "no strings"
oneOfStrings' matches strs = try $ do
c <- anyChar
let strs' = [xs | (x:xs) <- strs, x `matches` c]
case strs' of
[] -> fail "not found"
_ -> (c:) <$> oneOfStrings' matches strs'
<|> if "" `elem` strs'
then return [c]
else fail "not found"
oneOfStrings :: Stream s m Char => [String] -> ParserT s st m String
oneOfStrings = oneOfStrings' (==)
oneOfStringsCI :: Stream s m Char => [String] -> ParserT s st m String
oneOfStringsCI = oneOfStrings' ciMatch
where ciMatch x y = toLower' x == toLower' y
toLower' c | c >= 'A' && c <= 'Z' = chr (ord c + 32)
| isAscii c = c
| otherwise = toLower c
spaceChar :: Stream s m Char => ParserT s st m Char
spaceChar = satisfy $ \c -> c == ' ' || c == '\t'
nonspaceChar :: Stream s m Char => ParserT s st m Char
nonspaceChar = satisfy $ flip notElem ['\t', '\n', ' ', '\r']
skipSpaces :: Stream s m Char => ParserT s st m ()
skipSpaces = skipMany spaceChar
blankline :: Stream s m Char => ParserT s st m Char
blankline = try $ skipSpaces >> newline
blanklines :: Stream s m Char => ParserT s st m [Char]
blanklines = many1 blankline
enclosed :: Stream s m Char => ParserT s st m t
-> ParserT s st m end
-> ParserT s st m a
-> ParserT s st m [a]
enclosed start end parser = try $
start >> notFollowedBy space >> many1Till parser end
stringAnyCase :: Stream s m Char => [Char] -> ParserT s st m String
stringAnyCase [] = string ""
stringAnyCase (x:xs) = do
firstChar <- char (toUpper x) <|> char (toLower x)
rest <- stringAnyCase xs
return (firstChar:rest)
parseFromString :: Monad m => ParserT String st m a -> String -> ParserT String st m a
parseFromString parser str = do
oldPos <- getPosition
oldInput <- getInput
setInput str
result <- parser
spaces
eof
setInput oldInput
setPosition oldPos
return result
lineClump :: Stream [Char] m Char => ParserT [Char] st m String
lineClump = blanklines
<|> (many1 (notFollowedBy blankline >> anyLine) >>= return . unlines)
charsInBalanced :: Stream s m Char => Char -> Char -> ParserT s st m Char
-> ParserT s st m String
charsInBalanced open close parser = try $ do
char open
let isDelim c = c == open || c == close
raw <- many $ many1 (notFollowedBy (satisfy isDelim) >> parser)
<|> (do res <- charsInBalanced open close parser
return $ [open] ++ res ++ [close])
char close
return $ concat raw
lowercaseRomanDigits :: [Char]
lowercaseRomanDigits = ['i','v','x','l','c','d','m']
uppercaseRomanDigits :: [Char]
uppercaseRomanDigits = map toUpper lowercaseRomanDigits
romanNumeral :: Stream s m Char => Bool
-> ParserT s st m Int
romanNumeral upperCase = do
let romanDigits = if upperCase
then uppercaseRomanDigits
else lowercaseRomanDigits
lookAhead $ oneOf romanDigits
let [one, five, ten, fifty, hundred, fivehundred, thousand] =
map char romanDigits
thousands <- many thousand >>= (return . (1000 *) . length)
ninehundreds <- option 0 $ try $ hundred >> thousand >> return 900
fivehundreds <- many fivehundred >>= (return . (500 *) . length)
fourhundreds <- option 0 $ try $ hundred >> fivehundred >> return 400
hundreds <- many hundred >>= (return . (100 *) . length)
nineties <- option 0 $ try $ ten >> hundred >> return 90
fifties <- many fifty >>= (return . (50 *) . length)
forties <- option 0 $ try $ ten >> fifty >> return 40
tens <- many ten >>= (return . (10 *) . length)
nines <- option 0 $ try $ one >> ten >> return 9
fives <- many five >>= (return . (5 *) . length)
fours <- option 0 $ try $ one >> five >> return 4
ones <- many one >>= (return . length)
let total = thousands + ninehundreds + fivehundreds + fourhundreds +
hundreds + nineties + fifties + forties + tens + nines +
fives + fours + ones
if total == 0
then fail "not a roman numeral"
else return total
emailAddress :: Stream s m Char => ParserT s st m (String, String)
emailAddress = try $ toResult <$> mailbox <*> (char '@' *> domain)
where toResult mbox dom = let full = fromEntities $ mbox ++ '@':dom
in (full, escapeURI $ "mailto:" ++ full)
mailbox = intercalate "." <$> (emailWord `sepby1` dot)
domain = intercalate "." <$> (subdomain `sepby1` dot)
dot = char '.'
subdomain = many1 $ alphaNum <|> innerPunct
innerPunct = try (satisfy (\c -> isEmailPunct c || c == '@') <*
notFollowedBy space)
emailWord = many1 $ satisfy isEmailChar
isEmailChar c = isAlphaNum c || isEmailPunct c
isEmailPunct c = c `elem` "!\"#$%&'*+-/=?^_{|}~;"
sepby1 p sep = (:) <$> p <*> (many (try $ sep >> p))
schemes :: [String]
schemes = ["coap","doi","javascript","aaa","aaas","about","acap","cap","cid",
"crid","data","dav","dict","dns","file","ftp","geo","go","gopher",
"h323","http","https","iax","icap","im","imap","info","ipp","iris",
"iris.beep","iris.xpc","iris.xpcs","iris.lwz","ldap","mailto","mid",
"msrp","msrps","mtqp","mupdate","news","nfs","ni","nih","nntp",
"opaquelocktoken","pop","pres","rtsp","service","session","shttp","sieve",
"sip","sips","sms","snmp","soap.beep","soap.beeps","tag","tel","telnet",
"tftp","thismessage","tn3270","tip","tv","urn","vemmi","ws","wss","xcon",
"xcon-userid","xmlrpc.beep","xmlrpc.beeps","xmpp","z39.50r","z39.50s",
"adiumxtra","afp","afs","aim","apt","attachment","aw","beshare","bitcoin",
"bolo","callto","chrome","chrome-extension","com-eventbrite-attendee",
"content", "cvs","dlna-playsingle","dlna-playcontainer","dtn","dvb",
"ed2k","facetime","feed","finger","fish","gg","git","gizmoproject",
"gtalk","hcp","icon","ipn","irc","irc6","ircs","itms","jar","jms",
"keyparc","lastfm","ldaps","magnet","maps","market","message","mms",
"ms-help","msnim","mumble","mvn","notes","oid","palm","paparazzi",
"platform","proxy","psyc","query","res","resource","rmi","rsync",
"rtmp","secondlife","sftp","sgn","skype","smb","soldat","spotify",
"ssh","steam","svn","teamspeak","things","udp","unreal","ut2004",
"ventrilo","view-source","webcal","wtai","wyciwyg","xfire","xri",
"ymsgr", "isbn", "pmid"]
uriScheme :: Stream s m Char => ParserT s st m String
uriScheme = oneOfStringsCI schemes
uri :: Stream [Char] m Char => ParserT [Char] st m (String, String)
uri = try $ do
scheme <- uriScheme
char ':'
let isWordChar c = isAlphaNum c || c `elem` "#$%*+/@\\_-"
let wordChar = satisfy isWordChar
let percentEscaped = try $ char '%' >> skipMany1 (satisfy isHexDigit)
let entity = () <$ characterReference
let punct = skipMany1 (char ',')
<|> () <$ (satisfy (\c -> not (isSpace c) && c /= '<' && c /= '>'))
let uriChunk = skipMany1 wordChar
<|> percentEscaped
<|> entity
<|> (try $ punct >>
lookAhead (void (satisfy isWordChar) <|> percentEscaped))
str <- snd <$> withRaw (skipMany1 ( () <$
(enclosed (char '(') (char ')') uriChunk
<|> enclosed (char '{') (char '}') uriChunk
<|> enclosed (char '[') (char ']') uriChunk)
<|> uriChunk))
str' <- option str $ char '/' >> return (str ++ "/")
let uri' = scheme ++ ":" ++ fromEntities str'
return (uri', escapeURI uri')
mathInlineWith :: Stream s m Char => String -> String -> ParserT s st m String
mathInlineWith op cl = try $ do
string op
notFollowedBy space
words' <- many1Till (count 1 (noneOf " \t\n\\")
<|> (char '\\' >>
(try (string "text" >>
(("\\text" ++) <$> inBalancedBraces 0 ""))
<|> (\c -> ['\\',c]) <$> anyChar))
<|> do (blankline <* notFollowedBy' blankline) <|>
(oneOf " \t" <* skipMany (oneOf " \t"))
notFollowedBy (char '$')
return " "
) (try $ string cl)
notFollowedBy digit
return $ concat words'
where
inBalancedBraces :: Stream s m Char => Int -> String -> ParserT s st m String
inBalancedBraces 0 "" = do
c <- anyChar
if c == '{'
then inBalancedBraces 1 "{"
else mzero
inBalancedBraces 0 s = return $ reverse s
inBalancedBraces numOpen ('\\':xs) = do
c <- anyChar
inBalancedBraces numOpen (c:'\\':xs)
inBalancedBraces numOpen xs = do
c <- anyChar
case c of
'}' -> inBalancedBraces (numOpen 1) (c:xs)
'{' -> inBalancedBraces (numOpen + 1) (c:xs)
_ -> inBalancedBraces numOpen (c:xs)
mathDisplayWith :: Stream s m Char => String -> String -> ParserT s st m String
mathDisplayWith op cl = try $ do
string op
many1Till (noneOf "\n" <|> (newline <* notFollowedBy' blankline)) (try $ string cl)
mathDisplay :: (HasReaderOptions st, Stream s m Char)
=> ParserT s st m String
mathDisplay =
(guardEnabled Ext_tex_math_dollars >> mathDisplayWith "$$" "$$")
<|> (guardEnabled Ext_tex_math_single_backslash >>
mathDisplayWith "\\[" "\\]")
<|> (guardEnabled Ext_tex_math_double_backslash >>
mathDisplayWith "\\\\[" "\\\\]")
mathInline :: (HasReaderOptions st , Stream s m Char)
=> ParserT s st m String
mathInline =
(guardEnabled Ext_tex_math_dollars >> mathInlineWith "$" "$")
<|> (guardEnabled Ext_tex_math_single_backslash >>
mathInlineWith "\\(" "\\)")
<|> (guardEnabled Ext_tex_math_double_backslash >>
mathInlineWith "\\\\(" "\\\\)")
withHorizDisplacement :: Stream s m Char
=> ParserT s st m a
-> ParserT s st m (a, Int)
withHorizDisplacement parser = do
pos1 <- getPosition
result <- parser
pos2 <- getPosition
return (result, sourceColumn pos2 sourceColumn pos1)
withRaw :: Stream [Char] m Char => ParsecT [Char] st m a -> ParsecT [Char] st m (a, [Char])
withRaw parser = do
pos1 <- getPosition
inp <- getInput
result <- parser
pos2 <- getPosition
let (l1,c1) = (sourceLine pos1, sourceColumn pos1)
let (l2,c2) = (sourceLine pos2, sourceColumn pos2)
let inplines = take ((l2 l1) + 1) $ lines inp
let raw = case inplines of
[] -> ""
[l] -> take (c2 c1) l
ls -> unlines (init ls) ++ take (c2 1) (last ls)
return (result, raw)
escaped :: Stream s m Char
=> ParserT s st m Char
-> ParserT s st m Char
escaped parser = try $ char '\\' >> parser
characterReference :: Stream s m Char => ParserT s st m Char
characterReference = try $ do
char '&'
ent <- many1Till nonspaceChar (char ';')
let ent' = case ent of
'#':'X':xs -> '#':'x':xs
'#':_ -> ent
_ -> ent ++ ";"
case lookupEntity ent' of
Just c -> return c
Nothing -> fail "entity not found"
upperRoman :: Stream s m Char => ParserT s st m (ListNumberStyle, Int)
upperRoman = do
num <- romanNumeral True
return (UpperRoman, num)
lowerRoman :: Stream s m Char => ParserT s st m (ListNumberStyle, Int)
lowerRoman = do
num <- romanNumeral False
return (LowerRoman, num)
decimal :: Stream s m Char => ParserT s st m (ListNumberStyle, Int)
decimal = do
num <- many1 digit
return (Decimal, read num)
exampleNum :: Stream s m Char
=> ParserT s ParserState m (ListNumberStyle, Int)
exampleNum = do
char '@'
lab <- many (alphaNum <|> satisfy (\c -> c == '_' || c == '-'))
st <- getState
let num = stateNextExample st
let newlabels = if null lab
then stateExamples st
else M.insert lab num $ stateExamples st
updateState $ \s -> s{ stateNextExample = num + 1
, stateExamples = newlabels }
return (Example, num)
defaultNum :: Stream s m Char => ParserT s st m (ListNumberStyle, Int)
defaultNum = do
char '#'
return (DefaultStyle, 1)
lowerAlpha :: Stream s m Char => ParserT s st m (ListNumberStyle, Int)
lowerAlpha = do
ch <- oneOf ['a'..'z']
return (LowerAlpha, ord ch ord 'a' + 1)
upperAlpha :: Stream s m Char => ParserT s st m (ListNumberStyle, Int)
upperAlpha = do
ch <- oneOf ['A'..'Z']
return (UpperAlpha, ord ch ord 'A' + 1)
romanOne :: Stream s m Char => ParserT s st m (ListNumberStyle, Int)
romanOne = (char 'i' >> return (LowerRoman, 1)) <|>
(char 'I' >> return (UpperRoman, 1))
anyOrderedListMarker :: Stream s m Char => ParserT s ParserState m ListAttributes
anyOrderedListMarker = choice $
[delimParser numParser | delimParser <- [inPeriod, inOneParen, inTwoParens],
numParser <- [decimal, exampleNum, defaultNum, romanOne,
lowerAlpha, lowerRoman, upperAlpha, upperRoman]]
inPeriod :: Stream s m Char
=> ParserT s st m (ListNumberStyle, Int)
-> ParserT s st m ListAttributes
inPeriod num = try $ do
(style, start) <- num
char '.'
let delim = if style == DefaultStyle
then DefaultDelim
else Period
return (start, style, delim)
inOneParen :: Stream s m Char
=> ParserT s st m (ListNumberStyle, Int)
-> ParserT s st m ListAttributes
inOneParen num = try $ do
(style, start) <- num
char ')'
return (start, style, OneParen)
inTwoParens :: Stream s m Char
=> ParserT s st m (ListNumberStyle, Int)
-> ParserT s st m ListAttributes
inTwoParens num = try $ do
char '('
(style, start) <- num
char ')'
return (start, style, TwoParens)
orderedListMarker :: Stream s m Char
=> ListNumberStyle
-> ListNumberDelim
-> ParserT s ParserState m Int
orderedListMarker style delim = do
let num = defaultNum <|>
case style of
DefaultStyle -> decimal
Example -> exampleNum
Decimal -> decimal
UpperRoman -> upperRoman
LowerRoman -> lowerRoman
UpperAlpha -> upperAlpha
LowerAlpha -> lowerAlpha
let context = case delim of
DefaultDelim -> inPeriod
Period -> inPeriod
OneParen -> inOneParen
TwoParens -> inTwoParens
(start, _, _) <- context num
return start
charRef :: Stream s m Char => ParserT s st m Inline
charRef = do
c <- characterReference
return $ Str [c]
lineBlockLine :: Stream [Char] m Char => ParserT [Char] st m String
lineBlockLine = try $ do
char '|'
char ' '
white <- many (spaceChar >> return '\160')
notFollowedBy newline
line <- anyLine
continuations <- many (try $ char ' ' >> anyLine)
return $ white ++ unwords (line : continuations)
lineBlockLines :: Stream [Char] m Char => ParserT [Char] st m [String]
lineBlockLines = try $ do
lines' <- many1 lineBlockLine
skipMany1 $ blankline <|> try (char '|' >> blankline)
return lines'
tableWith :: Stream s m Char
=> ParserT s ParserState m ([[Block]], [Alignment], [Int])
-> ([Int] -> ParserT s ParserState m [[Block]])
-> ParserT s ParserState m sep
-> ParserT s ParserState m end
-> ParserT s ParserState m Block
tableWith headerParser rowParser lineParser footerParser = try $ do
(heads, aligns, indices) <- headerParser
lines' <- rowParser indices `sepEndBy1` lineParser
footerParser
numColumns <- getOption readerColumns
let widths = if (indices == [])
then replicate (length aligns) 0.0
else widthsFromIndices numColumns indices
return $ Table [] aligns widths heads lines'
widthsFromIndices :: Int
-> [Int]
-> [Double]
widthsFromIndices _ [] = []
widthsFromIndices numColumns' indices =
let numColumns = max numColumns' (if null indices then 0 else last indices)
lengths' = zipWith () indices (0:indices)
lengths = reverse $
case reverse lengths' of
[] -> []
[x] -> [x]
(x:y:zs) -> if x < y && y x <= 2
then y:y:zs
else x:y:zs
totLength = sum lengths
quotient = if totLength > numColumns
then fromIntegral totLength
else fromIntegral numColumns
fracs = map (\l -> (fromIntegral l) / quotient) lengths in
tail fracs
gridTableWith :: Stream [Char] m Char
=> ParserT [Char] ParserState m [Block]
-> Bool
-> ParserT [Char] ParserState m Block
gridTableWith blocks headless =
tableWith (gridTableHeader headless blocks) (gridTableRow blocks)
(gridTableSep '-') gridTableFooter
gridTableSplitLine :: [Int] -> String -> [String]
gridTableSplitLine indices line = map removeFinalBar $ tail $
splitStringByIndices (init indices) $ trimr line
gridPart :: Stream s m Char => Char -> ParserT s st m (Int, Int)
gridPart ch = do
dashes <- many1 (char ch)
char '+'
return (length dashes, length dashes + 1)
gridDashedLines :: Stream s m Char => Char -> ParserT s st m [(Int,Int)]
gridDashedLines ch = try $ char '+' >> many1 (gridPart ch) <* blankline
removeFinalBar :: String -> String
removeFinalBar =
reverse . dropWhile (`elem` " \t") . dropWhile (=='|') . reverse
gridTableSep :: Stream s m Char => Char -> ParserT s ParserState m Char
gridTableSep ch = try $ gridDashedLines ch >> return '\n'
gridTableHeader :: Stream [Char] m Char
=> Bool
-> ParserT [Char] ParserState m [Block]
-> ParserT [Char] ParserState m ([[Block]], [Alignment], [Int])
gridTableHeader headless blocks = try $ do
optional blanklines
dashes <- gridDashedLines '-'
rawContent <- if headless
then return $ repeat ""
else many1
(notFollowedBy (gridTableSep '=') >> char '|' >>
many1Till anyChar newline)
if headless
then return ()
else gridTableSep '=' >> return ()
let lines' = map snd dashes
let indices = scanl (+) 0 lines'
let aligns = replicate (length lines') AlignDefault
let rawHeads = if headless
then replicate (length dashes) ""
else map (intercalate " ") $ transpose
$ map (gridTableSplitLine indices) rawContent
heads <- mapM (parseFromString blocks) $ map trim rawHeads
return (heads, aligns, indices)
gridTableRawLine :: Stream s m Char => [Int] -> ParserT s ParserState m [String]
gridTableRawLine indices = do
char '|'
line <- many1Till anyChar newline
return (gridTableSplitLine indices line)
gridTableRow :: Stream [Char] m Char
=> ParserT [Char] ParserState m [Block]
-> [Int]
-> ParserT [Char] ParserState m [[Block]]
gridTableRow blocks indices = do
colLines <- many1 (gridTableRawLine indices)
let cols = map ((++ "\n") . unlines . removeOneLeadingSpace) $
transpose colLines
mapM (liftM compactifyCell . parseFromString blocks) cols
removeOneLeadingSpace :: [String] -> [String]
removeOneLeadingSpace xs =
if all startsWithSpace xs
then map (drop 1) xs
else xs
where startsWithSpace "" = True
startsWithSpace (y:_) = y == ' '
compactifyCell :: [Block] -> [Block]
compactifyCell bs = head $ compactify [bs]
gridTableFooter :: Stream s m Char => ParserT s ParserState m [Char]
gridTableFooter = blanklines
readWithM :: (Monad m)
=> ParserT [Char] st m a
-> st
-> String
-> m (Either PandocError a)
readWithM parser state input =
mapLeft (ParsecError input) `liftM` runParserT parser state "source" input
readWith :: Parser [Char] st a
-> st
-> String
-> Either PandocError a
readWith p t inp = runIdentity $ readWithM p t inp
readWithWarnings :: Parser [Char] ParserState a
-> ParserState
-> String
-> Either PandocError (a, [String])
readWithWarnings p = readWith $ do
doc <- p
warnings <- stateWarnings <$> getState
return (doc, warnings)
testStringWith :: (Show a)
=> ParserT [Char] ParserState Identity a
-> [Char]
-> IO ()
testStringWith parser str = UTF8.putStrLn $ show $
readWith parser defaultParserState str
data ParserState = ParserState
{ stateOptions :: ReaderOptions,
stateParserContext :: ParserContext,
stateQuoteContext :: QuoteContext,
stateAllowLinks :: Bool,
stateMaxNestingLevel :: Int,
stateLastStrPos :: Maybe SourcePos,
stateKeys :: KeyTable,
stateHeaderKeys :: KeyTable,
stateSubstitutions :: SubstTable,
stateNotes :: NoteTable,
stateNotes' :: NoteTable',
stateMeta :: Meta,
stateMeta' :: F Meta,
stateHeaderTable :: [HeaderType],
stateHeaders :: M.Map Inlines String,
stateIdentifiers :: Set.Set String,
stateNextExample :: Int,
stateExamples :: M.Map String Int,
stateHasChapters :: Bool,
stateMacros :: [Macro],
stateRstDefaultRole :: String,
stateRstCustomRoles :: M.Map String (String, Maybe String, Attr),
stateCaption :: Maybe Inlines,
stateInHtmlBlock :: Maybe String,
stateMarkdownAttribute :: Bool,
stateWarnings :: [String]
}
instance Default ParserState where
def = defaultParserState
instance HasMeta ParserState where
setMeta field val st =
st{ stateMeta = setMeta field val $ stateMeta st }
deleteMeta field st =
st{ stateMeta = deleteMeta field $ stateMeta st }
class HasReaderOptions st where
extractReaderOptions :: st -> ReaderOptions
getOption :: (Stream s m t) => (ReaderOptions -> b) -> ParserT s st m b
getOption f = (f . extractReaderOptions) <$> getState
class HasQuoteContext st m where
getQuoteContext :: (Stream s m t) => ParsecT s st m QuoteContext
withQuoteContext :: QuoteContext -> ParsecT s st m a -> ParsecT s st m a
instance Monad m => HasQuoteContext ParserState m where
getQuoteContext = stateQuoteContext <$> getState
withQuoteContext context parser = do
oldState <- getState
let oldQuoteContext = stateQuoteContext oldState
setState oldState { stateQuoteContext = context }
result <- parser
newState <- getState
setState newState { stateQuoteContext = oldQuoteContext }
return result
instance HasReaderOptions ParserState where
extractReaderOptions = stateOptions
class HasHeaderMap st where
extractHeaderMap :: st -> M.Map Inlines String
updateHeaderMap :: (M.Map Inlines String -> M.Map Inlines String) ->
st -> st
instance HasHeaderMap ParserState where
extractHeaderMap = stateHeaders
updateHeaderMap f st = st{ stateHeaders = f $ stateHeaders st }
class HasIdentifierList st where
extractIdentifierList :: st -> Set.Set String
updateIdentifierList :: (Set.Set String -> Set.Set String) -> st -> st
instance HasIdentifierList ParserState where
extractIdentifierList = stateIdentifiers
updateIdentifierList f st = st{ stateIdentifiers = f $ stateIdentifiers st }
class HasMacros st where
extractMacros :: st -> [Macro]
updateMacros :: ([Macro] -> [Macro]) -> st -> st
instance HasMacros ParserState where
extractMacros = stateMacros
updateMacros f st = st{ stateMacros = f $ stateMacros st }
class HasLastStrPosition st where
setLastStrPos :: SourcePos -> st -> st
getLastStrPos :: st -> Maybe SourcePos
instance HasLastStrPosition ParserState where
setLastStrPos pos st = st{ stateLastStrPos = Just pos }
getLastStrPos st = stateLastStrPos st
defaultParserState :: ParserState
defaultParserState =
ParserState { stateOptions = def,
stateParserContext = NullState,
stateQuoteContext = NoQuote,
stateAllowLinks = True,
stateMaxNestingLevel = 6,
stateLastStrPos = Nothing,
stateKeys = M.empty,
stateHeaderKeys = M.empty,
stateSubstitutions = M.empty,
stateNotes = [],
stateNotes' = [],
stateMeta = nullMeta,
stateMeta' = return nullMeta,
stateHeaderTable = [],
stateHeaders = M.empty,
stateIdentifiers = Set.empty,
stateNextExample = 1,
stateExamples = M.empty,
stateHasChapters = False,
stateMacros = [],
stateRstDefaultRole = "title-reference",
stateRstCustomRoles = M.empty,
stateCaption = Nothing,
stateInHtmlBlock = Nothing,
stateMarkdownAttribute = False,
stateWarnings = []}
guardEnabled :: (Stream s m a, HasReaderOptions st) => Extension -> ParserT s st m ()
guardEnabled ext = getOption readerExtensions >>= guard . Set.member ext
guardDisabled :: (Stream s m a, HasReaderOptions st) => Extension -> ParserT s st m ()
guardDisabled ext = getOption readerExtensions >>= guard . not . Set.member ext
updateLastStrPos :: (Stream s m a, HasLastStrPosition st) => ParserT s st m ()
updateLastStrPos = getPosition >>= updateState . setLastStrPos
notAfterString :: (Stream s m a, HasLastStrPosition st) => ParserT s st m Bool
notAfterString = do
pos <- getPosition
st <- getState
return $ getLastStrPos st /= Just pos
data HeaderType
= SingleHeader Char
| DoubleHeader Char
deriving (Eq, Show)
data ParserContext
= ListItemState
| NullState
deriving (Eq, Show)
data QuoteContext
= InSingleQuote
| InDoubleQuote
| NoQuote
deriving (Eq, Show)
type NoteTable = [(String, String)]
type NoteTable' = [(String, F Blocks)]
newtype Key = Key String deriving (Show, Read, Eq, Ord)
toKey :: String -> Key
toKey = Key . map toLower . unwords . words . unbracket
where unbracket ('[':xs) | "]" `isSuffixOf` xs = take (length xs 1) xs
unbracket xs = xs
type KeyTable = M.Map Key (Target, Attr)
type SubstTable = M.Map Key Inlines
registerHeader :: (Stream s m a, HasReaderOptions st, HasHeaderMap st, HasIdentifierList st)
=> Attr -> Inlines -> ParserT s st m Attr
registerHeader (ident,classes,kvs) header' = do
ids <- extractIdentifierList <$> getState
exts <- getOption readerExtensions
let insert' = M.insertWith (\_new old -> old)
if null ident && Ext_auto_identifiers `Set.member` exts
then do
let id' = uniqueIdent (B.toList header') ids
let id'' = if Ext_ascii_identifiers `Set.member` exts
then catMaybes $ map toAsciiChar id'
else id'
updateState $ updateIdentifierList $ Set.insert id'
updateState $ updateIdentifierList $ Set.insert id''
updateState $ updateHeaderMap $ insert' header' id'
return (id'',classes,kvs)
else do
unless (null ident) $
updateState $ updateHeaderMap $ insert' header' ident
return (ident,classes,kvs)
failUnlessSmart :: (Stream s m a, HasReaderOptions st) => ParserT s st m ()
failUnlessSmart = getOption readerSmart >>= guard
smartPunctuation :: (HasReaderOptions st, HasLastStrPosition st, HasQuoteContext st m, Stream s m Char)
=> ParserT s st m Inlines
-> ParserT s st m Inlines
smartPunctuation inlineParser = do
failUnlessSmart
choice [ quoted inlineParser, apostrophe, dash, ellipses ]
apostrophe :: Stream s m Char => ParserT s st m Inlines
apostrophe = (char '\'' <|> char '\8217') >> return (B.str "\x2019")
quoted :: (HasLastStrPosition st, HasQuoteContext st m, Stream s m Char)
=> ParserT s st m Inlines
-> ParserT s st m Inlines
quoted inlineParser = doubleQuoted inlineParser <|> singleQuoted inlineParser
singleQuoted :: (HasLastStrPosition st, HasQuoteContext st m, Stream s m Char)
=> ParserT s st m Inlines
-> ParserT s st m Inlines
singleQuoted inlineParser = try $ do
singleQuoteStart
withQuoteContext InSingleQuote $ many1Till inlineParser singleQuoteEnd >>=
return . B.singleQuoted . mconcat
doubleQuoted :: (HasQuoteContext st m, Stream s m Char)
=> ParserT s st m Inlines
-> ParserT s st m Inlines
doubleQuoted inlineParser = try $ do
doubleQuoteStart
withQuoteContext InDoubleQuote $ manyTill inlineParser doubleQuoteEnd >>=
return . B.doubleQuoted . mconcat
failIfInQuoteContext :: (HasQuoteContext st m, Stream s m t)
=> QuoteContext
-> ParserT s st m ()
failIfInQuoteContext context = do
context' <- getQuoteContext
if context' == context
then fail "already inside quotes"
else return ()
charOrRef :: Stream s m Char => String -> ParserT s st m Char
charOrRef cs =
oneOf cs <|> try (do c <- characterReference
guard (c `elem` cs)
return c)
singleQuoteStart :: (HasLastStrPosition st, HasQuoteContext st m, Stream s m Char)
=> ParserT s st m ()
singleQuoteStart = do
failIfInQuoteContext InSingleQuote
guard =<< notAfterString
() <$ charOrRef "'\8216\145"
singleQuoteEnd :: Stream s m Char
=> ParserT s st m ()
singleQuoteEnd = try $ do
charOrRef "'\8217\146"
notFollowedBy alphaNum
doubleQuoteStart :: (HasQuoteContext st m, Stream s m Char)
=> ParserT s st m ()
doubleQuoteStart = do
failIfInQuoteContext InDoubleQuote
try $ do charOrRef "\"\8220\147"
notFollowedBy . satisfy $ flip elem [' ', '\t', '\n']
doubleQuoteEnd :: Stream s m Char
=> ParserT s st m ()
doubleQuoteEnd = void (charOrRef "\"\8221\148")
ellipses :: Stream s m Char
=> ParserT s st m Inlines
ellipses = try (string "..." >> return (B.str "\8230"))
dash :: (HasReaderOptions st, Stream s m Char)
=> ParserT s st m Inlines
dash = try $ do
oldDashes <- getOption readerOldDashes
if oldDashes
then do
char '-'
(char '-' >> return (B.str "\8212"))
<|> (lookAhead digit >> return (B.str "\8211"))
else do
string "--"
(char '-' >> return (B.str "\8212"))
<|> return (B.str "\8211")
nested :: Stream s m a
=> ParserT s ParserState m a
-> ParserT s ParserState m a
nested p = do
nestlevel <- stateMaxNestingLevel <$> getState
guard $ nestlevel > 0
updateState $ \st -> st{ stateMaxNestingLevel = stateMaxNestingLevel st 1 }
res <- p
updateState $ \st -> st{ stateMaxNestingLevel = nestlevel }
return res
citeKey :: (Stream s m Char, HasLastStrPosition st)
=> ParserT s st m (Bool, String)
citeKey = try $ do
guard =<< notAfterString
suppress_author <- option False (char '-' *> return True)
char '@'
firstChar <- alphaNum <|> char '_' <|> char '*'
let regchar = satisfy (\c -> isAlphaNum c || c == '_')
let internal p = try $ p <* lookAhead regchar
rest <- many $ regchar <|> internal (oneOf ":.#$%&-+?<>~/") <|>
try (oneOf ":/" <* lookAhead (char '/'))
let key = firstChar:rest
return (suppress_author, key)
token :: (Stream s m t)
=> (t -> String)
-> (t -> SourcePos)
-> (t -> Maybe a)
-> ParsecT s st m a
token pp pos match = tokenPrim pp (\_ t _ -> pos t) match
macro :: (Stream [Char] m Char, HasMacros st, HasReaderOptions st)
=> ParserT [Char] st m Blocks
macro = do
apply <- getOption readerApplyMacros
inp <- getInput
case parseMacroDefinitions inp of
([], _) -> mzero
(ms, rest) -> do def' <- count (length inp length rest) anyChar
if apply
then do
updateState $ \st ->
updateMacros (ms ++) st
return mempty
else return $ rawBlock "latex" def'
applyMacros' :: (HasReaderOptions st, HasMacros st, Stream [Char] m Char)
=> String
-> ParserT [Char] st m String
applyMacros' target = do
apply <- getOption readerApplyMacros
if apply
then do macros <- extractMacros <$> getState
return $ applyMacros macros target
else return target
addWarning :: Maybe SourcePos -> String -> Parser [Char] ParserState ()
addWarning mbpos msg =
updateState $ \st -> st{
stateWarnings = (msg ++ maybe "" (\pos -> " " ++ show pos) mbpos) :
stateWarnings st }
infixr 5 <+?>
(<+?>) :: (Monoid a) => ParserT s st m a -> ParserT s st m a -> ParserT s st m a
a <+?> b = a >>= flip fmap (try b <|> return mempty) . (<>)
extractIdClass :: Attr -> Attr
extractIdClass (ident, cls, kvs) = (ident', cls', kvs')
where
ident' = case (lookup "id" kvs) of
Just v -> v
Nothing -> ident
cls' = case (lookup "class" kvs) of
Just cl -> words cl
Nothing -> cls
kvs' = filter (\(k,_) -> k /= "id" || k /= "class") kvs