diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,3 +1,8 @@ +## Megaparsec 6.5.0 + +* Added `Text.Megaparsec.Internal`, which exposes some internal data + structures and data constructor of `ParsecT`. + ## Megaparsec 6.4.1 * `scientific` now correctly backtracks after attempting to parse fractional diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -5,7 +5,6 @@ [![Stackage Nightly](http://stackage.org/package/megaparsec/badge/nightly)](http://stackage.org/nightly/package/megaparsec) [![Stackage LTS](http://stackage.org/package/megaparsec/badge/lts)](http://stackage.org/lts/package/megaparsec) [![Build Status](https://travis-ci.org/mrkkrp/megaparsec.svg?branch=master)](https://travis-ci.org/mrkkrp/megaparsec) -[![Coverage Status](https://coveralls.io/repos/mrkkrp/megaparsec/badge.svg?branch=master&service=github)](https://coveralls.io/github/mrkkrp/megaparsec?branch=master) * [Features](#features) * [Core features](#core-features) diff --git a/Text/Megaparsec.hs b/Text/Megaparsec.hs --- a/Text/Megaparsec.hs +++ b/Text/Megaparsec.hs @@ -54,1265 +54,248 @@ -- modules should be imported explicitly along with the modules mentioned -- above. -{-# LANGUAGE BangPatterns #-} -{-# LANGUAGE CPP #-} -{-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE FunctionalDependencies #-} -{-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TupleSections #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE UndecidableInstances #-} - -module Text.Megaparsec - ( -- * Re-exports - -- $reexports - module Text.Megaparsec.Pos - , module Text.Megaparsec.Error - , module Text.Megaparsec.Stream - , module Control.Monad.Combinators - -- * Data types - , State (..) - , Parsec - , ParsecT - -- * Running parser - , parse - , parseMaybe - , parseTest - , parseTest' - , runParser - , runParser' - , runParserT - , runParserT' - -- * Primitive combinators - , MonadParsec (..) - -- * Derivatives of primitive combinators - , () - , unexpected - , customFailure - , match - , region - , takeRest - , atEnd - -- * Parser state combinators - , getInput - , setInput - , getPosition - , getNextTokenPosition - , setPosition - , pushPosition - , popPosition - , getTokensProcessed - , setTokensProcessed - , getTabWidth - , setTabWidth - , setParserState - -- * Debugging - , dbg ) -where - -import Control.DeepSeq -import Control.Monad -import Control.Monad.Combinators -import Control.Monad.Cont.Class -import Control.Monad.Error.Class -import Control.Monad.Identity -import Control.Monad.Reader.Class -import Control.Monad.State.Class hiding (state) -import Control.Monad.Trans -import Data.Data (Data) -import Data.List.NonEmpty (NonEmpty (..)) -import Data.Maybe (fromJust) -import Data.Proxy -import Data.Semigroup hiding (option) -import Data.Set (Set) -import Data.String (IsString (..)) -import Data.Typeable (Typeable) -import Debug.Trace -import GHC.Generics -import Text.Megaparsec.Error -import Text.Megaparsec.Pos -import Text.Megaparsec.Stream -import qualified Control.Applicative as A -import qualified Control.Monad.Fail as Fail -import qualified Control.Monad.RWS.Lazy as L -import qualified Control.Monad.RWS.Strict as S -import qualified Control.Monad.Trans.Reader as L -import qualified Control.Monad.Trans.State.Lazy as L -import qualified Control.Monad.Trans.State.Strict as S -import qualified Control.Monad.Trans.Writer.Lazy as L -import qualified Control.Monad.Trans.Writer.Strict as S -import qualified Data.List.NonEmpty as NE -import qualified Data.Set as E - -#if !MIN_VERSION_base(4,8,0) -import Control.Applicative -#endif - -#if !MIN_VERSION_mtl(2,2,2) -import Control.Monad.Trans.Identity -#endif - --- $reexports --- --- Also note that you can import "Control.Monad.Combinators.NonEmpty" if you --- wish that combinators like 'some' return 'NonEmpty' lists. The module --- lives in the @parser-combinators@ package (you need at least version --- /0.4.0/). --- --- This module is intended to be imported qualified: --- --- > import qualified Control.Monad.Combinators.NonEmpty as NE - ----------------------------------------------------------------------------- --- Data types - --- | This is the Megaparsec's state parametrized over stream type @s@. - -data State s = State - { stateInput :: s - -- ^ The rest of input to process - , statePos :: NonEmpty SourcePos - -- ^ Current position (column + line number) with support for include files - , stateTokensProcessed :: {-# UNPACK #-} !Int - -- ^ Number of processed tokens so far - -- - -- @since 5.2.0 - , stateTabWidth :: Pos - -- ^ Tab width to use - } deriving (Show, Eq, Data, Typeable, Generic) - -instance NFData s => NFData (State s) - --- | All information available after parsing. This includes consumption of --- input, success (with returned value) or failure (with parse error), and --- parser state at the end of parsing. --- --- See also: 'Consumption', 'Result'. - -data Reply e s a = Reply (State s) Consumption (Result (Token s) e a) - --- | This data structure represents an aspect of result of parser's work. --- --- See also: 'Result', 'Reply'. - -data Consumption - = Consumed -- ^ Some part of input stream was consumed - | Virgin -- ^ No input was consumed - --- | This data structure represents an aspect of result of parser's work. --- --- See also: 'Consumption', 'Reply'. - -data Result t e a - = OK a -- ^ Parser succeeded - | Error (ParseError t e) -- ^ Parser failed - --- | 'Hints' represent a collection of 'ErrorItem's to be included into --- 'ParserError' (when it's a 'TrivialError') as “expected” message items --- when a parser fails without consuming input right after successful parser --- that produced the hints. --- --- For example, without hints you could get: --- --- >>> parseTest (many (char 'r') <* eof) "ra" --- 1:2: --- unexpected 'a' --- expecting end of input --- --- We're getting better error messages with help of hints: --- --- >>> parseTest (many (char 'r') <* eof) "ra" --- 1:2: --- unexpected 'a' --- expecting 'r' or end of input - -newtype Hints t = Hints [Set (ErrorItem t)] - deriving (Semigroup, Monoid) - --- | Convert 'ParseError' record into 'Hints'. - -toHints :: NonEmpty SourcePos -> ParseError t e -> Hints t -toHints streamPos = \case - TrivialError errPos _ ps -> - -- NOTE This is important to check here that the error indeed has - -- happened at the same position as current position of stream because - -- there might have been backtracking with 'try' and in that case we - -- must not convert such a parse error to hints. - if streamPos == errPos - then Hints (if E.null ps then [] else [ps]) - else mempty - FancyError _ _ -> mempty -{-# INLINE toHints #-} - --- | @withHints hs c@ makes “error” continuation @c@ use given hints @hs@. --- --- Note that if resulting continuation gets 'ParseError' that has custom --- data in it, hints are ignored. - -withHints :: Ord (Token s) - => Hints (Token s) -- ^ Hints to use - -> (ParseError (Token s) e -> State s -> m b) -- ^ Continuation to influence - -> ParseError (Token s) e -- ^ First argument of resulting continuation - -> State s -- ^ Second argument of resulting continuation - -> m b -withHints (Hints ps') c e = - case e of - TrivialError pos us ps -> c (TrivialError pos us (E.unions (ps : ps'))) - _ -> c e -{-# INLINE withHints #-} - --- | @accHints hs c@ results in “OK” continuation that will add given hints --- @hs@ to third argument of original continuation @c@. - -accHints - :: Hints t -- ^ 'Hints' to add - -> (a -> State s -> Hints t -> m b) -- ^ An “OK” continuation to alter - -> a -- ^ First argument of resulting continuation - -> State s -- ^ Second argument of resulting continuation - -> Hints t -- ^ Third argument of resulting continuation - -> m b -accHints hs1 c x s hs2 = c x s (hs1 <> hs2) -{-# INLINE accHints #-} - --- | Replace the most recent group of hints (if any) with the given --- 'ErrorItem' (or delete it if 'Nothing' is given). This is used in 'label' --- primitive. - -refreshLastHint :: Hints t -> Maybe (ErrorItem t) -> Hints t -refreshLastHint (Hints []) _ = Hints [] -refreshLastHint (Hints (_:xs)) Nothing = Hints xs -refreshLastHint (Hints (_:xs)) (Just m) = Hints (E.singleton m : xs) -{-# INLINE refreshLastHint #-} - --- | 'Parsec' is a non-transformer variant of the more general 'ParsecT' --- monad transformer. - -type Parsec e s = ParsecT e s Identity - --- | @'ParsecT' e s m a@ is a parser with custom data component of error --- @e@, stream type @s@, underlying monad @m@ and return type @a@. - -newtype ParsecT e s m a = ParsecT - { unParser - :: forall b. State s - -> (a -> State s -> Hints (Token s) -> m b) -- consumed-OK - -> (ParseError (Token s) e -> State s -> m b) -- consumed-error - -> (a -> State s -> Hints (Token s) -> m b) -- empty-OK - -> (ParseError (Token s) e -> State s -> m b) -- empty-error - -> m b } - --- | @since 5.3.0 - -instance (Stream s, Semigroup a) => Semigroup (ParsecT e s m a) where - (<>) = A.liftA2 (<>) - {-# INLINE (<>) #-} -#if MIN_VERSION_base(4,8,0) - sconcat = fmap sconcat . sequence -#else - sconcat = fmap (sconcat . NE.fromList) . sequence . NE.toList -#endif - {-# INLINE sconcat #-} - --- | @since 5.3.0 - -instance (Stream s, Monoid a) => Monoid (ParsecT e s m a) where - mempty = pure mempty - {-# INLINE mempty #-} - mappend = A.liftA2 mappend - {-# INLINE mappend #-} - mconcat = fmap mconcat . sequence - {-# INLINE mconcat #-} - --- | @since 6.3.0 - -instance (a ~ Tokens s, IsString a, Eq a, Stream s, Ord e) - => IsString (ParsecT e s m a) where - fromString s = tokens (==) (fromString s) - -instance Functor (ParsecT e s m) where - fmap = pMap - -pMap :: (a -> b) -> ParsecT e s m a -> ParsecT e s m b -pMap f p = ParsecT $ \s cok cerr eok eerr -> - unParser p s (cok . f) cerr (eok . f) eerr -{-# INLINE pMap #-} - --- | 'pure' returns a parser that __succeeds__ without consuming input. - -instance Stream s => A.Applicative (ParsecT e s m) where - pure = pPure - (<*>) = pAp - p1 *> p2 = p1 `pBind` const p2 - p1 <* p2 = do { x1 <- p1 ; void p2 ; return x1 } - -pAp :: Stream s - => ParsecT e s m (a -> b) - -> ParsecT e s m a - -> ParsecT e s m b -pAp m k = ParsecT $ \s cok cerr eok eerr -> - let mcok x s' hs = unParser k s' (cok . x) cerr - (accHints hs (cok . x)) (withHints hs cerr) - meok x s' hs = unParser k s' (cok . x) cerr - (accHints hs (eok . x)) (withHints hs eerr) - in unParser m s mcok cerr meok eerr -{-# INLINE pAp #-} - --- | 'A.empty' is a parser that __fails__ without consuming input. - -instance (Ord e, Stream s) => A.Alternative (ParsecT e s m) where - empty = mzero - (<|>) = mplus - --- | 'return' returns a parser that __succeeds__ without consuming input. - -instance Stream s => Monad (ParsecT e s m) where - return = pure - (>>=) = pBind - fail = Fail.fail - -pPure :: a -> ParsecT e s m a -pPure x = ParsecT $ \s _ _ eok _ -> eok x s mempty -{-# INLINE pPure #-} - -pBind :: Stream s - => ParsecT e s m a - -> (a -> ParsecT e s m b) - -> ParsecT e s m b -pBind m k = ParsecT $ \s cok cerr eok eerr -> - let mcok x s' hs = unParser (k x) s' cok cerr - (accHints hs cok) (withHints hs cerr) - meok x s' hs = unParser (k x) s' cok cerr - (accHints hs eok) (withHints hs eerr) - in unParser m s mcok cerr meok eerr -{-# INLINE pBind #-} - -instance Stream s => Fail.MonadFail (ParsecT e s m) where - fail = pFail - -pFail :: String -> ParsecT e s m a -pFail msg = ParsecT $ \s@(State _ pos _ _) _ _ _ eerr -> - let d = E.singleton (ErrorFail msg) - in eerr (FancyError pos d) s -{-# INLINE pFail #-} - -mkPT :: Monad m => (State s -> m (Reply e s a)) -> ParsecT e s m a -mkPT k = ParsecT $ \s cok cerr eok eerr -> do - (Reply s' consumption result) <- k s - case consumption of - Consumed -> - case result of - OK x -> cok x s' mempty - Error e -> cerr e s' - Virgin -> - case result of - OK x -> eok x s' mempty - Error e -> eerr e s' - -instance (Stream s, MonadIO m) => MonadIO (ParsecT e s m) where - liftIO = lift . liftIO - -instance (Stream s, MonadReader r m) => MonadReader r (ParsecT e s m) where - ask = lift ask - local f p = mkPT $ \s -> local f (runParsecT p s) - -instance (Stream s, MonadState st m) => MonadState st (ParsecT e s m) where - get = lift get - put = lift . put - -instance (Stream s, MonadCont m) => MonadCont (ParsecT e s m) where - callCC f = mkPT $ \s -> - callCC $ \c -> - runParsecT (f (\a -> mkPT $ \s' -> c (pack s' a))) s - where pack s a = Reply s Virgin (OK a) - -instance (Stream s, MonadError e' m) => MonadError e' (ParsecT e s m) where - throwError = lift . throwError - p `catchError` h = mkPT $ \s -> - runParsecT p s `catchError` \e -> - runParsecT (h e) s - --- | 'mzero' is a parser that __fails__ without consuming input. - -instance (Ord e, Stream s) => MonadPlus (ParsecT e s m) where - mzero = pZero - mplus = pPlus - -pZero :: ParsecT e s m a -pZero = ParsecT $ \s@(State _ pos _ _) _ _ _ eerr -> - eerr (TrivialError pos Nothing E.empty) s -{-# INLINE pZero #-} - -pPlus :: (Ord e, Stream s) - => ParsecT e s m a - -> ParsecT e s m a - -> ParsecT e s m a -pPlus m n = ParsecT $ \s cok cerr eok eerr -> - let meerr err ms = - let ncerr err' s' = cerr (err' <> err) (longestMatch ms s') - neok x s' hs = eok x s' (toHints (statePos s') err <> hs) - neerr err' s' = eerr (err' <> err) (longestMatch ms s') - in unParser n s cok ncerr neok neerr - in unParser m s cok cerr eok meerr -{-# INLINE pPlus #-} - --- | @since 6.0.0 - -instance (Stream s, MonadFix m) => MonadFix (ParsecT e s m) where - mfix f = mkPT $ \s -> mfix $ \(~(Reply _ _ result)) -> do - let - a = case result of - OK a' -> a' - Error _ -> error "mfix ParsecT" - runParsecT (f a) s - --- | From two states, return the one with the greater number of processed --- tokens. If the numbers of processed tokens are equal, prefer the second --- state. - -longestMatch :: State s -> State s -> State s -longestMatch s1@(State _ _ tp1 _) s2@(State _ _ tp2 _) = - case tp1 `compare` tp2 of - LT -> s2 - EQ -> s2 - GT -> s1 -{-# INLINE longestMatch #-} - -instance MonadTrans (ParsecT e s) where - lift amb = ParsecT $ \s _ _ eok _ -> - amb >>= \a -> eok a s mempty - ----------------------------------------------------------------------------- --- Running a parser - --- | @'parse' p file input@ runs parser @p@ over 'Identity' (see 'runParserT' --- if you're using the 'ParsecT' monad transformer; 'parse' itself is just a --- synonym for 'runParser'). It returns either a 'ParseError' ('Left') or a --- value of type @a@ ('Right'). 'parseErrorPretty' can be used to turn --- 'ParseError' into the string representation of the error message. See --- "Text.Megaparsec.Error" if you need to do more advanced error analysis. --- --- > main = case (parse numbers "" "11,2,43") of --- > Left err -> putStr (parseErrorPretty err) --- > Right xs -> print (sum xs) --- > --- > numbers = integer `sepBy` char ',' - -parse - :: Parsec e s a -- ^ Parser to run - -> String -- ^ Name of source file - -> s -- ^ Input for parser - -> Either (ParseError (Token s) e) a -parse = runParser - --- | @'parseMaybe' p input@ runs the parser @p@ on @input@ and returns the --- result inside 'Just' on success and 'Nothing' on failure. This function --- also parses 'eof', so if the parser doesn't consume all of its input, it --- will fail. --- --- The function is supposed to be useful for lightweight parsing, where --- error messages (and thus file name) are not important and entire input --- should be parsed. For example, it can be used when parsing of a single --- number according to a specification of its format is desired. - -parseMaybe :: (Ord e, Stream s) => Parsec e s a -> s -> Maybe a -parseMaybe p s = - case parse (p <* eof) "" s of - Left _ -> Nothing - Right x -> Just x - --- | The expression @'parseTest' p input@ applies the parser @p@ against --- input @input@ and prints the result to stdout. Useful for testing. - -parseTest :: ( ShowErrorComponent e - , Ord (Token s) - , ShowToken (Token s) - , Show a ) - => Parsec e s a -- ^ Parser to run - -> s -- ^ Input for parser - -> IO () -parseTest p input = - case parse p "" input of - Left e -> putStr (parseErrorPretty e) - Right x -> print x - --- | A version of 'parseTest' that also prints offending line in parse --- errors. --- --- @since 6.0.0 - -parseTest' :: ( ShowErrorComponent e - , ShowToken (Token s) - , LineToken (Token s) - , Show a - , Stream s ) - => Parsec e s a -- ^ Parser to run - -> s -- ^ Input for parser - -> IO () -parseTest' p input = - case parse p "" input of - Left e -> putStr (parseErrorPretty' input e) - Right x -> print x - --- | @'runParser' p file input@ runs parser @p@ on the input stream of --- tokens @input@, obtained from source @file@. The @file@ is only used in --- error messages and may be the empty string. Returns either a 'ParseError' --- ('Left') or a value of type @a@ ('Right'). --- --- > parseFromFile p file = runParser p file <$> readFile file - -runParser - :: Parsec e s a -- ^ Parser to run - -> String -- ^ Name of source file - -> s -- ^ Input for parser - -> Either (ParseError (Token s) e) a -runParser p name s = snd $ runParser' p (initialState name s) - --- | The function is similar to 'runParser' with the difference that it --- accepts and returns parser state. This allows to specify arbitrary --- textual position at the beginning of parsing, for example. This is the --- most general way to run a parser over the 'Identity' monad. --- --- @since 4.2.0 - -runParser' - :: Parsec e s a -- ^ Parser to run - -> State s -- ^ Initial state - -> (State s, Either (ParseError (Token s) e) a) -runParser' p = runIdentity . runParserT' p - --- | @'runParserT' p file input@ runs parser @p@ on the input list of tokens --- @input@, obtained from source @file@. The @file@ is only used in error --- messages and may be the empty string. Returns a computation in the --- underlying monad @m@ that returns either a 'ParseError' ('Left') or a --- value of type @a@ ('Right'). - -runParserT :: Monad m - => ParsecT e s m a -- ^ Parser to run - -> String -- ^ Name of source file - -> s -- ^ Input for parser - -> m (Either (ParseError (Token s) e) a) -runParserT p name s = snd `liftM` runParserT' p (initialState name s) - --- | This function is similar to 'runParserT', but like 'runParser'' it --- accepts and returns parser state. This is thus the most general way to --- run a parser. --- --- @since 4.2.0 - -runParserT' :: Monad m - => ParsecT e s m a -- ^ Parser to run - -> State s -- ^ Initial state - -> m (State s, Either (ParseError (Token s) e) a) -runParserT' p s = do - (Reply s' _ result) <- runParsecT p s - case result of - OK x -> return (s', Right x) - Error e -> return (s', Left e) - --- | Low-level unpacking of the 'ParsecT' type. 'runParserT' and 'runParser' --- are built upon this. - -runParsecT :: Monad m - => ParsecT e s m a -- ^ Parser to run - -> State s -- ^ Initial state - -> m (Reply e s a) -runParsecT p s = unParser p s cok cerr eok eerr - where cok a s' _ = return $ Reply s' Consumed (OK a) - cerr err s' = return $ Reply s' Consumed (Error err) - eok a s' _ = return $ Reply s' Virgin (OK a) - eerr err s' = return $ Reply s' Virgin (Error err) - --- | Given name of source file and input construct initial state for parser. - -initialState :: String -> s -> State s -initialState name s = State - { stateInput = s - , statePos = initialPos name :| [] - , stateTokensProcessed = 0 - , stateTabWidth = defaultTabWidth } - ----------------------------------------------------------------------------- --- Primitive combinators - --- | Type class describing monads that implement the full set of primitive --- parsers. --- --- __Note carefully__ that the following primitives are “fast” and should be --- taken advantage of as much as possible if your aim is a fast parser: --- 'tokens', 'takeWhileP', 'takeWhile1P', and 'takeP'. - -class (Stream s, A.Alternative m, MonadPlus m) - => MonadParsec e s m | m -> e s where - - -- | The most general way to stop parsing and report a trivial - -- 'ParseError'. - -- - -- @since 6.0.0 - - failure - :: Maybe (ErrorItem (Token s)) -- ^ Unexpected item (if any) - -> Set (ErrorItem (Token s)) -- ^ Expected items - -> m a - - -- | The most general way to stop parsing and report a fancy 'ParseError'. - -- To report a single custom parse error, see 'customFailure'. - -- - -- @since 6.0.0 - - fancyFailure - :: Set (ErrorFancy e) -- ^ Fancy error components - -> m a - - -- | The parser @'label' name p@ behaves as parser @p@, but whenever the - -- parser @p@ fails /without consuming any input/, it replaces names of - -- “expected” tokens with the name @name@. - - label :: String -> m a -> m a - - -- | @'hidden' p@ behaves just like parser @p@, but it doesn't show any - -- “expected” tokens in error message when @p@ fails. - -- - -- Please use 'hidden' instead of the old @'label' ""@ idiom. - - hidden :: m a -> m a - hidden = label "" - - -- | The parser @'try' p@ behaves like parser @p@, except that it - -- backtracks the parser state when @p@ fails (either consuming input or - -- not). - -- - -- This combinator is used whenever arbitrary look ahead is needed. Since - -- it pretends that it hasn't consumed any input when @p@ fails, the - -- ('A.<|>') combinator will try its second alternative even if the first - -- parser failed while consuming input. - -- - -- For example, here is a parser that is supposed to parse the word “let” - -- or the word “lexical”: - -- - -- >>> parseTest (string "let" <|> string "lexical") "lexical" - -- 1:1: - -- unexpected "lex" - -- expecting "let" - -- - -- What happens here? The first parser consumes “le” and fails (because it - -- doesn't see a “t”). The second parser, however, isn't tried, since the - -- first parser has already consumed some input! 'try' fixes this behavior - -- and allows backtracking to work: - -- - -- >>> parseTest (try (string "let") <|> string "lexical") "lexical" - -- "lexical" - -- - -- 'try' also improves error messages in case of overlapping alternatives, - -- because Megaparsec's hint system can be used: - -- - -- >>> parseTest (try (string "let") <|> string "lexical") "le" - -- 1:1: - -- unexpected "le" - -- expecting "let" or "lexical" - -- - -- __Please note__ that as of Megaparsec 4.4.0, 'string' backtracks - -- automatically (see 'tokens'), so it does not need 'try'. However, the - -- examples above demonstrate the idea behind 'try' so well that it was - -- decided to keep them. You still need to use 'try' when your - -- alternatives are complex, composite parsers. - - try :: m a -> m a - - -- | If @p@ in @'lookAhead' p@ succeeds (either consuming input or not) - -- the whole parser behaves like @p@ succeeded without consuming anything - -- (parser state is not updated as well). If @p@ fails, 'lookAhead' has no - -- effect, i.e. it will fail consuming input if @p@ fails consuming input. - -- Combine with 'try' if this is undesirable. - - lookAhead :: m a -> m a - - -- | @'notFollowedBy' p@ only succeeds when the parser @p@ fails. This - -- parser /never consumes/ any input and /never modifies/ parser state. It - -- can be used to implement the “longest match” rule. - - notFollowedBy :: m a -> m () - - -- | @'withRecovery' r p@ allows continue parsing even if parser @p@ - -- fails. In this case @r@ is called with the actual 'ParseError' as its - -- argument. Typical usage is to return a value signifying failure to - -- parse this particular object and to consume some part of the input up - -- to the point where the next object starts. - -- - -- Note that if @r@ fails, original error message is reported as if - -- without 'withRecovery'. In no way recovering parser @r@ can influence - -- error messages. - -- - -- @since 4.4.0 - - withRecovery - :: (ParseError (Token s) e -> m a) -- ^ How to recover from failure - -> m a -- ^ Original parser - -> m a -- ^ Parser that can recover from failures - - -- | @'observing' p@ allows to “observe” failure of the @p@ parser, should - -- it happen, without actually ending parsing, but instead getting the - -- 'ParseError' in 'Left'. On success parsed value is returned in 'Right' - -- as usual. Note that this primitive just allows you to observe parse - -- errors as they happen, it does not backtrack or change how the @p@ - -- parser works in any way. - -- - -- @since 5.1.0 - - observing - :: m a -- ^ The parser to run - -> m (Either (ParseError (Token s) e) a) - - -- | This parser only succeeds at the end of the input. - - eof :: m () - - -- | The parser @'token' test mrep@ accepts a token @t@ with result @x@ - -- when the function @test t@ returns @'Right' x@. @mrep@ may provide - -- representation of the token to report in error messages when input - -- stream in empty. - -- - -- This is the most primitive combinator for accepting tokens. For - -- example, the 'Text.Megaparsec.Char.satisfy' parser is implemented as: - -- - -- > satisfy f = token testChar Nothing - -- > where - -- > testChar x = - -- > if f x - -- > then Right x - -- > else Left (pure (Tokens (x:|[])), Set.empty) - - token - :: (Token s -> Either ( Maybe (ErrorItem (Token s)) - , Set (ErrorItem (Token s)) ) a) - -- ^ Matching function for the token to parse, it allows to construct - -- arbitrary error message on failure as well; things in the tuple - -- are: unexpected item (if any) and expected items - -> Maybe (Token s) -- ^ Token to report when input stream is empty - -> m a - - -- | The parser @'tokens' test@ parses a chunk of input and returns it. - -- Supplied predicate @test@ is used to check equality of given and parsed - -- chunks after a candidate chunk of correct length is fetched from the - -- stream. - -- - -- This can be used for example to write 'Text.Megaparsec.Char.string': - -- - -- > string = tokens (==) - -- - -- Note that beginning from Megaparsec 4.4.0, this is an auto-backtracking - -- primitive, which means that if it fails, it never consumes any input. - -- This is done to make its consumption model match how error messages for - -- this primitive are reported (which becomes an important thing as user - -- gets more control with primitives like 'withRecovery'): - -- - -- >>> parseTest (string "abc") "abd" - -- 1:1: - -- unexpected "abd" - -- expecting "abc" - -- - -- This means, in particular, that it's no longer necessary to use 'try' - -- with 'tokens'-based parsers, such as 'Text.Megaparsec.Char.string' and - -- 'Text.Megaparsec.Char.string''. This feature /does not/ affect - -- performance in any way. - - tokens - :: (Tokens s -> Tokens s -> Bool) - -- ^ Predicate to check equality of chunks - -> Tokens s - -- ^ Chunk of input to match against - -> m (Tokens s) - - -- | Parse /zero/ or more tokens for which the supplied predicate holds. - -- Try to use this as much as possible because for many streams the - -- combinator is much faster than parsers built with 'many' and - -- 'Text.Megaparsec.Char.satisfy'. - -- - -- The following equations should clarify the behavior: - -- - -- > takeWhileP (Just "foo") f = many (satisfy f "foo") - -- > takeWhileP Nothing f = many (satisfy f) - -- - -- The combinator never fails, although it may parse an empty chunk. - -- - -- @since 6.0.0 - - takeWhileP - :: Maybe String -- ^ Name for a single token in the row - -> (Token s -> Bool) -- ^ Predicate to use to test tokens - -> m (Tokens s) -- ^ A chunk of matching tokens - - -- | Similar to 'takeWhileP', but fails if it can't parse at least one - -- token. Note that the combinator either succeeds or fails without - -- consuming any input, so 'try' is not necessary with it. - -- - -- @since 6.0.0 - - takeWhile1P - :: Maybe String -- ^ Name for a single token in the row - -> (Token s -> Bool) -- ^ Predicate to use to test tokens - -> m (Tokens s) -- ^ A chunk of matching tokens - - -- | Extract the specified number of tokens from the input stream and - -- return them packed as a chunk of stream. If there is not enough tokens - -- in the stream, a parse error will be signaled. It's guaranteed that if - -- the parser succeeds, the requested number of tokens will be returned. - -- - -- The parser is roughly equivalent to: - -- - -- > takeP (Just "foo") n = count n (anyChar "foo") - -- > takeP Nothing n = count n anyChar - -- - -- Note that if the combinator fails due to insufficient number of tokens - -- in the input stream, it backtracks automatically. No 'try' is necessary - -- with 'takeP'. - -- - -- @since 6.0.0 - - takeP - :: Maybe String -- ^ Name for a single token in the row - -> Int -- ^ How many tokens to extract - -> m (Tokens s) -- ^ A chunk of matching tokens - - -- | Return the full parser state as a 'State' record. - - getParserState :: m (State s) - - -- | @'updateParserState' f@ applies the function @f@ to the parser state. - - updateParserState :: (State s -> State s) -> m () - -instance (Ord e, Stream s) => MonadParsec e s (ParsecT e s m) where - failure = pFailure - fancyFailure = pFancyFailure - label = pLabel - try = pTry - lookAhead = pLookAhead - notFollowedBy = pNotFollowedBy - withRecovery = pWithRecovery - observing = pObserving - eof = pEof - token = pToken - tokens = pTokens - takeWhileP = pTakeWhileP - takeWhile1P = pTakeWhile1P - takeP = pTakeP - getParserState = pGetParserState - updateParserState = pUpdateParserState - -pFailure - :: Maybe (ErrorItem (Token s)) - -> Set (ErrorItem (Token s)) - -> ParsecT e s m a -pFailure us ps = ParsecT $ \s@(State _ pos _ _) _ _ _ eerr -> - eerr (TrivialError pos us ps) s -{-# INLINE pFailure #-} - -pFancyFailure - :: Set (ErrorFancy e) - -> ParsecT e s m a -pFancyFailure xs = ParsecT $ \s@(State _ pos _ _) _ _ _ eerr -> - eerr (FancyError pos xs) s -{-# INLINE pFancyFailure #-} - -pLabel :: String -> ParsecT e s m a -> ParsecT e s m a -pLabel l p = ParsecT $ \s cok cerr eok eerr -> - let el = Label <$> NE.nonEmpty l - cl = Label . (NE.fromList "the rest of " <>) <$> NE.nonEmpty l - cok' x s' hs = cok x s' (refreshLastHint hs cl) - eok' x s' hs = eok x s' (refreshLastHint hs el) - eerr' err = eerr $ - case err of - (TrivialError pos us _) -> - TrivialError pos us (maybe E.empty E.singleton el) - _ -> err - in unParser p s cok' cerr eok' eerr' -{-# INLINE pLabel #-} - -pTry :: ParsecT e s m a -> ParsecT e s m a -pTry p = ParsecT $ \s cok _ eok eerr -> - let eerr' err _ = eerr err s - in unParser p s cok eerr' eok eerr' -{-# INLINE pTry #-} - -pLookAhead :: ParsecT e s m a -> ParsecT e s m a -pLookAhead p = ParsecT $ \s _ cerr eok eerr -> - let eok' a _ _ = eok a s mempty - in unParser p s eok' cerr eok' eerr -{-# INLINE pLookAhead #-} - -pNotFollowedBy :: Stream s => ParsecT e s m a -> ParsecT e s m () -pNotFollowedBy p = ParsecT $ \s@(State input pos _ _) _ _ eok eerr -> - let what = maybe EndOfInput (Tokens . nes . fst) (take1_ input) - unexpect u = TrivialError pos (pure u) E.empty - cok' _ _ _ = eerr (unexpect what) s - cerr' _ _ = eok () s mempty - eok' _ _ _ = eerr (unexpect what) s - eerr' _ _ = eok () s mempty - in unParser p s cok' cerr' eok' eerr' -{-# INLINE pNotFollowedBy #-} - -pWithRecovery - :: (ParseError (Token s) e -> ParsecT e s m a) - -> ParsecT e s m a - -> ParsecT e s m a -pWithRecovery r p = ParsecT $ \s cok cerr eok eerr -> - let mcerr err ms = - let rcok x s' _ = cok x s' mempty - rcerr _ _ = cerr err ms - reok x s' _ = eok x s' (toHints (statePos s') err) - reerr _ _ = cerr err ms - in unParser (r err) ms rcok rcerr reok reerr - meerr err ms = - let rcok x s' _ = cok x s' (toHints (statePos s') err) - rcerr _ _ = eerr err ms - reok x s' _ = eok x s' (toHints (statePos s') err) - reerr _ _ = eerr err ms - in unParser (r err) ms rcok rcerr reok reerr - in unParser p s cok mcerr eok meerr -{-# INLINE pWithRecovery #-} - -pObserving - :: ParsecT e s m a - -> ParsecT e s m (Either (ParseError (Token s) e) a) -pObserving p = ParsecT $ \s cok _ eok _ -> - let cerr' err s' = cok (Left err) s' mempty - eerr' err s' = eok (Left err) s' (toHints (statePos s') err) - in unParser p s (cok . Right) cerr' (eok . Right) eerr' -{-# INLINE pObserving #-} - -pEof :: forall e s m. Stream s => ParsecT e s m () -pEof = ParsecT $ \s@(State input (pos:|z) tp w) _ _ eok eerr -> - case take1_ input of - Nothing -> eok () s mempty - Just (x,_) -> - let !apos = positionAt1 (Proxy :: Proxy s) pos x - us = (pure . Tokens . nes) x - ps = E.singleton EndOfInput - in eerr (TrivialError (apos:|z) us ps) - (State input (apos:|z) tp w) -{-# INLINE pEof #-} - -pToken :: forall e s m a. Stream s - => (Token s -> Either ( Maybe (ErrorItem (Token s)) - , Set (ErrorItem (Token s)) ) a) - -> Maybe (Token s) - -> ParsecT e s m a -pToken test mtoken = ParsecT $ \s@(State input (pos:|z) tp w) cok _ _ eerr -> - case take1_ input of - Nothing -> - let us = pure EndOfInput - ps = maybe E.empty (E.singleton . Tokens . nes) mtoken - in eerr (TrivialError (pos:|z) us ps) s - Just (c,cs) -> - case test c of - Left (us, ps) -> - let !apos = positionAt1 (Proxy :: Proxy s) pos c - in eerr (TrivialError (apos:|z) us ps) - (State input (apos:|z) tp w) - Right x -> - let !npos = advance1 (Proxy :: Proxy s) w pos c - newstate = State cs (npos:|z) (tp + 1) w - in cok x newstate mempty -{-# INLINE pToken #-} - -pTokens :: forall e s m. Stream s - => (Tokens s -> Tokens s -> Bool) - -> Tokens s - -> ParsecT e s m (Tokens s) -pTokens f tts = ParsecT $ \s@(State input (pos:|z) tp w) cok _ eok eerr -> - let pxy = Proxy :: Proxy s - unexpect pos' u = - let us = pure u - ps = (E.singleton . Tokens . NE.fromList . chunkToTokens pxy) tts - in TrivialError pos' us ps - len = chunkLength pxy tts - in case takeN_ len input of - Nothing -> - eerr (unexpect (pos:|z) EndOfInput) s - Just (tts', input') -> - if f tts tts' - then let !npos = advanceN pxy w pos tts' - st = State input' (npos:|z) (tp + len) w - in if chunkEmpty pxy tts - then eok tts' st mempty - else cok tts' st mempty - else let !apos = positionAtN pxy pos tts' - ps = (Tokens . NE.fromList . chunkToTokens pxy) tts' - in eerr (unexpect (apos:|z) ps) (State input (apos:|z) tp w) -{-# INLINE pTokens #-} - -pTakeWhileP :: forall e s m. Stream s - => Maybe String - -> (Token s -> Bool) - -> ParsecT e s m (Tokens s) -pTakeWhileP ml f = ParsecT $ \(State input (pos:|z) tp w) cok _ eok _ -> - let pxy = Proxy :: Proxy s - (ts, input') = takeWhile_ f input - !npos = advanceN pxy w pos ts - len = chunkLength pxy ts - hs = - case ml >>= NE.nonEmpty of - Nothing -> mempty - Just l -> (Hints . pure . E.singleton . Label) l - in if chunkEmpty pxy ts - then eok ts (State input' (npos:|z) (tp + len) w) hs - else cok ts (State input' (npos:|z) (tp + len) w) hs -{-# INLINE pTakeWhileP #-} - -pTakeWhile1P :: forall e s m. Stream s - => Maybe String - -> (Token s -> Bool) - -> ParsecT e s m (Tokens s) -pTakeWhile1P ml f = ParsecT $ \(State input (pos:|z) tp w) cok _ _ eerr -> - let pxy = Proxy :: Proxy s - (ts, input') = takeWhile_ f input - len = chunkLength pxy ts - el = Label <$> (ml >>= NE.nonEmpty) - hs = - case el of - Nothing -> mempty - Just l -> (Hints . pure . E.singleton) l - in if chunkEmpty pxy ts - then let !apos = positionAtN pxy pos ts - us = pure $ - case take1_ input of - Nothing -> EndOfInput - Just (t,_) -> Tokens (nes t) - ps = maybe E.empty E.singleton el - in eerr (TrivialError (apos:|z) us ps) - (State input (apos:|z) tp w) - else let !npos = advanceN pxy w pos ts - in cok ts (State input' (npos:|z) (tp + len) w) hs -{-# INLINE pTakeWhile1P #-} - -pTakeP :: forall e s m. Stream s - => Maybe String - -> Int - -> ParsecT e s m (Tokens s) -pTakeP ml n = ParsecT $ \s@(State input (pos:|z) tp w) cok _ _ eerr -> - let pxy = Proxy :: Proxy s - el = Label <$> (ml >>= NE.nonEmpty) - ps = maybe E.empty E.singleton el - in case takeN_ n input of - Nothing -> - eerr (TrivialError (pos:|z) (pure EndOfInput) ps) s - Just (ts, input') -> - let len = chunkLength pxy ts - !apos = positionAtN pxy pos ts - !npos = advanceN pxy w pos ts - in if len /= n - then eerr (TrivialError (npos:|z) (pure EndOfInput) ps) - (State input (apos:|z) tp w) - else cok ts (State input' (npos:|z) (tp + len) w) mempty -{-# INLINE pTakeP #-} - -pGetParserState :: ParsecT e s m (State s) -pGetParserState = ParsecT $ \s _ _ eok _ -> eok s s mempty -{-# INLINE pGetParserState #-} - -pUpdateParserState :: (State s -> State s) -> ParsecT e s m () -pUpdateParserState f = ParsecT $ \s _ _ eok _ -> eok () (f s) mempty -{-# INLINE pUpdateParserState #-} - -nes :: a -> NonEmpty a -nes x = x :| [] -{-# INLINE nes #-} - -instance MonadParsec e s m => MonadParsec e s (L.StateT st m) where - failure us ps = lift (failure us ps) - fancyFailure xs = lift (fancyFailure xs) - label n (L.StateT m) = L.StateT $ label n . m - try (L.StateT m) = L.StateT $ try . m - lookAhead (L.StateT m) = L.StateT $ \s -> - (,s) . fst <$> lookAhead (m s) - notFollowedBy (L.StateT m) = L.StateT $ \s -> - notFollowedBy (fst <$> m s) >> return ((),s) - withRecovery r (L.StateT m) = L.StateT $ \s -> - withRecovery (\e -> L.runStateT (r e) s) (m s) - observing (L.StateT m) = L.StateT $ \s -> - fixs s <$> observing (m s) - eof = lift eof - token test mt = lift (token test mt) - tokens e ts = lift (tokens e ts) - takeWhileP l f = lift (takeWhileP l f) - takeWhile1P l f = lift (takeWhile1P l f) - takeP l n = lift (takeP l n) - getParserState = lift getParserState - updateParserState f = lift (updateParserState f) - -instance MonadParsec e s m => MonadParsec e s (S.StateT st m) where - failure us ps = lift (failure us ps) - fancyFailure xs = lift (fancyFailure xs) - label n (S.StateT m) = S.StateT $ label n . m - try (S.StateT m) = S.StateT $ try . m - lookAhead (S.StateT m) = S.StateT $ \s -> - (,s) . fst <$> lookAhead (m s) - notFollowedBy (S.StateT m) = S.StateT $ \s -> - notFollowedBy (fst <$> m s) >> return ((),s) - withRecovery r (S.StateT m) = S.StateT $ \s -> - withRecovery (\e -> S.runStateT (r e) s) (m s) - observing (S.StateT m) = S.StateT $ \s -> - fixs s <$> observing (m s) - eof = lift eof - token test mt = lift (token test mt) - tokens e ts = lift (tokens e ts) - takeWhileP l f = lift (takeWhileP l f) - takeWhile1P l f = lift (takeWhile1P l f) - takeP l n = lift (takeP l n) - getParserState = lift getParserState - updateParserState f = lift (updateParserState f) - -instance MonadParsec e s m => MonadParsec e s (L.ReaderT r m) where - failure us ps = lift (failure us ps) - fancyFailure xs = lift (fancyFailure xs) - label n (L.ReaderT m) = L.ReaderT $ label n . m - try (L.ReaderT m) = L.ReaderT $ try . m - lookAhead (L.ReaderT m) = L.ReaderT $ lookAhead . m - notFollowedBy (L.ReaderT m) = L.ReaderT $ notFollowedBy . m - withRecovery r (L.ReaderT m) = L.ReaderT $ \s -> - withRecovery (\e -> L.runReaderT (r e) s) (m s) - observing (L.ReaderT m) = L.ReaderT $ observing . m - eof = lift eof - token test mt = lift (token test mt) - tokens e ts = lift (tokens e ts) - takeWhileP l f = lift (takeWhileP l f) - takeWhile1P l f = lift (takeWhile1P l f) - takeP l n = lift (takeP l n) - getParserState = lift getParserState - updateParserState f = lift (updateParserState f) - -instance (Monoid w, MonadParsec e s m) => MonadParsec e s (L.WriterT w m) where - failure us ps = lift (failure us ps) - fancyFailure xs = lift (fancyFailure xs) - label n (L.WriterT m) = L.WriterT $ label n m - try (L.WriterT m) = L.WriterT $ try m - lookAhead (L.WriterT m) = L.WriterT $ - (,mempty) . fst <$> lookAhead m - notFollowedBy (L.WriterT m) = L.WriterT $ - (,mempty) <$> notFollowedBy (fst <$> m) - withRecovery r (L.WriterT m) = L.WriterT $ - withRecovery (L.runWriterT . r) m - observing (L.WriterT m) = L.WriterT $ - fixs mempty <$> observing m - eof = lift eof - token test mt = lift (token test mt) - tokens e ts = lift (tokens e ts) - takeWhileP l f = lift (takeWhileP l f) - takeWhile1P l f = lift (takeWhile1P l f) - takeP l n = lift (takeP l n) - getParserState = lift getParserState - updateParserState f = lift (updateParserState f) - -instance (Monoid w, MonadParsec e s m) => MonadParsec e s (S.WriterT w m) where - failure us ps = lift (failure us ps) - fancyFailure xs = lift (fancyFailure xs) - label n (S.WriterT m) = S.WriterT $ label n m - try (S.WriterT m) = S.WriterT $ try m - lookAhead (S.WriterT m) = S.WriterT $ - (,mempty) . fst <$> lookAhead m - notFollowedBy (S.WriterT m) = S.WriterT $ - (,mempty) <$> notFollowedBy (fst <$> m) - withRecovery r (S.WriterT m) = S.WriterT $ - withRecovery (S.runWriterT . r) m - observing (S.WriterT m) = S.WriterT $ - fixs mempty <$> observing m - eof = lift eof - token test mt = lift (token test mt) - tokens e ts = lift (tokens e ts) - takeWhileP l f = lift (takeWhileP l f) - takeWhile1P l f = lift (takeWhile1P l f) - takeP l n = lift (takeP l n) - getParserState = lift getParserState - updateParserState f = lift (updateParserState f) - --- | @since 5.2.0 - -instance (Monoid w, MonadParsec e s m) => MonadParsec e s (L.RWST r w st m) where - failure us ps = lift (failure us ps) - fancyFailure xs = lift (fancyFailure xs) - label n (L.RWST m) = L.RWST $ \r s -> label n (m r s) - try (L.RWST m) = L.RWST $ \r s -> try (m r s) - lookAhead (L.RWST m) = L.RWST $ \r s -> do - (x,_,_) <- lookAhead (m r s) - return (x,s,mempty) - notFollowedBy (L.RWST m) = L.RWST $ \r s -> do - notFollowedBy (void $ m r s) - return ((),s,mempty) - withRecovery n (L.RWST m) = L.RWST $ \r s -> - withRecovery (\e -> L.runRWST (n e) r s) (m r s) - observing (L.RWST m) = L.RWST $ \r s -> - fixs' s <$> observing (m r s) - eof = lift eof - token test mt = lift (token test mt) - tokens e ts = lift (tokens e ts) - takeWhileP l f = lift (takeWhileP l f) - takeWhile1P l f = lift (takeWhile1P l f) - takeP l n = lift (takeP l n) - getParserState = lift getParserState - updateParserState f = lift (updateParserState f) - --- | @since 5.2.0 - -instance (Monoid w, MonadParsec e s m) => MonadParsec e s (S.RWST r w st m) where - failure us ps = lift (failure us ps) - fancyFailure xs = lift (fancyFailure xs) - label n (S.RWST m) = S.RWST $ \r s -> label n (m r s) - try (S.RWST m) = S.RWST $ \r s -> try (m r s) - lookAhead (S.RWST m) = S.RWST $ \r s -> do - (x,_,_) <- lookAhead (m r s) - return (x,s,mempty) - notFollowedBy (S.RWST m) = S.RWST $ \r s -> do - notFollowedBy (void $ m r s) - return ((),s,mempty) - withRecovery n (S.RWST m) = S.RWST $ \r s -> - withRecovery (\e -> S.runRWST (n e) r s) (m r s) - observing (S.RWST m) = S.RWST $ \r s -> - fixs' s <$> observing (m r s) - eof = lift eof - token test mt = lift (token test mt) - tokens e ts = lift (tokens e ts) - takeWhileP l f = lift (takeWhileP l f) - takeWhile1P l f = lift (takeWhile1P l f) - takeP l n = lift (takeP l n) - getParserState = lift getParserState - updateParserState f = lift (updateParserState f) - -instance MonadParsec e s m => MonadParsec e s (IdentityT m) where - failure us ps = lift (failure us ps) - fancyFailure xs = lift (fancyFailure xs) - label n (IdentityT m) = IdentityT $ label n m - try = IdentityT . try . runIdentityT - lookAhead (IdentityT m) = IdentityT $ lookAhead m - notFollowedBy (IdentityT m) = IdentityT $ notFollowedBy m - withRecovery r (IdentityT m) = IdentityT $ - withRecovery (runIdentityT . r) m - observing (IdentityT m) = IdentityT $ observing m - eof = lift eof - token test mt = lift (token test mt) - tokens e ts = lift $ tokens e ts - takeWhileP l f = lift (takeWhileP l f) - takeWhile1P l f = lift (takeWhile1P l f) - takeP l n = lift (takeP l n) - getParserState = lift getParserState - updateParserState f = lift $ updateParserState f - -fixs :: s -> Either a (b, s) -> (Either a b, s) -fixs s (Left a) = (Left a, s) -fixs _ (Right (b, s)) = (Right b, s) -{-# INLINE fixs #-} - -fixs' :: Monoid w => s -> Either a (b, s, w) -> (Either a b, s, w) -fixs' s (Left a) = (Left a, s, mempty) -fixs' _ (Right (b,s,w)) = (Right b, s, w) -{-# INLINE fixs' #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TupleSections #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE UndecidableInstances #-} + +module Text.Megaparsec + ( -- * Re-exports + -- $reexports + module Text.Megaparsec.Pos + , module Text.Megaparsec.Error + , module Text.Megaparsec.Stream + , module Control.Monad.Combinators + -- * Data types + , State (..) + , Parsec + , ParsecT + -- * Running parser + , parse + , parseMaybe + , parseTest + , parseTest' + , runParser + , runParser' + , runParserT + , runParserT' + -- * Primitive combinators + , MonadParsec (..) + -- * Derivatives of primitive combinators + , () + , unexpected + , customFailure + , match + , region + , takeRest + , atEnd + -- * Parser state combinators + , getInput + , setInput + , getPosition + , getNextTokenPosition + , setPosition + , pushPosition + , popPosition + , getTokensProcessed + , setTokensProcessed + , getTabWidth + , setTabWidth + , setParserState + -- * Debugging + , dbg ) +where + +import Control.Monad +import Control.Monad.Combinators +import Control.Monad.Identity +import Data.List.NonEmpty (NonEmpty (..)) +import Data.Maybe (fromJust) +import Data.Proxy +import Debug.Trace +import Text.Megaparsec.Class +import Text.Megaparsec.Error +import Text.Megaparsec.Internal +import Text.Megaparsec.Pos +import Text.Megaparsec.State +import Text.Megaparsec.Stream +import qualified Data.List.NonEmpty as NE +import qualified Data.Set as E + +#if !MIN_VERSION_base(4,8,0) +import Control.Applicative hiding (many, some) +#endif + +-- $reexports +-- +-- Note that we re-export monadic combinators from +-- "Control.Monad.Combinators" because these are more efficient than +-- 'Applicative'-based ones. Thus 'many' and 'some' may clash with the +-- functions from "Control.Applicative". You need to hide the functions like +-- this: +-- +-- > import Control.Applicative hiding (many, some) +-- +-- Also note that you can import "Control.Monad.Combinators.NonEmpty" if you +-- wish that combinators like 'some' return 'NonEmpty' lists. The module +-- lives in the @parser-combinators@ package (you need at least version +-- /0.4.0/). +-- +-- This module is intended to be imported qualified: +-- +-- > import qualified Control.Monad.Combinators.NonEmpty as NE + +---------------------------------------------------------------------------- +-- Data types + +-- | 'Parsec' is a non-transformer variant of the more general 'ParsecT' +-- monad transformer. + +type Parsec e s = ParsecT e s Identity + +---------------------------------------------------------------------------- +-- Running a parser + +-- | @'parse' p file input@ runs parser @p@ over 'Identity' (see 'runParserT' +-- if you're using the 'ParsecT' monad transformer; 'parse' itself is just a +-- synonym for 'runParser'). It returns either a 'ParseError' ('Left') or a +-- value of type @a@ ('Right'). 'parseErrorPretty' can be used to turn +-- 'ParseError' into the string representation of the error message. See +-- "Text.Megaparsec.Error" if you need to do more advanced error analysis. +-- +-- > main = case (parse numbers "" "11,2,43") of +-- > Left err -> putStr (parseErrorPretty err) +-- > Right xs -> print (sum xs) +-- > +-- > numbers = integer `sepBy` char ',' + +parse + :: Parsec e s a -- ^ Parser to run + -> String -- ^ Name of source file + -> s -- ^ Input for parser + -> Either (ParseError (Token s) e) a +parse = runParser + +-- | @'parseMaybe' p input@ runs the parser @p@ on @input@ and returns the +-- result inside 'Just' on success and 'Nothing' on failure. This function +-- also parses 'eof', so if the parser doesn't consume all of its input, it +-- will fail. +-- +-- The function is supposed to be useful for lightweight parsing, where +-- error messages (and thus file name) are not important and entire input +-- should be parsed. For example, it can be used when parsing of a single +-- number according to a specification of its format is desired. + +parseMaybe :: (Ord e, Stream s) => Parsec e s a -> s -> Maybe a +parseMaybe p s = + case parse (p <* eof) "" s of + Left _ -> Nothing + Right x -> Just x + +-- | The expression @'parseTest' p input@ applies the parser @p@ against +-- input @input@ and prints the result to stdout. Useful for testing. + +parseTest :: ( ShowErrorComponent e + , Ord (Token s) + , ShowToken (Token s) + , Show a ) + => Parsec e s a -- ^ Parser to run + -> s -- ^ Input for parser + -> IO () +parseTest p input = + case parse p "" input of + Left e -> putStr (parseErrorPretty e) + Right x -> print x + +-- | A version of 'parseTest' that also prints offending line in parse +-- errors. +-- +-- @since 6.0.0 + +parseTest' :: ( ShowErrorComponent e + , ShowToken (Token s) + , LineToken (Token s) + , Show a + , Stream s ) + => Parsec e s a -- ^ Parser to run + -> s -- ^ Input for parser + -> IO () +parseTest' p input = + case parse p "" input of + Left e -> putStr (parseErrorPretty' input e) + Right x -> print x + +-- | @'runParser' p file input@ runs parser @p@ on the input stream of +-- tokens @input@, obtained from source @file@. The @file@ is only used in +-- error messages and may be the empty string. Returns either a 'ParseError' +-- ('Left') or a value of type @a@ ('Right'). +-- +-- > parseFromFile p file = runParser p file <$> readFile file + +runParser + :: Parsec e s a -- ^ Parser to run + -> String -- ^ Name of source file + -> s -- ^ Input for parser + -> Either (ParseError (Token s) e) a +runParser p name s = snd $ runParser' p (initialState name s) + +-- | The function is similar to 'runParser' with the difference that it +-- accepts and returns parser state. This allows to specify arbitrary +-- textual position at the beginning of parsing, for example. This is the +-- most general way to run a parser over the 'Identity' monad. +-- +-- @since 4.2.0 + +runParser' + :: Parsec e s a -- ^ Parser to run + -> State s -- ^ Initial state + -> (State s, Either (ParseError (Token s) e) a) +runParser' p = runIdentity . runParserT' p + +-- | @'runParserT' p file input@ runs parser @p@ on the input list of tokens +-- @input@, obtained from source @file@. The @file@ is only used in error +-- messages and may be the empty string. Returns a computation in the +-- underlying monad @m@ that returns either a 'ParseError' ('Left') or a +-- value of type @a@ ('Right'). + +runParserT :: Monad m + => ParsecT e s m a -- ^ Parser to run + -> String -- ^ Name of source file + -> s -- ^ Input for parser + -> m (Either (ParseError (Token s) e) a) +runParserT p name s = snd `liftM` runParserT' p (initialState name s) + +-- | This function is similar to 'runParserT', but like 'runParser'' it +-- accepts and returns parser state. This is thus the most general way to +-- run a parser. +-- +-- @since 4.2.0 + +runParserT' :: Monad m + => ParsecT e s m a -- ^ Parser to run + -> State s -- ^ Initial state + -> m (State s, Either (ParseError (Token s) e) a) +runParserT' p s = do + (Reply s' _ result) <- runParsecT p s + case result of + OK x -> return (s', Right x) + Error e -> return (s', Left e) + +-- | Given name of source file and input construct initial state for parser. + +initialState :: String -> s -> State s +initialState name s = State + { stateInput = s + , statePos = initialPos name :| [] + , stateTokensProcessed = 0 + , stateTabWidth = defaultTabWidth } ---------------------------------------------------------------------------- -- Derivatives of primitive combinators diff --git a/Text/Megaparsec/Char/Lexer.hs b/Text/Megaparsec/Char/Lexer.hs --- a/Text/Megaparsec/Char/Lexer.hs +++ b/Text/Megaparsec/Char/Lexer.hs @@ -397,10 +397,10 @@ charLiteral = label "literal character" $ do -- The @~@ is needed to avoid requiring a MonadFail constraint, -- and we do know that r will be non-empty if count' succeeds. - ~r@(x:_) <- lookAhead $ count' 1 8 C.anyChar + r <- lookAhead (count' 1 8 C.anyChar) case listToMaybe (Char.readLitChar r) of - Just (c, r') -> count (length r - length r') C.anyChar >> return c - Nothing -> unexpected (Tokens (x:|[])) + Just (c, r') -> c <$ skipCount (length r - length r') C.anyChar + Nothing -> unexpected (Tokens (head r:|[])) {-# INLINEABLE charLiteral #-} ---------------------------------------------------------------------------- diff --git a/Text/Megaparsec/Class.hs b/Text/Megaparsec/Class.hs new file mode 100644 --- /dev/null +++ b/Text/Megaparsec/Class.hs @@ -0,0 +1,488 @@ +-- | +-- Module : Text.Megaparsec.Class +-- Copyright : © 2015–2018 Megaparsec contributors +-- © 2007 Paolo Martini +-- © 1999–2001 Daan Leijen +-- License : FreeBSD +-- +-- Maintainer : Mark Karpov +-- Stability : experimental +-- Portability : portable +-- +-- Definition of 'MonadParsec'—type class describing monads that implement +-- the full set of primitive parsers. +-- +-- @since 6.5.0 + +{-# LANGUAGE CPP #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE FunctionalDependencies #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE TupleSections #-} +{-# LANGUAGE UndecidableInstances #-} + +module Text.Megaparsec.Class + ( MonadParsec (..) ) +where + +import Control.Applicative +import Control.Monad +import Control.Monad.Identity +import Control.Monad.Trans +import Data.Set (Set) +import Text.Megaparsec.Error +import Text.Megaparsec.State +import Text.Megaparsec.Stream +import qualified Control.Monad.RWS.Lazy as L +import qualified Control.Monad.RWS.Strict as S +import qualified Control.Monad.Trans.Reader as L +import qualified Control.Monad.Trans.State.Lazy as L +import qualified Control.Monad.Trans.State.Strict as S +import qualified Control.Monad.Trans.Writer.Lazy as L +import qualified Control.Monad.Trans.Writer.Strict as S + +#if !MIN_VERSION_mtl(2,2,2) +import Control.Monad.Trans.Identity +#endif + +#if !MIN_VERSION_base(4,8,0) +import Data.Monoid +#endif + +-- | Type class describing monads that implement the full set of primitive +-- parsers. +-- +-- __Note carefully__ that the following primitives are “fast” and should be +-- taken advantage of as much as possible if your aim is a fast parser: +-- 'tokens', 'takeWhileP', 'takeWhile1P', and 'takeP'. + +class (Stream s, Alternative m, MonadPlus m) + => MonadParsec e s m | m -> e s where + + -- | The most general way to stop parsing and report a trivial + -- 'ParseError'. + -- + -- @since 6.0.0 + + failure + :: Maybe (ErrorItem (Token s)) -- ^ Unexpected item (if any) + -> Set (ErrorItem (Token s)) -- ^ Expected items + -> m a + + -- | The most general way to stop parsing and report a fancy 'ParseError'. + -- To report a single custom parse error, see 'customFailure'. + -- + -- @since 6.0.0 + + fancyFailure + :: Set (ErrorFancy e) -- ^ Fancy error components + -> m a + + -- | The parser @'label' name p@ behaves as parser @p@, but whenever the + -- parser @p@ fails /without consuming any input/, it replaces names of + -- “expected” tokens with the name @name@. + + label :: String -> m a -> m a + + -- | @'hidden' p@ behaves just like parser @p@, but it doesn't show any + -- “expected” tokens in error message when @p@ fails. + -- + -- Please use 'hidden' instead of the old @'label' ""@ idiom. + + hidden :: m a -> m a + hidden = label "" + + -- | The parser @'try' p@ behaves like parser @p@, except that it + -- backtracks the parser state when @p@ fails (either consuming input or + -- not). + -- + -- This combinator is used whenever arbitrary look ahead is needed. Since + -- it pretends that it hasn't consumed any input when @p@ fails, the + -- ('A.<|>') combinator will try its second alternative even if the first + -- parser failed while consuming input. + -- + -- For example, here is a parser that is supposed to parse the word “let” + -- or the word “lexical”: + -- + -- >>> parseTest (string "let" <|> string "lexical") "lexical" + -- 1:1: + -- unexpected "lex" + -- expecting "let" + -- + -- What happens here? The first parser consumes “le” and fails (because it + -- doesn't see a “t”). The second parser, however, isn't tried, since the + -- first parser has already consumed some input! 'try' fixes this behavior + -- and allows backtracking to work: + -- + -- >>> parseTest (try (string "let") <|> string "lexical") "lexical" + -- "lexical" + -- + -- 'try' also improves error messages in case of overlapping alternatives, + -- because Megaparsec's hint system can be used: + -- + -- >>> parseTest (try (string "let") <|> string "lexical") "le" + -- 1:1: + -- unexpected "le" + -- expecting "let" or "lexical" + -- + -- __Please note__ that as of Megaparsec 4.4.0, 'string' backtracks + -- automatically (see 'tokens'), so it does not need 'try'. However, the + -- examples above demonstrate the idea behind 'try' so well that it was + -- decided to keep them. You still need to use 'try' when your + -- alternatives are complex, composite parsers. + + try :: m a -> m a + + -- | If @p@ in @'lookAhead' p@ succeeds (either consuming input or not) + -- the whole parser behaves like @p@ succeeded without consuming anything + -- (parser state is not updated as well). If @p@ fails, 'lookAhead' has no + -- effect, i.e. it will fail consuming input if @p@ fails consuming input. + -- Combine with 'try' if this is undesirable. + + lookAhead :: m a -> m a + + -- | @'notFollowedBy' p@ only succeeds when the parser @p@ fails. This + -- parser /never consumes/ any input and /never modifies/ parser state. It + -- can be used to implement the “longest match” rule. + + notFollowedBy :: m a -> m () + + -- | @'withRecovery' r p@ allows continue parsing even if parser @p@ + -- fails. In this case @r@ is called with the actual 'ParseError' as its + -- argument. Typical usage is to return a value signifying failure to + -- parse this particular object and to consume some part of the input up + -- to the point where the next object starts. + -- + -- Note that if @r@ fails, original error message is reported as if + -- without 'withRecovery'. In no way recovering parser @r@ can influence + -- error messages. + -- + -- @since 4.4.0 + + withRecovery + :: (ParseError (Token s) e -> m a) -- ^ How to recover from failure + -> m a -- ^ Original parser + -> m a -- ^ Parser that can recover from failures + + -- | @'observing' p@ allows to “observe” failure of the @p@ parser, should + -- it happen, without actually ending parsing, but instead getting the + -- 'ParseError' in 'Left'. On success parsed value is returned in 'Right' + -- as usual. Note that this primitive just allows you to observe parse + -- errors as they happen, it does not backtrack or change how the @p@ + -- parser works in any way. + -- + -- @since 5.1.0 + + observing + :: m a -- ^ The parser to run + -> m (Either (ParseError (Token s) e) a) + + -- | This parser only succeeds at the end of the input. + + eof :: m () + + -- | The parser @'token' test mrep@ accepts a token @t@ with result @x@ + -- when the function @test t@ returns @'Right' x@. @mrep@ may provide + -- representation of the token to report in error messages when input + -- stream in empty. + -- + -- This is the most primitive combinator for accepting tokens. For + -- example, the 'Text.Megaparsec.Char.satisfy' parser is implemented as: + -- + -- > satisfy f = token testChar Nothing + -- > where + -- > testChar x = + -- > if f x + -- > then Right x + -- > else Left (pure (Tokens (x:|[])), Set.empty) + + token + :: (Token s -> Either ( Maybe (ErrorItem (Token s)) + , Set (ErrorItem (Token s)) ) a) + -- ^ Matching function for the token to parse, it allows to construct + -- arbitrary error message on failure as well; things in the tuple + -- are: unexpected item (if any) and expected items + -> Maybe (Token s) -- ^ Token to report when input stream is empty + -> m a + + -- | The parser @'tokens' test@ parses a chunk of input and returns it. + -- Supplied predicate @test@ is used to check equality of given and parsed + -- chunks after a candidate chunk of correct length is fetched from the + -- stream. + -- + -- This can be used for example to write 'Text.Megaparsec.Char.string': + -- + -- > string = tokens (==) + -- + -- Note that beginning from Megaparsec 4.4.0, this is an auto-backtracking + -- primitive, which means that if it fails, it never consumes any input. + -- This is done to make its consumption model match how error messages for + -- this primitive are reported (which becomes an important thing as user + -- gets more control with primitives like 'withRecovery'): + -- + -- >>> parseTest (string "abc") "abd" + -- 1:1: + -- unexpected "abd" + -- expecting "abc" + -- + -- This means, in particular, that it's no longer necessary to use 'try' + -- with 'tokens'-based parsers, such as 'Text.Megaparsec.Char.string' and + -- 'Text.Megaparsec.Char.string''. This feature /does not/ affect + -- performance in any way. + + tokens + :: (Tokens s -> Tokens s -> Bool) + -- ^ Predicate to check equality of chunks + -> Tokens s + -- ^ Chunk of input to match against + -> m (Tokens s) + + -- | Parse /zero/ or more tokens for which the supplied predicate holds. + -- Try to use this as much as possible because for many streams the + -- combinator is much faster than parsers built with 'many' and + -- 'Text.Megaparsec.Char.satisfy'. + -- + -- The following equations should clarify the behavior: + -- + -- > takeWhileP (Just "foo") f = many (satisfy f "foo") + -- > takeWhileP Nothing f = many (satisfy f) + -- + -- The combinator never fails, although it may parse an empty chunk. + -- + -- @since 6.0.0 + + takeWhileP + :: Maybe String -- ^ Name for a single token in the row + -> (Token s -> Bool) -- ^ Predicate to use to test tokens + -> m (Tokens s) -- ^ A chunk of matching tokens + + -- | Similar to 'takeWhileP', but fails if it can't parse at least one + -- token. Note that the combinator either succeeds or fails without + -- consuming any input, so 'try' is not necessary with it. + -- + -- @since 6.0.0 + + takeWhile1P + :: Maybe String -- ^ Name for a single token in the row + -> (Token s -> Bool) -- ^ Predicate to use to test tokens + -> m (Tokens s) -- ^ A chunk of matching tokens + + -- | Extract the specified number of tokens from the input stream and + -- return them packed as a chunk of stream. If there is not enough tokens + -- in the stream, a parse error will be signaled. It's guaranteed that if + -- the parser succeeds, the requested number of tokens will be returned. + -- + -- The parser is roughly equivalent to: + -- + -- > takeP (Just "foo") n = count n (anyChar "foo") + -- > takeP Nothing n = count n anyChar + -- + -- Note that if the combinator fails due to insufficient number of tokens + -- in the input stream, it backtracks automatically. No 'try' is necessary + -- with 'takeP'. + -- + -- @since 6.0.0 + + takeP + :: Maybe String -- ^ Name for a single token in the row + -> Int -- ^ How many tokens to extract + -> m (Tokens s) -- ^ A chunk of matching tokens + + -- | Return the full parser state as a 'State' record. + + getParserState :: m (State s) + + -- | @'updateParserState' f@ applies the function @f@ to the parser state. + + updateParserState :: (State s -> State s) -> m () + +---------------------------------------------------------------------------- +-- Lifting through MTL + +instance MonadParsec e s m => MonadParsec e s (L.StateT st m) where + failure us ps = lift (failure us ps) + fancyFailure xs = lift (fancyFailure xs) + label n (L.StateT m) = L.StateT $ label n . m + try (L.StateT m) = L.StateT $ try . m + lookAhead (L.StateT m) = L.StateT $ \s -> + (,s) . fst <$> lookAhead (m s) + notFollowedBy (L.StateT m) = L.StateT $ \s -> + notFollowedBy (fst <$> m s) >> return ((),s) + withRecovery r (L.StateT m) = L.StateT $ \s -> + withRecovery (\e -> L.runStateT (r e) s) (m s) + observing (L.StateT m) = L.StateT $ \s -> + fixs s <$> observing (m s) + eof = lift eof + token test mt = lift (token test mt) + tokens e ts = lift (tokens e ts) + takeWhileP l f = lift (takeWhileP l f) + takeWhile1P l f = lift (takeWhile1P l f) + takeP l n = lift (takeP l n) + getParserState = lift getParserState + updateParserState f = lift (updateParserState f) + +instance MonadParsec e s m => MonadParsec e s (S.StateT st m) where + failure us ps = lift (failure us ps) + fancyFailure xs = lift (fancyFailure xs) + label n (S.StateT m) = S.StateT $ label n . m + try (S.StateT m) = S.StateT $ try . m + lookAhead (S.StateT m) = S.StateT $ \s -> + (,s) . fst <$> lookAhead (m s) + notFollowedBy (S.StateT m) = S.StateT $ \s -> + notFollowedBy (fst <$> m s) >> return ((),s) + withRecovery r (S.StateT m) = S.StateT $ \s -> + withRecovery (\e -> S.runStateT (r e) s) (m s) + observing (S.StateT m) = S.StateT $ \s -> + fixs s <$> observing (m s) + eof = lift eof + token test mt = lift (token test mt) + tokens e ts = lift (tokens e ts) + takeWhileP l f = lift (takeWhileP l f) + takeWhile1P l f = lift (takeWhile1P l f) + takeP l n = lift (takeP l n) + getParserState = lift getParserState + updateParserState f = lift (updateParserState f) + +instance MonadParsec e s m => MonadParsec e s (L.ReaderT r m) where + failure us ps = lift (failure us ps) + fancyFailure xs = lift (fancyFailure xs) + label n (L.ReaderT m) = L.ReaderT $ label n . m + try (L.ReaderT m) = L.ReaderT $ try . m + lookAhead (L.ReaderT m) = L.ReaderT $ lookAhead . m + notFollowedBy (L.ReaderT m) = L.ReaderT $ notFollowedBy . m + withRecovery r (L.ReaderT m) = L.ReaderT $ \s -> + withRecovery (\e -> L.runReaderT (r e) s) (m s) + observing (L.ReaderT m) = L.ReaderT $ observing . m + eof = lift eof + token test mt = lift (token test mt) + tokens e ts = lift (tokens e ts) + takeWhileP l f = lift (takeWhileP l f) + takeWhile1P l f = lift (takeWhile1P l f) + takeP l n = lift (takeP l n) + getParserState = lift getParserState + updateParserState f = lift (updateParserState f) + +instance (Monoid w, MonadParsec e s m) => MonadParsec e s (L.WriterT w m) where + failure us ps = lift (failure us ps) + fancyFailure xs = lift (fancyFailure xs) + label n (L.WriterT m) = L.WriterT $ label n m + try (L.WriterT m) = L.WriterT $ try m + lookAhead (L.WriterT m) = L.WriterT $ + (,mempty) . fst <$> lookAhead m + notFollowedBy (L.WriterT m) = L.WriterT $ + (,mempty) <$> notFollowedBy (fst <$> m) + withRecovery r (L.WriterT m) = L.WriterT $ + withRecovery (L.runWriterT . r) m + observing (L.WriterT m) = L.WriterT $ + fixs mempty <$> observing m + eof = lift eof + token test mt = lift (token test mt) + tokens e ts = lift (tokens e ts) + takeWhileP l f = lift (takeWhileP l f) + takeWhile1P l f = lift (takeWhile1P l f) + takeP l n = lift (takeP l n) + getParserState = lift getParserState + updateParserState f = lift (updateParserState f) + +instance (Monoid w, MonadParsec e s m) => MonadParsec e s (S.WriterT w m) where + failure us ps = lift (failure us ps) + fancyFailure xs = lift (fancyFailure xs) + label n (S.WriterT m) = S.WriterT $ label n m + try (S.WriterT m) = S.WriterT $ try m + lookAhead (S.WriterT m) = S.WriterT $ + (,mempty) . fst <$> lookAhead m + notFollowedBy (S.WriterT m) = S.WriterT $ + (,mempty) <$> notFollowedBy (fst <$> m) + withRecovery r (S.WriterT m) = S.WriterT $ + withRecovery (S.runWriterT . r) m + observing (S.WriterT m) = S.WriterT $ + fixs mempty <$> observing m + eof = lift eof + token test mt = lift (token test mt) + tokens e ts = lift (tokens e ts) + takeWhileP l f = lift (takeWhileP l f) + takeWhile1P l f = lift (takeWhile1P l f) + takeP l n = lift (takeP l n) + getParserState = lift getParserState + updateParserState f = lift (updateParserState f) + +-- | @since 5.2.0 + +instance (Monoid w, MonadParsec e s m) => MonadParsec e s (L.RWST r w st m) where + failure us ps = lift (failure us ps) + fancyFailure xs = lift (fancyFailure xs) + label n (L.RWST m) = L.RWST $ \r s -> label n (m r s) + try (L.RWST m) = L.RWST $ \r s -> try (m r s) + lookAhead (L.RWST m) = L.RWST $ \r s -> do + (x,_,_) <- lookAhead (m r s) + return (x,s,mempty) + notFollowedBy (L.RWST m) = L.RWST $ \r s -> do + notFollowedBy (void $ m r s) + return ((),s,mempty) + withRecovery n (L.RWST m) = L.RWST $ \r s -> + withRecovery (\e -> L.runRWST (n e) r s) (m r s) + observing (L.RWST m) = L.RWST $ \r s -> + fixs' s <$> observing (m r s) + eof = lift eof + token test mt = lift (token test mt) + tokens e ts = lift (tokens e ts) + takeWhileP l f = lift (takeWhileP l f) + takeWhile1P l f = lift (takeWhile1P l f) + takeP l n = lift (takeP l n) + getParserState = lift getParserState + updateParserState f = lift (updateParserState f) + +-- | @since 5.2.0 + +instance (Monoid w, MonadParsec e s m) => MonadParsec e s (S.RWST r w st m) where + failure us ps = lift (failure us ps) + fancyFailure xs = lift (fancyFailure xs) + label n (S.RWST m) = S.RWST $ \r s -> label n (m r s) + try (S.RWST m) = S.RWST $ \r s -> try (m r s) + lookAhead (S.RWST m) = S.RWST $ \r s -> do + (x,_,_) <- lookAhead (m r s) + return (x,s,mempty) + notFollowedBy (S.RWST m) = S.RWST $ \r s -> do + notFollowedBy (void $ m r s) + return ((),s,mempty) + withRecovery n (S.RWST m) = S.RWST $ \r s -> + withRecovery (\e -> S.runRWST (n e) r s) (m r s) + observing (S.RWST m) = S.RWST $ \r s -> + fixs' s <$> observing (m r s) + eof = lift eof + token test mt = lift (token test mt) + tokens e ts = lift (tokens e ts) + takeWhileP l f = lift (takeWhileP l f) + takeWhile1P l f = lift (takeWhile1P l f) + takeP l n = lift (takeP l n) + getParserState = lift getParserState + updateParserState f = lift (updateParserState f) + +instance MonadParsec e s m => MonadParsec e s (IdentityT m) where + failure us ps = lift (failure us ps) + fancyFailure xs = lift (fancyFailure xs) + label n (IdentityT m) = IdentityT $ label n m + try = IdentityT . try . runIdentityT + lookAhead (IdentityT m) = IdentityT $ lookAhead m + notFollowedBy (IdentityT m) = IdentityT $ notFollowedBy m + withRecovery r (IdentityT m) = IdentityT $ + withRecovery (runIdentityT . r) m + observing (IdentityT m) = IdentityT $ observing m + eof = lift eof + token test mt = lift (token test mt) + tokens e ts = lift $ tokens e ts + takeWhileP l f = lift (takeWhileP l f) + takeWhile1P l f = lift (takeWhile1P l f) + takeP l n = lift (takeP l n) + getParserState = lift getParserState + updateParserState f = lift $ updateParserState f + +fixs :: s -> Either a (b, s) -> (Either a b, s) +fixs s (Left a) = (Left a, s) +fixs _ (Right (b, s)) = (Right b, s) +{-# INLINE fixs #-} + +fixs' :: Monoid w => s -> Either a (b, s, w) -> (Either a b, s, w) +fixs' s (Left a) = (Left a, s, mempty) +fixs' _ (Right (b,s,w)) = (Right b, s, w) +{-# INLINE fixs' #-} diff --git a/Text/Megaparsec/Error/Builder.hs b/Text/Megaparsec/Error/Builder.hs --- a/Text/Megaparsec/Error/Builder.hs +++ b/Text/Megaparsec/Error/Builder.hs @@ -43,7 +43,6 @@ import Data.Data (Data) import Data.List.NonEmpty (NonEmpty (..)) import Data.Proxy -import Data.Semigroup import Data.Set (Set) import Data.Typeable (Typeable) import GHC.Generics @@ -55,6 +54,9 @@ #if !MIN_VERSION_base(4,8,0) import Control.Applicative +#endif +#if !MIN_VERSION_base(4,11,0) +import Data.Semigroup #endif ---------------------------------------------------------------------------- diff --git a/Text/Megaparsec/Internal.hs b/Text/Megaparsec/Internal.hs new file mode 100644 --- /dev/null +++ b/Text/Megaparsec/Internal.hs @@ -0,0 +1,622 @@ +-- | +-- Module : Text.Megaparsec.Internal +-- Copyright : © 2015–2018 Megaparsec contributors +-- © 2007 Paolo Martini +-- © 1999–2001 Daan Leijen +-- License : FreeBSD +-- +-- Maintainer : Mark Karpov +-- Stability : experimental +-- Portability : portable +-- +-- Internal definitions. Versioning rules do not apply here. Please do not +-- rely on these unless you really know what you're doing. +-- +-- @since 6.5.0 + +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE UndecidableInstances #-} + +#if MIN_VERSION_base(4,9,0) && !MIN_VERSION_base(4,11,0) +{-# OPTIONS -Wno-noncanonical-monoid-instances #-} +#endif + +module Text.Megaparsec.Internal + ( -- * Data types + Hints (..) + , Reply (..) + , Consumption (..) + , Result (..) + , ParsecT (..) + -- * Helper functions + , toHints + , withHints + , accHints + , refreshLastHint + , runParsecT ) +where + +import Control.Applicative +import Control.Monad +import Control.Monad.Cont.Class +import Control.Monad.Error.Class +import Control.Monad.Fix +import Control.Monad.IO.Class +import Control.Monad.Reader.Class +import Control.Monad.State.Class hiding (state) +import Control.Monad.Trans +import Data.List.NonEmpty (NonEmpty (..)) +import Data.Proxy +import Data.Semigroup hiding (option) +import Data.Set (Set) +import Data.String (IsString (..)) +import Text.Megaparsec.Class +import Text.Megaparsec.Error +import Text.Megaparsec.Pos +import Text.Megaparsec.State +import Text.Megaparsec.Stream +import qualified Control.Monad.Fail as Fail +import qualified Data.List.NonEmpty as NE +import qualified Data.Set as E + +---------------------------------------------------------------------------- +-- Data types + +-- | 'Hints' represent a collection of 'ErrorItem's to be included into +-- 'ParserError' (when it's a 'TrivialError') as “expected” message items +-- when a parser fails without consuming input right after successful parser +-- that produced the hints. +-- +-- For example, without hints you could get: +-- +-- >>> parseTest (many (char 'r') <* eof) "ra" +-- 1:2: +-- unexpected 'a' +-- expecting end of input +-- +-- We're getting better error messages with help of hints: +-- +-- >>> parseTest (many (char 'r') <* eof) "ra" +-- 1:2: +-- unexpected 'a' +-- expecting 'r' or end of input + +newtype Hints t = Hints [Set (ErrorItem t)] + deriving (Semigroup, Monoid) + +-- | All information available after parsing. This includes consumption of +-- input, success (with returned value) or failure (with parse error), and +-- parser state at the end of parsing. +-- +-- See also: 'Consumption', 'Result'. + +data Reply e s a = Reply (State s) Consumption (Result (Token s) e a) + +-- | This data structure represents an aspect of result of parser's work. +-- +-- See also: 'Result', 'Reply'. + +data Consumption + = Consumed -- ^ Some part of input stream was consumed + | Virgin -- ^ No input was consumed + +-- | This data structure represents an aspect of result of parser's work. +-- +-- See also: 'Consumption', 'Reply'. + +data Result t e a + = OK a -- ^ Parser succeeded + | Error (ParseError t e) -- ^ Parser failed + +-- | @'ParsecT' e s m a@ is a parser with custom data component of error +-- @e@, stream type @s@, underlying monad @m@ and return type @a@. + +newtype ParsecT e s m a = ParsecT + { unParser + :: forall b. State s + -> (a -> State s -> Hints (Token s) -> m b) -- consumed-OK + -> (ParseError (Token s) e -> State s -> m b) -- consumed-error + -> (a -> State s -> Hints (Token s) -> m b) -- empty-OK + -> (ParseError (Token s) e -> State s -> m b) -- empty-error + -> m b } + +-- | @since 5.3.0 + +instance (Stream s, Semigroup a) => Semigroup (ParsecT e s m a) where + (<>) = liftA2 (<>) + {-# INLINE (<>) #-} +#if MIN_VERSION_base(4,8,0) + sconcat = fmap sconcat . sequence +#else + sconcat = fmap (sconcat . NE.fromList) . sequence . NE.toList +#endif + {-# INLINE sconcat #-} + +-- | @since 5.3.0 + +instance (Stream s, Monoid a) => Monoid (ParsecT e s m a) where + mempty = pure mempty + {-# INLINE mempty #-} +#if MIN_VERSION_base(4,11,0) + mappend = (<>) +#else + mappend = liftA2 mappend +#endif + {-# INLINE mappend #-} + mconcat = fmap mconcat . sequence + {-# INLINE mconcat #-} + +-- | @since 6.3.0 + +instance (a ~ Tokens s, IsString a, Eq a, Stream s, Ord e) + => IsString (ParsecT e s m a) where + fromString s = tokens (==) (fromString s) + +instance Functor (ParsecT e s m) where + fmap = pMap + +pMap :: (a -> b) -> ParsecT e s m a -> ParsecT e s m b +pMap f p = ParsecT $ \s cok cerr eok eerr -> + unParser p s (cok . f) cerr (eok . f) eerr +{-# INLINE pMap #-} + +-- | 'pure' returns a parser that __succeeds__ without consuming input. + +instance Stream s => Applicative (ParsecT e s m) where + pure = pPure + (<*>) = pAp + p1 *> p2 = p1 `pBind` const p2 + p1 <* p2 = do { x1 <- p1 ; void p2 ; return x1 } + +pPure :: a -> ParsecT e s m a +pPure x = ParsecT $ \s _ _ eok _ -> eok x s mempty +{-# INLINE pPure #-} + +pAp :: Stream s + => ParsecT e s m (a -> b) + -> ParsecT e s m a + -> ParsecT e s m b +pAp m k = ParsecT $ \s cok cerr eok eerr -> + let mcok x s' hs = unParser k s' (cok . x) cerr + (accHints hs (cok . x)) (withHints hs cerr) + meok x s' hs = unParser k s' (cok . x) cerr + (accHints hs (eok . x)) (withHints hs eerr) + in unParser m s mcok cerr meok eerr +{-# INLINE pAp #-} + +-- | 'empty' is a parser that __fails__ without consuming input. + +instance (Ord e, Stream s) => Alternative (ParsecT e s m) where + empty = mzero + (<|>) = mplus + +-- | 'return' returns a parser that __succeeds__ without consuming input. + +instance Stream s => Monad (ParsecT e s m) where + return = pure + (>>=) = pBind + fail = Fail.fail + +pBind :: Stream s + => ParsecT e s m a + -> (a -> ParsecT e s m b) + -> ParsecT e s m b +pBind m k = ParsecT $ \s cok cerr eok eerr -> + let mcok x s' hs = unParser (k x) s' cok cerr + (accHints hs cok) (withHints hs cerr) + meok x s' hs = unParser (k x) s' cok cerr + (accHints hs eok) (withHints hs eerr) + in unParser m s mcok cerr meok eerr +{-# INLINE pBind #-} + +instance Stream s => Fail.MonadFail (ParsecT e s m) where + fail = pFail + +pFail :: String -> ParsecT e s m a +pFail msg = ParsecT $ \s@(State _ pos _ _) _ _ _ eerr -> + let d = E.singleton (ErrorFail msg) + in eerr (FancyError pos d) s +{-# INLINE pFail #-} + +instance (Stream s, MonadIO m) => MonadIO (ParsecT e s m) where + liftIO = lift . liftIO + +instance (Stream s, MonadReader r m) => MonadReader r (ParsecT e s m) where + ask = lift ask + local f p = mkPT $ \s -> local f (runParsecT p s) + +instance (Stream s, MonadState st m) => MonadState st (ParsecT e s m) where + get = lift get + put = lift . put + +instance (Stream s, MonadCont m) => MonadCont (ParsecT e s m) where + callCC f = mkPT $ \s -> + callCC $ \c -> + runParsecT (f (\a -> mkPT $ \s' -> c (pack s' a))) s + where pack s a = Reply s Virgin (OK a) + +instance (Stream s, MonadError e' m) => MonadError e' (ParsecT e s m) where + throwError = lift . throwError + p `catchError` h = mkPT $ \s -> + runParsecT p s `catchError` \e -> + runParsecT (h e) s + +mkPT :: Monad m => (State s -> m (Reply e s a)) -> ParsecT e s m a +mkPT k = ParsecT $ \s cok cerr eok eerr -> do + (Reply s' consumption result) <- k s + case consumption of + Consumed -> + case result of + OK x -> cok x s' mempty + Error e -> cerr e s' + Virgin -> + case result of + OK x -> eok x s' mempty + Error e -> eerr e s' + +-- | 'mzero' is a parser that __fails__ without consuming input. + +instance (Ord e, Stream s) => MonadPlus (ParsecT e s m) where + mzero = pZero + mplus = pPlus + +pZero :: ParsecT e s m a +pZero = ParsecT $ \s@(State _ pos _ _) _ _ _ eerr -> + eerr (TrivialError pos Nothing E.empty) s +{-# INLINE pZero #-} + +pPlus :: (Ord e, Stream s) + => ParsecT e s m a + -> ParsecT e s m a + -> ParsecT e s m a +pPlus m n = ParsecT $ \s cok cerr eok eerr -> + let meerr err ms = + let ncerr err' s' = cerr (err' <> err) (longestMatch ms s') + neok x s' hs = eok x s' (toHints (statePos s') err <> hs) + neerr err' s' = eerr (err' <> err) (longestMatch ms s') + in unParser n s cok ncerr neok neerr + in unParser m s cok cerr eok meerr +{-# INLINE pPlus #-} + +-- | @since 6.0.0 + +instance (Stream s, MonadFix m) => MonadFix (ParsecT e s m) where + mfix f = mkPT $ \s -> mfix $ \(~(Reply _ _ result)) -> do + let + a = case result of + OK a' -> a' + Error _ -> error "mfix ParsecT" + runParsecT (f a) s + +-- | From two states, return the one with the greater number of processed +-- tokens. If the numbers of processed tokens are equal, prefer the second +-- state. + +longestMatch :: State s -> State s -> State s +longestMatch s1@(State _ _ tp1 _) s2@(State _ _ tp2 _) = + case tp1 `compare` tp2 of + LT -> s2 + EQ -> s2 + GT -> s1 +{-# INLINE longestMatch #-} + +instance MonadTrans (ParsecT e s) where + lift amb = ParsecT $ \s _ _ eok _ -> + amb >>= \a -> eok a s mempty + +instance (Ord e, Stream s) => MonadParsec e s (ParsecT e s m) where + failure = pFailure + fancyFailure = pFancyFailure + label = pLabel + try = pTry + lookAhead = pLookAhead + notFollowedBy = pNotFollowedBy + withRecovery = pWithRecovery + observing = pObserving + eof = pEof + token = pToken + tokens = pTokens + takeWhileP = pTakeWhileP + takeWhile1P = pTakeWhile1P + takeP = pTakeP + getParserState = pGetParserState + updateParserState = pUpdateParserState + +pFailure + :: Maybe (ErrorItem (Token s)) + -> Set (ErrorItem (Token s)) + -> ParsecT e s m a +pFailure us ps = ParsecT $ \s@(State _ pos _ _) _ _ _ eerr -> + eerr (TrivialError pos us ps) s +{-# INLINE pFailure #-} + +pFancyFailure + :: Set (ErrorFancy e) + -> ParsecT e s m a +pFancyFailure xs = ParsecT $ \s@(State _ pos _ _) _ _ _ eerr -> + eerr (FancyError pos xs) s +{-# INLINE pFancyFailure #-} + +pLabel :: String -> ParsecT e s m a -> ParsecT e s m a +pLabel l p = ParsecT $ \s cok cerr eok eerr -> + let el = Label <$> NE.nonEmpty l + cl = Label . (NE.fromList "the rest of " <>) <$> NE.nonEmpty l + cok' x s' hs = cok x s' (refreshLastHint hs cl) + eok' x s' hs = eok x s' (refreshLastHint hs el) + eerr' err = eerr $ + case err of + (TrivialError pos us _) -> + TrivialError pos us (maybe E.empty E.singleton el) + _ -> err + in unParser p s cok' cerr eok' eerr' +{-# INLINE pLabel #-} + +pTry :: ParsecT e s m a -> ParsecT e s m a +pTry p = ParsecT $ \s cok _ eok eerr -> + let eerr' err _ = eerr err s + in unParser p s cok eerr' eok eerr' +{-# INLINE pTry #-} + +pLookAhead :: ParsecT e s m a -> ParsecT e s m a +pLookAhead p = ParsecT $ \s _ cerr eok eerr -> + let eok' a _ _ = eok a s mempty + in unParser p s eok' cerr eok' eerr +{-# INLINE pLookAhead #-} + +pNotFollowedBy :: Stream s => ParsecT e s m a -> ParsecT e s m () +pNotFollowedBy p = ParsecT $ \s@(State input pos _ _) _ _ eok eerr -> + let what = maybe EndOfInput (Tokens . nes . fst) (take1_ input) + unexpect u = TrivialError pos (pure u) E.empty + cok' _ _ _ = eerr (unexpect what) s + cerr' _ _ = eok () s mempty + eok' _ _ _ = eerr (unexpect what) s + eerr' _ _ = eok () s mempty + in unParser p s cok' cerr' eok' eerr' +{-# INLINE pNotFollowedBy #-} + +pWithRecovery + :: (ParseError (Token s) e -> ParsecT e s m a) + -> ParsecT e s m a + -> ParsecT e s m a +pWithRecovery r p = ParsecT $ \s cok cerr eok eerr -> + let mcerr err ms = + let rcok x s' _ = cok x s' mempty + rcerr _ _ = cerr err ms + reok x s' _ = eok x s' (toHints (statePos s') err) + reerr _ _ = cerr err ms + in unParser (r err) ms rcok rcerr reok reerr + meerr err ms = + let rcok x s' _ = cok x s' (toHints (statePos s') err) + rcerr _ _ = eerr err ms + reok x s' _ = eok x s' (toHints (statePos s') err) + reerr _ _ = eerr err ms + in unParser (r err) ms rcok rcerr reok reerr + in unParser p s cok mcerr eok meerr +{-# INLINE pWithRecovery #-} + +pObserving + :: ParsecT e s m a + -> ParsecT e s m (Either (ParseError (Token s) e) a) +pObserving p = ParsecT $ \s cok _ eok _ -> + let cerr' err s' = cok (Left err) s' mempty + eerr' err s' = eok (Left err) s' (toHints (statePos s') err) + in unParser p s (cok . Right) cerr' (eok . Right) eerr' +{-# INLINE pObserving #-} + +pEof :: forall e s m. Stream s => ParsecT e s m () +pEof = ParsecT $ \s@(State input (pos:|z) tp w) _ _ eok eerr -> + case take1_ input of + Nothing -> eok () s mempty + Just (x,_) -> + let !apos = positionAt1 (Proxy :: Proxy s) pos x + us = (pure . Tokens . nes) x + ps = E.singleton EndOfInput + in eerr (TrivialError (apos:|z) us ps) + (State input (apos:|z) tp w) +{-# INLINE pEof #-} + +pToken :: forall e s m a. Stream s + => (Token s -> Either ( Maybe (ErrorItem (Token s)) + , Set (ErrorItem (Token s)) ) a) + -> Maybe (Token s) + -> ParsecT e s m a +pToken test mtoken = ParsecT $ \s@(State input (pos:|z) tp w) cok _ _ eerr -> + case take1_ input of + Nothing -> + let us = pure EndOfInput + ps = maybe E.empty (E.singleton . Tokens . nes) mtoken + in eerr (TrivialError (pos:|z) us ps) s + Just (c,cs) -> + case test c of + Left (us, ps) -> + let !apos = positionAt1 (Proxy :: Proxy s) pos c + in eerr (TrivialError (apos:|z) us ps) + (State input (apos:|z) tp w) + Right x -> + let !npos = advance1 (Proxy :: Proxy s) w pos c + newstate = State cs (npos:|z) (tp + 1) w + in cok x newstate mempty +{-# INLINE pToken #-} + +pTokens :: forall e s m. Stream s + => (Tokens s -> Tokens s -> Bool) + -> Tokens s + -> ParsecT e s m (Tokens s) +pTokens f tts = ParsecT $ \s@(State input (pos:|z) tp w) cok _ eok eerr -> + let pxy = Proxy :: Proxy s + unexpect pos' u = + let us = pure u + ps = (E.singleton . Tokens . NE.fromList . chunkToTokens pxy) tts + in TrivialError pos' us ps + len = chunkLength pxy tts + in case takeN_ len input of + Nothing -> + eerr (unexpect (pos:|z) EndOfInput) s + Just (tts', input') -> + if f tts tts' + then let !npos = advanceN pxy w pos tts' + st = State input' (npos:|z) (tp + len) w + in if chunkEmpty pxy tts + then eok tts' st mempty + else cok tts' st mempty + else let !apos = positionAtN pxy pos tts' + ps = (Tokens . NE.fromList . chunkToTokens pxy) tts' + in eerr (unexpect (apos:|z) ps) (State input (apos:|z) tp w) +{-# INLINE pTokens #-} + +pTakeWhileP :: forall e s m. Stream s + => Maybe String + -> (Token s -> Bool) + -> ParsecT e s m (Tokens s) +pTakeWhileP ml f = ParsecT $ \(State input (pos:|z) tp w) cok _ eok _ -> + let pxy = Proxy :: Proxy s + (ts, input') = takeWhile_ f input + !npos = advanceN pxy w pos ts + len = chunkLength pxy ts + hs = + case ml >>= NE.nonEmpty of + Nothing -> mempty + Just l -> (Hints . pure . E.singleton . Label) l + in if chunkEmpty pxy ts + then eok ts (State input' (npos:|z) (tp + len) w) hs + else cok ts (State input' (npos:|z) (tp + len) w) hs +{-# INLINE pTakeWhileP #-} + +pTakeWhile1P :: forall e s m. Stream s + => Maybe String + -> (Token s -> Bool) + -> ParsecT e s m (Tokens s) +pTakeWhile1P ml f = ParsecT $ \(State input (pos:|z) tp w) cok _ _ eerr -> + let pxy = Proxy :: Proxy s + (ts, input') = takeWhile_ f input + len = chunkLength pxy ts + el = Label <$> (ml >>= NE.nonEmpty) + hs = + case el of + Nothing -> mempty + Just l -> (Hints . pure . E.singleton) l + in if chunkEmpty pxy ts + then let !apos = positionAtN pxy pos ts + us = pure $ + case take1_ input of + Nothing -> EndOfInput + Just (t,_) -> Tokens (nes t) + ps = maybe E.empty E.singleton el + in eerr (TrivialError (apos:|z) us ps) + (State input (apos:|z) tp w) + else let !npos = advanceN pxy w pos ts + in cok ts (State input' (npos:|z) (tp + len) w) hs +{-# INLINE pTakeWhile1P #-} + +pTakeP :: forall e s m. Stream s + => Maybe String + -> Int + -> ParsecT e s m (Tokens s) +pTakeP ml n = ParsecT $ \s@(State input (pos:|z) tp w) cok _ _ eerr -> + let pxy = Proxy :: Proxy s + el = Label <$> (ml >>= NE.nonEmpty) + ps = maybe E.empty E.singleton el + in case takeN_ n input of + Nothing -> + eerr (TrivialError (pos:|z) (pure EndOfInput) ps) s + Just (ts, input') -> + let len = chunkLength pxy ts + !apos = positionAtN pxy pos ts + !npos = advanceN pxy w pos ts + in if len /= n + then eerr (TrivialError (npos:|z) (pure EndOfInput) ps) + (State input (apos:|z) tp w) + else cok ts (State input' (npos:|z) (tp + len) w) mempty +{-# INLINE pTakeP #-} + +pGetParserState :: ParsecT e s m (State s) +pGetParserState = ParsecT $ \s _ _ eok _ -> eok s s mempty +{-# INLINE pGetParserState #-} + +pUpdateParserState :: (State s -> State s) -> ParsecT e s m () +pUpdateParserState f = ParsecT $ \s _ _ eok _ -> eok () (f s) mempty +{-# INLINE pUpdateParserState #-} + +nes :: a -> NonEmpty a +nes x = x :| [] +{-# INLINE nes #-} + +---------------------------------------------------------------------------- +-- Helper functions + +-- | Convert 'ParseError' record into 'Hints'. + +toHints :: NonEmpty SourcePos -> ParseError t e -> Hints t +toHints streamPos = \case + TrivialError errPos _ ps -> + -- NOTE This is important to check here that the error indeed has + -- happened at the same position as current position of stream because + -- there might have been backtracking with 'try' and in that case we + -- must not convert such a parse error to hints. + if streamPos == errPos + then Hints (if E.null ps then [] else [ps]) + else mempty + FancyError _ _ -> mempty +{-# INLINE toHints #-} + +-- | @withHints hs c@ makes “error” continuation @c@ use given hints @hs@. +-- +-- Note that if resulting continuation gets 'ParseError' that has custom +-- data in it, hints are ignored. + +withHints :: Ord (Token s) + => Hints (Token s) -- ^ Hints to use + -> (ParseError (Token s) e -> State s -> m b) -- ^ Continuation to influence + -> ParseError (Token s) e -- ^ First argument of resulting continuation + -> State s -- ^ Second argument of resulting continuation + -> m b +withHints (Hints ps') c e = + case e of + TrivialError pos us ps -> c (TrivialError pos us (E.unions (ps : ps'))) + _ -> c e +{-# INLINE withHints #-} + +-- | @accHints hs c@ results in “OK” continuation that will add given hints +-- @hs@ to third argument of original continuation @c@. + +accHints + :: Hints t -- ^ 'Hints' to add + -> (a -> State s -> Hints t -> m b) -- ^ An “OK” continuation to alter + -> a -- ^ First argument of resulting continuation + -> State s -- ^ Second argument of resulting continuation + -> Hints t -- ^ Third argument of resulting continuation + -> m b +accHints hs1 c x s hs2 = c x s (hs1 <> hs2) +{-# INLINE accHints #-} + +-- | Replace the most recent group of hints (if any) with the given +-- 'ErrorItem' (or delete it if 'Nothing' is given). This is used in 'label' +-- primitive. + +refreshLastHint :: Hints t -> Maybe (ErrorItem t) -> Hints t +refreshLastHint (Hints []) _ = Hints [] +refreshLastHint (Hints (_:xs)) Nothing = Hints xs +refreshLastHint (Hints (_:xs)) (Just m) = Hints (E.singleton m : xs) +{-# INLINE refreshLastHint #-} + +-- | Low-level unpacking of the 'ParsecT' type. + +runParsecT :: Monad m + => ParsecT e s m a -- ^ Parser to run + -> State s -- ^ Initial state + -> m (Reply e s a) +runParsecT p s = unParser p s cok cerr eok eerr + where + cok a s' _ = return $ Reply s' Consumed (OK a) + cerr err s' = return $ Reply s' Consumed (Error err) + eok a s' _ = return $ Reply s' Virgin (OK a) + eerr err s' = return $ Reply s' Virgin (Error err) diff --git a/Text/Megaparsec/Pos.hs b/Text/Megaparsec/Pos.hs --- a/Text/Megaparsec/Pos.hs +++ b/Text/Megaparsec/Pos.hs @@ -14,6 +14,7 @@ -- You probably do not want to import this module directly because -- "Text.Megaparsec" re-exports it anyway. +{-# LANGUAGE CPP #-} {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} @@ -35,9 +36,12 @@ import Control.DeepSeq import Control.Exception import Data.Data (Data) -import Data.Semigroup import Data.Typeable (Typeable) import GHC.Generics + +#if !MIN_VERSION_base(4,11,0) +import Data.Semigroup +#endif ---------------------------------------------------------------------------- -- Abstract position diff --git a/Text/Megaparsec/State.hs b/Text/Megaparsec/State.hs new file mode 100644 --- /dev/null +++ b/Text/Megaparsec/State.hs @@ -0,0 +1,45 @@ +-- | +-- Module : Text.Megaparsec.State +-- Copyright : © 2015–2018 Megaparsec contributors +-- © 2007 Paolo Martini +-- © 1999–2001 Daan Leijen +-- License : FreeBSD +-- +-- Maintainer : Mark Karpov +-- Stability : experimental +-- Portability : portable +-- +-- Definition of Megaparsec's 'State'. +-- +-- @since 6.5.0 + +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE DeriveGeneric #-} + +module Text.Megaparsec.State + ( State (..) ) +where + +import Control.DeepSeq (NFData) +import Data.Data (Data) +import Data.List.NonEmpty (NonEmpty (..)) +import Data.Typeable (Typeable) +import GHC.Generics +import Text.Megaparsec.Pos + +-- | This is the Megaparsec's state parametrized over stream type @s@. + +data State s = State + { stateInput :: s + -- ^ The rest of input to process + , statePos :: NonEmpty SourcePos + -- ^ Current position (column + line number) with support for include files + , stateTokensProcessed :: {-# UNPACK #-} !Int + -- ^ Number of processed tokens so far + -- + -- @since 5.2.0 + , stateTabWidth :: Pos + -- ^ Tab width to use + } deriving (Show, Eq, Data, Typeable, Generic) + +instance NFData s => NFData (State s) diff --git a/bench/speed/Main.hs b/bench/speed/Main.hs --- a/bench/speed/Main.hs +++ b/bench/speed/Main.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE CPP #-} {-# LANGUAGE OverloadedStrings #-} module Main (main) where @@ -11,6 +12,10 @@ import Text.Megaparsec.Char import qualified Data.Text as T import qualified Text.Megaparsec.Char.Lexer as L + +#if !MIN_VERSION_base(4,8,0) +import Control.Applicative hiding (many, some) +#endif -- | The type of parser that consumes 'String's. diff --git a/megaparsec.cabal b/megaparsec.cabal --- a/megaparsec.cabal +++ b/megaparsec.cabal @@ -1,7 +1,7 @@ name: megaparsec -version: 6.4.1 -cabal-version: >= 1.18 -tested-with: GHC==7.8.4, GHC==7.10.3, GHC==8.0.2, GHC==8.2.2 +version: 6.5.0 +cabal-version: 1.18 +tested-with: GHC==7.8.4, GHC==7.10.3, GHC==8.0.2, GHC==8.2.2, GHC==8.4.1 license: BSD2 license-file: LICENSE.md author: Megaparsec contributors, @@ -57,24 +57,34 @@ , Text.Megaparsec.Error , Text.Megaparsec.Error.Builder , Text.Megaparsec.Expr + , Text.Megaparsec.Internal , Text.Megaparsec.Perm , Text.Megaparsec.Pos , Text.Megaparsec.Stream + other-modules: Text.Megaparsec.Class + , Text.Megaparsec.State if flag(dev) ghc-options: -O0 -Wall -Werror else ghc-options: -O2 -Wall + if flag(dev) && impl(ghc >= 8.0) + ghc-options: -Wcompat + -Wincomplete-record-updates + -Wincomplete-uni-patterns + -Wnoncanonical-monad-instances + -Wnoncanonical-monadfail-instances default-language: Haskell2010 test-suite tests - main-is: Spec.hs + main-is: Main.hs hs-source-dirs: tests type: exitcode-stdio-1.0 if flag(dev) ghc-options: -O0 -Wall -Werror else ghc-options: -O2 -Wall - other-modules: Control.Applicative.CombinatorsSpec + other-modules: Spec + , Control.Applicative.CombinatorsSpec , Control.Monad.CombinatorsSpec , Test.Hspec.Megaparsec , Test.Hspec.Megaparsec.AdHoc @@ -88,7 +98,7 @@ , Text.Megaparsec.PosSpec , Text.Megaparsec.StreamSpec , Text.MegaparsecSpec - build-depends: QuickCheck >= 2.7 && < 2.11 + build-depends: QuickCheck >= 2.7 && < 2.12 , base >= 4.7 && < 5.0 , bytestring >= 0.2 && < 0.11 , containers >= 0.5 && < 0.6 @@ -99,6 +109,7 @@ , scientific >= 0.3.1 && < 0.4 , text >= 0.2 && < 1.3 , transformers >= 0.4 && < 0.6 + build-tools: hspec-discover >= 2.0 && < 3.0 if !impl(ghc >= 8.0) build-depends: semigroups == 0.18.* if !impl(ghc >= 7.10) @@ -110,7 +121,7 @@ hs-source-dirs: bench/speed type: exitcode-stdio-1.0 build-depends: base >= 4.7 && < 5.0 - , criterion >= 0.6.2.1 && < 1.4 + , criterion >= 0.6.2.1 && < 1.5 , deepseq >= 1.3 && < 1.5 , megaparsec , text >= 0.2 && < 1.3 diff --git a/tests/Control/Applicative/CombinatorsSpec.hs b/tests/Control/Applicative/CombinatorsSpec.hs --- a/tests/Control/Applicative/CombinatorsSpec.hs +++ b/tests/Control/Applicative/CombinatorsSpec.hs @@ -6,7 +6,6 @@ import Data.Char (isLetter, isDigit) import Data.List (intersperse) import Data.Maybe (fromMaybe, maybeToList, isNothing, fromJust) -import Data.Monoid import Test.Hspec import Test.Hspec.Megaparsec import Test.Hspec.Megaparsec.AdHoc @@ -16,6 +15,9 @@ #if !MIN_VERSION_base(4,8,0) import Control.Applicative hiding (many, some) +#endif +#if !MIN_VERSION_base(4,11,0) +import Data.Monoid #endif spec :: Spec diff --git a/tests/Control/Monad/CombinatorsSpec.hs b/tests/Control/Monad/CombinatorsSpec.hs --- a/tests/Control/Monad/CombinatorsSpec.hs +++ b/tests/Control/Monad/CombinatorsSpec.hs @@ -5,7 +5,6 @@ import Data.List (intersperse) import Data.Maybe (maybeToList, isNothing, fromJust) -import Data.Monoid import Test.Hspec import Test.Hspec.Megaparsec import Test.Hspec.Megaparsec.AdHoc @@ -15,6 +14,9 @@ #if !MIN_VERSION_base(4,8,0) import Control.Applicative hiding (many, some) +#endif +#if !MIN_VERSION_base(4,11,0) +import Data.Monoid #endif spec :: Spec diff --git a/tests/Main.hs b/tests/Main.hs new file mode 100644 --- /dev/null +++ b/tests/Main.hs @@ -0,0 +1,7 @@ +module Main (main) where + +import Test.Hspec.Runner +import Spec (spec) + +main :: IO () +main = hspecWith defaultConfig { configQuickCheckMaxSuccess = Just 1000 } spec diff --git a/tests/Spec.hs b/tests/Spec.hs --- a/tests/Spec.hs +++ b/tests/Spec.hs @@ -1,1 +1,1 @@ -{-# OPTIONS_GHC -F -pgmF hspec-discover #-} +{-# OPTIONS_GHC -F -pgmF hspec-discover -optF --module-name=Spec #-} diff --git a/tests/Test/Hspec/Megaparsec.hs b/tests/Test/Hspec/Megaparsec.hs --- a/tests/Test/Hspec/Megaparsec.hs +++ b/tests/Test/Hspec/Megaparsec.hs @@ -9,7 +9,6 @@ -- -- Utility functions for testing Megaparsec parsers with Hspec. -{-# LANGUAGE CPP #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-} @@ -166,9 +165,7 @@ initialState s = State { stateInput = s , statePos = initialPos "" :| [] -#if MIN_VERSION_megaparsec(5,2,0) , stateTokensProcessed = 0 -#endif , stateTabWidth = defaultTabWidth } ---------------------------------------------------------------------------- diff --git a/tests/Text/Megaparsec/ErrorSpec.hs b/tests/Text/Megaparsec/ErrorSpec.hs --- a/tests/Text/Megaparsec/ErrorSpec.hs +++ b/tests/Text/Megaparsec/ErrorSpec.hs @@ -7,7 +7,6 @@ import Data.Char (isControl, isSpace) import Data.List (isInfixOf, isSuffixOf) import Data.List.NonEmpty (NonEmpty (..)) -import Data.Monoid import Data.Void import Data.Word (Word8) import Test.Hspec @@ -26,6 +25,9 @@ import Prelude hiding (all) #else import Control.Exception (Exception (..)) +#endif +#if !MIN_VERSION_base(4,11,0) +import Data.Monoid #endif type PE = ParseError Char Void diff --git a/tests/Text/Megaparsec/PermSpec.hs b/tests/Text/Megaparsec/PermSpec.hs --- a/tests/Text/Megaparsec/PermSpec.hs +++ b/tests/Text/Megaparsec/PermSpec.hs @@ -1,10 +1,10 @@ +{-# LANGUAGE CPP #-} {-# LANGUAGE MultiWayIf #-} module Text.Megaparsec.PermSpec (spec) where import Control.Applicative import Data.List (nub, elemIndices) -import Data.Monoid import Test.Hspec import Test.Hspec.Megaparsec import Test.Hspec.Megaparsec.AdHoc @@ -12,6 +12,10 @@ import Text.Megaparsec.Char import Text.Megaparsec.Char.Lexer (decimal) import Text.Megaparsec.Perm + +#if !MIN_VERSION_base(4,11,0) +import Data.Monoid +#endif data CharRows = CharRows { getChars :: (Char, Char, Char)