summaryrefslogtreecommitdiff
path: root/src/Text/Pandoc/Parsing.hs
diff options
context:
space:
mode:
authorMatthew Pickering <matthewtpickering@gmail.com>2014-07-11 12:45:34 +0100
committerMatthew Pickering <matthewtpickering@gmail.com>2014-07-11 12:45:34 +0100
commitf201bdcb58743d10cc9dc357da6779fd29b531b5 (patch)
treeb592c282051c2ca383acd82123345fafcd983ca1 /src/Text/Pandoc/Parsing.hs
parent05a5b4e3c2aa53fa9c12464791d3a4969b18daba (diff)
Generalised all functions in Parsing.hs
Before it wasn't possible to use these general combinators with the ParsecT transformer but with the more general types this is now possible.
Diffstat (limited to 'src/Text/Pandoc/Parsing.hs')
-rw-r--r--src/Text/Pandoc/Parsing.hs296
1 files changed, 168 insertions, 128 deletions
diff --git a/src/Text/Pandoc/Parsing.hs b/src/Text/Pandoc/Parsing.hs
index 391131338..7a3e2529d 100644
--- a/src/Text/Pandoc/Parsing.hs
+++ b/src/Text/Pandoc/Parsing.hs
@@ -1,5 +1,8 @@
-{-# LANGUAGE GeneralizedNewtypeDeriving, TypeSynonymInstances,
- FlexibleInstances#-}
+{-# LANGUAGE
+ FlexibleContexts
+, GeneralizedNewtypeDeriving
+, TypeSynonymInstances
+, FlexibleInstances #-}
{-
Copyright (C) 2006-2014 John MacFarlane <jgm@berkeley.edu>
@@ -177,12 +180,15 @@ import Text.Pandoc.Asciify (toAsciiChar)
import Data.Default
import qualified Data.Set as Set
import Control.Monad.Reader
-import Control.Applicative ((*>), (<*), (<$), liftA2, Applicative)
+import Control.Monad.Identity
+import Control.Applicative ((<$>), (<*>), (*>), (<*), (<$), Applicative)
import Data.Monoid
import Data.Maybe (catMaybes)
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
@@ -201,11 +207,11 @@ instance Monoid a => Monoid (F a) where
-- | Like >>, but returns the operation on the left.
-- (Suggested by Tillmann Rendel on Haskell-cafe list.)
-(>>~) :: (Monad m) => m a -> m b -> m a
-a >>~ b = a >>= \x -> b >> return x
+(>>~) :: (Applicative m) => m a -> m b -> m a
+a >>~ b = a <* b
-- | Parse any line of text
-anyLine :: Parser [Char] st [Char]
+anyLine :: Stream [Char] m Char => ParserT [Char] st m [Char]
anyLine = do
-- This is much faster than:
-- manyTill anyChar newline
@@ -221,9 +227,10 @@ anyLine = do
_ -> mzero
-- | Like @manyTill@, but reads at least one item.
-many1Till :: Parser [tok] st a
- -> Parser [tok] st end
- -> Parser [tok] st [a]
+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
@@ -232,14 +239,14 @@ many1Till p end = do
-- | A more general form of @notFollowedBy@. This one allows any
-- type of parser to be specified, and succeeds only if that parser fails.
-- It does not consume any input.
-notFollowedBy' :: Show b => Parser [a] st b -> Parser [a] st ()
+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 ())
-- (This version due to Andrew Pimlott on the Haskell mailing list.)
-oneOfStrings' :: (Char -> Char -> Bool) -> [String] -> Parser [Char] st String
+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
@@ -254,11 +261,11 @@ oneOfStrings' matches strs = try $ do
-- | Parses one of a list of strings. If the list contains
-- two strings one of which is a prefix of the other, the longer
-- string will be matched if possible.
-oneOfStrings :: [String] -> Parser [Char] st String
+oneOfStrings :: Stream s m Char => [String] -> ParserT s st m String
oneOfStrings = oneOfStrings' (==)
-- | Parses one of a list of strings (tried in order), case insensitive.
-oneOfStringsCI :: [String] -> Parser [Char] st String
+oneOfStringsCI :: Stream s m Char => [String] -> ParserT s st m String
oneOfStringsCI = oneOfStrings' ciMatch
where ciMatch x y = toLower' x == toLower' y
-- this optimizes toLower by checking common ASCII case
@@ -269,35 +276,35 @@ oneOfStringsCI = oneOfStrings' ciMatch
| otherwise = toLower c
-- | Parses a space or tab.
-spaceChar :: Parser [Char] st Char
+spaceChar :: Stream s m Char => ParserT s st m Char
spaceChar = satisfy $ \c -> c == ' ' || c == '\t'
-- | Parses a nonspace, nonnewline character.
-nonspaceChar :: Parser [Char] st Char
+nonspaceChar :: Stream s m Char => ParserT s st m Char
nonspaceChar = satisfy $ flip notElem ['\t', '\n', ' ', '\r']
-- | Skips zero or more spaces or tabs.
-skipSpaces :: Parser [Char] st ()
+skipSpaces :: Stream s m Char => ParserT s st m ()
skipSpaces = skipMany spaceChar
-- | Skips zero or more spaces or tabs, then reads a newline.
-blankline :: Parser [Char] st Char
+blankline :: Stream s m Char => ParserT s st m Char
blankline = try $ skipSpaces >> newline
-- | Parses one or more blank lines and returns a string of newlines.
-blanklines :: Parser [Char] st [Char]
+blanklines :: Stream s m Char => ParserT s st m [Char]
blanklines = many1 blankline
-- | Parses material enclosed between start and end parsers.
-enclosed :: Parser [Char] st t -- ^ start parser
- -> Parser [Char] st end -- ^ end parser
- -> Parser [Char] st a -- ^ content parser (to be used repeatedly)
- -> Parser [Char] st [a]
+enclosed :: Stream s m Char => ParserT s st m t -- ^ start parser
+ -> ParserT s st m end -- ^ end parser
+ -> ParserT s st m a -- ^ content parser (to be used repeatedly)
+ -> ParserT s st m [a]
enclosed start end parser = try $
start >> notFollowedBy space >> many1Till parser end
-- | Parse string, case insensitive.
-stringAnyCase :: [Char] -> Parser [Char] st String
+stringAnyCase :: Stream s m Char => [Char] -> ParserT s st m String
stringAnyCase [] = string ""
stringAnyCase (x:xs) = do
firstChar <- char (toUpper x) <|> char (toLower x)
@@ -305,7 +312,7 @@ stringAnyCase (x:xs) = do
return (firstChar:rest)
-- | Parse contents of 'str' using 'parser' and return result.
-parseFromString :: Parser [tok] st a -> [tok] -> Parser [tok] st a
+parseFromString :: Stream s m t => ParserT s st m a -> s -> ParserT s st m a
parseFromString parser str = do
oldPos <- getPosition
oldInput <- getInput
@@ -316,7 +323,7 @@ parseFromString parser str = do
return result
-- | Parse raw line block up to and including blank lines.
-lineClump :: Parser [Char] st String
+lineClump :: Stream [Char] m Char => ParserT [Char] st m String
lineClump = blanklines
<|> (many1 (notFollowedBy blankline >> anyLine) >>= return . unlines)
@@ -325,8 +332,8 @@ lineClump = blanklines
-- pairs of open and close, which must be different. For example,
-- @charsInBalanced '(' ')' anyChar@ will parse "(hello (there))"
-- and return "hello (there)".
-charsInBalanced :: Char -> Char -> Parser [Char] st Char
- -> Parser [Char] st String
+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
@@ -350,8 +357,8 @@ uppercaseRomanDigits :: [Char]
uppercaseRomanDigits = map toUpper lowercaseRomanDigits
-- | Parses a roman numeral (uppercase or lowercase), returns number.
-romanNumeral :: Bool -- ^ Uppercase if true
- -> Parser [Char] st Int
+romanNumeral :: Stream s m Char => Bool -- ^ Uppercase if true
+ -> ParserT s st m Int
romanNumeral upperCase = do
let romanDigits = if upperCase
then uppercaseRomanDigits
@@ -383,8 +390,8 @@ romanNumeral upperCase = do
-- | Parses an email address; returns original and corresponding
-- escaped mailto: URI.
-emailAddress :: Parser [Char] st (String, String)
-emailAddress = try $ liftA2 toResult mailbox (char '@' *> domain)
+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 "." `fmap` (emailWord `sepby1` dot)
@@ -398,7 +405,7 @@ emailAddress = try $ liftA2 toResult mailbox (char '@' *> domain)
isEmailPunct c = c `elem` "!\"#$%&'*+-/=?^_{|}~;"
-- note: sepBy1 from parsec consumes input when sep
-- succeeds and p fails, so we use this variant here.
- sepby1 p sep = liftA2 (:) p (many (try $ sep >> p))
+ sepby1 p sep = (:) <$> p <*> (many (try $ sep >> p))
-- Schemes from http://www.iana.org/assignments/uri-schemes.html plus
@@ -426,11 +433,11 @@ schemes = ["coap","doi","javascript","aaa","aaas","about","acap","cap","cid",
"ventrilo","view-source","webcal","wtai","wyciwyg","xfire","xri",
"ymsgr"]
-uriScheme :: Parser [Char] st String
+uriScheme :: Stream s m Char => ParserT s st m String
uriScheme = oneOfStringsCI schemes
-- | Parses a URI. Returns pair of original and URI-escaped version.
-uri :: Parser [Char] st (String, String)
+uri :: Stream [Char] m Char => ParserT [Char] st m (String, String)
uri = try $ do
scheme <- uriScheme
char ':'
@@ -460,7 +467,7 @@ uri = try $ do
let uri' = scheme ++ ":" ++ fromEntities str'
return (uri', escapeURI uri')
-mathInlineWith :: String -> String -> Parser [Char] st String
+mathInlineWith :: Stream s m Char => String -> String -> ParserT s st m String
mathInlineWith op cl = try $ do
string op
notFollowedBy space
@@ -474,12 +481,12 @@ mathInlineWith op cl = try $ do
notFollowedBy digit -- to prevent capture of $5
return $ concat words'
-mathDisplayWith :: String -> String -> Parser [Char] st String
+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 :: Parser [Char] ParserState String
+mathDisplay :: Stream s m Char => ParserT s ParserState m String
mathDisplay =
(guardEnabled Ext_tex_math_dollars >> mathDisplayWith "$$" "$$")
<|> (guardEnabled Ext_tex_math_single_backslash >>
@@ -487,7 +494,7 @@ mathDisplay =
<|> (guardEnabled Ext_tex_math_double_backslash >>
mathDisplayWith "\\\\[" "\\\\]")
-mathInline :: Parser [Char] ParserState String
+mathInline :: Stream s m Char => ParserT s ParserState m String
mathInline =
(guardEnabled Ext_tex_math_dollars >> mathInlineWith "$" "$")
<|> (guardEnabled Ext_tex_math_single_backslash >>
@@ -499,8 +506,9 @@ mathInline =
-- displacement (the difference between the source column at the end
-- and the source column at the beginning). Vertical displacement
-- (source row) is ignored.
-withHorizDisplacement :: Parser [Char] st a -- ^ Parser to apply
- -> Parser [Char] st (a, Int) -- ^ (result, displacement)
+withHorizDisplacement :: Stream s m Char
+ => ParserT s st m a -- ^ Parser to apply
+ -> ParserT s st m (a, Int) -- ^ (result, displacement)
withHorizDisplacement parser = do
pos1 <- getPosition
result <- parser
@@ -509,7 +517,7 @@ withHorizDisplacement parser = do
-- | Applies a parser and returns the raw string that was parsed,
-- along with the value produced by the parser.
-withRaw :: Monad m => ParsecT [Char] st m a -> ParsecT [Char] st m (a, [Char])
+withRaw :: Stream [Char] m Char => ParsecT [Char] st m a -> ParsecT [Char] st m (a, [Char])
withRaw parser = do
pos1 <- getPosition
inp <- getInput
@@ -525,12 +533,13 @@ withRaw parser = do
return (result, raw)
-- | Parses backslash, then applies character parser.
-escaped :: Parser [Char] st Char -- ^ Parser for character to escape
- -> Parser [Char] st Char
+escaped :: Stream s m Char
+ => ParserT s st m Char -- ^ Parser for character to escape
+ -> ParserT s st m Char
escaped parser = try $ char '\\' >> parser
-- | Parse character entity.
-characterReference :: Parser [Char] st Char
+characterReference :: Stream s m Char => ParserT s st m Char
characterReference = try $ do
char '&'
ent <- many1Till nonspaceChar (char ';')
@@ -539,19 +548,19 @@ characterReference = try $ do
Nothing -> fail "entity not found"
-- | Parses an uppercase roman numeral and returns (UpperRoman, number).
-upperRoman :: Parser [Char] st (ListNumberStyle, Int)
+upperRoman :: Stream s m Char => ParserT s st m (ListNumberStyle, Int)
upperRoman = do
num <- romanNumeral True
return (UpperRoman, num)
-- | Parses a lowercase roman numeral and returns (LowerRoman, number).
-lowerRoman :: Parser [Char] st (ListNumberStyle, Int)
+lowerRoman :: Stream s m Char => ParserT s st m (ListNumberStyle, Int)
lowerRoman = do
num <- romanNumeral False
return (LowerRoman, num)
-- | Parses a decimal numeral and returns (Decimal, number).
-decimal :: Parser [Char] st (ListNumberStyle, Int)
+decimal :: Stream s m Char => ParserT s st m (ListNumberStyle, Int)
decimal = do
num <- many1 digit
return (Decimal, read num)
@@ -560,7 +569,8 @@ decimal = do
-- returns (DefaultStyle, [next example number]). The next
-- example number is incremented in parser state, and the label
-- (if present) is added to the label table.
-exampleNum :: Parser [Char] ParserState (ListNumberStyle, Int)
+exampleNum :: Stream s m Char
+ => ParserT s ParserState m (ListNumberStyle, Int)
exampleNum = do
char '@'
lab <- many (alphaNum <|> satisfy (\c -> c == '_' || c == '-'))
@@ -574,38 +584,39 @@ exampleNum = do
return (Example, num)
-- | Parses a '#' returns (DefaultStyle, 1).
-defaultNum :: Parser [Char] st (ListNumberStyle, Int)
+defaultNum :: Stream s m Char => ParserT s st m (ListNumberStyle, Int)
defaultNum = do
char '#'
return (DefaultStyle, 1)
-- | Parses a lowercase letter and returns (LowerAlpha, number).
-lowerAlpha :: Parser [Char] st (ListNumberStyle, Int)
+lowerAlpha :: Stream s m Char => ParserT s st m (ListNumberStyle, Int)
lowerAlpha = do
ch <- oneOf ['a'..'z']
return (LowerAlpha, ord ch - ord 'a' + 1)
-- | Parses an uppercase letter and returns (UpperAlpha, number).
-upperAlpha :: Parser [Char] st (ListNumberStyle, Int)
+upperAlpha :: Stream s m Char => ParserT s st m (ListNumberStyle, Int)
upperAlpha = do
ch <- oneOf ['A'..'Z']
return (UpperAlpha, ord ch - ord 'A' + 1)
-- | Parses a roman numeral i or I
-romanOne :: Parser [Char] st (ListNumberStyle, Int)
+romanOne :: Stream s m Char => ParserT s st m (ListNumberStyle, Int)
romanOne = (char 'i' >> return (LowerRoman, 1)) <|>
(char 'I' >> return (UpperRoman, 1))
-- | Parses an ordered list marker and returns list attributes.
-anyOrderedListMarker :: Parser [Char] ParserState ListAttributes
+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]]
-- | Parses a list number (num) followed by a period, returns list attributes.
-inPeriod :: Parser [Char] st (ListNumberStyle, Int)
- -> Parser [Char] st ListAttributes
+inPeriod :: Stream s m Char
+ => ParserT s st m (ListNumberStyle, Int)
+ -> ParserT s st m ListAttributes
inPeriod num = try $ do
(style, start) <- num
char '.'
@@ -615,16 +626,18 @@ inPeriod num = try $ do
return (start, style, delim)
-- | Parses a list number (num) followed by a paren, returns list attributes.
-inOneParen :: Parser [Char] st (ListNumberStyle, Int)
- -> Parser [Char] st ListAttributes
+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)
-- | Parses a list number (num) enclosed in parens, returns list attributes.
-inTwoParens :: Parser [Char] st (ListNumberStyle, Int)
- -> Parser [Char] st ListAttributes
+inTwoParens :: Stream s m Char
+ => ParserT s st m (ListNumberStyle, Int)
+ -> ParserT s st m ListAttributes
inTwoParens num = try $ do
char '('
(style, start) <- num
@@ -633,9 +646,10 @@ inTwoParens num = try $ do
-- | Parses an ordered list marker with a given style and delimiter,
-- returns number.
-orderedListMarker :: ListNumberStyle
+orderedListMarker :: Stream s m Char
+ => ListNumberStyle
-> ListNumberDelim
- -> Parser [Char] ParserState Int
+ -> ParserT s ParserState m Int
orderedListMarker style delim = do
let num = defaultNum <|> -- # can continue any kind of list
case style of
@@ -655,12 +669,12 @@ orderedListMarker style delim = do
return start
-- | Parses a character reference and returns a Str element.
-charRef :: Parser [Char] st Inline
+charRef :: Stream s m Char => ParserT s st m Inline
charRef = do
c <- characterReference
return $ Str [c]
-lineBlockLine :: Parser [Char] st String
+lineBlockLine :: Stream [Char] m Char => ParserT [Char] st m String
lineBlockLine = try $ do
char '|'
char ' '
@@ -671,7 +685,7 @@ lineBlockLine = try $ do
return $ white ++ unwords (line : continuations)
-- | Parses an RST-style line block and returns a list of strings.
-lineBlockLines :: Parser [Char] st [String]
+lineBlockLines :: Stream [Char] m Char => ParserT [Char] st m [String]
lineBlockLines = try $ do
lines' <- many1 lineBlockLine
skipMany1 $ blankline <|> try (char '|' >> blankline)
@@ -679,11 +693,12 @@ lineBlockLines = try $ do
-- | Parse a table using 'headerParser', 'rowParser',
-- 'lineParser', and 'footerParser'.
-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 :: 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
@@ -725,9 +740,10 @@ widthsFromIndices numColumns' indices =
-- (which may be grid), then the rows,
-- which may be grid, separated by blank lines, and
-- ending with a footer (dashed line followed by blank line).
-gridTableWith :: Parser [Char] ParserState [Block] -- ^ Block list parser
+gridTableWith :: Stream [Char] m Char
+ => ParserT [Char] ParserState m [Block] -- ^ Block list parser
-> Bool -- ^ Headerless table
- -> Parser [Char] ParserState Block
+ -> ParserT [Char] ParserState m Block
gridTableWith blocks headless =
tableWith (gridTableHeader headless blocks) (gridTableRow blocks)
(gridTableSep '-') gridTableFooter
@@ -736,13 +752,13 @@ gridTableSplitLine :: [Int] -> String -> [String]
gridTableSplitLine indices line = map removeFinalBar $ tail $
splitStringByIndices (init indices) $ trimr line
-gridPart :: Char -> Parser [Char] st (Int, Int)
+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 :: Char -> Parser [Char] st [(Int,Int)]
+gridDashedLines :: Stream s m Char => Char -> ParserT s st m [(Int,Int)]
gridDashedLines ch = try $ char '+' >> many1 (gridPart ch) >>~ blankline
removeFinalBar :: String -> String
@@ -750,13 +766,14 @@ removeFinalBar =
reverse . dropWhile (`elem` " \t") . dropWhile (=='|') . reverse
-- | Separator between rows of grid table.
-gridTableSep :: Char -> Parser [Char] ParserState Char
+gridTableSep :: Stream s m Char => Char -> ParserT s ParserState m Char
gridTableSep ch = try $ gridDashedLines ch >> return '\n'
-- | Parse header for a grid table.
-gridTableHeader :: Bool -- ^ Headerless table
- -> Parser [Char] ParserState [Block]
- -> Parser [Char] ParserState ([[Block]], [Alignment], [Int])
+gridTableHeader :: Stream [Char] m Char
+ => Bool -- ^ Headerless table
+ -> ParserT [Char] ParserState m [Block]
+ -> ParserT [Char] ParserState m ([[Block]], [Alignment], [Int])
gridTableHeader headless blocks = try $ do
optional blanklines
dashes <- gridDashedLines '-'
@@ -779,16 +796,17 @@ gridTableHeader headless blocks = try $ do
heads <- mapM (parseFromString blocks) $ map trim rawHeads
return (heads, aligns, indices)
-gridTableRawLine :: [Int] -> Parser [Char] ParserState [String]
+gridTableRawLine :: Stream s m Char => [Int] -> ParserT s ParserState m [String]
gridTableRawLine indices = do
char '|'
line <- many1Till anyChar newline
return (gridTableSplitLine indices line)
-- | Parse row of grid table.
-gridTableRow :: Parser [Char] ParserState [Block]
+gridTableRow :: Stream [Char] m Char
+ => ParserT [Char] ParserState m [Block]
-> [Int]
- -> Parser [Char] ParserState [[Block]]
+ -> ParserT [Char] ParserState m [[Block]]
gridTableRow blocks indices = do
colLines <- many1 (gridTableRawLine indices)
let cols = map ((++ "\n") . unlines . removeOneLeadingSpace) $
@@ -807,15 +825,16 @@ compactifyCell :: [Block] -> [Block]
compactifyCell bs = head $ compactify [bs]
-- | Parse footer for a grid table.
-gridTableFooter :: Parser [Char] ParserState [Char]
+gridTableFooter :: Stream s m Char => ParserT s ParserState m [Char]
gridTableFooter = blanklines
---
-- | Parse a string with a given parser and state.
-readWith :: Parser [Char] st a -- ^ parser
+readWith :: (Show s, Stream s Identity Char)
+ => ParserT s st Identity a -- ^ parser
-> st -- ^ initial state
- -> [Char] -- ^ input
+ -> s -- ^ input
-> a
readWith parser state input =
case runParser parser state "source" input of
@@ -823,15 +842,16 @@ readWith parser state input =
let errPos = errorPos err'
errLine = sourceLine errPos
errColumn = sourceColumn errPos
- theline = (lines input ++ [""]) !! (errLine - 1)
+ theline = (lines (show input) ++ [""]) !! (errLine - 1)
in error $ "\nError at " ++ show err' ++ "\n" ++
theline ++ "\n" ++ replicate (errColumn - 1) ' ' ++
"^"
Right result -> result
-- | Parse a string with @parser@ (for testing).
-testStringWith :: (Show a) => Parser [Char] ParserState a
- -> String
+testStringWith :: (Show s, Show a, Stream s Identity Char)
+ => ParserT s ParserState Identity a
+ -> s
-> IO ()
testStringWith parser str = UTF8.putStrLn $ show $
readWith parser defaultParserState str
@@ -878,7 +898,7 @@ instance HasMeta ParserState where
class HasReaderOptions st where
extractReaderOptions :: st -> ReaderOptions
- getOption :: (ReaderOptions -> b) -> Parser s st b
+ getOption :: (Stream s m t) => (ReaderOptions -> b) -> ParserT s st m b
-- default
getOption f = (f . extractReaderOptions) `fmap` getState
@@ -946,19 +966,19 @@ defaultParserState =
stateWarnings = []}
-- | Succeed only if the extension is enabled.
-guardEnabled :: HasReaderOptions st => Extension -> Parser s st ()
+guardEnabled :: (Stream s m a, HasReaderOptions st) => Extension -> ParserT s st m ()
guardEnabled ext = getOption readerExtensions >>= guard . Set.member ext
-- | Succeed only if the extension is disabled.
-guardDisabled :: HasReaderOptions st => Extension -> Parser s st ()
+guardDisabled :: (Stream s m a, HasReaderOptions st) => Extension -> ParserT s st m ()
guardDisabled ext = getOption readerExtensions >>= guard . not . Set.member ext
-- | Update the position on which the last string ended.
-updateLastStrPos :: HasLastStrPosition st => Parser s st ()
+updateLastStrPos :: (Stream s m a, HasLastStrPosition st) => ParserT s st m ()
updateLastStrPos = getPosition >>= updateState . setLastStrPos
-- | Whether we are right after the end of a string.
-notAfterString :: HasLastStrPosition st => Parser s st Bool
+notAfterString :: (Stream s m a, HasLastStrPosition st) => ParserT s st m Bool
notAfterString = do
pos <- getPosition
st <- getState
@@ -998,8 +1018,8 @@ type SubstTable = M.Map Key Inlines
-- and the auto_identifers extension is set, generate a new
-- unique identifier, and update the list of identifiers
-- in state.
-registerHeader :: (HasReaderOptions st, HasHeaderMap st, HasIdentifierList st)
- => Attr -> Inlines -> Parser s st Attr
+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 `fmap` getState
exts <- getOption readerExtensions
@@ -1020,25 +1040,28 @@ registerHeader (ident,classes,kvs) header' = do
return (ident,classes,kvs)
-- | Fail unless we're in "smart typography" mode.
-failUnlessSmart :: HasReaderOptions st => Parser s st ()
+failUnlessSmart :: (Stream s m a, HasReaderOptions st) => ParserT s st m ()
failUnlessSmart = getOption readerSmart >>= guard
-smartPunctuation :: Parser [Char] ParserState Inlines
- -> Parser [Char] ParserState Inlines
+smartPunctuation :: Stream s m Char
+ => ParserT s ParserState m Inlines
+ -> ParserT s ParserState m Inlines
smartPunctuation inlineParser = do
failUnlessSmart
choice [ quoted inlineParser, apostrophe, dash, ellipses ]
-apostrophe :: Parser [Char] ParserState Inlines
+apostrophe :: Stream s m Char => ParserT s st m Inlines
apostrophe = (char '\'' <|> char '\8217') >> return (B.str "\x2019")
-quoted :: Parser [Char] ParserState Inlines
- -> Parser [Char] ParserState Inlines
+quoted :: Stream s m Char
+ => ParserT s ParserState m Inlines
+ -> ParserT s ParserState m Inlines
quoted inlineParser = doubleQuoted inlineParser <|> singleQuoted inlineParser
-withQuoteContext :: QuoteContext
- -> Parser [tok] ParserState a
- -> Parser [tok] ParserState a
+withQuoteContext :: Stream s m t
+ => QuoteContext
+ -> ParserT s ParserState m a
+ -> ParserT s ParserState m a
withQuoteContext context parser = do
oldState <- getState
let oldQuoteContext = stateQuoteContext oldState
@@ -1048,99 +1071,112 @@ withQuoteContext context parser = do
setState newState { stateQuoteContext = oldQuoteContext }
return result
-singleQuoted :: Parser [Char] ParserState Inlines
- -> Parser [Char] ParserState Inlines
+singleQuoted :: Stream s m Char
+ => ParserT s ParserState m Inlines
+ -> ParserT s ParserState m Inlines
singleQuoted inlineParser = try $ do
singleQuoteStart
withQuoteContext InSingleQuote $ many1Till inlineParser singleQuoteEnd >>=
return . B.singleQuoted . mconcat
-doubleQuoted :: Parser [Char] ParserState Inlines
- -> Parser [Char] ParserState Inlines
+doubleQuoted :: Stream s m Char
+ => ParserT s ParserState m Inlines
+ -> ParserT s ParserState m Inlines
doubleQuoted inlineParser = try $ do
doubleQuoteStart
withQuoteContext InDoubleQuote $ manyTill inlineParser doubleQuoteEnd >>=
return . B.doubleQuoted . mconcat
-failIfInQuoteContext :: QuoteContext -> Parser [tok] ParserState ()
+failIfInQuoteContext :: Stream s m t
+ => QuoteContext
+ -> ParserT s ParserState m ()
failIfInQuoteContext context = do
st <- getState
if stateQuoteContext st == context
then fail "already inside quotes"
else return ()
-charOrRef :: [Char] -> Parser [Char] st Char
+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 :: Parser [Char] ParserState ()
+singleQuoteStart :: Stream s m Char
+ => ParserT s ParserState m ()
singleQuoteStart = do
failIfInQuoteContext InSingleQuote
-- single quote start can't be right after str
guard =<< notAfterString
() <$ charOrRef "'\8216\145"
-singleQuoteEnd :: Parser [Char] st ()
+singleQuoteEnd :: Stream s m Char
+ => ParserT s st m ()
singleQuoteEnd = try $ do
charOrRef "'\8217\146"
notFollowedBy alphaNum
-doubleQuoteStart :: Parser [Char] ParserState ()
+doubleQuoteStart :: Stream s m Char
+ => ParserT s ParserState m ()
doubleQuoteStart = do
failIfInQuoteContext InDoubleQuote
try $ do charOrRef "\"\8220\147"
notFollowedBy . satisfy $ flip elem [' ', '\t', '\n']
-doubleQuoteEnd :: Parser [Char] st ()
-doubleQuoteEnd = do
- charOrRef "\"\8221\148"
- return ()
+doubleQuoteEnd :: Stream s m Char
+ => ParserT s st m ()
+doubleQuoteEnd = void (charOrRef "\"\8221\148")
-ellipses :: Parser [Char] st Inlines
+ellipses :: Stream s m Char
+ => ParserT s st m Inlines
ellipses = do
try (charOrRef "\8230\133") <|> try (string "..." >> return '…')
return (B.str "\8230")
-dash :: Parser [Char] ParserState Inlines
+dash :: Stream s m Char => ParserT s ParserState m Inlines
dash = do
oldDashes <- getOption readerOldDashes
if oldDashes
then emDashOld <|> enDashOld
- else B.str `fmap` (hyphenDash <|> emDash <|> enDash)
+ else B.str <$> (hyphenDash <|> emDash <|> enDash)
-- Two hyphens = en-dash, three = em-dash
-hyphenDash :: Parser [Char] st String
+hyphenDash :: Stream s m Char
+ => ParserT s st m String
hyphenDash = do
try $ string "--"
option "\8211" (char '-' >> return "\8212")
-emDash :: Parser [Char] st String
+emDash :: Stream s m Char
+ => ParserT s st m String
emDash = do
try (charOrRef "\8212\151")
return "\8212"
-enDash :: Parser [Char] st String
+enDash :: Stream s m Char
+ => ParserT s st m String
enDash = do
try (charOrRef "\8212\151")
return "\8211"
-enDashOld :: Parser [Char] st Inlines
+enDashOld :: Stream s m Char
+ => ParserT s st m Inlines
enDashOld = do
try (charOrRef "\8211\150") <|>
try (char '-' >> lookAhead (satisfy isDigit) >> return '–')
return (B.str "\8211")
-emDashOld :: Parser [Char] st Inlines
+emDashOld :: Stream s m Char
+ => ParserT s st m Inlines
emDashOld = do
try (charOrRef "\8212\151") <|> (try $ string "--" >> optional (char '-') >> return '-')
return (B.str "\8212")
-- This is used to prevent exponential blowups for things like:
-- a**a*a**a*a**a*a**a*a**a*a**a*a**
-nested :: Parser s ParserState a
- -> Parser s ParserState a
+nested :: Stream s m a
+ => ParserT s ParserState m a
+ -> ParserT s ParserState m a
nested p = do
nestlevel <- stateMaxNestingLevel `fmap` getState
guard $ nestlevel > 0
@@ -1149,7 +1185,8 @@ nested p = do
updateState $ \st -> st{ stateMaxNestingLevel = nestlevel }
return res
-citeKey :: HasLastStrPosition st => Parser [Char] st (Bool, String)
+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)
@@ -1166,7 +1203,8 @@ citeKey = try $ do
--
-- | Parse a \newcommand or \renewcommand macro definition.
-macro :: (HasMacros st, HasReaderOptions st) => Parser [Char] st Blocks
+macro :: (Stream [Char] m Char, HasMacros st, HasReaderOptions st)
+ => ParserT [Char] st m Blocks
macro = do
apply <- getOption readerApplyMacros
inp <- getInput
@@ -1181,7 +1219,9 @@ macro = do
else return $ rawBlock "latex" def'
-- | Apply current macros to string.
-applyMacros' :: String -> Parser [Char] ParserState String
+applyMacros' :: Stream [Char] m Char
+ => String
+ -> ParserT [Char] ParserState m String
applyMacros' target = do
apply <- getOption readerApplyMacros
if apply