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.
This commit is contained in:
Matthew Pickering
parent
05a5b4e3c2
commit
f201bdcb58
1 changed files with 168 additions and 128 deletions
|
|
@ -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
|
||||
|
|
|
|||
Loading…
Add table
Reference in a new issue