module Text.Pandoc.Parsing ( (>>~),
anyLine,
many1Till,
notFollowedBy',
oneOfStrings,
oneOfStringsCI,
spaceChar,
nonspaceChar,
skipSpaces,
blankline,
blanklines,
enclosed,
stringAnyCase,
parseFromString,
lineClump,
charsInBalanced,
romanNumeral,
emailAddress,
uri,
withHorizDisplacement,
withRaw,
escaped,
characterReference,
updateLastStrPos,
anyOrderedListMarker,
orderedListMarker,
charRef,
lineBlockLines,
tableWith,
widthsFromIndices,
gridTableWith,
readWith,
testStringWith,
getOption,
guardEnabled,
guardDisabled,
ParserState (..),
defaultParserState,
HeaderType (..),
ParserContext (..),
QuoteContext (..),
NoteTable,
NoteTable',
KeyTable,
SubstTable,
Key (..),
toKey,
smartPunctuation,
withQuoteContext,
singleQuoteStart,
singleQuoteEnd,
doubleQuoteStart,
doubleQuoteEnd,
ellipses,
apostrophe,
dash,
nested,
macro,
applyMacros',
Parser,
F(..),
runF,
askF,
asksF,
runParser,
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,
newPos,
token
)
where
import Text.Pandoc.Definition
import Text.Pandoc.Options
import Text.Pandoc.Builder (Blocks, Inlines)
import qualified Text.Pandoc.UTF8 as UTF8 (putStrLn)
import Text.Parsec
import Text.Parsec.Pos (newPos)
import Data.Char ( toLower, toUpper, ord, isAscii, isAlphaNum, isDigit, isHexDigit,
isSpace )
import Data.List ( intercalate, transpose )
import Text.Pandoc.Shared
import qualified Data.Map as M
import Text.TeXMath.Macros (applyMacros, Macro, parseMacroDefinitions)
import Text.HTML.TagSoup.Entity ( lookupEntity )
import Data.Default
import qualified Data.Set as Set
import Control.Monad.Reader
import Control.Applicative ((*>), (<*), (<$), liftA2)
import Data.Monoid
type Parser t s = Parsec t s
newtype F a = F { unF :: Reader ParserState a } deriving (Monad, 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
(>>~) :: (Monad m) => m a -> m b -> m a
a >>~ b = a >>= \x -> b >> return x
anyLine :: Parser [Char] st [Char]
anyLine = manyTill anyChar newline
many1Till :: Parser [tok] st a
-> Parser [tok] st end
-> Parser [tok] st [a]
many1Till p end = do
first <- p
rest <- manyTill p end
return (first:rest)
notFollowedBy' :: Show b => Parser [a] st b -> Parser [a] st ()
notFollowedBy' p = try $ join $ do a <- try p
return (unexpected (show a))
<|>
return (return ())
oneOfStrings' :: (Char -> Char -> Bool) -> [String] -> Parser [Char] st 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:) `fmap` oneOfStrings' matches strs'
<|> if "" `elem` strs'
then return [c]
else fail "not found"
oneOfStrings :: [String] -> Parser [Char] st String
oneOfStrings = oneOfStrings' (==)
oneOfStringsCI :: [String] -> Parser [Char] st String
oneOfStringsCI = oneOfStrings' ciMatch
where ciMatch x y = toLower x == toLower y
spaceChar :: Parser [Char] st Char
spaceChar = satisfy $ \c -> c == ' ' || c == '\t'
nonspaceChar :: Parser [Char] st Char
nonspaceChar = satisfy $ \x -> x /= '\t' && x /= '\n' && x /= ' ' && x /= '\r'
skipSpaces :: Parser [Char] st ()
skipSpaces = skipMany spaceChar
blankline :: Parser [Char] st Char
blankline = try $ skipSpaces >> newline
blanklines :: Parser [Char] st [Char]
blanklines = many1 blankline
enclosed :: Parser [Char] st t
-> Parser [Char] st end
-> Parser [Char] st a
-> Parser [Char] st [a]
enclosed start end parser = try $
start >> notFollowedBy space >> many1Till parser end
stringAnyCase :: [Char] -> Parser [Char] st String
stringAnyCase [] = string ""
stringAnyCase (x:xs) = do
firstChar <- char (toUpper x) <|> char (toLower x)
rest <- stringAnyCase xs
return (firstChar:rest)
parseFromString :: Parser [tok] st a -> [tok] -> Parser [tok] st a
parseFromString parser str = do
oldPos <- getPosition
oldInput <- getInput
setInput str
result <- parser
setInput oldInput
setPosition oldPos
return result
lineClump :: Parser [Char] st String
lineClump = blanklines
<|> (many1 (notFollowedBy blankline >> anyLine) >>= return . unlines)
charsInBalanced :: Char -> Char -> Parser [Char] st Char
-> Parser [Char] st 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 :: Bool
-> Parser [Char] st 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 :: Parser [Char] st (String, String)
emailAddress = try $ liftA2 toResult mailbox (char '@' *> domain)
where toResult mbox dom = let full = mbox ++ '@':dom
in (full, escapeURI $ "mailto:" ++ full)
mailbox = intercalate "." `fmap` (emailWord `sepby1` dot)
domain = intercalate "." `fmap` (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 = liftA2 (:) 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"]
uriScheme :: Parser [Char] st String
uriScheme = oneOfStringsCI schemes
uri :: Parser [Char] st (String, String)
uri = try $ do
scheme <- uriScheme
char ':'
let isWordChar c = isAlphaNum c || c == '_' || c == '/' || not (isAscii c)
let wordChar = satisfy isWordChar
let percentEscaped = try $ char '%' >> skipMany1 (satisfy isHexDigit)
let entity = () <$ characterReference
let punct = skipMany1 (char ',')
<|> () <$ (satisfy (not . isSpace))
let uriChunk = skipMany1 wordChar
<|> percentEscaped
<|> entity
<|> (try $ punct >> notFollowedBy (satisfy $ not . isWordChar))
str <- snd `fmap` withRaw (skipMany1 ( () <$
(enclosed (char '(') (char ')') uriChunk
<|> enclosed (char '{') (char '}') uriChunk
<|> enclosed (char '[') (char ']') uriChunk)
<|> uriChunk))
str' <- option str $ char '/' >> return (str ++ "/")
let uri' = scheme ++ ":" ++ str'
return (uri', escapeURI uri')
withHorizDisplacement :: Parser [Char] st a
-> Parser [Char] st (a, Int)
withHorizDisplacement parser = do
pos1 <- getPosition
result <- parser
pos2 <- getPosition
return (result, sourceColumn pos2 sourceColumn pos1)
withRaw :: Parser [Char] st a -> Parser [Char] st (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 :: Parser [Char] st Char
-> Parser [Char] st Char
escaped parser = try $ char '\\' >> parser
characterReference :: Parser [Char] st Char
characterReference = try $ do
char '&'
ent <- many1Till nonspaceChar (char ';')
case lookupEntity ent of
Just c -> return c
Nothing -> fail "entity not found"
upperRoman :: Parser [Char] st (ListNumberStyle, Int)
upperRoman = do
num <- romanNumeral True
return (UpperRoman, num)
lowerRoman :: Parser [Char] st (ListNumberStyle, Int)
lowerRoman = do
num <- romanNumeral False
return (LowerRoman, num)
decimal :: Parser [Char] st (ListNumberStyle, Int)
decimal = do
num <- many1 digit
return (Decimal, read num)
exampleNum :: Parser [Char] ParserState (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 :: Parser [Char] st (ListNumberStyle, Int)
defaultNum = do
char '#'
return (DefaultStyle, 1)
lowerAlpha :: Parser [Char] st (ListNumberStyle, Int)
lowerAlpha = do
ch <- oneOf ['a'..'z']
return (LowerAlpha, ord ch ord 'a' + 1)
upperAlpha :: Parser [Char] st (ListNumberStyle, Int)
upperAlpha = do
ch <- oneOf ['A'..'Z']
return (UpperAlpha, ord ch ord 'A' + 1)
romanOne :: Parser [Char] st (ListNumberStyle, Int)
romanOne = (char 'i' >> return (LowerRoman, 1)) <|>
(char 'I' >> return (UpperRoman, 1))
anyOrderedListMarker :: Parser [Char] ParserState ListAttributes
anyOrderedListMarker = choice $
[delimParser numParser | delimParser <- [inPeriod, inOneParen, inTwoParens],
numParser <- [decimal, exampleNum, defaultNum, romanOne,
lowerAlpha, lowerRoman, upperAlpha, upperRoman]]
inPeriod :: Parser [Char] st (ListNumberStyle, Int)
-> Parser [Char] st ListAttributes
inPeriod num = try $ do
(style, start) <- num
char '.'
let delim = if style == DefaultStyle
then DefaultDelim
else Period
return (start, style, delim)
inOneParen :: Parser [Char] st (ListNumberStyle, Int)
-> Parser [Char] st ListAttributes
inOneParen num = try $ do
(style, start) <- num
char ')'
return (start, style, OneParen)
inTwoParens :: Parser [Char] st (ListNumberStyle, Int)
-> Parser [Char] st ListAttributes
inTwoParens num = try $ do
char '('
(style, start) <- num
char ')'
return (start, style, TwoParens)
orderedListMarker :: ListNumberStyle
-> ListNumberDelim
-> Parser [Char] ParserState 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 :: Parser [Char] st Inline
charRef = do
c <- characterReference
return $ Str [c]
lineBlockLine :: Parser [Char] st 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 :: Parser [Char] st [String]
lineBlockLines = try $ do
lines' <- many1 lineBlockLine
skipMany1 $ blankline <|> try (char '|' >> blankline)
return lines'
tableWith :: Parser [Char] ParserState ([[Block]], [Alignment], [Int])
-> ([Int] -> Parser [Char] ParserState [[Block]])
-> Parser [Char] ParserState sep
-> Parser [Char] ParserState end
-> Parser [Char] ParserState 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 :: Parser [Char] ParserState [Block]
-> Bool
-> Parser [Char] ParserState 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 :: Char -> Parser [Char] st (Int, Int)
gridPart ch = do
dashes <- many1 (char ch)
char '+'
return (length dashes, length dashes + 1)
gridDashedLines :: Char -> Parser [Char] st [(Int,Int)]
gridDashedLines ch = try $ char '+' >> many1 (gridPart ch) >>~ blankline
removeFinalBar :: String -> String
removeFinalBar =
reverse . dropWhile (`elem` " \t") . dropWhile (=='|') . reverse
gridTableSep :: Char -> Parser [Char] ParserState Char
gridTableSep ch = try $ gridDashedLines ch >> return '\n'
gridTableHeader :: Bool
-> Parser [Char] ParserState [Block]
-> Parser [Char] ParserState ([[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 :: [Int] -> Parser [Char] ParserState [String]
gridTableRawLine indices = do
char '|'
line <- many1Till anyChar newline
return (gridTableSplitLine indices line)
gridTableRow :: Parser [Char] ParserState [Block]
-> [Int]
-> Parser [Char] ParserState [[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 :: Parser [Char] ParserState [Char]
gridTableFooter = blanklines
readWith :: Parser [t] ParserState a
-> ParserState
-> [t]
-> a
readWith parser state input =
case runParser parser state "source" input of
Left err' -> error $ "\nError:\n" ++ show err'
Right result -> result
testStringWith :: (Show a) => Parser [Char] ParserState a
-> String
-> 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,
stateSubstitutions :: SubstTable,
stateNotes :: NoteTable,
stateNotes' :: NoteTable',
stateTitle :: [Inline],
stateAuthors :: [[Inline]],
stateDate :: [Inline],
stateHeaderTable :: [HeaderType],
stateHeaders :: [[Inline]],
stateIdentifiers :: [String],
stateNextExample :: Int,
stateExamples :: M.Map String Int,
stateHasChapters :: Bool,
stateMacros :: [Macro],
stateRstDefaultRole :: String,
stateWarnings :: [String]
}
instance Default ParserState where
def = defaultParserState
defaultParserState :: ParserState
defaultParserState =
ParserState { stateOptions = def,
stateParserContext = NullState,
stateQuoteContext = NoQuote,
stateAllowLinks = True,
stateMaxNestingLevel = 6,
stateLastStrPos = Nothing,
stateKeys = M.empty,
stateSubstitutions = M.empty,
stateNotes = [],
stateNotes' = [],
stateTitle = [],
stateAuthors = [],
stateDate = [],
stateHeaderTable = [],
stateHeaders = [],
stateIdentifiers = [],
stateNextExample = 1,
stateExamples = M.empty,
stateHasChapters = False,
stateMacros = [],
stateRstDefaultRole = "title-reference",
stateWarnings = []}
getOption :: (ReaderOptions -> a) -> Parser s ParserState a
getOption f = (f . stateOptions) `fmap` getState
guardEnabled :: Extension -> Parser s ParserState ()
guardEnabled ext = getOption readerExtensions >>= guard . Set.member ext
guardDisabled :: Extension -> Parser s ParserState ()
guardDisabled ext = getOption readerExtensions >>= guard . not . Set.member ext
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
type KeyTable = M.Map Key Target
type SubstTable = M.Map Key Inlines
failUnlessSmart :: Parser [tok] ParserState ()
failUnlessSmart = getOption readerSmart >>= guard
smartPunctuation :: Parser [Char] ParserState Inline
-> Parser [Char] ParserState Inline
smartPunctuation inlineParser = do
failUnlessSmart
choice [ quoted inlineParser, apostrophe, dash, ellipses ]
apostrophe :: Parser [Char] ParserState Inline
apostrophe = (char '\'' <|> char '\8217') >> return (Str "\x2019")
quoted :: Parser [Char] ParserState Inline
-> Parser [Char] ParserState Inline
quoted inlineParser = doubleQuoted inlineParser <|> singleQuoted inlineParser
withQuoteContext :: QuoteContext
-> Parser [tok] ParserState a
-> Parser [tok] ParserState a
withQuoteContext context parser = do
oldState <- getState
let oldQuoteContext = stateQuoteContext oldState
setState oldState { stateQuoteContext = context }
result <- parser
newState <- getState
setState newState { stateQuoteContext = oldQuoteContext }
return result
singleQuoted :: Parser [Char] ParserState Inline
-> Parser [Char] ParserState Inline
singleQuoted inlineParser = try $ do
singleQuoteStart
withQuoteContext InSingleQuote $ many1Till inlineParser singleQuoteEnd >>=
return . Quoted SingleQuote . normalizeSpaces
doubleQuoted :: Parser [Char] ParserState Inline
-> Parser [Char] ParserState Inline
doubleQuoted inlineParser = try $ do
doubleQuoteStart
withQuoteContext InDoubleQuote $ do
contents <- manyTill inlineParser doubleQuoteEnd
return . Quoted DoubleQuote . normalizeSpaces $ contents
failIfInQuoteContext :: QuoteContext -> Parser [tok] ParserState ()
failIfInQuoteContext context = do
st <- getState
if stateQuoteContext st == context
then fail "already inside quotes"
else return ()
charOrRef :: [Char] -> Parser [Char] st Char
charOrRef cs =
oneOf cs <|> try (do c <- characterReference
guard (c `elem` cs)
return c)
updateLastStrPos :: Parser [Char] ParserState ()
updateLastStrPos = getPosition >>= \p ->
updateState $ \s -> s{ stateLastStrPos = Just p }
singleQuoteStart :: Parser [Char] ParserState ()
singleQuoteStart = do
failIfInQuoteContext InSingleQuote
pos <- getPosition
st <- getState
guard $ stateLastStrPos st /= Just pos
() <$ charOrRef "'\8216\145"
singleQuoteEnd :: Parser [Char] st ()
singleQuoteEnd = try $ do
charOrRef "'\8217\146"
notFollowedBy alphaNum
doubleQuoteStart :: Parser [Char] ParserState ()
doubleQuoteStart = do
failIfInQuoteContext InDoubleQuote
try $ do charOrRef "\"\8220\147"
notFollowedBy (satisfy (\c -> c == ' ' || c == '\t' || c == '\n'))
doubleQuoteEnd :: Parser [Char] st ()
doubleQuoteEnd = do
charOrRef "\"\8221\148"
return ()
ellipses :: Parser [Char] st Inline
ellipses = do
try (charOrRef "\8230\133") <|> try (string "..." >> return '…')
return (Str "\8230")
dash :: Parser [Char] ParserState Inline
dash = do
oldDashes <- getOption readerOldDashes
if oldDashes
then emDashOld <|> enDashOld
else Str `fmap` (hyphenDash <|> emDash <|> enDash)
hyphenDash :: Parser [Char] st String
hyphenDash = do
try $ string "--"
option "\8211" (char '-' >> return "\8212")
emDash :: Parser [Char] st String
emDash = do
try (charOrRef "\8212\151")
return "\8212"
enDash :: Parser [Char] st String
enDash = do
try (charOrRef "\8212\151")
return "\8211"
enDashOld :: Parser [Char] st Inline
enDashOld = do
try (charOrRef "\8211\150") <|>
try (char '-' >> lookAhead (satisfy isDigit) >> return '–')
return (Str "\8211")
emDashOld :: Parser [Char] st Inline
emDashOld = do
try (charOrRef "\8212\151") <|> (try $ string "--" >> optional (char '-') >> return '-')
return (Str "\8212")
nested :: Parser s ParserState a
-> Parser s ParserState a
nested p = do
nestlevel <- stateMaxNestingLevel `fmap` getState
guard $ nestlevel > 0
updateState $ \st -> st{ stateMaxNestingLevel = stateMaxNestingLevel st 1 }
res <- p
updateState $ \st -> st{ stateMaxNestingLevel = nestlevel }
return res
macro :: Parser [Char] ParserState Block
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 ->
st { stateMacros = ms ++ stateMacros st }
return Null
else return $ RawBlock "latex" def'
applyMacros' :: String -> Parser [Char] ParserState String
applyMacros' target = do
apply <- getOption readerApplyMacros
if apply
then do macros <- liftM stateMacros getState
return $ applyMacros macros target
else return target