From f201bdcb58743d10cc9dc357da6779fd29b531b5 Mon Sep 17 00:00:00 2001 From: Matthew Pickering Date: Fri, 11 Jul 2014 12:45:34 +0100 Subject: 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. --- src/Text/Pandoc/Parsing.hs | 296 +++++++++++++++++++++++++-------------------- 1 file changed, 168 insertions(+), 128 deletions(-) (limited to 'src/Text/Pandoc') 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 @@ -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 -- cgit v1.2.3 From 2fb8063f7869b43684796fb58d0ef08273fea0ba Mon Sep 17 00:00:00 2001 From: Matthew Pickering Date: Fri, 11 Jul 2014 12:51:26 +0100 Subject: Removed (>>~) function This function is equivalent to the more general (<*) which is defined in Control.Applicative. This change makes pandoc code easier to understand for those not familar with the codebase. --- src/Text/Pandoc/Parsing.hs | 13 ++++--------- src/Text/Pandoc/Readers/HTML.hs | 6 +++--- src/Text/Pandoc/Readers/LaTeX.hs | 2 +- src/Text/Pandoc/Readers/Markdown.hs | 8 ++++---- src/Text/Pandoc/Readers/MediaWiki.hs | 2 +- src/Text/Pandoc/Readers/RST.hs | 8 ++++---- 6 files changed, 17 insertions(+), 22 deletions(-) (limited to 'src/Text/Pandoc') diff --git a/src/Text/Pandoc/Parsing.hs b/src/Text/Pandoc/Parsing.hs index 7a3e2529d..d3e1d6fbd 100644 --- a/src/Text/Pandoc/Parsing.hs +++ b/src/Text/Pandoc/Parsing.hs @@ -32,8 +32,7 @@ Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA A utility library with parsers used in pandoc readers. -} -module Text.Pandoc.Parsing ( (>>~), - anyLine, +module Text.Pandoc.Parsing ( anyLine, many1Till, notFollowedBy', oneOfStrings, @@ -101,6 +100,7 @@ module Text.Pandoc.Parsing ( (>>~), macro, applyMacros', Parser, + ParserT, F(..), runF, askF, @@ -205,11 +205,6 @@ instance Monoid a => Monoid (F a) where mappend = liftM2 mappend mconcat = liftM mconcat . sequence --- | Like >>, but returns the operation on the left. --- (Suggested by Tillmann Rendel on Haskell-cafe list.) -(>>~) :: (Applicative m) => m a -> m b -> m a -a >>~ b = a <* b - -- | Parse any line of text anyLine :: Stream [Char] m Char => ParserT [Char] st m [Char] anyLine = do @@ -484,7 +479,7 @@ mathInlineWith op cl = try $ do 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) + many1Till (noneOf "\n" <|> (newline <* notFollowedBy' blankline)) (try $ string cl) mathDisplay :: Stream s m Char => ParserT s ParserState m String mathDisplay = @@ -759,7 +754,7 @@ gridPart ch = do 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 +gridDashedLines ch = try $ char '+' >> many1 (gridPart ch) <* blankline removeFinalBar :: String -> String removeFinalBar = diff --git a/src/Text/Pandoc/Readers/HTML.hs b/src/Text/Pandoc/Readers/HTML.hs index 381b67e18..cedbb8c9e 100644 --- a/src/Text/Pandoc/Readers/HTML.hs +++ b/src/Text/Pandoc/Readers/HTML.hs @@ -128,7 +128,7 @@ pBulletList = try $ do -- note: if they have an
    or
      not in scope of a
    • , -- treat it as a list item, though it's not valid xhtml... skipMany nonItem - items <- manyTill (pInTags "li" block >>~ skipMany nonItem) (pCloses "ul") + items <- manyTill (pInTags "li" block <* skipMany nonItem) (pCloses "ul") return $ B.bulletList $ map (fixPlains True) items pOrderedList :: TagParser Blocks @@ -156,7 +156,7 @@ pOrderedList = try $ do -- note: if they have an
        or
          not in scope of a
        • , -- treat it as a list item, though it's not valid xhtml... skipMany nonItem - items <- manyTill (pInTags "li" block >>~ skipMany nonItem) (pCloses "ol") + items <- manyTill (pInTags "li" block <* skipMany nonItem) (pCloses "ol") return $ B.orderedListWith (start, style, DefaultDelim) $ map (fixPlains True) items pDefinitionList :: TagParser Blocks @@ -244,7 +244,7 @@ pTable :: TagParser Blocks pTable = try $ do TagOpen _ _ <- pSatisfy (~== TagOpen "table" []) skipMany pBlank - caption <- option mempty $ pInTags "caption" inline >>~ skipMany pBlank + caption <- option mempty $ pInTags "caption" inline <* skipMany pBlank -- TODO actually read these and take width information from them widths' <- pColgroup <|> many pCol head' <- option [] $ pOptInTag "thead" $ pInTags "tr" (pCell "th") diff --git a/src/Text/Pandoc/Readers/LaTeX.hs b/src/Text/Pandoc/Readers/LaTeX.hs index 97bfaa455..339f8e3c9 100644 --- a/src/Text/Pandoc/Readers/LaTeX.hs +++ b/src/Text/Pandoc/Readers/LaTeX.hs @@ -104,7 +104,7 @@ dimenarg = try $ do sp :: LP () sp = skipMany1 $ satisfy (\c -> c == ' ' || c == '\t') - <|> (try $ newline >>~ lookAhead anyChar >>~ notFollowedBy blankline) + <|> (try $ newline <* lookAhead anyChar <* notFollowedBy blankline) isLowerHex :: Char -> Bool isLowerHex x = x >= '0' && x <= '9' || x >= 'a' && x <= 'f' diff --git a/src/Text/Pandoc/Readers/Markdown.hs b/src/Text/Pandoc/Readers/Markdown.hs index 5361158cc..7d19ee1e6 100644 --- a/src/Text/Pandoc/Readers/Markdown.hs +++ b/src/Text/Pandoc/Readers/Markdown.hs @@ -571,7 +571,7 @@ attributes :: MarkdownParser Attr attributes = try $ do char '{' spnl - attrs <- many (attribute >>~ spnl) + attrs <- many (attribute <* spnl) char '}' return $ foldl (\x f -> f x) nullAttr attrs @@ -688,7 +688,7 @@ birdTrackLine c = try $ do -- emailBlockQuoteStart :: MarkdownParser Char -emailBlockQuoteStart = try $ skipNonindentSpaces >> char '>' >>~ optional (char ' ') +emailBlockQuoteStart = try $ skipNonindentSpaces >> char '>' <* optional (char ' ') emailBlockQuote :: MarkdownParser [String] emailBlockQuote = try $ do @@ -1165,7 +1165,7 @@ gridPart ch = do return (length dashes, length dashes + 1) gridDashedLines :: Char -> Parser [Char] st [(Int,Int)] -gridDashedLines ch = try $ char '+' >> many1 (gridPart ch) >>~ blankline +gridDashedLines ch = try $ char '+' >> many1 (gridPart ch) <* blankline removeFinalBar :: String -> String removeFinalBar = @@ -1499,7 +1499,7 @@ inlinesBetween :: (Show b) inlinesBetween start end = (trimInlinesF . mconcat) <$> try (start >> many1Till inner end) where inner = innerSpace <|> (notFollowedBy' (() <$ whitespace) >> inline) - innerSpace = try $ whitespace >>~ notFollowedBy' end + innerSpace = try $ whitespace <* notFollowedBy' end strikeout :: MarkdownParser (F Inlines) strikeout = fmap B.strikeout <$> diff --git a/src/Text/Pandoc/Readers/MediaWiki.hs b/src/Text/Pandoc/Readers/MediaWiki.hs index f1dcce8f7..719bde160 100644 --- a/src/Text/Pandoc/Readers/MediaWiki.hs +++ b/src/Text/Pandoc/Readers/MediaWiki.hs @@ -634,7 +634,7 @@ inlinesBetween :: (Show b) => MWParser a -> MWParser b -> MWParser Inlines inlinesBetween start end = (trimInlines . mconcat) <$> try (start >> many1Till inner end) where inner = innerSpace <|> (notFollowedBy' (() <$ whitespace) >> inline) - innerSpace = try $ whitespace >>~ notFollowedBy' end + innerSpace = try $ whitespace <* notFollowedBy' end emph :: MWParser Inlines emph = B.emph <$> nested (inlinesBetween start end) diff --git a/src/Text/Pandoc/Readers/RST.hs b/src/Text/Pandoc/Readers/RST.hs index fa8438e70..b7bc83e86 100644 --- a/src/Text/Pandoc/Readers/RST.hs +++ b/src/Text/Pandoc/Readers/RST.hs @@ -460,7 +460,7 @@ listItem :: RSTParser Int listItem start = try $ do (markerLength, first) <- rawListItem start rest <- many (listContinuation markerLength) - blanks <- choice [ try (many blankline >>~ lookAhead start), + blanks <- choice [ try (many blankline <* lookAhead start), many1 blankline ] -- whole list must end with blank. -- parsing with ListItemState forces markers at beginning of lines to -- count as list item markers, even if not separated by blank space. @@ -480,7 +480,7 @@ listItem start = try $ do orderedList :: RSTParser Blocks orderedList = try $ do - (start, style, delim) <- lookAhead (anyOrderedListMarker >>~ spaceChar) + (start, style, delim) <- lookAhead (anyOrderedListMarker <* spaceChar) items <- many1 (listItem (orderedListStart style delim)) let items' = compactify' items return $ B.orderedListWith (start, style, delim) items' @@ -747,7 +747,7 @@ simpleReferenceName = do referenceName :: RSTParser Inlines referenceName = quotedReferenceName <|> - (try $ simpleReferenceName >>~ lookAhead (char ':')) <|> + (try $ simpleReferenceName <* lookAhead (char ':')) <|> unquotedReferenceName referenceKey :: RSTParser [Char] @@ -1076,7 +1076,7 @@ explicitLink = try $ do referenceLink :: RSTParser Inlines referenceLink = try $ do - (label',ref) <- withRaw (quotedReferenceName <|> simpleReferenceName) >>~ + (label',ref) <- withRaw (quotedReferenceName <|> simpleReferenceName) <* char '_' state <- getState let keyTable = stateKeys state -- cgit v1.2.3 From 72fe742ca014f42c7e45e8046ceeea3c0ab2cd9a Mon Sep 17 00:00:00 2001 From: Matthew Pickering Date: Fri, 11 Jul 2014 12:53:31 +0100 Subject: Removed inline fmap from Parsing.hs Replaced all inline occurences of fmap with the more idiomatic (<$>). --- src/Text/Pandoc/Parsing.hs | 16 ++++++++-------- 1 file changed, 8 insertions(+), 8 deletions(-) (limited to 'src/Text/Pandoc') diff --git a/src/Text/Pandoc/Parsing.hs b/src/Text/Pandoc/Parsing.hs index d3e1d6fbd..d4d5295c0 100644 --- a/src/Text/Pandoc/Parsing.hs +++ b/src/Text/Pandoc/Parsing.hs @@ -248,7 +248,7 @@ oneOfStrings' matches strs = try $ do let strs' = [xs | (x:xs) <- strs, x `matches` c] case strs' of [] -> fail "not found" - _ -> (c:) `fmap` oneOfStrings' matches strs' + _ -> (c:) <$> oneOfStrings' matches strs' <|> if "" `elem` strs' then return [c] else fail "not found" @@ -389,8 +389,8 @@ 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) - domain = intercalate "." `fmap` (subdomain `sepby1` dot) + mailbox = intercalate "." <$> (emailWord `sepby1` dot) + domain = intercalate "." <$> (subdomain `sepby1` dot) dot = char '.' subdomain = many1 $ alphaNum <|> innerPunct innerPunct = try (satisfy (\c -> isEmailPunct c || c == '@') <* @@ -453,7 +453,7 @@ uri = try $ do <|> entity <|> (try $ punct >> lookAhead (void (satisfy isWordChar) <|> percentEscaped)) - str <- snd `fmap` withRaw (skipMany1 ( () <$ + str <- snd <$> withRaw (skipMany1 ( () <$ (enclosed (char '(') (char ')') uriChunk <|> enclosed (char '{') (char '}') uriChunk <|> enclosed (char '[') (char ']') uriChunk) @@ -895,7 +895,7 @@ class HasReaderOptions st where extractReaderOptions :: st -> ReaderOptions getOption :: (Stream s m t) => (ReaderOptions -> b) -> ParserT s st m b -- default - getOption f = (f . extractReaderOptions) `fmap` getState + getOption f = (f . extractReaderOptions) <$> getState instance HasReaderOptions ParserState where extractReaderOptions = stateOptions @@ -1016,7 +1016,7 @@ 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 `fmap` getState + ids <- extractIdentifierList <$> getState exts <- getOption readerExtensions let insert' = M.insertWith (\_new old -> old) if null ident && Ext_auto_identifiers `Set.member` exts @@ -1173,7 +1173,7 @@ nested :: Stream s m a => ParserT s ParserState m a -> ParserT s ParserState m a nested p = do - nestlevel <- stateMaxNestingLevel `fmap` getState + nestlevel <- stateMaxNestingLevel <$> getState guard $ nestlevel > 0 updateState $ \st -> st{ stateMaxNestingLevel = stateMaxNestingLevel st - 1 } res <- p @@ -1220,6 +1220,6 @@ applyMacros' :: Stream [Char] m Char applyMacros' target = do apply <- getOption readerApplyMacros if apply - then do macros <- extractMacros `fmap` getState + then do macros <- extractMacros <$> getState return $ applyMacros macros target else return target -- cgit v1.2.3