megaparsec 5.1.2 → 5.2.0
raw patch · 32 files changed
+775/−386 lines, 32 filesdep +weighdep ~bytestringdep ~megaparsec
Dependencies added: weigh
Dependency ranges changed: bytestring, megaparsec
Files
- AUTHORS.md +1/−0
- CHANGELOG.md +34/−0
- LICENSE.md +1/−1
- README.md +20/−5
- Text/Megaparsec.hs +15/−5
- Text/Megaparsec/ByteString.hs +1/−1
- Text/Megaparsec/ByteString/Lazy.hs +1/−1
- Text/Megaparsec/Char.hs +1/−1
- Text/Megaparsec/Combinator.hs +13/−11
- Text/Megaparsec/Error.hs +1/−1
- Text/Megaparsec/Expr.hs +1/−1
- Text/Megaparsec/Lexer.hs +31/−18
- Text/Megaparsec/Perm.hs +1/−1
- Text/Megaparsec/Pos.hs +2/−3
- Text/Megaparsec/Prim.hs +133/−74
- Text/Megaparsec/String.hs +1/−1
- Text/Megaparsec/Text.hs +1/−1
- Text/Megaparsec/Text/Lazy.hs +1/−1
- bench-memory/Main.hs +93/−0
- bench-speed/Main.hs +93/−0
- benchmarks/Main.hs +0/−192
- megaparsec.cabal +27/−14
- tests/Test/Hspec/Megaparsec.hs +6/−2
- tests/Test/Hspec/Megaparsec/AdHoc.hs +17/−1
- tests/Text/Megaparsec/CharSpec.hs +3/−3
- tests/Text/Megaparsec/CombinatorSpec.hs +1/−1
- tests/Text/Megaparsec/ErrorSpec.hs +1/−1
- tests/Text/Megaparsec/ExprSpec.hs +1/−1
- tests/Text/Megaparsec/LexerSpec.hs +36/−4
- tests/Text/Megaparsec/PermSpec.hs +1/−1
- tests/Text/Megaparsec/PosSpec.hs +1/−1
- tests/Text/Megaparsec/PrimSpec.hs +236/−39
AUTHORS.md view
@@ -49,3 +49,4 @@ * Simon Vandel * Slava Shklyaev * Tal Walter+* Tomáš Janoušek
CHANGELOG.md view
@@ -1,3 +1,37 @@+## Megaparsec 5.2.0++* Added `MonadParsec` instance for `RWST`.++* Allowed `many` to run parsers that do not consume input. Previously this+ signalled an `error` which was ugly. Of course, in most cases giving+ `many` a parser that do not consume input will lead to non-termination+ bugs, but there are legal cases when this should be allowed. The test+ suite now contains an example of this. Non-termination issues is something+ inherited from the power Megaparsec gives (with more power comes more+ responsibility), so that `error` case in `many` really does not solve the+ problem, it was just a little ah-hoc guard we got from Parsec's past.++* The criterion benchmark was completely re-written and a new weigh+ benchmark to analyze memory consumption was added.++* Performance improvements: `count` (marginal improvement, simpler+ implementation), `count'` (considerable improvement), and `many`+ (marginal improvement, simpler implementation).++* Added `stateTokensProcessed` field to parser state and helper functions+ `getTokensProcessed` and `setTokensProcessed`. The field contains number+ of processed tokens so far. This allows, for example, create wrappers that+ return just parsed fragment of input stream alongside with result of+ parsing. (It was possible before, but very inefficient because it required+ traversing entire input stream twice.)++* `IndentNone` option of `indentBlock` now picks whitespace after it like+ its sisters `IndentMany` and `IndentSome` do, see #161.++* Fixed a couple of quite subtle bugs in `indentBlock` introduced by+ changing behaviour of `skipLineComment` in version 5.1.0. See #178 for+ more information.+ ## Megaparsec 5.1.2 * Stopped using property tests with `dbg` helper to avoid flood of debugging
LICENSE.md view
@@ -1,4 +1,4 @@-Copyright © 2015–2016 Megaparsec contributors<br>+Copyright © 2015–2017 Megaparsec contributors<br> Copyright © 2007 Paolo Martini<br> Copyright © 1999–2000 Daan Leijen
README.md view
@@ -23,6 +23,7 @@ * [Megaparsec and Parsec](#megaparsec-and-parsec) * [Megaparsec and Parsers](#megaparsec-and-parsers) * [Related packages](#related-packages)+* [Links to announcements](#links-to-announcements) * [Authors](#authors) * [Contribution](#contribution) * [License](#license)@@ -102,7 +103,8 @@ description of every primitive function in [Megaparsec documentation](https://hackage.haskell.org/package/megaparsec/docs/Text-Megaparsec-Prim.html). -Megaparsec can currently work with the following types of input stream:+Megaparsec can currently work with the following types of input stream+out-of-box: * `String` = `[Char]` @@ -205,9 +207,12 @@ ## Tutorials You can visit [site of the project](https://mrkkrp.github.io/megaparsec/)-which has [several tutorials](https://mrkkrp.github.io/megaparsec/tutorials.html) that-should help you to start with your parsing tasks. The site also has-instructions and tips for Parsec users who decide to switch.+which+has [several tutorials](https://mrkkrp.github.io/megaparsec/tutorials.html)+that should help you to start with your parsing tasks. The site also has+instructions and tips for Parsec users who decide to switch. If you want to+improve an existing tutorial or add your own, open a PR+against [this repo](https://github.com/mrkkrp/megaparsec-site). ## Performance @@ -330,6 +335,16 @@ — a library for easily using [TagSoup](https://hackage.haskell.org/package/tagsoup) as a token type in Megaparsec. +## Links to announcements++Here are some blog posts mainly announcing new features of the project and+describing what sort of things are now possible:++* [The original Megaparsec 4.0.0 announcement](https://notehub.org/w7037)+* [Megaparsec 4 and 5](https://mrkkrp.github.io/posts/megaparsec-4-and-5.html)+* [Announcing Megaparsec 5](https://mrkkrp.github.io/posts/announcing-megaparsec-5.html)+* [Latest additions to Megaparsec](https://mrkkrp.github.io/posts/latest-additions-to-megaparsec.html)+ ## Authors The project was started and is currently maintained by Mark Karpov. You can@@ -351,7 +366,7 @@ ## License -Copyright © 2015–2016 Megaparsec contributors<br>+Copyright © 2015–2017 Megaparsec contributors<br> Copyright © 2007 Paolo Martini<br> Copyright © 1999–2000 Daan Leijen
Text/Megaparsec.hs view
@@ -1,6 +1,6 @@ -- | -- Module : Text.Megaparsec--- Copyright : © 2015–2016 Megaparsec contributors+-- Copyright : © 2015–2017 Megaparsec contributors -- © 2007 Paolo Martini -- © 1999–2001 Daan Leijen -- License : FreeBSD@@ -33,8 +33,16 @@ -- > -- import Text.Megaparsec.Text.Lazy -- -- As you can see the second import depends on data type you want to use as--- input stream. It just defines useful type-synonym @Parser@.+-- input stream. It just defines the useful type-synonym @Parser@. --+-- Megaparsec 5 uses some type-level machinery to provide flexibility+-- without compromising on type safety. Thus type signatures are sometimes+-- necessary to avoid ambiguous types. If you're seeing a error message that+-- reads like “Ambiguous type variable @e0@ arising from … prevents the+-- constraint @(ErrorComponent e0)@ from being resolved”, you need to give+-- an explicit signature to your parser to eliminate the ambiguity. It's a+-- good idea to provide type signatures for all top-level definitions.+-- -- Megaparsec is capable of a lot. Apart from this standard functionality -- you can parse permutation phrases with "Text.Megaparsec.Perm", -- expressions with "Text.Megaparsec.Expr", and even entire languages with@@ -45,13 +53,13 @@ ( -- * Running parser Parsec , ParsecT+ , parse+ , parseMaybe+ , parseTest , runParser , runParser' , runParserT , runParserT'- , parse- , parseMaybe- , parseTest -- * Combinators , (A.<|>) -- $assocbo@@ -152,6 +160,8 @@ , setPosition , pushPosition , popPosition+ , getTokensProcessed+ , setTokensProcessed , getTabWidth , setTabWidth , getParserState
Text/Megaparsec/ByteString.hs view
@@ -1,6 +1,6 @@ -- | -- Module : Text.Megaparsec.ByteString--- Copyright : © 2015–2016 Megaparsec contributors+-- Copyright : © 2015–2017 Megaparsec contributors -- License : FreeBSD -- -- Maintainer : Mark Karpov <markkarpov@opmbx.org>
Text/Megaparsec/ByteString/Lazy.hs view
@@ -1,6 +1,6 @@ -- | -- Module : Text.Megaparsec.ByteString.Lazy--- Copyright : © 2015–2016 Megaparsec contributors+-- Copyright : © 2015–2017 Megaparsec contributors -- License : FreeBSD -- -- Maintainer : Mark Karpov <markkarpov@opmbx.org>
Text/Megaparsec/Char.hs view
@@ -1,6 +1,6 @@ -- | -- Module : Text.Megaparsec.Char--- Copyright : © 2015–2016 Megaparsec contributors+-- Copyright : © 2015–2017 Megaparsec contributors -- © 2007 Paolo Martini -- © 1999–2001 Daan Leijen -- License : FreeBSD
Text/Megaparsec/Combinator.hs view
@@ -1,6 +1,6 @@ -- | -- Module : Text.Megaparsec.Combinator--- Copyright : © 2015–2016 Megaparsec contributors+-- Copyright : © 2015–2017 Megaparsec contributors -- © 2007 Paolo Martini -- © 1999–2001 Daan Leijen -- License : FreeBSD@@ -12,7 +12,8 @@ -- Commonly used generic combinators. Note that all combinators works with -- any 'Alternative' instances. -{-# LANGUAGE CPP #-}+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE CPP #-} module Text.Megaparsec.Combinator ( between@@ -63,9 +64,7 @@ -- values. count :: Applicative m => Int -> m a -> m [a]-count n p- | n <= 0 = pure []- | otherwise = sequenceA (replicate n p)+count n p = sequenceA (replicate n p) {-# INLINE count #-} -- | @count\' m n p@ parses from @m@ to @n@ occurrences of @p@. If @n@ is@@ -76,12 +75,15 @@ -- as if it were equal to zero. count' :: Alternative m => Int -> Int -> m a -> m [a]-count' m n p- | n <= 0 || m > n = pure []- | m > 0 = (:) <$> p <*> count' (pred m) (pred n) p- | otherwise =- let f t ts = maybe [] (:ts) t- in f <$> optional p <*> count' 0 (pred n) p+count' m' n' p = go m' n'+ where+ go !m !n+ | n <= 0 || m > n = pure []+ | m > 0 = (:) <$> p <*> go (m - 1) (n - 1)+ | otherwise =+ let f t ts = maybe [] (:ts) t+ in f <$> optional p <*> go 0 (pred n)+{-# INLINE count' #-} -- | Combine two alternatives. --
Text/Megaparsec/Error.hs view
@@ -1,6 +1,6 @@ -- | -- Module : Text.Megaparsec.Error--- Copyright : © 2015–2016 Megaparsec contributors+-- Copyright : © 2015–2017 Megaparsec contributors -- License : FreeBSD -- -- Maintainer : Mark Karpov <markkarpov@opmbx.org>
Text/Megaparsec/Expr.hs view
@@ -1,6 +1,6 @@ -- | -- Module : Text.Megaparsec.Expr--- Copyright : © 2015–2016 Megaparsec contributors+-- Copyright : © 2015–2017 Megaparsec contributors -- © 2007 Paolo Martini -- © 1999–2001 Daan Leijen -- License : FreeBSD
Text/Megaparsec/Lexer.hs view
@@ -1,6 +1,6 @@ -- | -- Module : Text.Megaparsec.Lexer--- Copyright : © 2015–2016 Megaparsec contributors+-- Copyright : © 2015–2017 Megaparsec contributors -- © 2007 Paolo Martini -- © 1999–2001 Daan Leijen -- License : FreeBSD@@ -20,6 +20,7 @@ {-# LANGUAGE CPP #-} {-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE MultiWayIf #-} {-# LANGUAGE TypeFamilies #-} module Text.Megaparsec.Lexer@@ -99,7 +100,7 @@ -- of the file). space :: MonadParsec e s m- => m () -- ^ A parser for a space character (e.g. 'C.spaceChar')+ => m () -- ^ A parser for a space character (e.g. @'void' 'C.spaceChar'@) -> m () -- ^ A parser for a line comment (e.g. 'skipLineComment') -> m () -- ^ A parser for a block comment (e.g. 'skipBlockComment') -> m ()@@ -264,7 +265,7 @@ -- ^ Parse many indented tokens (possibly zero), use given indentation -- level (if 'Nothing', use level of the first indented token); the -- second argument tells how to get final result, and third argument- -- describes how to parse indented token+ -- describes how to parse an indented token | IndentSome (Maybe Pos) ([b] -> m a) (m b) -- ^ Just like 'IndentMany', but requires at least one indented token to -- be present@@ -289,15 +290,19 @@ ref <- indentLevel a <- r case a of- IndentNone x -> return x+ IndentNone x -> sc *> return x IndentMany indent f p -> do- mlvl <- optional . try $ C.eol *> indentGuard sc GT ref- case mlvl of- Nothing -> sc *> f []- Just lvl -> indentedItems ref (fromMaybe lvl indent) sc p >>= f+ mlvl <- (optional . try) (C.eol *> indentGuard sc GT ref)+ done <- isJust <$> optional eof+ case (mlvl, done) of+ (Just lvl, False) ->+ indentedItems ref (fromMaybe lvl indent) sc p >>= f+ _ -> sc *> f [] IndentSome indent f p -> do lvl <- C.eol *> indentGuard sc GT ref- indentedItems ref (fromMaybe lvl indent) sc p >>= f+ x <- p+ xs <- indentedItems ref (fromMaybe lvl indent) sc p+ f (x:xs) -- | Grab indented items. This is a helper for 'indentBlock', it's not a -- part of public API.@@ -310,15 +315,15 @@ -> m [b] indentedItems ref lvl sc p = go where- go = (sc *> indentLevel) >>= re- re pos- | pos <= ref = return []- | pos == lvl = (:) <$> p <*> go- | otherwise = do- done <- isJust <$> optional eof- if done- then return []- else incorrectIndent EQ lvl pos+ go = do+ sc+ pos <- indentLevel+ done <- isJust <$> optional eof+ if done+ then return []+ else if | pos <= ref -> return []+ | pos == lvl -> (:) <$> p <*> go+ | otherwise -> incorrectIndent EQ lvl pos -- | Create a parser that supports line-folding. The first argument is used -- to consume white space between components of line fold, thus it /must/@@ -361,6 +366,14 @@ -- string literals: -- -- > stringLiteral = char '"' >> manyTill L.charLiteral (char '"')+--+-- If you want to write @stringLiteral@ that adheres to the Haskell report+-- though, you'll need to take care of the @\\&@ combination which is not a+-- character, but can be used to separate characters (as in @\"\\291\\&4\"@+-- which is two characters long):+--+-- > stringLiteral = catMaybes <$> (char '"' >> manyTill ch (char '"'))+-- > where ch = (Just <$> L.charLiteral) <|> (Nothing <$ string "\\&") charLiteral :: (MonadParsec e s m, Token s ~ Char) => m Char charLiteral = label "literal character" $ do
Text/Megaparsec/Perm.hs view
@@ -1,6 +1,6 @@ -- | -- Module : Text.Megaparsec.Perm--- Copyright : © 2015–2016 Megaparsec contributors+-- Copyright : © 2015–2017 Megaparsec contributors -- © 2007 Paolo Martini -- © 1999–2001 Daan Leijen -- License : FreeBSD
Text/Megaparsec/Pos.hs view
@@ -1,6 +1,6 @@ -- | -- Module : Text.Megaparsec.Pos--- Copyright : © 2015–2016 Megaparsec contributors+-- Copyright : © 2015–2017 Megaparsec contributors -- License : FreeBSD -- -- Maintainer : Mark Karpov <markkarpov@opmbx.org>@@ -40,7 +40,6 @@ import Data.Typeable (Typeable) import GHC.Generics import Test.QuickCheck-import Unsafe.Coerce #if !MIN_VERSION_base(4,8,0) import Control.Applicative@@ -93,7 +92,7 @@ -- @since 5.0.0 unPos :: Pos -> Word-unPos = unsafeCoerce+unPos (Pos w) = w {-# INLINE unPos #-} instance Semigroup Pos where
Text/Megaparsec/Prim.hs view
@@ -1,6 +1,6 @@ -- | -- Module : Text.Megaparsec.Prim--- Copyright : © 2015–2016 Megaparsec contributors+-- Copyright : © 2015–2017 Megaparsec contributors -- © 2007 Paolo Martini -- © 1999–2001 Daan Leijen -- License : FreeBSD@@ -44,17 +44,19 @@ , setPosition , pushPosition , popPosition+ , getTokensProcessed+ , setTokensProcessed , getTabWidth , setTabWidth , setParserState -- * Running parser+ , parse+ , parseMaybe+ , parseTest , runParser , runParser' , runParserT , runParserT'- , parse- , parseMaybe- , parseTest -- * Debugging , dbg ) where@@ -70,6 +72,7 @@ import Control.Monad.Trans.Identity import Data.Data (Data) import Data.Foldable (foldl')+import Data.List (genericTake) import Data.List.NonEmpty (NonEmpty (..)) import Data.Monoid hiding ((<>)) import Data.Proxy@@ -82,6 +85,8 @@ import Test.QuickCheck hiding (Result (..), label) 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@@ -99,6 +104,7 @@ #if !MIN_VERSION_base(4,8,0) import Control.Applicative+import Data.Word (Word) #endif ----------------------------------------------------------------------------@@ -107,10 +113,17 @@ -- | This is Megaparsec's state, it's parametrized over stream type @s@. data State s = State- { stateInput :: s- , statePos :: NonEmpty SourcePos- , stateTabWidth :: Pos }- deriving (Show, Eq, Data, Typeable, Generic)+ { stateInput :: s+ -- ^ Current input (already processed input is removed from the stream)+ , statePos :: NonEmpty SourcePos+ -- ^ Current position (column + line number) with support for include files+ , stateTokensProcessed :: {-# UNPACK #-} !Word+ -- ^ 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) @@ -123,6 +136,7 @@ #else arbitrary #endif+ <*> choose (1, 10000) <*> (unsafePos <$> choose (1, 20)) -- | All information available after parsing. This includes consumption of@@ -374,24 +388,7 @@ instance (ErrorComponent e, Stream s) => A.Alternative (ParsecT e s m) where empty = mzero (<|>) = mplus- many p = reverse <$> manyAcc p -manyAcc :: ParsecT e s m a -> ParsecT e s m [a]-manyAcc p = ParsecT $ \s cok cerr eok _ ->- let errToHints c err _ = c (toHints err)- walk xs x s' _ =- unParser p s'- (seq xs $ walk $ x:xs) -- consumed-OK- cerr -- consumed-error- manyErr -- empty-OK- (errToHints $ cok (x:xs) s') -- empty-error- in unParser p s (walk []) cerr manyErr (errToHints $ eok [] s)--manyErr :: a-manyErr = error $- "Text.Megaparsec.Prim.many: combinator 'many' is applied to a parser"- ++ " that may consume no input."- instance (ErrorComponent e, Stream s) => Monad (ParsecT e s m) where return = pure@@ -419,7 +416,7 @@ fail = pFail pFail :: ErrorComponent e => String -> ParsecT e s m a-pFail msg = ParsecT $ \s@(State _ pos _) _ _ _ eerr ->+pFail msg = ParsecT $ \s@(State _ pos _ _) _ _ _ eerr -> eerr (ParseError pos E.empty E.empty d) s where d = E.singleton (representFail msg) {-# INLINE pFail #-}@@ -473,7 +470,7 @@ mplus = pPlus pZero :: ParsecT e s m a-pZero = ParsecT $ \s@(State _ pos _) _ _ _ eerr ->+pZero = ParsecT $ \s@(State _ pos _ _) _ _ _ eerr -> eerr (ParseError pos E.empty E.empty E.empty) s {-# INLINE pZero #-} @@ -490,12 +487,13 @@ in unParser m s cok cerr eok meerr {-# INLINE pPlus #-} --- | From two states, return the one with greater textual position. If the--- positions are equal, prefer the latter state.+-- | From two states, return the one with greater number of processed+-- tokens. If the numbers of processed tokens are equal, prefer the latter+-- state. longestMatch :: State s -> State s -> State s-longestMatch s1@(State _ pos1 _) s2@(State _ pos2 _) =- case pos1 `compare` pos2 of+longestMatch s1@(State _ _ tp1 _) s2@(State _ _ tp2 _) =+ case tp1 `compare` tp2 of LT -> s2 EQ -> s2 GT -> s1@@ -709,7 +707,7 @@ -> Set (ErrorItem (Token s)) -> Set e -> ParsecT e s m a-pFailure us ps xs = ParsecT $ \s@(State _ pos _) _ _ _ eerr ->+pFailure us ps xs = ParsecT $ \s@(State _ pos _ _) _ _ _ eerr -> eerr (ParseError pos us ps xs) s {-# INLINE pFailure #-} @@ -737,7 +735,7 @@ {-# INLINE pLookAhead #-} pNotFollowedBy :: Stream s => ParsecT e s m a -> ParsecT e s m ()-pNotFollowedBy p = ParsecT $ \s@(State input pos _) _ _ eok eerr ->+pNotFollowedBy p = ParsecT $ \s@(State input pos _ _) _ _ eok eerr -> let what = maybe EndOfInput (Tokens . nes . fst) (uncons input) unexpect u = ParseError pos (E.singleton u) E.empty E.empty cok' _ _ _ = eerr (unexpect what) s@@ -777,7 +775,7 @@ {-# INLINE pObserving #-} pEof :: forall e s m. Stream s => ParsecT e s m ()-pEof = ParsecT $ \s@(State input (pos:|z) w) _ _ eok eerr ->+pEof = ParsecT $ \s@(State input (pos:|z) tp w) _ _ eok eerr -> case uncons input of Nothing -> eok () s mempty Just (x,_) ->@@ -787,7 +785,7 @@ , errorUnexpected = (E.singleton . Tokens . nes) x , errorExpected = E.singleton EndOfInput , errorCustom = E.empty }- (State input (apos:|z) w)+ (State input (apos:|z) tp w) {-# INLINE pEof #-} pToken :: forall e s m a. Stream s@@ -796,7 +794,7 @@ , Set e ) a) -> Maybe (Token s) -> ParsecT e s m a-pToken test mtoken = ParsecT $ \s@(State input (pos:|z) w) cok _ _ eerr ->+pToken test mtoken = ParsecT $ \s@(State input (pos:|z) tp w) cok _ _ eerr -> case uncons input of Nothing -> eerr ParseError { errorPos = pos:|z@@ -809,9 +807,9 @@ Left (us, ps, xs) -> apos `seq` eerr (ParseError (apos:|z) us ps xs)- (State input (apos:|z) w)+ (State input (apos:|z) tp w) Right x ->- let newstate = State cs (npos:|z) w+ let newstate = State cs (npos:|z) (tp + 1) w in npos `seq` cok x newstate mempty {-# INLINE pToken #-} @@ -820,7 +818,7 @@ -> [Token s] -> ParsecT e s m [Token s] pTokens _ [] = ParsecT $ \s _ _ eok _ -> eok [] s mempty-pTokens test tts = ParsecT $ \s@(State input (pos:|z) w) cok _ _ eerr ->+pTokens test tts = ParsecT $ \s@(State input (pos:|z) tp w) cok _ _ eerr -> let updatePos' = updatePos (Proxy :: Proxy s) w toTokens = Tokens . NE.fromList . reverse unexpect pos' u = ParseError@@ -830,20 +828,23 @@ , errorCustom = E.empty } go _ [] is rs = let ris = reverse is- !npos = foldl' (\p t -> snd (updatePos' p t)) pos ris- in cok ris (State rs (npos:|z) w) mempty+ (npos, tp') = foldl'+ (\(p, n) t -> (snd (updatePos' p t), n + 1))+ (pos, tp)+ ris+ in cok ris (State rs (npos:|z) tp' w) mempty go apos (t:ts) is rs = case uncons rs of Nothing -> apos `seq` eerr (unexpect (apos:|z) (toTokens is))- (State input (apos:|z) w)+ (State input (apos:|z) tp w) Just (x,xs) -> if test t x then go apos ts (x:is) xs else apos `seq` eerr (unexpect (apos:|z) . toTokens $ x:is)- (State input (apos:|z) w)+ (State input (apos:|z) tp w) in case uncons input of Nothing -> eerr (unexpect (pos:|z) EndOfInput) s@@ -854,7 +855,7 @@ then go apos ts [x] xs else apos `seq` eerr (unexpect (apos:|z) $ Tokens (nes x))- (State input (apos:|z) w)+ (State input (apos:|z) tp w) {-# INLINE pTokens #-} pGetParserState :: ParsecT e s m (State s)@@ -897,7 +898,7 @@ -- 'setInput' functions can for example be used to deal with include files. setInput :: MonadParsec e s m => s -> m ()-setInput s = updateParserState (\(State _ pos w) -> State s pos w)+setInput s = updateParserState (\(State _ pos tp w) -> State s pos tp w) -- | Return the current source position. --@@ -911,8 +912,8 @@ -- See also: 'getPosition', 'pushPosition', 'popPosition', and 'SourcePos'. setPosition :: MonadParsec e s m => SourcePos -> m ()-setPosition pos = updateParserState $ \(State s (_:|z) w) ->- State s (pos:|z) w+setPosition pos = updateParserState $ \(State s (_:|z) tp w) ->+ State s (pos:|z) tp w -- | Push given position into stack of positions and continue parsing -- working with this position. Useful for working with include files and the@@ -923,8 +924,8 @@ -- @since 5.0.0 pushPosition :: MonadParsec e s m => SourcePos -> m ()-pushPosition pos = updateParserState $ \(State s z w) ->- State s (NE.cons pos z) w+pushPosition pos = updateParserState $ \(State s z tp w) ->+ State s (NE.cons pos z) tp w -- | Pop a position from stack of positions unless it only contains one -- element (in that case stack of positions remains the same). This is how@@ -935,11 +936,26 @@ -- @since 5.0.0 popPosition :: MonadParsec e s m => m ()-popPosition = updateParserState $ \(State s z w) ->+popPosition = updateParserState $ \(State s z tp w) -> case snd (NE.uncons z) of- Nothing -> State s z w- Just z' -> State s z' w+ Nothing -> State s z tp w+ Just z' -> State s z' tp w +-- | Get number of tokens processed so far.+--+-- @since 5.2.0++getTokensProcessed :: MonadParsec e s m => m Word+getTokensProcessed = stateTokensProcessed <$> getParserState++-- | Set number of tokens processed so far.+--+-- @since 5.2.0++setTokensProcessed :: MonadParsec e s m => Word -> m ()+setTokensProcessed tp = updateParserState $ \(State s pos _ w) ->+ State s pos tp w+ -- | Return tab width. Default tab width is equal to 'defaultTabWidth'. You -- can set different tab width with help of 'setTabWidth'. @@ -950,7 +966,8 @@ -- 'defaultTabWidth' will be used. setTabWidth :: MonadParsec e s m => Pos -> m ()-setTabWidth w = updateParserState (\(State s pos _) -> State s pos w)+setTabWidth w = updateParserState $ \(State s pos tp _) ->+ State s pos tp w -- | @setParserState st@ set the full parser state to @st@. @@ -1067,11 +1084,6 @@ 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 s (initialPos name :| []) defaultTabWidth- -- | Low-level unpacking of the 'ParsecT' type. 'runParserT' and 'runParser' -- are built upon this. @@ -1085,6 +1097,15 @@ 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 }+ ---------------------------------------------------------------------------- -- Instances of 'MonadParsec' @@ -1124,7 +1145,7 @@ getParserState = lift getParserState updateParserState f = lift (updateParserState f) -instance MonadParsec e s m => MonadParsec e s (L.ReaderT st m) where+instance MonadParsec e s m => MonadParsec e s (L.ReaderT r m) where failure us ps xs = lift (failure us ps xs) label n (L.ReaderT m) = L.ReaderT $ label n . m try (L.ReaderT m) = L.ReaderT $ try . m@@ -1175,6 +1196,46 @@ getParserState = lift getParserState updateParserState f = lift (updateParserState f) +instance (Monoid w, MonadParsec e s m) => MonadParsec e s (L.RWST r w st m) where+ failure us ps xs = lift (failure us ps 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)+ getParserState = lift getParserState+ updateParserState f = lift (updateParserState f)++instance (Monoid w, MonadParsec e s m) => MonadParsec e s (S.RWST r w st m) where+ failure us ps xs = lift (failure us ps 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)+ getParserState = lift getParserState+ updateParserState f = lift (updateParserState f)+ instance MonadParsec e s m => MonadParsec e s (IdentityT m) where failure us ps xs = lift (failure us ps xs) label n (IdentityT m) = IdentityT $ label n m@@ -1195,6 +1256,11 @@ 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' #-}+ ---------------------------------------------------------------------------- -- Debugging @@ -1220,12 +1286,6 @@ -- * @EOK@ — “empty OK”. The parser succeeded without consuming input. -- * @EERR@ — “empty error”. The parser failed without consuming input. ----- Due to how input streams are represented (see 'Stream'), we need to--- traverse entire input twice (calculating length before and after @p@--- parser) to understand what part of input was matched and consumed. This--- makes this combinator very inefficient, be sure to remove it from your--- code once you have finished with debugging.--- -- Finally, it's not possible to lift this function into some monad -- transformers without introducing surprising behavior (e.g. unexpected -- state backtracking) or adding otherwise redundant constraints (e.g.@@ -1298,20 +1358,19 @@ let (h, r) = splitAt 40 (showTokens ne) in if null r then h else h ++ " <…>" --- | Calculate difference in length of two input streams from given parser--- 'State's.+-- | Calculate number of consumed tokens given 'State' of parser before and+-- after parsing. -streamDelta :: Stream s- => State s -- ^ State of parser before consumption+streamDelta+ :: State s -- ^ State of parser before consumption -> State s -- ^ State of parser after consumption- -> Int -- ^ Number of consumed tokens-streamDelta s0 s1 = streamLength (stateInput s0) - streamLength (stateInput s1)- where streamLength s = length (unfold s)+ -> Word -- ^ Number of consumed tokens+streamDelta s0 s1 = stateTokensProcessed s1 - stateTokensProcessed s0 -- | Extract given number of tokens from the stream. -streamTake :: Stream s => Int -> s -> [Token s]-streamTake n s = take n (unfold s)+streamTake :: Stream s => Word -> s -> [Token s]+streamTake n s = genericTake n (unfold s) -- | Custom version of 'unfold' that matches signature of 'uncons' method in -- 'Stream' type class we use.
Text/Megaparsec/String.hs view
@@ -1,6 +1,6 @@ -- | -- Module : Text.Megaparsec.String--- Copyright : © 2015–2016 Megaparsec contributors+-- Copyright : © 2015–2017 Megaparsec contributors -- License : FreeBSD -- -- Maintainer : Mark Karpov <markkarpov@opmbx.org>
Text/Megaparsec/Text.hs view
@@ -1,6 +1,6 @@ -- | -- Module : Text.Megaparsec.Text--- Copyright : © 2015–2016 Megaparsec contributors+-- Copyright : © 2015–2017 Megaparsec contributors -- License : FreeBSD -- -- Maintainer : Mark Karpov <markkarpov@opmbx.org>
Text/Megaparsec/Text/Lazy.hs view
@@ -1,6 +1,6 @@ -- | -- Module : Text.Megaparsec.Text.Lazy--- Copyright : © 2015–2016 Megaparsec contributors+-- Copyright : © 2015–2017 Megaparsec contributors -- License : FreeBSD -- -- Maintainer : Mark Karpov <markkarpov@opmbx.org>
+ bench-memory/Main.hs view
@@ -0,0 +1,93 @@+--+-- Weigh benchmarks for Megaparsec.+--+-- Copyright © 2015–2017 Megaparsec contributors+--+-- Redistribution and use in source and binary forms, with or without+-- modification, are permitted provided that the following conditions are+-- met:+--+-- * Redistributions of source code must retain the above copyright notice,+-- this list of conditions and the following disclaimer.+--+-- * Redistributions in binary form must reproduce the above copyright+-- notice, this list of conditions and the following disclaimer in the+-- documentation and/or other materials provided with the distribution.+--+-- THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS “AS IS” AND ANY+-- EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED+-- WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE+-- DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDERS BE LIABLE FOR ANY+-- DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL+-- DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS+-- OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION)+-- HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT,+-- STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN+-- ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE+-- POSSIBILITY OF SUCH DAMAGE.++module Main (main) where++import Control.DeepSeq+import Control.Monad+import Text.Megaparsec+import Text.Megaparsec.String+import Weigh++main :: IO ()+main = mainWith $ do+ bparser "string" manyAs (string . fst)+ bparser "string'" manyAs (string' . fst)+ bparser "choice" (const "b") (choice . fmap char . manyAsB . snd)+ bparser "many" manyAs (const $ many (char 'a'))+ bparser "some" manyAs (const $ some (char 'a'))+ bparser "count" manyAs (\(_,n) -> count n (char 'a'))+ bparser "count'" manyAs (\(_,n) -> count' 1 n (char 'a'))+ bparser "endBy" manyAbs' (const $ endBy (char 'a') (char 'b'))+ bparser "endBy1" manyAbs' (const $ endBy1 (char 'a') (char 'b'))+ bparser "sepBy" manyAbs (const $ sepBy (char 'a') (char 'b'))+ bparser "sepBy1" manyAbs (const $ sepBy1 (char 'a') (char 'b'))+ bparser "sepEndBy" manyAbs' (const $ sepEndBy (char 'a') (char 'b'))+ bparser "sepEndBy1" manyAbs' (const $ sepEndBy1 (char 'a') (char 'b'))+ bparser "manyTill" manyAsB (const $ manyTill (char 'a') (char 'b'))+ bparser "someTill" manyAsB (const $ someTill (char 'a') (char 'b'))++-- | Perform a series of measurements with the same parser.++bparser :: NFData a+ => String -- ^ Name of the benchmark group+ -> (Int -> String) -- ^ How to construct input+ -> ((String, Int) -> Parser a) -- ^ The parser receiving its future input+ -> Weigh ()+bparser name f p = forM_ stdSeries $ \i -> do+ let arg = (f i,i)+ p' (s,n) = parse (p (s,n)) "" s+ func (name ++ "/" ++ show i) p' arg++-- | The series of sizes to try as part of 'bparser'.++stdSeries :: [Int]+stdSeries = [500,1000,2000,4000]++----------------------------------------------------------------------------+-- Helpers++-- | Generate that many \'a\' characters.++manyAs :: Int -> String+manyAs n = replicate n 'a'++-- | Like 'manyAs', but interspersed with \'b\'s.++manyAbs :: Int -> String+manyAbs n = take (if even n then n + 1 else n) (cycle "ab")++-- | Like 'manyAs', but with a \'b\' added to the end.++manyAsB :: Int -> String+manyAsB n = replicate n 'a' ++ "b"++-- | Like 'manyAbs', but ends in a \'b\'.++manyAbs' :: Int -> String+manyAbs' n = take (if even n then n else n + 1) (cycle "ab")
+ bench-speed/Main.hs view
@@ -0,0 +1,93 @@+--+-- Criterion benchmarks for Megaparsec.+--+-- Copyright © 2015–2017 Megaparsec contributors+--+-- Redistribution and use in source and binary forms, with or without+-- modification, are permitted provided that the following conditions are+-- met:+--+-- * Redistributions of source code must retain the above copyright notice,+-- this list of conditions and the following disclaimer.+--+-- * Redistributions in binary form must reproduce the above copyright+-- notice, this list of conditions and the following disclaimer in the+-- documentation and/or other materials provided with the distribution.+--+-- THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS “AS IS” AND ANY+-- EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED+-- WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE+-- DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDERS BE LIABLE FOR ANY+-- DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL+-- DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS+-- OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION)+-- HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT,+-- STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN+-- ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE+-- POSSIBILITY OF SUCH DAMAGE.++module Main (main) where++import Control.DeepSeq+import Criterion.Main+import Text.Megaparsec+import Text.Megaparsec.String++main :: IO ()+main = defaultMain+ [ bparser "string" manyAs (string . fst)+ , bparser "string'" manyAs (string' . fst)+ , bparser "choice" (const "b") (choice . fmap char . manyAsB . snd)+ , bparser "many" manyAs (const $ many (char 'a'))+ , bparser "some" manyAs (const $ some (char 'a'))+ , bparser "count" manyAs (\(_,n) -> count n (char 'a'))+ , bparser "count'" manyAs (\(_,n) -> count' 1 n (char 'a'))+ , bparser "endBy" manyAbs' (const $ endBy (char 'a') (char 'b'))+ , bparser "endBy1" manyAbs' (const $ endBy1 (char 'a') (char 'b'))+ , bparser "sepBy" manyAbs (const $ sepBy (char 'a') (char 'b'))+ , bparser "sepBy1" manyAbs (const $ sepBy1 (char 'a') (char 'b'))+ , bparser "sepEndBy" manyAbs' (const $ sepEndBy (char 'a') (char 'b'))+ , bparser "sepEndBy1" manyAbs' (const $ sepEndBy1 (char 'a') (char 'b'))+ , bparser "manyTill" manyAsB (const $ manyTill (char 'a') (char 'b'))+ , bparser "someTill" manyAsB (const $ someTill (char 'a') (char 'b'))+ ]++-- | Perform a series to measurements with the same parser.++bparser :: NFData a+ => String -- ^ Name of the benchmark group+ -> (Int -> String) -- ^ How to construct input+ -> ((String, Int) -> Parser a) -- ^ The parser receiving its future input+ -> Benchmark -- ^ The benchmark+bparser name f p = bgroup name (bs <$> stdSeries)+ where+ bs n = env (return (f n, n)) (bench (show n) . nf p')+ p' (s,n) = parse (p (s,n)) "" s++-- | The series of sizes to try as part of 'bparser'.++stdSeries :: [Int]+stdSeries = [500,1000,2000,4000]++----------------------------------------------------------------------------+-- Helpers++-- | Generate that many \'a\' characters.++manyAs :: Int -> String+manyAs n = replicate n 'a'++-- | Like 'manyAs', but with a \'b\' added to the end.++manyAsB :: Int -> String+manyAsB n = replicate n 'a' ++ "b"++-- | Like 'manyAs', but interspersed with \'b\'s and ends in a \'a\'.++manyAbs :: Int -> String+manyAbs n = take (if even n then n + 1 else n) (cycle "ab")++-- | Like 'manyAbs', but ends in a \'b\'.++manyAbs' :: Int -> String+manyAbs' n = take (if even n then n else n + 1) (cycle "ab")
− benchmarks/Main.hs
@@ -1,192 +0,0 @@------ Criterion benchmarks for Megaparsec.------ Copyright © 2015–2016 Megaparsec contributors------ Redistribution and use in source and binary forms, with or without--- modification, are permitted provided that the following conditions are--- met:------ * Redistributions of source code must retain the above copyright notice,--- this list of conditions and the following disclaimer.------ * Redistributions in binary form must reproduce the above copyright--- notice, this list of conditions and the following disclaimer in the--- documentation and/or other materials provided with the distribution.------ THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS “AS IS” AND ANY--- EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED--- WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE--- DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDERS BE LIABLE FOR ANY--- DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL--- DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS--- OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION)--- HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT,--- STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN--- ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE--- POSSIBILITY OF SUCH DAMAGE.--{-# LANGUAGE CPP #-}--module Main (main) where--import Criterion.Main--import Text.Megaparsec---- Configuration parameters.---- To configure the benchmark, build the benchmarks e.g. like this:--- $ cabal build --ghc-options="-DBENCHMARK_TYPE=3 -DBENCHMARK_STEPS=10"---- BENCHMARK_TYPE options:--- 0: Text.Megaparsec.String--- 1: Text.Megaparsec.Text--- 2: Text.Megaparsec.Text.Lazy--- 3: Text.Megaparsec.ByteString--- 4: Text.Megaparsec.ByteString.Lazy--#ifndef BENCHMARK_TYPE-#define BENCHMARK_TYPE 0-#endif--#if BENCHMARK_TYPE == 0-import Text.Megaparsec.String (Parser)-pack :: String -> String-pack = id-#endif-#if BENCHMARK_TYPE == 1-import Text.Megaparsec.Text (Parser)-import Data.Text (pack)-#endif-#if BENCHMARK_TYPE == 2-import Text.Megaparsec.Text.Lazy (Parser)-import Data.Text.Lazy (pack)-#endif-#if BENCHMARK_TYPE == 3-import Text.Megaparsec.ByteString (Parser)-import Data.ByteString.Char8 (pack)-#endif-#if BENCHMARK_TYPE == 4-import Text.Megaparsec.ByteString.Lazy (Parser)-import Data.ByteString.Lazy.Char8 (pack)-#endif---- benchSteps and benchSize control the benchmark test points--benchSteps :: Int-#if BENCHMARK_STEPS-benchSteps = BENCHMARK_STEPS-#else-benchSteps = 5-#endif-benchSize :: Int-#if BENCHMARK_SIZE-benchSize = BENCHMARK_SIZE-#else-benchSize = 1000-#endif---- End of configuration parameters--main :: IO ()-main = defaultMain benchmarks--benchmarks :: [Benchmark]-benchmarks =- [- -- First the primitives- bgroup "string" $ benchBunch $ \size str ->- parse (string str :: Parser String) ""- (pack $ replicate size 'a')- , bgroup "try-string" $ benchBunch $ \size str ->- parse (try $ string str :: Parser String) ""- (pack $ replicate size 'a')- , bgroup "lookahead-string" $ benchBunch $ \size str ->- parse (lookAhead $ string str :: Parser String) ""- (pack $ replicate size 'a')- , bgroup "notfollowedby-string" $ benchBunch $ \size str ->- parse (notFollowedBy $ string str :: Parser ()) ""- (pack $ replicate size 'a')- , bgroup "manual-string" benchManual-- -- Now for a few combinators- -- Major class instance operators: return, >>=, <|>, mzero- -- TODO- -- I'm not really sure how to test these operators since I can't imagine what- -- supraconstant complexity they might have.-- -- A few non-primitive combinators follow below- , bgroup "choice"- [ bgroup "match" $ benchBunchMatch $ \size _ ->- parse- (choice (replicate (size-1) (char 'b') ++ [char 'a']) :: Parser Char)- ""- (pack $ replicate size 'a')- , bgroup "nomatch" $ benchBunchMatch $ \size _ ->- parse- (choice (replicate size (char 'b')) :: Parser Char)- ""- (pack $ replicate size 'a')- ]- , bgroup "count'" benchCount- , bgroup "sepBy1" benchSepBy1- , bgroup "manyTill" $ benchBunchNoMatchLate $ \size _ ->- parse- (manyTill (char 'a') (char 'b') :: Parser String)- ""- (pack $ replicate (size-1) 'a' ++ "b")- ]--benchManual :: [Benchmark]-benchManual =- map benchOne [benchSize,benchSize*2..benchSize*benchSteps]- where- benchOne num = bench (show num) $ whnf- (parse (sequence $ fmap char (replicate num 'a') :: Parser String) "")- (pack $ replicate num 'a')--benchCount :: [Benchmark]-benchCount =- map benchOne [benchSize,benchSize*2..benchSize*benchSteps]- where- benchOne num = bench (show num) $ whnf- (parse (count' size (size*2) (char 'a') :: Parser String) "")- (pack $ replicate (num-1) 'a' ++ "b")- where- size = round ((0.7 :: Double) * fromIntegral num)--benchSepBy1 :: [Benchmark]-benchSepBy1 =- map benchOne [benchSize,benchSize*2..benchSize*benchSteps]- where- benchOne num = bench (show num) $ whnf- (parse (sepBy1 (char 'a') (char 'b') :: Parser String) "")- (pack $ genString num)- genString 0 = "ac"- genString i = 'a' : 'b' : genString (i-1)--benchBunch :: (Int -> String -> b) -> [Benchmark]-benchBunch f =- [ bgroup "match" $ benchBunchMatch f- , bgroup "nomatch_early" $ benchBunchNoMatchEarly f- , bgroup "nomatch_late" $ benchBunchNoMatchLate f- ]--benchBunchMatch :: (Int -> String -> b) -> [Benchmark]-benchBunchMatch f =- map benchOne [benchSize,benchSize*2..benchSize*benchSteps]- where- benchOne num = bench (show num) $ whnf (f num) (replicate num 'a')--benchBunchNoMatchEarly :: (Int -> String -> b) -> [Benchmark]-benchBunchNoMatchEarly f =- map benchOne [benchSize,benchSize*2..benchSize*benchSteps]- where- benchOne num = bench (show num) $ whnf (f num) (replicate num 'b')--benchBunchNoMatchLate :: (Int -> String -> b) -> [Benchmark]-benchBunchNoMatchLate f =- map benchOne [benchSize,benchSize*2..benchSize*benchSteps]- where- benchOne num = bench (show num) $ whnf (f num) (replicate (num-1) 'a' ++ "b")
megaparsec.cabal view
@@ -1,7 +1,7 @@ -- -- Cabal config for Megaparsec. ----- Copyright © 2015–2016 Megaparsec contributors+-- Copyright © 2015–2017 Megaparsec contributors -- -- Redistribution and use in source and binary forms, with or without -- modification, are permitted provided that the following conditions are@@ -27,7 +27,7 @@ -- POSSIBILITY OF SUCH DAMAGE. name: megaparsec-version: 5.1.2+version: 5.2.0 cabal-version: >= 1.10 license: BSD2 license-file: LICENSE.md@@ -50,6 +50,10 @@ , CHANGELOG.md , README.md +source-repository head+ type: git+ location: https://github.com/mrkkrp/megaparsec.git+ flag dev description: Turn on development settings. manual: True@@ -123,8 +127,8 @@ , containers >= 0.5 && < 0.6 , exceptions >= 0.6 && < 0.9 , hspec >= 2.0 && < 3.0- , hspec-expectations >= 0.5 && < 0.8- , megaparsec >= 5.1.2+ , hspec-expectations >= 0.5 && < 0.9+ , megaparsec >= 5.2.0 , mtl >= 2.0 && < 3.0 , scientific >= 0.3.1 && < 0.4 , text >= 0.2 && < 1.3@@ -139,21 +143,30 @@ default-language: Haskell2010 -benchmark benchmarks+benchmark bench-speed main-is: Main.hs- hs-source-dirs: benchmarks+ hs-source-dirs: bench-speed type: exitcode-stdio-1.0+ build-depends: base >= 4.6 && < 5.0+ , criterion >= 0.6.2.1 && < 1.2+ , deepseq >= 1.3 && < 1.5+ , megaparsec >= 5.2.0 if flag(dev) ghc-options: -O2 -Wall -Werror else ghc-options: -O2 -Wall- build-depends: base >= 4.6 && < 5.0- , bytestring >= 0.10 && < 0.11- , criterion >= 0.6.2.1 && < 1.2- , megaparsec >= 5.1.2- , text >= 0.2 && < 1.3 default-language: Haskell2010 -source-repository head- type: git- location: https://github.com/mrkkrp/megaparsec.git+benchmark bench-memory+ main-is: Main.hs+ hs-source-dirs: bench-memory+ type: exitcode-stdio-1.0+ build-depends: base >= 4.6 && < 5.0+ , deepseq >= 1.3 && < 1.5+ , megaparsec >= 5.2.0+ , weigh >= 0.0.3+ if flag(dev)+ ghc-options: -O2 -Wall -Werror+ else+ ghc-options: -O2 -Wall+ default-language: Haskell2010
tests/Test/Hspec/Megaparsec.hs view
@@ -1,6 +1,6 @@ -- | -- Module : Test.Hspec.Megaparsec--- Copyright : © 2016 Mark Karpov+-- Copyright : © 2015–2017 Mark Karpov -- License : BSD 3 clause -- -- Maintainer : Mark Karpov <markkarpov@openmailbox.org>@@ -320,7 +320,11 @@ -- column). initialState :: s -> State s-initialState s = State s (initialPos "" :| []) defaultTabWidth+initialState s = State+ { stateInput = s+ , statePos = initialPos "" :| []+ , stateTokensProcessed = 0+ , stateTabWidth = defaultTabWidth } ---------------------------------------------------------------------------- -- Helpers
tests/Test/Hspec/Megaparsec/AdHoc.hs view
@@ -1,7 +1,7 @@ -- -- Tests for Megaparsec's expression parsers. ----- Copyright © 2015–2016 Megaparsec contributors+-- Copyright © 2015–2017 Megaparsec contributors -- -- Redistribution and use in source and binary forms, with or without -- modification, are permitted provided that the following conditions are@@ -56,6 +56,8 @@ import Text.Megaparsec.Error import Text.Megaparsec.Pos import Text.Megaparsec.Prim+import qualified Control.Monad.RWS.Lazy as L+import qualified Control.Monad.RWS.Strict as S import qualified Control.Monad.State.Lazy as L import qualified Control.Monad.State.Strict as S import qualified Control.Monad.Writer.Lazy as L@@ -116,6 +118,8 @@ r (prs (S.evalStateT p ()) s) r (prs (evalWriterTL p) s) r (prs (evalWriterTS p) s)+ r (prs (evalRWSTL p) s)+ r (prs (evalRWSTS p) s) -- | 'grs'' to 'grs' as 'prs'' to 'prs'. @@ -133,11 +137,23 @@ r (prs' (S.evalStateT p ()) s) r (prs' (evalWriterTL p) s) r (prs' (evalWriterTS p) s)+ r (prs' (evalRWSTL p) s)+ r (prs' (evalRWSTS p) s) evalWriterTL :: Monad m => L.WriterT [Int] m a -> m a evalWriterTL = liftM fst . L.runWriterT evalWriterTS :: Monad m => S.WriterT [Int] m a -> m a evalWriterTS = liftM fst . S.runWriterT++evalRWSTL :: Monad m => L.RWST () [Int] () m a -> m a+evalRWSTL m = do+ (a,_,_) <- L.runRWST m () ()+ return a++evalRWSTS :: Monad m => S.RWST () [Int] () m a -> m a+evalRWSTS m = do+ (a,_,_) <- S.runRWST m () ()+ return a ---------------------------------------------------------------------------- -- Working with source position
tests/Text/Megaparsec/CharSpec.hs view
@@ -1,7 +1,7 @@ -- -- Tests for Megaparsec's character parsers. ----- Copyright © 2015–2016 Megaparsec contributors+-- Copyright © 2015–2017 Megaparsec contributors -- -- Redistribution and use in source and binary forms, with or without -- modification, are permitted provided that the following conditions are@@ -67,7 +67,7 @@ prs eol s' `shouldParse` "\n" prs' eol s' `succeedsLeaving` s context "when stream begins with CRLF sequence" $- it "parses the CSRF sequence" $+ it "parses the CRLF sequence" $ property $ \s -> do let s' = '\r' : '\n' : s prs eol s' `shouldParse` "\r\n"@@ -82,7 +82,7 @@ it "signals correct parse error" $ prs eol "\r" `shouldFailWith` err posI (utok '\r' <> elabel "end of line")- context "when stream does not begin with newline or CSRF sequence" $+ context "when stream does not begin with newline or CRLF sequence" $ it "signals correct parse error" $ property $ \ch s -> (ch `notElem` "\r\n") ==> do let s' = ch : s
tests/Text/Megaparsec/CombinatorSpec.hs view
@@ -1,7 +1,7 @@ -- -- Tests for Megaparsec's generic parser combinators. ----- Copyright © 2015–2016 Megaparsec contributors+-- Copyright © 2015–2017 Megaparsec contributors -- -- Redistribution and use in source and binary forms, with or without -- modification, are permitted provided that the following conditions are
tests/Text/Megaparsec/ErrorSpec.hs view
@@ -1,7 +1,7 @@ -- -- Tests for Megaparsec's parse errors. ----- Copyright © 2015–2016 Megaparsec contributors+-- Copyright © 2015–2017 Megaparsec contributors -- -- Redistribution and use in source and binary forms, with or without -- modification, are permitted provided that the following conditions are
tests/Text/Megaparsec/ExprSpec.hs view
@@ -1,7 +1,7 @@ -- -- Tests for Megaparsec's expression parsers. ----- Copyright © 2015–2016 Megaparsec contributors+-- Copyright © 2015–2017 Megaparsec contributors -- -- Redistribution and use in source and binary forms, with or without -- modification, are permitted provided that the following conditions are
tests/Text/Megaparsec/LexerSpec.hs view
@@ -1,7 +1,7 @@ -- -- Tests for Megaparsec's lexer. ----- Copyright © 2015–2016 Megaparsec contributors+-- Copyright © 2015–2017 Megaparsec contributors -- -- Redistribution and use in source and binary forms, with or without -- modification, are permitted provided that the following conditions are@@ -174,7 +174,7 @@ | col2 <= col1 -> prs p s `shouldFailWith` err (posN (getIndent l2 + g 2) s) (ii GT col1 col2) | col3 == col2 -> prs p s `shouldFailWith`- err (posN (getIndent l3 + g 3) s) (utok (head sblb) <> etoks sblc)+ err (posN (getIndent l3 + g 3) s) (utok (head sblb) <> etoks sblc <> eeof) | col3 <= col0 -> prs p s `shouldFailWith` err (posN (getIndent l3 + g 3) s) (utok (head sblb) <> eeof) | col3 < col1 -> prs p s `shouldFailWith`@@ -185,8 +185,8 @@ err (posN (getIndent l4 + g 4) s) (ii GT col3 col4) | otherwise -> prs p s `shouldParse` (sbla, [(sblb, [sblc]), (sblb, [sblc])])- it "IndentMany works as intended" $- property $ forAll (mkIndent sbla 0) $ \s -> do+ it "IndentMany works as intended (newline at the end)" $+ property $ forAll ((<>) <$> mkIndent sbla 0 <*> mkWhiteSpaceNl) $ \s -> do let p = lvla lvla = indentBlock scn $ IndentMany Nothing (l sbla) lvlb <$ b sbla lvlb = b sblb@@ -194,6 +194,35 @@ l x = return . (x,) prs p s `shouldParse` (sbla, []) prs' p s `succeedsLeaving` ""+ it "IndentMany works as intended (eof)" $+ property $ forAll ((<>) <$> mkIndent sbla 0 <*> mkWhiteSpace) $ \s -> do+ let p = lvla+ lvla = indentBlock scn $ IndentMany Nothing (l sbla) lvlb <$ b sbla+ lvlb = b sblb+ b = symbol sc+ l x = return . (x,)+ prs p s `shouldParse` (sbla, [])+ prs' p s `succeedsLeaving` ""+ it "IndentMany works as intended (whitespace aligned precisely to the ref level)" $ do+ let p = lvla+ lvla = indentBlock scn $ IndentMany Nothing (l sbla) lvlb <$ b sbla+ lvlb = b sblb+ b = symbol sc+ l x = return . (x,)+ s = "aaa\n bbb\n "+ prs p s `shouldParse` (sbla, [sblb])+ prs' p s `succeedsLeaving` ""+ it "works with many and both IndentMany and IndentNone" $+ property $ forAll ((<>) <$> mkIndent sbla 0 <*> mkWhiteSpaceNl) $ \s -> do+ let p1 = indentBlock scn $ IndentMany Nothing (l sbla) lvlb <$ b sbla+ p2 = indentBlock scn $ IndentNone sbla <$ b sbla+ lvlb = b sblb+ b = symbol sc+ l x = return . (x,)+ prs (many p1) s `shouldParse` [(sbla, [])]+ prs (many p2) s `shouldParse` [sbla]+ prs' (many p1) s `succeedsLeaving` ""+ prs' (many p2) s `succeedsLeaving` "" describe "lineFold" $ it "works as intended" $@@ -427,6 +456,9 @@ mkWhiteSpace :: Gen String mkWhiteSpace = concat <$> listOf whiteUnit where whiteUnit = oneof [whiteChars, whiteLine, whiteBlock]++mkWhiteSpaceNl :: Gen String+mkWhiteSpaceNl = (<>) <$> mkWhiteSpace <*> pure "\n" mkSymbol :: Gen String mkSymbol = (++) <$> symbolName <*> whiteChars
tests/Text/Megaparsec/PermSpec.hs view
@@ -1,7 +1,7 @@ -- -- Tests for Megaparsec's permutation phrases parsers. ----- Copyright © 2015–2016 Megaparsec contributors+-- Copyright © 2015–2017 Megaparsec contributors -- -- Redistribution and use in source and binary forms, with or without -- modification, are permitted provided that the following conditions are
tests/Text/Megaparsec/PosSpec.hs view
@@ -1,7 +1,7 @@ -- -- Tests for Megaparsec's textual source positions. ----- Copyright © 2015–2016 Megaparsec contributors+-- Copyright © 2015–2017 Megaparsec contributors -- -- Redistribution and use in source and binary forms, with or without -- modification, are permitted provided that the following conditions are
tests/Text/Megaparsec/PrimSpec.hs view
@@ -1,7 +1,7 @@ -- -- Tests for Megaparsec's primitive parser combinators. ----- Copyright © 2015–2016 Megaparsec contributors+-- Copyright © 2015–2017 Megaparsec contributors -- -- Redistribution and use in source and binary forms, with or without -- modification, are permitted provided that the following conditions are@@ -46,7 +46,7 @@ import Data.Foldable (asum, concat) import Data.List (isPrefixOf, foldl') import Data.List.NonEmpty (NonEmpty (..))-import Data.Maybe (fromMaybe)+import Data.Maybe (fromMaybe, listToMaybe, isJust) import Data.Monoid import Data.Proxy import Data.Word (Word8)@@ -61,6 +61,8 @@ import Text.Megaparsec.Pos import Text.Megaparsec.Prim import Text.Megaparsec.String+import qualified Control.Monad.RWS.Lazy as L+import qualified Control.Monad.RWS.Strict as S import qualified Control.Monad.State.Lazy as L import qualified Control.Monad.State.Strict as S import qualified Control.Monad.Writer.Lazy as L@@ -137,24 +139,38 @@ ( st { statePos = apos } , Left (err apos $ utok h <> eeof) ) - describe "token" $- it "updates position in stream correctly" $- property $ \st@State {..} span -> do- let p = pSpan span- h = head stateInput- (apos, npos) =- let z = NE.tail statePos- in (spanStart h :| z, spanEnd h :| z)- if | null stateInput -> runParser' p st `shouldBe`- ( st- , Left (err statePos $ ueof <> etok span) )- | spanBody h == spanBody span -> runParser' p st `shouldBe`- ( st { statePos = npos- , stateInput = tail stateInput }- , Right span )- | otherwise -> runParser' p st `shouldBe`- ( st { statePos = apos}- , Left (err apos $ utok h <> etok span))+ describe "token" $ do+ context "when input stream is empty" $+ it "signals correct parse error" $+ property $ \st'@State {..} span -> do+ let p = pSpan span+ st = (st' :: State [Span]) { stateInput = [] }+ runParser' p st `shouldBe`+ ( st+ , Left (err statePos $ ueof <> etok span) )+ context "when head of stream matches" $+ it "updates parser state correctly" $+ property $ \st'@State {..} span -> do+ let p = pSpan span+ st = st' { stateInput = span : stateInput }+ npos = spanEnd span :| NE.tail statePos+ runParser' p st `shouldBe`+ ( st { statePos = npos+ , stateTokensProcessed = stateTokensProcessed + 1+ , stateInput = stateInput }+ , Right span )+ context "when head of stream does not match" $ do+ let checkIt s span =+ let ms = listToMaybe s+ in isJust ms && (spanBody <$> ms) /= Just (spanBody span)+ it "signals correct parse error" $+ property $ \st@State {..} span -> checkIt stateInput span ==> do+ let p = pSpan span+ h = head stateInput+ apos = spanStart h :| NE.tail statePos+ runParser' p st `shouldBe`+ ( st { statePos = apos }+ , Left (err apos $ utok h <> etok span)) describe "tokens" $ it "updates position is stream correctly" $@@ -174,8 +190,9 @@ ( st , Left (err statePos $ ueof <> etoks ts) ) | il == tl -> runParser' p st `shouldBe`- ( st { statePos = npos- , stateInput = drop (length ts) stateInput }+ ( st { statePos = npos+ , stateTokensProcessed = stateTokensProcessed + fromIntegral tl+ , stateInput = drop (length ts) stateInput } , Right consumed ) | otherwise -> runParser' p st `shouldBe` ( st { statePos = apos }@@ -334,6 +351,16 @@ let p = many (char 'a') *> many (char 'b') *> eof prs p "c" `shouldFailWith` err posI (utok 'c' <> etok 'a' <> etok 'b' <> eeof)+ context "when the argument parser succeeds without consuming" $+ it "is run nevertheless" $+ property $ \n' -> do+ let n = getSmall (getNonNegative n') :: Integer+ p = void . many $ do+ x <- S.get+ if x < n then S.modify (+ 1) else empty+ v :: S.State Integer (Either (ParseError Char Dec) ())+ v = runParserT p "" ""+ S.execState v 0 `shouldBe` n describe "some" $ do context "when stream begins with things argument of some parses" $@@ -963,12 +990,25 @@ describe "combinators for manipulating parser state" $ do + describe "setInput and getInput" $+ it "sets input and gets it back" $+ property $ \s -> do+ let p = do+ st0 <- getInput+ guard (null st0)+ setInput s+ result <- string s+ st1 <- getInput+ guard (null st1)+ return result+ prs p "" `shouldParse` s+ describe "setPosition and getPosition" $ it "sets position and gets it back" $ property $ \st pos -> do let p :: Parser SourcePos p = setPosition pos >> getPosition- f (State s (_:|xs) w) y = State s (y:|xs) w+ f (State s (_:|xs) tp w) y = State s (y:|xs) tp w runParser' p st `shouldBe` (f st pos, Right pos) describe "pushPosition" $@@ -988,18 +1028,11 @@ fst (runParser' p st) `shouldBe` st { statePos = fromMaybe pos (snd (NE.uncons pos)) } - describe "setInput and getInput" $- it "sets input and gets it back" $- property $ \s -> do- let p = do- st0 <- getInput- guard (null st0)- setInput s- result <- string s- st1 <- getInput- guard (null st1)- return result- prs p "" `shouldParse` s+ describe "setTokensProcessed and getTokensProcessed" $+ it "sets number of processed toknes and gets it back" $+ property $ \tp -> do+ let p = setTokensProcessed tp >> getTokensProcessed+ prs p "" `shouldParse` tp describe "setTabWidth and getTabWidth" $ it "sets tab width and gets it back" $@@ -1013,11 +1046,11 @@ let p :: MonadParsec Dec String m => m (State String) p = do st <- getParserState- guard (st == State s posI defaultTabWidth)+ guard (st == State s posI 0 defaultTabWidth) setParserState s1 updateParserState (f s2) liftM2 const getParserState (setInput "")- f (State s1' pos w) (State s2' _ _) = State (max s1' s2') pos w+ f (State s1' pos tp w) (State s2' _ _ _) = State (max s1' s2') pos tp w s = "" grs p s (`shouldParse` f s2 s1) @@ -1162,6 +1195,18 @@ return cs prs (L.runWriterT p) "abx" `shouldParse` ("ab", pre ++ "AB" ++ post ++ "x") + describe "lookAhead" $+ it "discards what writer tells inside it" $+ property $ \w -> do+ let p = lookAhead (L.tell [w])+ prs (L.runWriterT p) "" `shouldParse` ((), mempty :: [Int])++ describe "notFollowedBy" $+ it "discards what writer tells inside it" $+ property $ \w -> do+ let p = notFollowedBy (L.tell [w] <* char 'a')+ prs (L.runWriterT p) "" `shouldParse` ((), mempty :: [Int])+ describe "observing" $ do context "when inner parser succeeds" $ it "can affect log" $@@ -1189,6 +1234,18 @@ return cs prs (S.runWriterT p) "abx" `shouldParse` ("ab", pre ++ "AB" ++ post ++ "x") + describe "lookAhead" $+ it "discards what writer tells inside it" $+ property $ \w -> do+ let p = lookAhead (S.tell [w])+ prs (S.runWriterT p) "" `shouldParse` ((), mempty :: [Int])++ describe "notFollowedBy" $+ it "discards what writer tells inside it" $+ property $ \w -> do+ let p = notFollowedBy (S.tell [w] <* char 'a')+ prs (S.runWriterT p) "" `shouldParse` ((), mempty :: [Int])+ describe "observing" $ do context "when inner parser succeeds" $ it "can affect log" $@@ -1201,6 +1258,146 @@ let p = observing (S.tell (Sum n) <* empty) prs (S.execWriterT p) "" `shouldParse` (mempty :: Sum Integer) + describe "MonadParsec instance of lazy RWST" $ do++ describe "label" $+ it "allows to access reader context and state inside it" $+ property $ \r s -> do+ let p = label "a" ((,) <$> L.ask <*> L.get)+ prs (L.runRWST p (r :: Int) (s :: Int)) "" `shouldParse`+ ((r, s), s, mempty :: [Int])++ describe "try" $+ it "allows to access reader context and state inside it" $+ property $ \r s -> do+ let p = try ((,) <$> L.ask <*> L.get)+ prs (L.runRWST p (r :: Int) (s :: Int)) "" `shouldParse`+ ((r, s), s, mempty :: [Int])++ describe "lookAhead" $ do+ it "allows to access reader context and state inside it" $+ property $ \r s -> do+ let p = lookAhead ((,) <$> L.ask <*> L.get)+ prs (L.runRWST p (r :: Int) (s :: Int)) "" `shouldParse`+ ((r, s), s, mempty :: [Int])+ it "discards what writer tells inside it" $+ property $ \w -> do+ let p = lookAhead (L.tell [w])+ prs (L.runRWST p (0 :: Int) (0 :: Int)) "" `shouldParse`+ ((), 0, mempty :: [Int])+ it "does not allow to influence state outside it" $+ property $ \s0 s1 -> (s0 /= s1) ==> do+ let p = lookAhead (L.put s1)+ prs (L.runRWST p (0 :: Int) (s0 :: Int)) "" `shouldParse`+ ((), s0, mempty :: [Int])++ describe "notFollowedBy" $ do+ it "discards what writer tells inside it" $+ property $ \w -> do+ let p = notFollowedBy (L.tell [w] <* char 'a')+ prs (L.runRWST p (0 :: Int) (0 :: Int)) "" `shouldParse`+ ((), 0, mempty :: [Int])+ it "does not allow to influence state outside it" $+ property $ \s0 s1 -> (s0 /= s1) ==> do+ let p = notFollowedBy (L.put s1 <* char 'a')+ prs (L.runRWST p (0 :: Int) (s0 :: Int)) "" `shouldParse`+ ((), s0, mempty :: [Int])++ describe "withRecovery" $ do+ it "allows main parser to access reader context and state inside it" $+ property $ \r s -> do+ let p = withRecovery (const empty) ((,) <$> L.ask <*> L.get)+ prs (L.runRWST p (r :: Int) (s :: Int)) "" `shouldParse`+ ((r, s), s, mempty :: [Int])+ it "allows recovering parser to access reader context and state inside it" $+ property $ \r s -> do+ let p = withRecovery (\_ -> (,) <$> L.ask <*> L.get) empty+ prs (L.runRWST p (r :: Int) (s :: Int)) "" `shouldParse`+ ((r, s), s, mempty :: [Int])++ describe "observing" $ do+ it "allows to access reader context and state inside it" $+ property $ \r s -> do+ let p = observing ((,) <$> L.ask <*> L.get)+ prs (L.runRWST p (r :: Int) (s :: Int)) "" `shouldParse`+ (Right (r, s), s, mempty :: [Int])+ context "when the inner parser fails" $+ it "backtracks state" $+ property $ \r s0 s1 -> (s0 /= s1) ==> do+ let p = observing (L.put s1 <* empty)+ prs (L.runRWST p (r :: Int) (s0 :: Int)) "" `shouldParse`+ (Left (err posI mempty), s0, mempty :: [Int])++ describe "MonadParsec instance of strict RWST" $ do++ describe "label" $+ it "allows to access reader context and state inside it" $+ property $ \r s -> do+ let p = label "a" ((,) <$> S.ask <*> S.get)+ prs (S.runRWST p (r :: Int) (s :: Int)) "" `shouldParse`+ ((r, s), s, mempty :: [Int])++ describe "try" $+ it "allows to access reader context and state inside it" $+ property $ \r s -> do+ let p = try ((,) <$> S.ask <*> S.get)+ prs (S.runRWST p (r :: Int) (s :: Int)) "" `shouldParse`+ ((r, s), s, mempty :: [Int])++ describe "lookAhead" $ do+ it "allows to access reader context and state inside it" $+ property $ \r s -> do+ let p = lookAhead ((,) <$> S.ask <*> S.get)+ prs (S.runRWST p (r :: Int) (s :: Int)) "" `shouldParse`+ ((r, s), s, mempty :: [Int])+ it "discards what writer tells inside it" $+ property $ \w -> do+ let p = lookAhead (S.tell [w])+ prs (S.runRWST p (0 :: Int) (0 :: Int)) "" `shouldParse`+ ((), 0, mempty :: [Int])+ it "does not allow to influence state outside it" $+ property $ \s0 s1 -> (s0 /= s1) ==> do+ let p = lookAhead (S.put s1)+ prs (S.runRWST p (0 :: Int) (s0 :: Int)) "" `shouldParse`+ ((), s0, mempty :: [Int])++ describe "notFollowedBy" $ do+ it "discards what writer tells inside it" $+ property $ \w -> do+ let p = notFollowedBy (S.tell [w] <* char 'a')+ prs (S.runRWST p (0 :: Int) (0 :: Int)) "" `shouldParse`+ ((), 0, mempty :: [Int])+ it "does not allow to influence state outside it" $+ property $ \s0 s1 -> (s0 /= s1) ==> do+ let p = notFollowedBy (S.put s1 <* char 'a')+ prs (S.runRWST p (0 :: Int) (s0 :: Int)) "" `shouldParse`+ ((), s0, mempty :: [Int])++ describe "withRecovery" $ do+ it "allows main parser to access reader context and state inside it" $+ property $ \r s -> do+ let p = withRecovery (const empty) ((,) <$> S.ask <*> S.get)+ prs (S.runRWST p (r :: Int) (s :: Int)) "" `shouldParse`+ ((r, s), s, mempty :: [Int])+ it "allows recovering parser to access reader context and state inside it" $+ property $ \r s -> do+ let p = withRecovery (\_ -> (,) <$> S.ask <*> S.get) empty+ prs (S.runRWST p (r :: Int) (s :: Int)) "" `shouldParse`+ ((r, s), s, mempty :: [Int])++ describe "observing" $ do+ it "allows to access reader context and state inside it" $+ property $ \r s -> do+ let p = observing ((,) <$> S.ask <*> S.get)+ prs (S.runRWST p (r :: Int) (s :: Int)) "" `shouldParse`+ (Right (r, s), s, mempty :: [Int])+ context "when the inner parser fails" $+ it "backtracks state" $+ property $ \r s0 s1 -> (s0 /= s1) ==> do+ let p = observing (S.put s1 <* empty)+ prs (S.runRWST p (r :: Int) (s0 :: Int)) "" `shouldParse`+ (Left (err posI mempty), s0, mempty :: [Int])+ describe "dbg" $ do -- NOTE We don't test properties here to avoid flood of debugging output -- when the test runs.@@ -1295,8 +1492,8 @@ :: State String -> String -> (State String, Either (ParseError Char Dec) String)-emulateStrParsing st@(State i (pos:|z) t) s =+emulateStrParsing st@(State i (pos:|z) tp w) s = if l == length s- then (State (drop l i) (updatePosString t pos s :| z) t, Right s)+ then (State (drop l i) (updatePosString w pos s :| z) (tp + fromIntegral l) w, Right s) else (st, Left $ err (pos:|z) (etoks s <> utoks (take (l + 1) i))) where l = length (takeWhile id $ zipWith (==) s i)