megaparsec 6.5.0 → 7.0.0

raw patch · 40 files changed

+3554/−3079 lines, 40 filesdep ~basedep ~hspec-expectationsdep ~parser-combinatorsPVP ok

version bump matches the API change (PVP)

Dependency ranges changed: base, hspec-expectations, parser-combinators

API changes (from Hackage documentation)

Files

• CHANGELOG.md +144/−0
• README.md +25/−43
• Text/Megaparsec.hs +254/−300
• Text/Megaparsec/Byte.hs +62/−43
• Text/Megaparsec/Byte/Lexer.hs +43/−20
• Text/Megaparsec/Char.hs +22/−129
• Text/Megaparsec/Char/Lexer.hs +32/−92
• Text/Megaparsec/Class.hs +25/−33
• Text/Megaparsec/Common.hs +42/−0
• Text/Megaparsec/Debug.hs +138/−0
• Text/Megaparsec/Error.hs +241/−271
• Text/Megaparsec/Error/Builder.hs +53/−67
• Text/Megaparsec/Expr.hs +0/−156
• Text/Megaparsec/Internal.hs +110/−107
• Text/Megaparsec/Lexer.hs +111/−0
• Text/Megaparsec/Perm.hs +0/−146
• Text/Megaparsec/Pos.hs +3/−3
• Text/Megaparsec/State.hs +28/−8
• Text/Megaparsec/Stream.hs +320/−95
• bench/memory/Main.hs +94/−1
• bench/speed/Main.hs +90/−5
• megaparsec.cabal +23/−19
• tests/Control/Applicative/CombinatorsSpec.hs +32/−39
• tests/Control/Applicative/PermutationsSpec.hs +103/−0
• tests/Control/Monad/Combinators/ExprSpec.hs +160/−0
• tests/Control/Monad/CombinatorsSpec.hs +29/−36
• tests/Main.hs +46/−1
• tests/Spec.hs +0/−1
• tests/Test/Hspec/Megaparsec.hs +142/−51
• tests/Test/Hspec/Megaparsec/AdHoc.hs +141/−67
• tests/Text/Megaparsec/Byte/LexerSpec.hs +48/−21
• tests/Text/Megaparsec/ByteSpec.hs +45/−60
• tests/Text/Megaparsec/Char/LexerSpec.hs +81/−55
• tests/Text/Megaparsec/CharSpec.hs +59/−115
• tests/Text/Megaparsec/DebugSpec.hs +55/−0
• tests/Text/Megaparsec/ErrorSpec.hs +178/−209
• tests/Text/Megaparsec/ExprSpec.hs +0/−159
• tests/Text/Megaparsec/PermSpec.hs +0/−101
• tests/Text/Megaparsec/StreamSpec.hs +310/−174
• tests/Text/MegaparsecSpec.hs +265/−452

@@ -1,3 +1,147 @@+## Megaparsec 7.0.0++### General++* Dropped the `Text.Megaparsec.Perm` module. Use+  `Control.Applicative.Permutations` from `parser-combinators` instead.++* Dropped the `Text.Megaparsec.Expr` module. Use+  `Control.Monad.Combinators.Expr` from `parser-combinators` instead.++* The debugging function `dbg` has been moved from `Text.Megaparsec` to its+  own module `Text.Megaparsec.Debug`.++* Dropped support for GHC 7.8.++### Combinators++* Moved some general combinators from `Text.Megaparsec.Char` and+  `Text.Megaparsec.Byte` to `Text.Megaparsec`, renaming some of them for+  clarity.++  Practical consequences:++  * Now there is the `single` combinator that is a generalization of `char`+    for arbitrary streams. `Text.Megaparsec.Char` and `Text.Megaparsec.Byte`+    still contain `char` as type-constrained versions of `single`.++  * Similarly, now there is the `chunk` combinator that is a generalization+    of `string` for arbitrary streams. The `string` combinator is still+    re-exported from `Text.Megaparsec.Char` and `Text.Megaparsec.Byte` for+    compatibility.++  * `satisfy` does not depend on type of token, and so it now lives in+    `Text.Megaparsec`.++  * `anyChar` was renamed to `anySingle` and moved to `Text.Megaparsec`.++  * `notChar` was renamed to `anySingleBut` and moved to `Text.Megaparsec`.++  * `oneOf` and `noneOf` were moved to `Text.Megaparsec`.++* Simplified the type of the `token` primitive. It now takes just a matching+  function `Token s -> Maybe a` as the first argument and the collection of+  expected items `Set (ErrorItem (Token s))` as the second argument. This+  makes sense because the collection of expected items cannot depend on what+  we see in the input stream.++* The `label` primitive now doesn't prepend the phrase “the rest of” to the+  label when its inner parser produces hints after consuming input. In that+  case `label` has no effect.++* Fixed the `Text.Megaparsec.Char.Lexer.charLiteral` so it can accept longer+  escape sequences (max length is now 10).++* Added the `binDigitChar` functions in `Text.Megaparsec.Byte` and+  `Text.Megaparsec.Char`.++* Added the `binary` functions in `Text.Megaparsec.Byte.Lexer` and+  `Text.Megaparsec.Char.Lexer`.++* Improved case-insensitive character matching in the cases when e.g.+  `isLower` and `isUpper` both return `False`. Functions affected:+  `Text.Megaparsec.Char.char'`.++* Renamed `getPosition` to `getSourcePos`.++* Renamed `getTokensProcessed` to `getOffset`, `setTokensProcessed` to+  `setOffset`.++* Dropped `getTabWidth` and `setTabWidth` because tab width is irrelevant to+  parsing process now, it's only relevant for pretty-printing of parse+  errors, which is handled separately.++* Added and `withParsecT` in `Text.Megaparsec.Internal` to allow changing+  the type of the custom data component in parse errors.++### Parser state and input stream++* Dropped stacks of source positions. Accordingly, the functions+  `pushPosition` and `popPosition` from `Text.Megaparsec` and+  `sourcePosStackPretty` from `Text.Megaparsec.Error` were removed. The+  reason for this simplification is that I could not find any code that uses+  the feature and it makes manipulation of source positions hairy.++* Introduced `PosState` for calculating `SourcePos` from offsets and getting+  offending line for displaying on pretty-printing of parse errors. It's now+  contained in both `State` and `ParseErrorBundle`.++* Dropped `positionAt1`, `positionAtN`, `advance1`, and `advanceN` methods+  from `Stream`. They are no longer necessary because `reachOffset` (and its+  specialized version `reachOffsetNoLine`) takes care of `SourcePos`+  calculation.++### Parse errors++* `ParseError` now contains raw offset in input stream instead of+  `SourcePos`. `errorPos` was dropped from `Text.Megaparsec.Error`.++* `ParseError` is now parametrized over stream type `s` instead of token+  type `t`.++* Introduced `ParseErrorBundle` which contains one or more `ParseError`+  equipped with all information that is necessary to pretty-print them+  together with offending lines from the input stream. Functions like+  `runParser` now return `ParseErrorBundle` instead of plain `ParseError`.++  By default there will be only one `ParseError` in such a bundle, but it's+  possible to add more parse errors to a bundle manually. During+  pretty-printing, the input stream will be traversed only once.++* The primary function for pretty-printing of parse+  errors—`errorBundlePretty` always prints offending lines now.+  `parseErrorPretty` is still there, but it probably won't see a lot of use+  from now on. `parseErrorPretty'` and `parseErrorPretty_` were removed.+  `parseTest'` was removed because `parseTest` always prints offending lines+  now.++* Added `attachSourcePos` function in `Text.Megaparsec.Error`.++* The `ShowToken` type class has been removed and its method `showTokens`+  now lives in the `Stream` type class.++* The `LineToken` type class is no longer necessary because the new method+  `reachOffset` of the type class `Stream` does its job.++* In `Text.Megaparsec.Error` the following functions were added:+  `mapParseError`, `errorOffset`.++* Implemented continuous highlighting in parse errors. For this we added the+  `errorComponentLen` method to the `ShowErrorComponent` type class.++### Parse error builder++* The functions `err` and `errFancy` now accept offsets at which the parse+  errors are expected to have happened, i.e. `Int`s. Thus `posI` and `posN`+  are no longer necessary and were removed.++* `ET` is now parametrized over the type of stream `s` instead of token type+  `t`.++* Combinators like `utoks` and `etoks` now accept chunks of input stream+  directly, i.e. `Tokens s` instead of `[Token s]` which should be more+  natural and convenient.+ ## Megaparsec 6.5.0  * Added `Text.Megaparsec.Internal`, which exposes some internal data

@@ -11,8 +11,6 @@     * [Error messages](#error-messages)     * [Alex support](#alex-support)     * [Character and binary parsing](#character-and-binary-parsing)-    * [Permutation parsing](#permutation-parsing)-    * [Expression parsing](#expression-parsing)     * [Lexer](#lexer) * [Documentation](#documentation) * [Tutorials](#tutorials)@@ -65,7 +63,7 @@ * `observing` allows to “observe” parse errors without ending parsing (they   are returned in `Left`, while normal results are wrapped in `Right`). -In addition to that, Megaparsec 6 features high-performance combinators+In addition to that, Megaparsec features high-performance combinators similar to those found in Attoparsec:  * `tokens` makes it easy to parse several tokens in a row (`string` and@@ -78,9 +76,8 @@ * `takeP` allows to grab n tokens from the stream and returns them as a   “chunk” of the stream. -So now that we have matched the main “performance boosters” of Attoparsec,-Megaparsec 6 is not significantly slower than Attoparsec if you write your-parser carefully (see also [the section about performance](#performance)).+Megaparsec is about as fast as Attoparsec if you write your parser carefully+(see also [the section about performance](#performance)).  Megaparsec can currently work with the following types of input stream out-of-the-box:@@ -94,19 +91,21 @@  ### Error messages -Megaparsec 5 introduced well-typed error messages and the ability to use-custom data types to adjust the library to specific domain of interest. No-need to use a shapeless bunch of strings.+Megaparsec has well-typed error messages and the ability to use custom data+types to adjust the library to specific domain of interest. No need to use a+shapeless bunch of strings. -The design of parse errors has been revised in version 6 significantly, but-custom errors are still easy (probably even easier now).+Megaparsec 7 introduced the `ParseErrorBundle` data type that helps to+manage multi-error messages and pretty-print them easily and efficiently.+That version of the library also made the practice of displaying offending+line the default.  ### Alex support  Megaparsec works well with streams of tokens produced by tools like Alex. The design of the `Stream` type class has been changed significantly in-version 6, but user can still work with custom streams of tokens without-problems.+versions 6 and 7, but user can still work with custom streams of tokens+without problems.  ### Character and binary parsing @@ -117,24 +116,6 @@ [`Text.Megaparsec.Byte`](https://hackage.haskell.org/package/megaparsec/docs/Text-Megaparsec-Byte.html) module for parsing streams of bytes. -### Permutation parsing--For those who are interested in parsing of permutation phrases, there is-[`Text.Megaparsec.Perm`](https://hackage.haskell.org/package/megaparsec/docs/Text-Megaparsec-Perm.html).-You have to import the module explicitly, it's not included in the-`Text.Megaparsec` module.--### Expression parsing--Megaparsec has a solution for parsing of expressions. Take a look at-[`Text.Megaparsec.Expr`](https://hackage.haskell.org/package/megaparsec/docs/Text-Megaparsec-Expr.html).-You have to import the module explicitly, it's not included in the-`Text.Megaparsec`.--Given a table of operators that describes their fixity and precedence, you-can construct a parser that will parse any expression involving the-operators. See documentation for comprehensive description of how it works.- ### Lexer  [`Text.Megaparsec.Char.Lexer`](https://hackage.haskell.org/package/megaparsec/docs/Text-Megaparsec-Char-Lexer.html)@@ -173,18 +154,18 @@  ## Performance -Despite being flexible, Megaparsec is also quite fast. Here is how-Megaparsec 6.4.0 compares to Attoparsec 0.13.2.0 (the fastest widely used-parsing library in the Haskell ecosystem):+Despite being flexible, Megaparsec is also fast. Here is how Megaparsec+7.0.0 compares to Attoparsec 0.13.2.2 (the fastest widely used parsing+library in the Haskell ecosystem):  Test case         | Execution time | Allocated | Max residency ------------------|---------------:|----------:|-------------:-CSV (Attoparsec)  |       57.14 μs |   397,912 |        10,560-CSV (Megaparsec)  |       76.27 μs |   557,272 |         9,120-Log (Attoparsec)  |       244.2 μs | 1,181,120 |        11,144-Log (Megaparsec)  |       315.2 μs | 1,485,776 |        11,392-JSON (Attoparsec) |       14.39 μs |   132,496 |         9,048-JSON (Megaparsec) |       26.70 μs |   233,336 |         9,424+CSV (Attoparsec)  |       76.50 μs |   397,784 |        10,544+CSV (Megaparsec)  |       64.69 μs |   352,408 |         9,104+Log (Attoparsec)  |       302.8 μs | 1,150,032 |        10,912+Log (Megaparsec)  |       337.8 μs | 1,246,496 |        10,912+JSON (Attoparsec) |       18.20 μs |   128,368 |         9,032+JSON (Megaparsec) |       25.45 μs |   203,824 |         9,176  The benchmarks were created to guide development of Megaparsec 6 and can be found [here](https://github.com/mrkkrp/parsers-bench).@@ -204,9 +185,9 @@ library for parsing. Although the both libraries deal with parsing, it's usually easy to decide which you will need in particular project: -* *Attoparsec* is faster but not that feature-rich. It should be used when-  you want to process large amounts of data where performance matters more-  than quality of error messages.+* *Attoparsec* is sometimes faster but not that feature-rich. It should be+  used when you want to process large amounts of data where performance+  matters more than quality of error messages.  * *Megaparsec* is good for parsing of source code or other human-readable   texts. It has better error messages and it's implemented as monad@@ -359,6 +340,7 @@ Here are some blog posts mainly announcing new features of the project and describing what sort of things are now possible: +* [Megaparsec 7](https://markkarpov.com/post/megaparsec-7.html) * [Evolution of error messages](https://markkarpov.com/post/evolution-of-error-messages.html) * [A major upgrade to Megaparsec: more speed, more power](https://markkarpov.com/post/megaparsec-more-speed-more-power.html) * [Latest additions to Megaparsec](https://markkarpov.com/post/latest-additions-to-megaparsec.html)

@@ -24,21 +24,18 @@ -- > type Parser = Parsec Void Text -- >                      ^    ^ -- >                      |    |--- > Custom error component    Type of input+-- > Custom error component    Input stream type ----- Then you can write type signatures like @Parser Int@—for a parser that+-- Then you can write type signatures like @Parser 'Int'@—for a parser that -- returns an 'Int' for example. -- -- Similarly (since it's known to cause confusion), you should use--- 'ParseError' type parametrized like this:------ > ParseError Char Void--- >            ^    ^--- >            |    |--- >   Token type    Custom error component (the same you used in Parser)+-- 'ParseErrorBundle' type parametrized like this: ----- Token type for 'String' and 'Data.Text.Text' (strict and lazy) is 'Char',--- for 'Data.ByteString.ByteString's it's 'Data.Word.Word8'.+-- > ParseErrorBundle Text Void+-- >                  ^    ^+-- >                  |    |+-- >  Input stream type    Custom error component (the same you used in Parser) -- -- Megaparsec uses some type-level machinery to provide flexibility without -- compromising on type safety. Thus type signatures are sometimes necessary@@ -46,25 +43,14 @@ -- like “Type variable @e0@ is ambiguous …”, you need to give an explicit -- signature to your parser to resolve 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", do lexing with--- "Text.Megaparsec.Char.Lexer" and "Text.Megaparsec.Byte.Lexer". These--- modules should be imported explicitly along with the modules mentioned--- above. -{-# LANGUAGE CPP                        #-}-{-# LANGUAGE FlexibleContexts           #-}-{-# LANGUAGE FlexibleInstances          #-}-{-# LANGUAGE LambdaCase                 #-}-{-# LANGUAGE MultiParamTypeClasses      #-}-{-# LANGUAGE RankNTypes                 #-}-{-# LANGUAGE RecordWildCards            #-}-{-# LANGUAGE ScopedTypeVariables        #-}-{-# LANGUAGE TupleSections              #-}-{-# LANGUAGE TypeFamilies               #-}-{-# LANGUAGE UndecidableInstances       #-}+{-# LANGUAGE FlexibleContexts      #-}+{-# LANGUAGE FlexibleInstances     #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE RankNTypes            #-}+{-# LANGUAGE ScopedTypeVariables   #-}+{-# LANGUAGE TypeFamilies          #-}+{-# LANGUAGE UndecidableInstances  #-}  module Text.Megaparsec   ( -- * Re-exports@@ -75,13 +61,13 @@   , module Control.Monad.Combinators     -- * Data types   , State (..)+  , PosState (..)   , Parsec   , ParsecT     -- * Running parser   , parse   , parseMaybe   , parseTest-  , parseTest'   , runParser   , runParser'   , runParserT@@ -89,6 +75,13 @@     -- * Primitive combinators   , MonadParsec (..)     -- * Derivatives of primitive combinators+  , single+  , satisfy+  , anySingle+  , anySingleBut+  , oneOf+  , noneOf+  , chunk   , (<?>)   , unexpected   , customFailure@@ -99,18 +92,10 @@     -- * Parser state combinators   , getInput   , setInput-  , getPosition-  , getNextTokenPosition-  , setPosition-  , pushPosition-  , popPosition-  , getTokensProcessed-  , setTokensProcessed-  , getTabWidth-  , setTabWidth-  , setParserState-    -- * Debugging-  , dbg )+  , getSourcePos+  , getOffset+  , setOffset+  , setParserState ) where  import Control.Monad@@ -118,20 +103,13 @@ 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+import qualified Data.Set as E  -- $reexports --@@ -151,6 +129,12 @@ -- This module is intended to be imported qualified: -- -- > import qualified Control.Monad.Combinators.NonEmpty as NE+--+-- Other modules of interest are:+--+--     * "Control.Monad.Combinators.Expr" for parsing of expressions.+--     * "Control.Applicative.Permutations" for parsing of permutations+--       phrases.  ---------------------------------------------------------------------------- -- Data types@@ -163,24 +147,25 @@ ---------------------------------------------------------------------------- -- 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.+-- | @'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+-- 'ParseErrorBundle' ('Left') or a value of type @a@ ('Right').+-- 'errorBundlePretty' can be used to turn 'ParseErrorBundle' 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)+-- > main = case parse numbers "" "11,2,43" of+-- >          Left bundle -> putStr (errorBundlePretty bundle) -- >          Right xs -> print (sum xs) -- >--- > numbers = integer `sepBy` char ','+-- > numbers = decimal `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+  -> Either (ParseErrorBundle s e) a parse = runParser  -- | @'parseMaybe' p input@ runs the parser @p@ on @input@ and returns the@@ -203,33 +188,15 @@ -- input @input@ and prints the result to stdout. Useful for testing.  parseTest :: ( ShowErrorComponent e-             , Ord (Token s)-             , ShowToken (Token s)-             , Show a )+             , 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 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)+    Left  e -> putStr (errorBundlePretty e)     Right x -> print x  -- | @'runParser' p file input@ runs parser @p@ on the input stream of@@ -243,7 +210,7 @@   :: Parsec e s a -- ^ Parser to run   -> String     -- ^ Name of source file   -> s          -- ^ Input for parser-  -> Either (ParseError (Token s) e) a+  -> Either (ParseErrorBundle s e) a runParser p name s = snd $ runParser' p (initialState name s)  -- | The function is similar to 'runParser' with the difference that it@@ -256,7 +223,7 @@ runParser'   :: Parsec e s a -- ^ Parser to run   -> State s    -- ^ Initial state-  -> (State s, Either (ParseError (Token s) e) a)+  -> (State s, Either (ParseErrorBundle s e) a) runParser' p = runIdentity . runParserT' p  -- | @'runParserT' p file input@ runs parser @p@ on the input list of tokens@@ -269,7 +236,7 @@   => ParsecT e s m a -- ^ Parser to run   -> String        -- ^ Name of source file   -> s             -- ^ Input for parser-  -> m (Either (ParseError (Token s) e) a)+  -> m (Either (ParseErrorBundle s e) a) runParserT p name s = snd `liftM` runParserT' p (initialState name s)  -- | This function is similar to 'runParserT', but like 'runParser'' it@@ -281,25 +248,162 @@ runParserT' :: Monad m   => ParsecT e s m a -- ^ Parser to run   -> State s       -- ^ Initial state-  -> m (State s, Either (ParseError (Token s) e) a)+  -> m (State s, Either (ParseErrorBundle 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)+  return $ case result of+    OK    x -> (s', Right x)+    Error e ->+      let bundle = ParseErrorBundle+            { bundleErrors = e :| []+            , bundlePosState = statePosState s+            }+      in (s', Left bundle)  -- | 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 }+  { stateInput  = s+  , stateOffset = 0+  , statePosState = PosState+    { pstateInput = s+    , pstateOffset = 0+    , pstateSourcePos = initialPos name+    , pstateTabWidth = defaultTabWidth+    , pstateLinePrefix = ""+    }+  }  ---------------------------------------------------------------------------- -- Derivatives of primitive combinators +-- | @'single' t@ only matches the single token @t@.+--+-- > semicolon = single ';'+--+-- See also: 'token', 'anySingle', 'Text.Megaparsec.Byte.char',+-- 'Text.Megaparsec.Char.char'.+--+-- @since 7.0.0++single :: MonadParsec e s m+  => Token s           -- ^ Token to match+  -> m (Token s)+single t = token testToken expected+  where+    testToken x = if x == t then Just x else Nothing+    expected    = E.singleton (Tokens (t:|[]))+{-# INLINE single #-}++-- | The parser @'satisfy' f@ succeeds for any token for which the supplied+-- function @f@ returns 'True'. Returns the character that is actually+-- parsed.+--+-- > digitChar = satisfy isDigit <?> "digit"+-- > oneOf cs  = satisfy (`elem` cs)+--+-- See also: 'anySingle', 'anySingleBut', 'oneOf', 'noneOf'.+--+-- @since 7.0.0++satisfy :: MonadParsec e s m+  => (Token s -> Bool) -- ^ Predicate to apply+  -> m (Token s)+satisfy f = token testChar E.empty+  where+    testChar x = if f x then Just x else Nothing+{-# INLINE satisfy #-}++-- | Parse and return a single token. It's a good idea to attach a 'label'+-- to this parser manually.+--+-- > anySingle = satisfy (const True)+--+-- See also: 'satisfy', 'anySingleBut'.+--+-- @since 7.0.0++anySingle :: MonadParsec e s m => m (Token s)+anySingle = satisfy (const True)+{-# INLINE anySingle #-}++-- | Match any token but the given one. It's a good idea to attach a 'label'+-- to this parser manually.+--+-- > anySingleBut t = satisfy (/= t)+--+-- See also: 'single', 'anySingle', 'satisfy'.+--+-- @since 7.0.0++anySingleBut :: MonadParsec e s m+  => Token s           -- ^ Token we should not match+  -> m (Token s)+anySingleBut t = satisfy (/= t)+{-# INLINE anySingleBut #-}++-- | @'oneOf' ts@ succeeds if the current token is in the supplied+-- collection of tokens @ts@. Returns the parsed token. Note that this+-- parser cannot automatically generate the “expected” component of error+-- message, so usually you should label it manually with 'label' or ('<?>').+--+-- > oneOf cs = satisfy (`elem` cs)+--+-- See also: 'satisfy'.+--+-- > digit = oneOf ['0'..'9'] <?> "digit"+--+-- __Performance note__: prefer 'satisfy' when you can because it's faster+-- when you have only a couple of tokens to compare to:+--+-- > quoteFast = satisfy (\x -> x == '\'' || x == '\"')+-- > quoteSlow = oneOf "'\""+--+-- @since 7.0.0++oneOf :: (Foldable f, MonadParsec e s m)+  => f (Token s)       -- ^ Collection of matching tokens+  -> m (Token s)+oneOf cs = satisfy (`elem` cs)+{-# INLINE oneOf #-}++-- | As the dual of 'oneOf', @'noneOf' ts@ succeeds if the current token+-- /not/ in the supplied list of tokens @ts@. Returns the parsed character.+-- Note that this parser cannot automatically generate the “expected”+-- component of error message, so usually you should label it manually with+-- 'label' or ('<?>').+--+-- > noneOf cs = satisfy (`notElem` cs)+--+-- See also: 'satisfy'.+--+-- __Performance note__: prefer 'satisfy' and 'singleBut' when you can+-- because it's faster.+--+-- @since 7.0.0++noneOf :: (Foldable f, MonadParsec e s m)+  => f (Token s)       -- ^ Collection of taken we should not match+  -> m (Token s)+noneOf cs = satisfy (`notElem` cs)+{-# INLINE noneOf #-}++-- | @'chunk' chk@ only matches the chunk @chk@.+--+-- > divOrMod = chunk "div" <|> chunk "mod"+--+-- See also: 'tokens', 'Text.Megaparsec.Char.string',+-- 'Text.Megaparsec.Byte.string'.+--+-- @since 7.0.0++chunk :: MonadParsec e s m+  => Tokens s          -- ^ Chunk to match+  -> m (Tokens s)+chunk = tokens (==)+{-# INLINE chunk #-}+ -- | A synonym for 'label' in the form of an operator.  infix 0 <?>@@ -311,15 +415,17 @@ -- | The parser @'unexpected' item@ fails with an error message telling -- about unexpected item @item@ without consuming any input. ----- > unexpected item = failure (pure item) Set.empty+-- > unexpected item = failure (Just item) Set.empty  unexpected :: MonadParsec e s m => ErrorItem (Token s) -> m a-unexpected item = failure (pure item) E.empty+unexpected item = failure (Just item) E.empty {-# INLINE unexpected #-}  -- | Report a custom parse error. For a more general version, see -- 'fancyFailure'. --+-- > customFailure = fancyFailure . E.singleton . ErrorCustom+-- -- @since 6.3.0  customFailure :: MonadParsec e s m => e -> m a@@ -327,38 +433,37 @@ {-# INLINE customFailure #-}  -- | Return both the result of a parse and a chunk of input that was--- consumed during parsing. This relies on the change of the--- 'stateTokensProcessed' value to evaluate how many tokens were consumed.--- If you mess with it manually in the argument parser, prepare for--- troubles.+-- consumed during parsing. This relies on the change of the 'stateOffset'+-- value to evaluate how many tokens were consumed. If you mess with it+-- manually in the argument parser, prepare for troubles. -- -- @since 5.3.0  match :: MonadParsec e s m => m a -> m (Tokens s, a) match p = do-  tp  <- getTokensProcessed-  s   <- getInput-  r   <- p-  tp' <- getTokensProcessed+  o  <- getOffset+  s  <- getInput+  r  <- p+  o' <- getOffset   -- NOTE The 'fromJust' call here should never fail because if the stream   -- is empty before 'p' (the only case when 'takeN_' can return 'Nothing'   -- as per its invariants), (tp' - tp) won't be greater than 0, and in that   -- case 'Just' is guaranteed to be returned as per another invariant of   -- 'takeN_'.-  return ((fst . fromJust) (takeN_ (tp' - tp) s), r)+  return ((fst . fromJust) (takeN_ (o' - o) s), r) {-# INLINEABLE match #-}  -- | Specify how to process 'ParseError's that happen inside of this -- wrapper. As a side effect of the current implementation changing--- 'errorPos' with this combinator will also change the final 'statePos' in--- the parser state (try to avoid that because 'statePos' will go out of--- sync with factual position in the input stream, which is probably OK if--- you finish parsing right after that, but be warned).+-- 'errorOffset' with this combinator will also change the final+-- 'stateOffset' in the parser state (try to avoid that because+-- 'stateOffset' will go out of sync with factual position in the input+-- stream and pretty-printing of parse errors afterwards will be incorrect). -- -- @since 5.3.0  region :: MonadParsec e s m-  => (ParseError (Token s) e -> ParseError (Token s) e)+  => (ParseError s e -> ParseError s e)      -- ^ How to process 'ParseError's   -> m a               -- ^ The “region” that the processing applies to   -> m a@@ -367,17 +472,17 @@   case r of     Left err ->       case f err of-        TrivialError pos us ps -> do-          updateParserState $ \st -> st { statePos = pos }+        TrivialError o us ps -> do+          updateParserState $ \st -> st { stateOffset = o }           failure us ps-        FancyError pos xs -> do-          updateParserState $ \st -> st { statePos = pos }+        FancyError o xs -> do+          updateParserState $ \st -> st { stateOffset = o }           fancyFailure xs     Right x -> return x {-# INLINEABLE region #-}  -- | Consume the rest of the input and return it as a chunk. This parser--- never fails, but may return an empty chunk.+-- never fails, but may return the empty chunk. -- -- > takeRest = takeWhileP Nothing (const True) --@@ -389,6 +494,8 @@  -- | Return 'True' when end of input has been reached. --+-- > atEnd = option False (True <$ hidden eof)+-- -- @since 6.0.0  atEnd :: MonadParsec e s m => m Bool@@ -402,210 +509,57 @@  getInput :: MonadParsec e s m => m s getInput = stateInput <$> getParserState+{-# INLINE getInput #-} --- | @'setInput' input@ continues parsing with @input@. The 'getInput' and--- 'setInput' functions can for example be used to deal with include files.+-- | @'setInput' input@ continues parsing with @input@.  setInput :: MonadParsec e s m => s -> m ()-setInput s = updateParserState (\(State _ pos tp w) -> State s pos tp w)---- | Return the current source position.------ See also: 'setPosition', 'pushPosition', 'popPosition', and 'SourcePos'.--getPosition :: MonadParsec e s m => m SourcePos-getPosition = NE.head . statePos <$> getParserState---- | Get the position where the next token in the stream begins. If the--- stream is empty, return 'Nothing'.------ @since 5.3.0--getNextTokenPosition :: forall e s m. MonadParsec e s m => m (Maybe SourcePos)-getNextTokenPosition = do-  State {..} <- getParserState-  let f = positionAt1 (Proxy :: Proxy s) (NE.head statePos)-  return (f . fst <$> take1_ stateInput)-{-# INLINEABLE getNextTokenPosition #-}---- | @'setPosition' pos@ sets the current source position to @pos@.------ See also: 'getPosition', 'pushPosition', 'popPosition', and 'SourcePos'.--setPosition :: MonadParsec e s m => SourcePos -> m ()-setPosition pos = updateParserState $ \(State s (_:|z) tp w) ->-  State s (pos:|z) tp w---- | Push a position into stack of positions and continue parsing working--- with this position. Useful for working with include files and the like.------ See also: 'getPosition', 'setPosition', 'popPosition', and 'SourcePos'.------ @since 5.0.0--pushPosition :: MonadParsec e s m => SourcePos -> m ()-pushPosition pos = updateParserState $ \(State s z tp w) ->-  State s (NE.cons pos z) tp w+setInput s = updateParserState (\(State _ o pst) -> State s o pst)+{-# INLINE setInput #-} --- | Pop a position from the stack of positions unless it only contains one--- element (in that case the stack of positions remains the same). This is--- how to return to previous source file after 'pushPosition'.+-- | Return the current source position. This function /is not cheap/, do+-- not call it e.g. on matching of every token, that's a bad idea. Still you+-- can use it to get 'SourcePos' to attach to things that you parse. ----- See also: 'getPosition', 'setPosition', 'pushPosition', and 'SourcePos'.+-- The function works under the assumption that we move in input stream only+-- forward and never backward, which is always true unless the user abuses+-- the library on purpose. ----- @since 5.0.0+-- @since 7.0.0 -popPosition :: MonadParsec e s m => m ()-popPosition = updateParserState $ \(State s z tp w) ->-  case snd (NE.uncons z) of-    Nothing -> State s z  tp w-    Just z' -> State s z' tp w+getSourcePos :: MonadParsec e s m => m SourcePos+getSourcePos = do+  st <- getParserState+  let (pos, pst) = reachOffsetNoLine (stateOffset st) (statePosState st)+  setParserState st { statePosState = pst }+  return pos+{-# INLINE getSourcePos #-}  -- | Get the number of tokens processed so far. ----- @since 6.0.0+-- See also: 'setOffset'.+--+-- @since 7.0.0 -getTokensProcessed :: MonadParsec e s m => m Int-getTokensProcessed = stateTokensProcessed <$> getParserState+getOffset :: MonadParsec e s m => m Int+getOffset = stateOffset <$> getParserState+{-# INLINE getOffset #-}  -- | Set the number of tokens processed so far. ----- @since 6.0.0--setTokensProcessed :: MonadParsec e s m => Int -> m ()-setTokensProcessed tp = updateParserState $ \(State s pos _ w) ->-  State s pos tp w---- | Return the tab width. The default tab width is equal to--- 'defaultTabWidth'. You can set a different tab width with the help of--- 'setTabWidth'.--getTabWidth :: MonadParsec e s m => m Pos-getTabWidth = stateTabWidth <$> getParserState---- | Set tab width. If the argument of the function is not a positive--- number, 'defaultTabWidth' will be used.+-- See also: 'getOffset'.+--+-- @since 7.0.0 -setTabWidth :: MonadParsec e s m => Pos -> m ()-setTabWidth w = updateParserState $ \(State s pos tp _) ->-  State s pos tp w+setOffset :: MonadParsec e s m => Int -> m ()+setOffset o = updateParserState $ \(State s _ pst) ->+  State s o pst+{-# INLINE setOffset #-}  -- | @'setParserState' st@ sets the parser state to @st@.+--+-- See also: 'getParserState', 'updateParserState'.  setParserState :: MonadParsec e s m => State s -> m () setParserState st = updateParserState (const st)--------------------------------------------------------------------------------- Debugging---- | @'dbg' label p@ parser works exactly like @p@, but when it's evaluated--- it also prints information useful for debugging. The @label@ is only used--- to refer to this parser in the debugging output. This combinator uses the--- 'trace' function from "Debug.Trace" under the hood.------ Typical usage is to wrap every sub-parser in misbehaving parser with--- 'dbg' assigning meaningful labels. Then give it a shot and go through the--- print-out. As of current version, this combinator prints all available--- information except for /hints/, which are probably only interesting to--- the maintainer of Megaparsec itself and may be quite verbose to output in--- general. Let me know if you would like to be able to see hints in the--- debugging output.------ The output itself is pretty self-explanatory, although the following--- abbreviations should be clarified (they are derived from the low-level--- source code):------     * @COK@—“consumed OK”. The parser consumed input and succeeded.---     * @CERR@—“consumed error”. The parser consumed input and failed.---     * @EOK@—“empty OK”. The parser succeeded without consuming input.---     * @EERR@—“empty error”. The parser failed without consuming input.------ 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.--- 'Show' instance for state), so this helper is only available for--- 'ParsecT' monad, not 'MonadParsec' in general.------ @since 5.1.0--dbg :: forall e s m a.-  ( Stream s-  , ShowToken (Token s)-  , ShowErrorComponent e-  , Show a )-  => String            -- ^ Debugging label-  -> ParsecT e s m a   -- ^ Parser to debug-  -> ParsecT e s m a   -- ^ Parser that prints debugging messages-dbg lbl p = ParsecT $ \s cok cerr eok eerr ->-  let l = dbgLog lbl :: DbgItem s e a -> String-      unfold = streamTake 40-      cok' x s' hs = flip trace (cok x s' hs) $-        l (DbgIn (unfold (stateInput s))) ++-        l (DbgCOK (streamTake (streamDelta s s') (stateInput s)) x)-      cerr' err s' = flip trace (cerr err s') $-        l (DbgIn (unfold (stateInput s))) ++-        l (DbgCERR (streamTake (streamDelta s s') (stateInput s)) err)-      eok' x s' hs = flip trace (eok x s' hs) $-        l (DbgIn (unfold (stateInput s))) ++-        l (DbgEOK (streamTake (streamDelta s s') (stateInput s)) x)-      eerr' err s' = flip trace (eerr err s') $-        l (DbgIn (unfold (stateInput s))) ++-        l (DbgEERR (streamTake (streamDelta s s') (stateInput s)) err)-  in unParser p s cok' cerr' eok' eerr'---- | A single piece of info to be rendered with 'dbgLog'.--data DbgItem s e a-  = DbgIn   [Token s]-  | DbgCOK  [Token s] a-  | DbgCERR [Token s] (ParseError (Token s) e)-  | DbgEOK  [Token s] a-  | DbgEERR [Token s] (ParseError (Token s) e)---- | Render a single piece of debugging info.--dbgLog :: (ShowToken (Token s), ShowErrorComponent e, Show a, Ord (Token s))-  => String            -- ^ Debugging label-  -> DbgItem s e a     -- ^ Information to render-  -> String            -- ^ Rendered result-dbgLog lbl item = prefix msg-  where-    prefix = unlines . fmap ((lbl ++ "> ") ++) . lines-    msg = case item of-      DbgIn   ts   ->-        "IN: " ++ showStream ts-      DbgCOK  ts a ->-        "MATCH (COK): " ++ showStream ts ++ "\nVALUE: " ++ show a-      DbgCERR ts e ->-        "MATCH (CERR): " ++ showStream ts ++ "\nERROR:\n" ++ parseErrorPretty e-      DbgEOK  ts a ->-        "MATCH (EOK): " ++ showStream ts ++ "\nVALUE: " ++ show a-      DbgEERR ts e ->-        "MATCH (EERR): " ++ showStream ts ++ "\nERROR:\n" ++ parseErrorPretty e---- | Pretty-print a list of tokens.--showStream :: ShowToken t => [t] -> String-showStream ts =-  case NE.nonEmpty ts of-    Nothing -> "<EMPTY>"-    Just ne ->-      let (h, r) = splitAt 40 (showTokens ne)-      in if null r then h else h ++ " <…>"---- | Calculate number of consumed tokens given 'State' of parser before and--- after parsing.--streamDelta-  :: State s           -- ^ State of parser before consumption-  -> State s           -- ^ State of parser after consumption-  -> Int               -- ^ Number of consumed tokens-streamDelta s0 s1 = stateTokensProcessed s1 - stateTokensProcessed s0---- | Extract a given number of tokens from the stream.--streamTake :: forall s. Stream s => Int -> s -> [Token s]-streamTake n s =-  case fst <$> takeN_ n s of-    Nothing -> []-    Just chunk -> chunkToTokens (Proxy :: Proxy s) chunk+{-# INLINE setParserState #-}

@@ -31,30 +31,25 @@   , alphaNumChar   , printChar   , digitChar+  , binDigitChar   , octDigitChar   , hexDigitChar   , asciiChar-    -- * More general parsers-  , C.char+    -- * Single byte+  , char   , char'-  , C.anyChar-  , C.notChar-  , C.oneOf-  , C.noneOf-  , C.satisfy     -- * Sequence of bytes-  , C.string-  , C.string' )+  , string+  , string' ) where  import Control.Applicative-import Data.Char+import Data.Char hiding (toLower, toUpper) import Data.Functor (void)-import Data.Maybe (fromMaybe) import Data.Proxy import Data.Word (Word8) import Text.Megaparsec-import qualified Text.Megaparsec.Char as C+import Text.Megaparsec.Common  ---------------------------------------------------------------------------- -- Simple parsers@@ -62,14 +57,14 @@ -- | Parse a newline byte.  newline :: (MonadParsec e s m, Token s ~ Word8) => m (Token s)-newline = C.char 10+newline = char 10 {-# INLINE newline #-}  -- | Parse a carriage return character followed by a newline character. -- Return the sequence of characters parsed.  crlf :: forall e s m. (MonadParsec e s m, Token s ~ Word8) => m (Tokens s)-crlf = C.string (tokensToChunk (Proxy :: Proxy s) [13,10])+crlf = string (tokensToChunk (Proxy :: Proxy s) [13,10]) {-# INLINE crlf #-}  -- | Parse a CRLF (see 'crlf') or LF (see 'newline') end of line. Return the@@ -84,7 +79,7 @@ -- | Parse a tab character.  tab :: (MonadParsec e s m, Token s ~ Word8) => m (Token s)-tab = C.char 9+tab = char 9 {-# INLINE tab #-}  -- | Skip /zero/ or more white space characters.@@ -109,59 +104,69 @@ -- | Parse a control character.  controlChar :: (MonadParsec e s m, Token s ~ Word8) => m (Token s)-controlChar = C.satisfy (isControl . toChar) <?> "control character"+controlChar = satisfy (isControl . toChar) <?> "control character" {-# INLINE controlChar #-}  -- | Parse a space character, and the control characters: tab, newline, -- carriage return, form feed, and vertical tab.  spaceChar :: (MonadParsec e s m, Token s ~ Word8) => m (Token s)-spaceChar = C.satisfy isSpace' <?> "white space"+spaceChar = satisfy isSpace' <?> "white space" {-# INLINE spaceChar #-}  -- | Parse an upper-case character.  upperChar :: (MonadParsec e s m, Token s ~ Word8) => m (Token s)-upperChar = C.satisfy (isUpper . toChar) <?> "uppercase letter"+upperChar = satisfy (isUpper . toChar) <?> "uppercase letter" {-# INLINE upperChar #-}  -- | Parse a lower-case alphabetic character.  lowerChar :: (MonadParsec e s m, Token s ~ Word8) => m (Token s)-lowerChar = C.satisfy (isLower . toChar) <?> "lowercase letter"+lowerChar = satisfy (isLower . toChar) <?> "lowercase letter" {-# INLINE lowerChar #-}  -- | Parse an alphabetic character: lower-case or upper-case.  letterChar :: (MonadParsec e s m, Token s ~ Word8) => m (Token s)-letterChar = C.satisfy (isLetter . toChar) <?> "letter"+letterChar = satisfy (isLetter . toChar) <?> "letter" {-# INLINE letterChar #-}  -- | Parse an alphabetic or digit characters.  alphaNumChar :: (MonadParsec e s m, Token s ~ Word8) => m (Token s)-alphaNumChar = C.satisfy (isAlphaNum . toChar) <?> "alphanumeric character"+alphaNumChar = satisfy (isAlphaNum . toChar) <?> "alphanumeric character" {-# INLINE alphaNumChar #-}  -- | Parse a printable character: letter, number, mark, punctuation, symbol -- or space.  printChar :: (MonadParsec e s m, Token s ~ Word8) => m (Token s)-printChar = C.satisfy (isPrint . toChar) <?> "printable character"+printChar = satisfy (isPrint . toChar) <?> "printable character" {-# INLINE printChar #-}  -- | Parse an ASCII digit, i.e between “0” and “9”.  digitChar :: (MonadParsec e s m, Token s ~ Word8) => m (Token s)-digitChar = C.satisfy isDigit' <?> "digit"+digitChar = satisfy isDigit' <?> "digit"   where     isDigit' x = x >= 48 && x <= 57 {-# INLINE digitChar #-} +-- | Parse a binary digit, i.e. “0” or “1”.+--+-- @since 7.0.0++binDigitChar :: (MonadParsec e s m, Token s ~ Word8) => m (Token s)+binDigitChar = satisfy isBinDigit <?> "binary digit"+  where+    isBinDigit x = x == 48 || x == 49+{-# INLINE binDigitChar #-}+ -- | Parse an octal digit, i.e. between “0” and “7”.  octDigitChar :: (MonadParsec e s m, Token s ~ Word8) => m (Token s)-octDigitChar = C.satisfy isOctDigit' <?> "octal digit"+octDigitChar = satisfy isOctDigit' <?> "octal digit"   where     isOctDigit' x = x >= 48 && x <= 55 {-# INLINE octDigitChar #-}@@ -170,19 +175,27 @@ -- “A” and “F”.  hexDigitChar :: (MonadParsec e s m, Token s ~ Word8) => m (Token s)-hexDigitChar = C.satisfy (isHexDigit . toChar) <?> "hexadecimal digit"+hexDigitChar = satisfy (isHexDigit . toChar) <?> "hexadecimal digit" {-# INLINE hexDigitChar #-}  -- | Parse a character from the first 128 characters of the Unicode -- character set, corresponding to the ASCII character set.  asciiChar :: (MonadParsec e s m, Token s ~ Word8) => m (Token s)-asciiChar = C.satisfy (< 128) <?> "ASCII character"+asciiChar = satisfy (< 128) <?> "ASCII character" {-# INLINE asciiChar #-}  ------------------------------------------------------------------------------- More general parsers+-- Single byte +-- | A type-constrained version of 'single'.+--+-- > newline = char 10++char :: (MonadParsec e s m, Token s ~ Word8) => Token s -> m (Token s)+char = single+{-# INLINE char #-}+ -- | The same as 'char' but case-insensitive. This parser returns the -- actually parsed character preserving its case. --@@ -195,15 +208,9 @@  char' :: (MonadParsec e s m, Token s ~ Word8) => Token s -> m (Token s) char' c = choice-  [ C.char c-  , C.char (fromMaybe c (swapCase c)) ]-  where-    swapCase x-      | isUpper g = fromChar (toLower g)-      | isLower g = fromChar (toUpper g)-      | otherwise = Nothing-      where-        g = toChar x+  [ char (toLower c)+  , char (toUpper c)+  ] {-# INLINE char' #-}  ----------------------------------------------------------------------------@@ -225,11 +232,23 @@ toChar = chr . fromIntegral {-# INLINE toChar #-} --- | Convert a char to byte.+-- | Convert a byte to its upper-case version. -fromChar :: Char -> Maybe Word8-fromChar x = let p = ord x in-  if p > 0xff-    then Nothing-    else Just (fromIntegral p)-{-# INLINE fromChar #-}+toUpper :: Word8 -> Word8+toUpper x+  | x >= 97 && x <= 122 = x - 32+  | x == 247 = x -- division sign+  | x == 255 = x -- latin small letter y with diaeresis+  | x >= 224 = x - 32+  | otherwise = x+{-# INLINE toUpper #-}++-- | Convert a byte to its lower-case version.++toLower :: Word8 -> Word8+toLower x+  | x >= 65 && x <= 90 = x + 32+  | x == 215 = x -- multiplication sign+  | x >= 192 && x <= 222 = x + 32+  | otherwise = x+{-# INLINE toLower #-}

@@ -19,15 +19,16 @@  module Text.Megaparsec.Byte.Lexer   ( -- * White space-    C.space-  , C.lexeme-  , C.symbol-  , C.symbol'+    space+  , lexeme+  , symbol+  , symbol'   , skipLineComment   , skipBlockComment   , skipBlockCommentNested     -- * Numbers   , decimal+  , binary   , octal   , hexadecimal   , scientific@@ -42,9 +43,9 @@ import Data.Scientific (Scientific) import Data.Word (Word8) import Text.Megaparsec-import Text.Megaparsec.Byte-import qualified Data.Scientific            as Sci-import qualified Text.Megaparsec.Char.Lexer as C+import Text.Megaparsec.Lexer+import qualified Data.Scientific      as Sci+import qualified Text.Megaparsec.Byte as B  ---------------------------------------------------------------------------- -- White space@@ -58,7 +59,7 @@   => Tokens s          -- ^ Line comment prefix   -> m () skipLineComment prefix =-  string prefix *> void (takeWhileP (Just "character") (/= 10))+  B.string prefix *> void (takeWhileP (Just "character") (/= 10)) {-# INLINEABLE skipLineComment #-}  -- | @'skipBlockComment' start end@ skips non-nested block comment starting@@ -68,10 +69,10 @@   => Tokens s          -- ^ Start of block comment   -> Tokens s          -- ^ End of block comment   -> m ()-skipBlockComment start end = p >> void (manyTill anyChar n)+skipBlockComment start end = p >> void (manyTill anySingle n)   where-    p = string start-    n = string end+    p = B.string start+    n = B.string end {-# INLINEABLE skipBlockComment #-}  -- | @'skipBlockCommentNested' start end@ skips possibly nested block@@ -85,9 +86,9 @@   -> m () skipBlockCommentNested start end = p >> void (manyTill e n)   where-    e = skipBlockCommentNested start end <|> void anyChar-    p = string start-    n = string end+    e = skipBlockCommentNested start end <|> void anySingle+    p = B.string start+    n = B.string end {-# INLINEABLE skipBlockCommentNested #-}  ----------------------------------------------------------------------------@@ -113,7 +114,29 @@   where     mkNum    = foldl' step 0 . chunkToTokens (Proxy :: Proxy s)     step a w = a * 10 + fromIntegral (w - 48)+{-# INLINE decimal_ #-} +-- | Parse an integer in binary representation. Binary number is expected to+-- be a non-empty sequence of zeroes “0” and ones “1”.+--+-- You could of course parse some prefix before the actual number:+--+-- > binary = char 48 >> char' 98 >> L.binary+--+-- @since 7.0.0++binary+  :: forall e s m a. (MonadParsec e s m, Token s ~ Word8, Integral a)+  => m a+binary = mkNum+  <$> takeWhile1P Nothing isBinDigit+  <?> "binary integer"+  where+    mkNum        = foldl' step 0 . chunkToTokens (Proxy :: Proxy s)+    step a w     = a * 2 + fromIntegral (w - 48)+    isBinDigit w = w == 48 || w == 49+{-# INLINEABLE binary #-}+ -- | Parse an integer in octal representation. Representation of octal -- number is expected to be according to the Haskell report except for the -- fact that this parser doesn't parse “0o” or “0O” prefix. It is a@@ -122,7 +145,7 @@ -- -- For example you can make it conform to the Haskell report like this: ----- > octal = char '0' >> char' 'o' >> L.octal+-- > octal = char 48 >> char' 111 >> L.octal  octal   :: forall e s m a. (MonadParsec e s m, Token s ~ Word8, Integral a)@@ -144,7 +167,7 @@ -- -- For example you can make it conform to the Haskell report like this: ----- > hexadecimal = char '0' >> char' 'x' >> L.hexadecimal+-- > hexadecimal = char 48 >> char' 120 >> L.hexadecimal  hexadecimal   :: forall e s m a. (MonadParsec e s m, Token s ~ Word8, Integral a)@@ -210,7 +233,7 @@   -> Integer   -> m SP dotDecimal_ pxy c' = do-  void (char 46)+  void (B.char 46)   let mkNum    = foldl' step (SP c' 0) . chunkToTokens pxy       step (SP a e') w = SP         (a * 10 + fromIntegral (w - 48))@@ -222,7 +245,7 @@   => Int   -> m Int exponent_ e' = do-  void (char' 101)+  void (B.char' 101)   (+ e') <$> signed (return ()) decimal_ {-# INLINE exponent_ #-} @@ -242,9 +265,9 @@   => m ()              -- ^ How to consume white space after the sign   -> m a               -- ^ How to parse the number itself   -> m a               -- ^ Parser for signed numbers-signed spc p = ($) <$> option id (C.lexeme spc sign) <*> p+signed spc p = option id (lexeme spc sign) <*> p   where-    sign = (id <$ char 43) <|> (negate <$ char 45)+    sign = (id <$ B.char 43) <|> (negate <$ B.char 45) {-# INLINEABLE signed #-}  ----------------------------------------------------------------------------

@@ -34,6 +34,7 @@   , alphaNumChar   , printChar   , digitChar+  , binDigitChar   , octDigitChar   , hexDigitChar   , markChar@@ -45,14 +46,9 @@   , latin1Char   , charCategory   , categoryName-    -- * More general parsers+    -- * Single character   , char   , char'-  , anyChar-  , notChar-  , oneOf-  , noneOf-  , satisfy     -- * Sequence of characters   , string   , string' )@@ -60,18 +56,10 @@  import Control.Applicative import Data.Char-import Data.Function (on) import Data.Functor (void)-import Data.List.NonEmpty (NonEmpty (..)) import Data.Proxy import Text.Megaparsec-import qualified Data.CaseInsensitive as CI-import qualified Data.Set             as E--#if !MIN_VERSION_base(4,8,0)-import Data.Foldable (Foldable (), elem, notElem)-import Prelude hiding (elem, notElem)-#endif+import Text.Megaparsec.Common  ---------------------------------------------------------------------------- -- Simple parsers@@ -183,6 +171,16 @@ digitChar = satisfy isDigit <?> "digit" {-# INLINE digitChar #-} +-- | Parse a binary digit, i.e. "0" or "1".+--+-- @since 7.0.0++binDigitChar :: (MonadParsec e s m, Token s ~ Char) => m (Token s)+binDigitChar = satisfy isBinDigit <?> "binary digit"+  where+    isBinDigit x = x == '0' || x == '1'+{-# INLINE binDigitChar #-}+ -- | Parse an octal digit, i.e. between “0” and “7”.  octDigitChar :: (MonadParsec e s m, Token s ~ Char) => m (Token s)@@ -289,20 +287,14 @@   NotAssigned          -> "non-assigned Unicode character"  ------------------------------------------------------------------------------- More general parsers+-- Single character --- | @'char' c@ parses a single character @c@.+-- | A type-constrained version of 'single'. -- -- > semicolon = char ';' -char :: MonadParsec e s m => Token s -> m (Token s)-char c = token testChar (Just c)-  where-    f x = Tokens (x:|[])-    testChar x =-      if x == c-        then Right x-        else Left (pure (f x), E.singleton (f c))+char :: (MonadParsec e s m, Token s ~ Char) => Token s -> m (Token s)+char = single {-# INLINE char #-}  -- | The same as 'char' but case-insensitive. This parser returns the@@ -316,108 +308,9 @@ -- expecting 'E' or 'e'  char' :: (MonadParsec e s m, Token s ~ Char) => Token s -> m (Token s)-char' c = choice [char c, char (swapCase c)]-  where-    swapCase x-      | isUpper x = toLower x-      | isLower x = toUpper x-      | otherwise = x+char' c = choice+  [ char (toLower c)+  , char (toUpper c)+  , char (toTitle c)+  ] {-# INLINE char' #-}---- | This parser succeeds for any character. Returns the parsed character.--anyChar :: MonadParsec e s m => m (Token s)-anyChar = satisfy (const True) <?> "character"-{-# INLINE anyChar #-}---- | Match any character but the given one. It's a good idea to attach a--- 'label' to this parser manually.------ @since 6.0.0--notChar :: MonadParsec e s m => Token s -> m (Token s)-notChar c = satisfy (/= c)-{-# INLINE notChar #-}---- | @'oneOf' cs@ succeeds if the current character is in the supplied--- collection of characters @cs@. Returns the parsed character. Note that--- this parser cannot automatically generate the “expected” component of--- error message, so usually you should label it manually with 'label' or--- ('<?>').------ See also: 'satisfy'.------ > digit = oneOf ['0'..'9'] <?> "digit"------ __Performance note__: prefer 'satisfy' when you can because it's faster--- when you have only a couple of tokens to compare to:------ > quoteFast = satisfy (\x -> x == '\'' || x == '\"')--- > quoteSlow = oneOf "'\""--oneOf :: (Foldable f, MonadParsec e s m)-  => f (Token s)-  -> m (Token s)-oneOf cs = satisfy (`elem` cs)-{-# INLINE oneOf #-}---- | As the dual of 'oneOf', @'noneOf' cs@ succeeds if the current character--- /not/ in the supplied list of characters @cs@. Returns the parsed--- character. Note that this parser cannot automatically generate the--- “expected” component of error message, so usually you should label it--- manually with 'label' or ('<?>').------ See also: 'satisfy'.------ __Performance note__: prefer 'satisfy' and 'notChar' when you can because--- it's faster.--noneOf :: (Foldable f, MonadParsec e s m)-  => f (Token s)-  -> m (Token s)-noneOf cs = satisfy (`notElem` cs)-{-# INLINE noneOf #-}---- | The parser @'satisfy' f@ succeeds for any character for which the--- supplied function @f@ returns 'True'. Returns the character that is--- actually parsed.------ > digitChar = satisfy isDigit <?> "digit"--- > oneOf cs  = satisfy (`elem` cs)--satisfy :: MonadParsec e s m-  => (Token s -> Bool) -- ^ Predicate to apply-  -> m (Token s)-satisfy f = token testChar Nothing-  where-    testChar x =-      if f x-        then Right x-        else Left (pure (Tokens (x:|[])), E.empty)-{-# INLINE satisfy #-}--------------------------------------------------------------------------------- Sequence of characters---- | @'string' s@ parses a sequence of characters given by @s@. Returns the--- parsed string (i.e. @s@).------ > divOrMod = string "div" <|> string "mod"--string :: MonadParsec e s m-  => Tokens s-  -> m (Tokens s)-string = tokens (==)-{-# INLINE string #-}---- | The same as 'string', but case-insensitive. On success returns string--- cased as actually parsed input.------ >>> parseTest (string' "foobar") "foObAr"--- "foObAr"--string' :: (MonadParsec e s m, CI.FoldCase (Tokens s))-  => Tokens s-  -> m (Tokens s)-string' = tokens ((==) `on` CI.mk)-{-# INLINE string' #-}

@@ -55,6 +55,7 @@   , charLiteral     -- * Numbers   , decimal+  , binary   , octal   , hexadecimal   , scientific@@ -70,7 +71,7 @@ import Data.Proxy import Data.Scientific (Scientific) import Text.Megaparsec-import qualified Data.CaseInsensitive as CI+import Text.Megaparsec.Lexer import qualified Data.Char            as Char import qualified Data.Scientific      as Sci import qualified Data.Set             as E@@ -79,87 +80,6 @@ ---------------------------------------------------------------------------- -- White space --- | @'space' sc lineComment blockComment@ produces parser that can parse--- white space in general. It's expected that you create such a parser once--- and pass it to other functions in this module as needed (when you see--- @spaceConsumer@ in documentation, usually it means that something like--- 'space' is expected there).------ @sc@ is used to parse blocks of space characters. You can use 'C.space1'--- from "Text.Megaparsec.Char" for this purpose as well as your own parser--- (if you don't want to automatically consume newlines, for example). Make--- sure the parser does not succeed on empty input though. In earlier--- version 'C.spaceChar' was recommended, but now parsers based on--- 'takeWhile1P' are preferred because of their speed.------ @lineComment@ is used to parse line comments. You can use--- 'skipLineComment' if you don't need anything special.------ @blockComment@ is used to parse block (multi-line) comments. You can use--- 'skipBlockComment' or 'skipBlockCommentNested' if you don't need anything--- special.------ If you don't want to allow a kind of comment, simply pass 'empty' which--- will fail instantly when parsing of that sort of comment is attempted and--- 'space' will just move on or finish depending on whether there is more--- white space for it to consume.--space :: MonadParsec e s m-  => m () -- ^ A parser for space characters which does not accept empty-          -- input (e.g. 'C.space1')-  -> m () -- ^ A parser for a line comment (e.g. 'skipLineComment')-  -> m () -- ^ A parser for a block comment (e.g. 'skipBlockComment')-  -> m ()-space sp line block = skipMany $ choice-  [hidden sp, hidden line, hidden block]-{-# INLINEABLE space #-}---- | This is a wrapper for lexemes. Typical usage is to supply the first--- argument (parser that consumes white space, probably defined via 'space')--- and use the resulting function to wrap parsers for every lexeme.------ > lexeme  = L.lexeme spaceConsumer--- > integer = lexeme L.decimal--lexeme :: MonadParsec e s m-  => m ()              -- ^ How to consume white space after lexeme-  -> m a               -- ^ How to parse actual lexeme-  -> m a-lexeme spc p = p <* spc-{-# INLINEABLE lexeme #-}---- | This is a helper to parse symbols, i.e. verbatim strings. You pass the--- first argument (parser that consumes white space, probably defined via--- 'space') and then you can use the resulting function to parse strings:------ > symbol    = L.symbol spaceConsumer--- >--- > parens    = between (symbol "(") (symbol ")")--- > braces    = between (symbol "{") (symbol "}")--- > angles    = between (symbol "<") (symbol ">")--- > brackets  = between (symbol "[") (symbol "]")--- > semicolon = symbol ";"--- > comma     = symbol ","--- > colon     = symbol ":"--- > dot       = symbol "."--symbol :: MonadParsec e s m-  => m ()              -- ^ How to consume white space after lexeme-  -> Tokens s          -- ^ Symbol to parse-  -> m (Tokens s)-symbol spc = lexeme spc . C.string-{-# INLINEABLE symbol #-}---- | Case-insensitive version of 'symbol'. This may be helpful if you're--- working with case-insensitive languages.--symbol' :: (MonadParsec e s m, CI.FoldCase (Tokens s))-  => m ()              -- ^ How to consume white space after lexeme-  -> Tokens s          -- ^ Symbol to parse (case-insensitive)-  -> m (Tokens s)-symbol' spc = lexeme spc . C.string'-{-# INLINEABLE symbol' #-}- -- | Given comment prefix this function returns a parser that skips line -- comments. Note that it stops just before the newline character but -- doesn't consume the newline. Newline is either supposed to be consumed by@@ -179,7 +99,7 @@   => Tokens s          -- ^ Start of block comment   -> Tokens s          -- ^ End of block comment   -> m ()-skipBlockComment start end = p >> void (manyTill C.anyChar n)+skipBlockComment start end = p >> void (manyTill anySingle n)   where     p = C.string start     n = C.string end@@ -196,7 +116,7 @@   -> m () skipBlockCommentNested start end = p >> void (manyTill e n)   where-    e = skipBlockCommentNested start end <|> void C.anyChar+    e = skipBlockCommentNested start end <|> void anySingle     p = C.string start     n = C.string end {-# INLINEABLE skipBlockCommentNested #-}@@ -213,8 +133,8 @@ -- @since 4.3.0  indentLevel :: MonadParsec e s m => m Pos-indentLevel = sourceColumn <$> getPosition-{-# INLINEABLE indentLevel #-}+indentLevel = sourceColumn <$> getSourcePos+{-# INLINE indentLevel #-}  -- | Fail reporting incorrect indentation error. The error has attached -- information:@@ -308,7 +228,7 @@   ref <- indentLevel   a   <- r   case a of-    IndentNone x -> sc *> return x+    IndentNone x -> x <$ sc     IndentMany indent f p -> do       mlvl <- (optional . try) (C.eol *> indentGuard sc GT ref)       done <- isJust <$> optional eof@@ -397,9 +317,9 @@ 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 <- lookAhead (count' 1 8 C.anyChar)+  r <- lookAhead (count' 1 10 anySingle)   case listToMaybe (Char.readLitChar r) of-    Just (c, r') -> c <$ skipCount (length r - length r') C.anyChar+    Just (c, r') -> c <$ skipCount (length r - length r') anySingle     Nothing      -> unexpected (Tokens (head r:|[])) {-# INLINEABLE charLiteral #-} @@ -414,9 +334,7 @@ -- __Note__: before version 6.0.0 the function returned 'Integer', i.e. it -- wasn't polymorphic in its return type. -decimal-  :: forall e s m a. (MonadParsec e s m, Token s ~ Char, Integral a)-  => m a+decimal :: (MonadParsec e s m, Token s ~ Char, Integral a) => m a decimal = decimal_ <?> "integer" {-# INLINEABLE decimal #-} @@ -429,6 +347,28 @@   where     mkNum    = foldl' step 0 . chunkToTokens (Proxy :: Proxy s)     step a c = a * 10 + fromIntegral (Char.digitToInt c)+{-# INLINE decimal_ #-}++-- | Parse an integer in binary representation. Binary number is expected to+-- be a non-empty sequence of zeroes “0” and ones “1”.+--+-- You could of course parse some prefix before the actual number:+--+-- > binary = char '0' >> char' 'b' >> L.binary+--+-- @since 7.0.0++binary+  :: forall e s m a. (MonadParsec e s m, Token s ~ Char, Integral a)+  => m a+binary = mkNum+  <$> takeWhile1P Nothing isBinDigit+  <?> "binary integer"+  where+    mkNum        = foldl' step 0 . chunkToTokens (Proxy :: Proxy s)+    step a c     = a * 2 + fromIntegral (Char.digitToInt c)+    isBinDigit x = x == '0' || x == '1'+{-# INLINEABLE binary #-}  -- | Parse an integer in octal representation. Representation of octal -- number is expected to be according to the Haskell report except for the

@@ -25,7 +25,6 @@   ( MonadParsec (..) ) where -import Control.Applicative import Control.Monad import Control.Monad.Identity import Control.Monad.Trans@@ -45,10 +44,6 @@ 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. --@@ -56,8 +51,7 @@ -- 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+class (Stream s, MonadPlus m) => MonadParsec e s m | m -> e s where    -- | The most general way to stop parsing and report a trivial   -- 'ParseError'.@@ -70,7 +64,8 @@     -> m a    -- | The most general way to stop parsing and report a fancy 'ParseError'.-  -- To report a single custom parse error, see 'customFailure'.+  -- To report a single custom parse error, see+  -- 'Text.Megaparsec.customFailure'.   --   -- @since 6.0.0 @@ -160,7 +155,7 @@   -- @since 4.4.0    withRecovery-    :: (ParseError (Token s) e -> m a) -- ^ How to recover from failure+    :: (ParseError s e -> m a) -- ^ How to recover from failure     -> m a             -- ^ Original parser     -> m a             -- ^ Parser that can recover from failures @@ -175,44 +170,41 @@    observing     :: m a             -- ^ The parser to run-    -> m (Either (ParseError (Token s) e) a)+    -> m (Either (ParseError 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.+  -- | The parser @'token' test expected@ accepts a token @t@ with result+  -- @x@ when the function @test t@ returns @'Just' x@. @expected@ specifies+  -- the collection of expected items to report in error messages.   --   -- This is the most primitive combinator for accepting tokens. For-  -- example, the 'Text.Megaparsec.Char.satisfy' parser is implemented as:+  -- example, the 'Text.Megaparsec.satisfy' parser is implemented as:   ---  -- > satisfy f = token testChar Nothing+  -- > satisfy f = token testToken E.empty   -- >   where-  -- >     testChar x =-  -- >       if f x-  -- >         then Right x-  -- >         else Left (pure (Tokens (x:|[])), Set.empty)+  -- >     testToken x = if f x then Just x else Nothing+  --+  -- __Note__: type signature of this primitive was changed in the version+  -- /7.0.0/.    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+    :: (Token s -> Maybe a)+       -- ^ Matching function for the token to parse+    -> Set (ErrorItem (Token s))+       -- ^ Expected items (in case of an error)     -> 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.+  -- | The parser @'tokens' test chk@ parses a chunk of input @chk@ and+  -- returns it. The 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':+  -- This can be used for example to write 'Text.Megaparsec.chunk':   ---  -- > string = tokens (==)+  -- > chunk = 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.@@ -247,7 +239,7 @@   -- > 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.+  -- The combinator never fails, although it may parse the empty chunk.   --   -- @since 6.0.0 

@@ -0,0 +1,42 @@+-- |+-- Module      :  Text.Megaparsec.Common+-- Copyright   :  © 2018 Megaparsec contributors+-- License     :  FreeBSD+--+-- Maintainer  :  Mark Karpov <markkarpov92@gmail.com>+-- Stability   :  experimental+-- Portability :  portable+--+-- Common token combinators. This module is not public, the functions from+-- it are re-exported in "Text.Megaparsec.Byte" and "Text.Megaparsec.Char".+--+-- @since 7.0.0++{-# LANGUAGE FlexibleContexts #-}++module Text.Megaparsec.Common+  ( string+  , string' )+where++import Data.Function (on)+import Text.Megaparsec+import qualified Data.CaseInsensitive as CI++-- | A synonym for 'chunk'.++string :: MonadParsec e s m => Tokens s -> m (Tokens s)+string = chunk+{-# INLINE string #-}++-- | The same as 'string', but case-insensitive. On success returns string+-- cased as actually parsed input.+--+-- >>> parseTest (string' "foobar") "foObAr"+-- "foObAr"++string' :: (MonadParsec e s m, CI.FoldCase (Tokens s))+  => Tokens s+  -> m (Tokens s)+string' = tokens ((==) `on` CI.mk)+{-# INLINE string' #-}

@@ -0,0 +1,138 @@+-- |+-- Module      :  Text.Megaparsec.Debug+-- Copyright   :  © 2015–2018 Megaparsec contributors+-- License     :  FreeBSD+--+-- Maintainer  :  Mark Karpov <markkarpov92@gmail.com>+-- Stability   :  experimental+-- Portability :  portable+--+-- Debugging helpers.+--+-- @since 7.0.0++{-# LANGUAGE FlexibleContexts    #-}+{-# LANGUAGE ScopedTypeVariables #-}++module Text.Megaparsec.Debug+  ( dbg )+where++import Data.Proxy+import Debug.Trace+import Text.Megaparsec.Error+import Text.Megaparsec.Internal+import Text.Megaparsec.State+import Text.Megaparsec.Stream+import qualified Data.List.NonEmpty as NE++-- | @'dbg' label p@ parser works exactly like @p@, but when it's evaluated+-- it also prints information useful for debugging. The @label@ is only used+-- to refer to this parser in the debugging output. This combinator uses the+-- 'trace' function from "Debug.Trace" under the hood.+--+-- Typical usage is to wrap every sub-parser in misbehaving parser with+-- 'dbg' assigning meaningful labels. Then give it a shot and go through the+-- print-out. As of current version, this combinator prints all available+-- information except for /hints/, which are probably only interesting to+-- the maintainer of Megaparsec itself and may be quite verbose to output in+-- general. Let me know if you would like to be able to see hints in the+-- debugging output.+--+-- The output itself is pretty self-explanatory, although the following+-- abbreviations should be clarified (they are derived from the low-level+-- source code):+--+--     * @COK@—“consumed OK”. The parser consumed input and succeeded.+--     * @CERR@—“consumed error”. The parser consumed input and failed.+--     * @EOK@—“empty OK”. The parser succeeded without consuming input.+--     * @EERR@—“empty error”. The parser failed without consuming input.+--+-- 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.+-- 'Show' instance for state), so this helper is only available for+-- 'ParsecT' monad, not any instance of 'MonadParsec' in general.++dbg :: forall e s m a.+  ( Stream s+  , ShowErrorComponent e+  , Show a )+  => String            -- ^ Debugging label+  -> ParsecT e s m a   -- ^ Parser to debug+  -> ParsecT e s m a   -- ^ Parser that prints debugging messages+dbg lbl p = ParsecT $ \s cok cerr eok eerr ->+  let l = dbgLog lbl :: DbgItem s e a -> String+      unfold = streamTake 40+      cok' x s' hs = flip trace (cok x s' hs) $+        l (DbgIn (unfold (stateInput s))) +++        l (DbgCOK (streamTake (streamDelta s s') (stateInput s)) x)+      cerr' err s' = flip trace (cerr err s') $+        l (DbgIn (unfold (stateInput s))) +++        l (DbgCERR (streamTake (streamDelta s s') (stateInput s)) err)+      eok' x s' hs = flip trace (eok x s' hs) $+        l (DbgIn (unfold (stateInput s))) +++        l (DbgEOK (streamTake (streamDelta s s') (stateInput s)) x)+      eerr' err s' = flip trace (eerr err s') $+        l (DbgIn (unfold (stateInput s))) +++        l (DbgEERR (streamTake (streamDelta s s') (stateInput s)) err)+  in unParser p s cok' cerr' eok' eerr'++-- | A single piece of info to be rendered with 'dbgLog'.++data DbgItem s e a+  = DbgIn   [Token s]+  | DbgCOK  [Token s] a+  | DbgCERR [Token s] (ParseError s e)+  | DbgEOK  [Token s] a+  | DbgEERR [Token s] (ParseError s e)++-- | Render a single piece of debugging info.++dbgLog+  :: forall s e a. (Stream s, ShowErrorComponent e, Show a)+  => String            -- ^ Debugging label+  -> DbgItem s e a     -- ^ Information to render+  -> String            -- ^ Rendered result+dbgLog lbl item = prefix msg+  where+    prefix = unlines . fmap ((lbl ++ "> ") ++) . lines+    pxy = Proxy :: Proxy s+    msg = case item of+      DbgIn   ts   ->+        "IN: " ++ showStream pxy ts+      DbgCOK  ts a ->+        "MATCH (COK): " ++ showStream pxy ts ++ "\nVALUE: " ++ show a+      DbgCERR ts e ->+        "MATCH (CERR): " ++ showStream pxy ts ++ "\nERROR:\n" ++ parseErrorPretty e+      DbgEOK  ts a ->+        "MATCH (EOK): " ++ showStream pxy ts ++ "\nVALUE: " ++ show a+      DbgEERR ts e ->+        "MATCH (EERR): " ++ showStream pxy ts ++ "\nERROR:\n" ++ parseErrorPretty e++-- | Pretty-print a list of tokens.++showStream :: Stream s => Proxy s -> [Token s] -> String+showStream pxy ts =+  case NE.nonEmpty ts of+    Nothing -> "<EMPTY>"+    Just ne ->+      let (h, r) = splitAt 40 (showTokens pxy ne)+      in if null r then h else h ++ " <…>"++-- | Calculate number of consumed tokens given 'State' of parser before and+-- after parsing.++streamDelta+  :: State s           -- ^ State of parser before consumption+  -> State s           -- ^ State of parser after consumption+  -> Int               -- ^ Number of consumed tokens+streamDelta s0 s1 = stateOffset s1 - stateOffset s0++-- | Extract a given number of tokens from the stream.++streamTake :: forall s. Stream s => Int -> s -> [Token s]+streamTake n s =+  case fst <$> takeN_ n s of+    Nothing -> []+    Just chk -> chunkToTokens (Proxy :: Proxy s) chk

@@ -7,8 +7,8 @@ -- Stability   :  experimental -- Portability :  portable ----- Parse errors. Current version of Megaparsec supports well-typed errors--- instead of 'String'-based ones. This gives a lot of flexibility in+-- Parse errors. The current version of Megaparsec supports well-typed+-- errors instead of 'String'-based ones. This gives a lot of flexibility in -- describing what exactly went wrong as well as a way to return arbitrary -- data in case of failure. --@@ -22,47 +22,48 @@ {-# LANGUAGE DeriveGeneric       #-} {-# LANGUAGE FlexibleContexts    #-} {-# LANGUAGE FlexibleInstances   #-}+{-# LANGUAGE LambdaCase          #-}+{-# LANGUAGE RecordWildCards     #-} {-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE StandaloneDeriving  #-}+{-# LANGUAGE UndecidableInstances#-}  module Text.Megaparsec.Error   ( -- * Parse error type     ErrorItem (..)   , ErrorFancy (..)   , ParseError (..)-  , errorPos+  , mapParseError+  , errorOffset+  , ParseErrorBundle (..)+  , attachSourcePos     -- * Pretty-printing-  , ShowToken (..)-  , LineToken (..)   , ShowErrorComponent (..)+  , errorBundlePretty   , parseErrorPretty-  , parseErrorPretty'-  , parseErrorPretty_-  , sourcePosStackPretty   , parseErrorTextPretty ) where  import Control.DeepSeq import Control.Exception-import Data.Char (chr)+import Control.Monad.State.Strict import Data.Data (Data) import Data.List (intercalate) import Data.List.NonEmpty (NonEmpty (..))-import Data.Maybe (fromMaybe, isNothing)+import Data.Maybe (isNothing) import Data.Proxy-import Data.Semigroup import Data.Set (Set) import Data.Typeable (Typeable) import Data.Void-import Data.Word (Word8) import GHC.Generics-import Prelude hiding (concat) 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+#if !MIN_VERSION_base(4,11,0)+import Data.Semigroup #endif  ----------------------------------------------------------------------------@@ -107,70 +108,97 @@ -- | @'ParseError' t e@ represents a parse error parametrized over the token -- type @t@ and the custom data @e@. ----- Note that the stack of source positions contains current position as its--- head, and the rest of positions allows to track full sequence of include--- files with topmost source file at the end of the list.--- -- 'Semigroup' and 'Monoid' instances of the data type allow to merge parse -- errors from different branches of parsing. When merging two -- 'ParseError's, the longest match is preferred; if positions are the same, -- custom data sets and collections of message items are combined. Note that -- fancy errors take precedence over trivial errors in merging. ----- @since 6.0.0+-- @since 7.0.0 -data ParseError t e-  = TrivialError (NonEmpty SourcePos) (Maybe (ErrorItem t)) (Set (ErrorItem t))+data ParseError s e+  = TrivialError Int (Maybe (ErrorItem (Token s))) (Set (ErrorItem (Token s)))     -- ^ Trivial errors, generated by Megaparsec's machinery. The data-    -- constructor includes the stack of source positions, unexpected token+    -- constructor includes the source position of error, unexpected token     -- (if any), and expected tokens.-  | FancyError (NonEmpty SourcePos) (Set (ErrorFancy e))+    --+    -- Type of the first argument was changed in the version /7.0.0/.+  | FancyError Int (Set (ErrorFancy e))     -- ^ Fancy, custom errors.-  deriving (Show, Read, Eq, Data, Typeable, Generic)+    --+    -- Type of the first argument was changed in the version /7.0.0/.+  deriving (Typeable, Generic) -instance (NFData t, NFData e) => NFData (ParseError t e)+deriving instance ( Show (Token s)+                  , Show e+                  ) => Show (ParseError s e) -instance (Ord t, Ord e) => Semigroup (ParseError t e) where+deriving instance ( Eq (Token s)+                  , Eq e+                  ) => Eq (ParseError s e)++deriving instance ( Data s+                  , Data (Token s)+                  , Ord (Token s)+                  , Data e+                  , Ord e+                  ) => Data (ParseError s e)++instance ( NFData (Token s)+         , NFData e+         ) => NFData (ParseError s e)++instance (Stream s, Ord e) => Semigroup (ParseError s e) where   (<>) = mergeError   {-# INLINE (<>) #-} -instance (Ord t, Ord e) => Monoid (ParseError t e) where-  mempty  = TrivialError (initialPos "" :| []) Nothing E.empty+instance (Stream s, Ord e) => Monoid (ParseError s e) where+  mempty  = TrivialError 0 Nothing E.empty   mappend = (<>)   {-# INLINE mappend #-} -instance ( Show t-         , Ord t-         , ShowToken t-         , Typeable t+instance ( Show s+         , Show (Token s)          , Show e          , ShowErrorComponent e+         , Stream s+         , Typeable s          , Typeable e )-  => Exception (ParseError t e) where-#if MIN_VERSION_base(4,8,0)+  => Exception (ParseError s e) where   displayException = parseErrorPretty-#endif --- | Get position of given 'ParseError'.+-- | Modify the custom data component in a parse error. This could be done+-- via 'fmap' if not for the 'Ord' constraint. ----- @since 6.0.0+-- @since 7.0.0 -errorPos :: ParseError t e -> NonEmpty SourcePos-errorPos (TrivialError p _ _) = p-errorPos (FancyError   p _)   = p+mapParseError :: Ord e'+  => (e -> e')+  -> ParseError s e+  -> ParseError s e'+mapParseError _ (TrivialError o u p) = TrivialError o u p+mapParseError f (FancyError o x) = FancyError o (E.map (fmap f) x) +-- | Get offset of given 'ParseError'.+--+-- @since 7.0.0++errorOffset :: ParseError s e -> Int+errorOffset (TrivialError o _ _) = o+errorOffset (FancyError   o _)   = o+ -- | Merge two error data structures into one joining their collections of -- message items and preferring the longest match. In other words, earlier -- error message is discarded. This may seem counter-intuitive, but -- 'mergeError' is only used to merge error messages of alternative branches -- of parsing and in this case longest match should be preferred. -mergeError :: (Ord t, Ord e)-  => ParseError t e-  -> ParseError t e-  -> ParseError t e+mergeError :: (Stream s, Ord e)+  => ParseError s e+  -> ParseError s e+  -> ParseError s e mergeError e1 e2 =-  case errorPos e1 `compare` errorPos e2 of+  case errorOffset e1 `compare` errorOffset e2 of     LT -> e2     EQ ->       case (e1, e2) of@@ -196,260 +224,235 @@     n (Just x) (Just y) = Just (max x y) {-# INLINE mergeError #-} -------------------------------------------------------------------------------- Pretty-printing---- | Type class 'ShowToken' includes methods that allow to pretty-print--- single token as well as stream of tokens. This is used for rendering of--- error messages.+-- | A non-empty collection of 'ParseError's equipped with 'PosState' that+-- allows to pretty-print the errors efficiently and correctly. ----- @since 5.0.0--class ShowToken a where--  -- | Pretty-print non-empty stream of tokens. This function is also used-  -- to print single tokens (represented as singleton lists).--  showTokens :: NonEmpty a -> String+-- @since 7.0.0 -instance ShowToken Char where-  showTokens = stringPretty+data ParseErrorBundle s e = ParseErrorBundle+  { bundleErrors :: NonEmpty (ParseError s e)+    -- ^ A collection of 'ParseError's that is sorted by parse error offsets+  , bundlePosState :: PosState s+    -- ^ State that is used for line\/column calculation+  } deriving (Generic) -instance ShowToken Word8 where-  showTokens = stringPretty . fmap (chr . fromIntegral)+deriving instance ( Show s+                  , Show (Token s)+                  , Show e+                  ) => Show (ParseErrorBundle s e) --- | Type class for tokens that support operations necessary for selecting--- and displaying relevant line of input.------ @since 6.0.0+deriving instance ( Eq s+                  , Eq (Token s)+                  , Eq e+                  ) => Eq (ParseErrorBundle s e) -class LineToken a where+deriving instance ( Typeable s+                  , Typeable (Token s)+                  , Typeable e+                  ) => Typeable (ParseErrorBundle s e) -  -- | Convert a token to a 'Char'. This is used to print relevant line from-  -- input stream by turning a list of tokens into a 'String'.+deriving instance ( Data s+                  , Data (Token s)+                  , Ord (Token s)+                  , Data e+                  , Ord e+                  ) => Data (ParseErrorBundle s e) -  tokenAsChar :: a -> Char+instance ( NFData s+         , NFData (Token s)+         , NFData e+         ) => NFData (ParseErrorBundle s e) -  -- | Check if given token is a newline or contains newline.+instance ( Show s+         , Show (Token s)+         , Show e+         , ShowErrorComponent e+         , Stream s+         , Typeable s+         , Typeable e+         ) => Exception (ParseErrorBundle s e) where+  displayException = errorBundlePretty -  tokenIsNewline :: a -> Bool+-- | Attach 'SourcePos'es to items in a 'Traversable' container given that+-- there is a projection allowing to get an offset per item.+--+-- Items must be in ascending order with respect to their offsets.+--+-- @since 7.0.0 -instance LineToken Char where-  tokenAsChar = id-  tokenIsNewline x = x == '\n'+attachSourcePos+  :: (Traversable t, Stream s)+  => (a -> Int) -- ^ How to project offset from an item (e.g. 'errorOffset')+  -> t a               -- ^ The collection of items+  -> PosState s        -- ^ Initial 'PosState'+  -> (t (a, SourcePos), PosState s) -- ^ The collection with 'SourcePos'es+                                    -- added and the final 'PosState'+attachSourcePos projectOffset xs = runState (traverse f xs)+  where+    f a = do+      pst <- get+      let (spos, pst') = reachOffsetNoLine (projectOffset a) pst+      put pst'+      return (a, spos)+{-# INLINEABLE attachSourcePos #-} -instance LineToken Word8 where-  tokenAsChar = chr . fromIntegral-  tokenIsNewline x = x == 10+----------------------------------------------------------------------------+-- Pretty-printing --- | The type class defines how to print custom data component of--- 'ParseError'.+-- | The type class defines how to print a custom component of 'ParseError'. -- -- @since 5.0.0  class Ord a => ShowErrorComponent a where -  -- | Pretty-print custom data component of 'ParseError'.+  -- | Pretty-print a component of 'ParseError'.    showErrorComponent :: a -> String -instance (Ord t, ShowToken t) => ShowErrorComponent (ErrorItem t) where-  showErrorComponent (Tokens   ts) = showTokens ts-  showErrorComponent (Label label) = NE.toList label-  showErrorComponent EndOfInput    = "end of input"+  -- | Length of the error component in characters, used for highlighting of+  -- parse errors in input string.+  --+  -- @since 7.0.0 -instance ShowErrorComponent e => ShowErrorComponent (ErrorFancy e) where-  showErrorComponent (ErrorFail msg) = msg-  showErrorComponent (ErrorIndentation ord ref actual) =-    "incorrect indentation (got " <> show (unPos actual) <>-    ", should be " <> p <> show (unPos ref) <> ")"-    where-      p = case ord of-            LT -> "less than "-            EQ -> "equal to "-            GT -> "greater than "-  showErrorComponent (ErrorCustom a) = showErrorComponent a+  errorComponentLen :: a -> Int+  errorComponentLen _ = 1  instance ShowErrorComponent Void where   showErrorComponent = absurd +-- | Pretty-print a 'ParseErrorBundle'. All 'ParseError's in the bundle will+-- be pretty-printed in order together with the corresponding offending+-- lines by doing a single efficient pass over the input stream. The+-- rendered 'String' always ends with a newline.+--+-- @since 7.0.0++errorBundlePretty+  :: forall s e. ( Stream s+                 , ShowErrorComponent e+                 )+  => ParseErrorBundle s e -- ^ Parse error bundle to display+  -> String               -- ^ Textual rendition of the bundle+errorBundlePretty ParseErrorBundle {..} =+  let (r, _) = foldl f (id, bundlePosState) bundleErrors+  in drop 1 (r "")+  where+    f :: (ShowS, PosState s)+      -> ParseError s e+      -> (ShowS, PosState s)+    f (o, !pst) e = (o . (outChunk ++), pst')+      where+        (epos, sline, pst') = reachOffset (errorOffset e) pst+        ppos = pstateSourcePos pst+        outChunk =+          "\n" <> sourcePosPretty epos <> ":\n" <>+          padding <> "|\n" <>+          lineNumber <> " | " <> gpadding <> sline <> "\n" <>+          padding <> "| " <> rpadding <> pointer <> "\n" <>+          parseErrorTextPretty e+        lineNumber = (show . unPos . sourceLine) epos+        padding = replicate (length lineNumber + 1) ' '+        gpadding = replicate gpshift '?'+        gpshift = unPos (sourceColumn ppos) - 1+        rpadding = replicate rpshift ' '+        rpshift = unPos (sourceColumn epos) - 1+        pointer = replicate+          (if rpshift + elen > gpshift + slineLen+             then gpshift + slineLen - rpshift + 1+             else elen)+          '^'+        slineLen = length sline+        elen =+          case e of+            TrivialError _ Nothing _ -> 1+            TrivialError _ (Just x) _ -> errorItemLength x+            FancyError _ xs ->+              E.foldl' (\a b -> max a (errorFancyLength b)) 1 xs+ -- | Pretty-print a 'ParseError'. The rendered 'String' always ends with a -- newline. -- -- @since 5.0.0  parseErrorPretty-  :: ( Ord t-     , ShowToken t-     , ShowErrorComponent e )-  => ParseError t e    -- ^ Parse error to render+  :: (Stream s, ShowErrorComponent e)+  => ParseError s e    -- ^ Parse error to render   -> String            -- ^ Result of rendering parseErrorPretty e =-  sourcePosStackPretty (errorPos e) <> ":\n" <> parseErrorTextPretty e---- | Pretty-print a 'ParseError' and display the line on which the parse--- error occurred. The rendered 'String' always ends with a newline.------ Note that if you work with include files and have a stack of--- 'SourcePos'es in 'ParseError', it's up to you to provide correct input--- stream corresponding to the file in which parse error actually happened.------ 'parseErrorPretty'' is defined in terms of the more general--- 'parseErrorPretty_' function which allows to specify tab width as well:------ > parseErrorPretty' = parseErrorPretty_ defaultTabWidth------ @since 6.0.0--parseErrorPretty'-  :: ( ShowToken (Token s)-     , LineToken (Token s)-     , ShowErrorComponent e-     , Stream s )-  => s                 -- ^ Original input stream-  -> ParseError (Token s) e -- ^ Parse error to render-  -> String            -- ^ Result of rendering-parseErrorPretty' = parseErrorPretty_ defaultTabWidth---- | Just like 'parseErrorPretty'', but allows to specify tab width.------ @since 6.1.0--parseErrorPretty_-  :: forall s e.-     ( ShowToken (Token s)-     , LineToken (Token s)-     , ShowErrorComponent e-     , Stream s )-  => Pos               -- ^ Tab width-  -> s                 -- ^ Original input stream-  -> ParseError (Token s) e -- ^ Parse error to render-  -> String             -- ^ Result of rendering-parseErrorPretty_ w s e =-  sourcePosStackPretty (errorPos e) <> ":\n" <>-    padding <> "|\n" <>-    lineNumber <> " | " <> rline <> "\n" <>-    padding <> "| " <> rpadding <> "^\n" <>-    parseErrorTextPretty e-  where-    epos       = NE.last (errorPos e)-    lineNumber = (show . unPos . sourceLine) epos-    padding    = replicate (length lineNumber + 1) ' '-    rpadding   = replicate (unPos (sourceColumn epos) - 1) ' '-    rline      =-      case rline' of-        [] -> "<empty line>"-        xs -> expandTab w xs-    rline'     = fmap tokenAsChar . chunkToTokens (Proxy :: Proxy s) $-      selectLine (sourceLine epos) s---- | Pretty-print a stack of source positions.------ @since 5.0.0--sourcePosStackPretty :: NonEmpty SourcePos -> String-sourcePosStackPretty ms = mconcat (f <$> rest) <> sourcePosPretty pos-  where-    (pos :| rest') = ms-    rest           = reverse rest'-    f p = "in file included from " <> sourcePosPretty p <> ",\n"+  "offset=" <> show (errorOffset e) <> ":\n" <> parseErrorTextPretty e  -- | Pretty-print a textual part of a 'ParseError', that is, everything--- except stack of source positions. The rendered staring always ends with a--- new line.+-- except stack of source positions. The rendered 'String' always ends with a+-- newline. -- -- @since 5.1.0  parseErrorTextPretty-  :: ( Ord t-     , ShowToken t-     , ShowErrorComponent e )-  => ParseError t e    -- ^ Parse error to render+  :: forall s e. (Stream s, ShowErrorComponent e)+  => ParseError s e    -- ^ Parse error to render   -> String            -- ^ Result of rendering parseErrorTextPretty (TrivialError _ us ps) =   if isNothing us && E.null ps     then "unknown parse error\n"-    else messageItemsPretty "unexpected " (maybe E.empty E.singleton us) <>-         messageItemsPretty "expecting "  ps+    else messageItemsPretty "unexpected " (showErrorItem pxy `E.map` maybe E.empty E.singleton us) <>+         messageItemsPretty "expecting "  (showErrorItem pxy `E.map` ps)+  where+    pxy = Proxy :: Proxy s parseErrorTextPretty (FancyError _ xs) =   if E.null xs     then "unknown fancy parse error\n"-    else unlines (showErrorComponent <$> E.toAscList xs)+    else unlines (showErrorFancy <$> E.toAscList xs)  ---------------------------------------------------------------------------- -- Helpers --- | @stringPretty s@ returns pretty representation of string @s@. This is--- used when printing string tokens in error messages.+-- | Pretty-print an 'ErrorItem'. -stringPretty :: NonEmpty Char -> String-stringPretty (x:|[])      = charPretty x-stringPretty ('\r':|"\n") = "crlf newline"-stringPretty xs           = "\"" <> concatMap f (NE.toList xs) <> "\""-  where-    f ch =-      case charPretty' ch of-        Nothing     -> [ch]-        Just pretty -> "<" <> pretty <> ">"+showErrorItem :: Stream s => Proxy s -> ErrorItem (Token s) -> String+showErrorItem pxy = \case+    Tokens   ts -> showTokens pxy ts+    Label label -> NE.toList label+    EndOfInput  -> "end of input" --- | @charPretty ch@ returns user-friendly string representation of given--- character @ch@, suitable for using in error messages.+-- | Get length of the “pointer” to display under a given 'ErrorItem'. -charPretty :: Char -> String-charPretty ' ' = "space"-charPretty ch = fromMaybe ("'" <> [ch] <> "'") (charPretty' ch)+errorItemLength :: ErrorItem t -> Int+errorItemLength = \case+  Tokens ts -> NE.length ts+  _         -> 1 --- | If the given character has a pretty representation, return that,--- otherwise 'Nothing'. This is an internal helper.+-- | Pretty-print an 'ErrorFancy'. -charPretty' :: Char -> Maybe String-charPretty' '\NUL' = pure "null"-charPretty' '\SOH' = pure "start of heading"-charPretty' '\STX' = pure "start of text"-charPretty' '\ETX' = pure "end of text"-charPretty' '\EOT' = pure "end of transmission"-charPretty' '\ENQ' = pure "enquiry"-charPretty' '\ACK' = pure "acknowledge"-charPretty' '\BEL' = pure "bell"-charPretty' '\BS'  = pure "backspace"-charPretty' '\t'   = pure "tab"-charPretty' '\n'   = pure "newline"-charPretty' '\v'   = pure "vertical tab"-charPretty' '\f'   = pure "form feed"-charPretty' '\r'   = pure "carriage return"-charPretty' '\SO'  = pure "shift out"-charPretty' '\SI'  = pure "shift in"-charPretty' '\DLE' = pure "data link escape"-charPretty' '\DC1' = pure "device control one"-charPretty' '\DC2' = pure "device control two"-charPretty' '\DC3' = pure "device control three"-charPretty' '\DC4' = pure "device control four"-charPretty' '\NAK' = pure "negative acknowledge"-charPretty' '\SYN' = pure "synchronous idle"-charPretty' '\ETB' = pure "end of transmission block"-charPretty' '\CAN' = pure "cancel"-charPretty' '\EM'  = pure "end of medium"-charPretty' '\SUB' = pure "substitute"-charPretty' '\ESC' = pure "escape"-charPretty' '\FS'  = pure "file separator"-charPretty' '\GS'  = pure "group separator"-charPretty' '\RS'  = pure "record separator"-charPretty' '\US'  = pure "unit separator"-charPretty' '\DEL' = pure "delete"-charPretty' '\160' = pure "non-breaking space"-charPretty' _      = Nothing+showErrorFancy :: ShowErrorComponent e => ErrorFancy e -> String+showErrorFancy = \case+  ErrorFail msg -> msg+  ErrorIndentation ord ref actual ->+    "incorrect indentation (got " <> show (unPos actual) <>+    ", should be " <> p <> show (unPos ref) <> ")"+    where+      p = case ord of+            LT -> "less than "+            EQ -> "equal to "+            GT -> "greater than "+  ErrorCustom a -> showErrorComponent a +-- | Get length of the “pointer” to display under a given 'ErrorFancy'.++errorFancyLength :: ShowErrorComponent e => ErrorFancy e -> Int+errorFancyLength = \case+  ErrorCustom a -> errorComponentLen a+  _             -> 1+ -- | Transforms a list of error messages into their textual representation. -messageItemsPretty :: ShowErrorComponent a-  => String            -- ^ Prefix to prepend-  -> Set a             -- ^ Collection of messages+messageItemsPretty+  :: String            -- ^ Prefix to prepend+  -> Set String        -- ^ Collection of messages   -> String            -- ^ Result of rendering messageItemsPretty prefix ts   | E.null ts = ""   | otherwise =-    let f = orList . NE.fromList . E.toAscList . E.map showErrorComponent-    in prefix <> f ts <> "\n"+    prefix <> (orList . NE.fromList . E.toAscList) ts <> "\n"  -- | Print a pretty list where items are separated with commas and the word -- “or” according to the rules of English punctuation.@@ -458,36 +461,3 @@ orList (x:|[])  = x orList (x:|[y]) = x <> " or " <> y orList xs       = intercalate ", " (NE.init xs) <> ", or " <> NE.last xs---- | Select a line from input stream given its number.--selectLine-  :: forall s. (LineToken (Token s), Stream s)-  => Pos               -- ^ Number of line to select-  -> s                 -- ^ Input stream-  -> Tokens s          -- ^ Selected line-selectLine l = go pos1-  where-    go !n !s =-      if n == l-        then fst (takeWhile_ notNewline s)-        else go (n <> pos1) (stripNewline $ snd (takeWhile_ notNewline s))-    notNewline = not . tokenIsNewline-    stripNewline s =-      case take1_ s of-        Nothing -> s-        Just (_, s') -> s'---- | Replace tab characters with given number of spaces.--expandTab-  :: Pos-  -> String-  -> String-expandTab w' = go 0-  where-    go 0 []        = []-    go 0 ('\t':xs) = go w xs-    go 0 (x:xs)    = x : go 0 xs-    go !n xs       = ' ' : go (n - 1) xs-    w              = unPos w'

@@ -8,23 +8,22 @@ -- Portability :  portable -- -- A set of helpers that should make construction of 'ParseError's more--- concise. This is primarily useful in test suites and for debugging, you--- most certainly don't need it for normal usage.+-- concise. This is primarily useful in test suites and for debugging. -- -- @since 6.0.0 -{-# LANGUAGE CPP                 #-}-{-# LANGUAGE DeriveDataTypeable  #-}-{-# LANGUAGE DeriveGeneric       #-}-{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE CPP                  #-}+{-# LANGUAGE DeriveDataTypeable   #-}+{-# LANGUAGE DeriveGeneric        #-}+{-# LANGUAGE FlexibleContexts     #-}+{-# LANGUAGE ScopedTypeVariables  #-}+{-# LANGUAGE StandaloneDeriving   #-}+{-# LANGUAGE UndecidableInstances #-}  module Text.Megaparsec.Error.Builder   ( -- * Top-level helpers     err   , errFancy-    -- * Error position-  , posI-  , posN     -- * Error components   , utok   , utoks@@ -47,14 +46,10 @@ import Data.Typeable (Typeable) import GHC.Generics import Text.Megaparsec.Error-import Text.Megaparsec.Pos 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-#endif #if !MIN_VERSION_base(4,11,0) import Data.Semigroup #endif@@ -64,10 +59,19 @@  -- | Auxiliary type for construction of trivial parse errors. -data ET t = ET (Maybe (ErrorItem t)) (Set (ErrorItem t))-  deriving (Eq, Ord, Data, Typeable, Generic)+data ET s = ET (Maybe (ErrorItem (Token s))) (Set (ErrorItem (Token s)))+  deriving (Typeable, Generic) -instance Ord t => Semigroup (ET t) where+deriving instance Eq (Token s) => Eq (ET s)++deriving instance Ord (Token s) => Ord (ET s)++deriving instance ( Data s+                  , Data (Token s)+                  , Ord (Token s)+                  ) => Data (ET s)++instance Stream s => Semigroup (ET s) where   ET us0 ps0 <> ET us1 ps1 = ET (n us0 us1) (E.union ps0 ps1)     where       n Nothing  Nothing = Nothing@@ -75,13 +79,13 @@       n Nothing (Just y) = Just y       n (Just x) (Just y) = Just (max x y) -instance Ord t => Monoid (ET t) where+instance Stream s => Monoid (ET s) where   mempty  = ET Nothing E.empty   mappend = (<>)  -- | Auxiliary type for construction of fancy parse errors. -data EF e = EF (Set (ErrorFancy e))+newtype EF e = EF (Set (ErrorFancy e))   deriving (Eq, Ord, Data, Typeable, Generic)  instance Ord e => Semigroup (EF e) where@@ -94,91 +98,69 @@ ---------------------------------------------------------------------------- -- Top-level helpers --- | Assemble a 'ParseError' from source position and @'ET' t@ value. To--- create source position, two helpers are available: 'posI' and 'posN'.--- @'ET' t@ is a monoid and can be assembled by combining primitives--- provided by this module, see below.+-- | Assemble a 'ParseError' from offset and @'ET' t@ value. @'ET' t@ is a+-- monoid and can be assembled by combining primitives provided by this+-- module, see below.  err-  :: NonEmpty SourcePos -- ^ 'ParseError' position-  -> ET t              -- ^ Error components-  -> ParseError t e    -- ^ Resulting 'ParseError'-err pos (ET us ps) = TrivialError pos us ps+  :: Int               -- ^ 'ParseError' offset+  -> ET s              -- ^ Error components+  -> ParseError s e    -- ^ Resulting 'ParseError'+err p (ET us ps) = TrivialError p us ps  -- | Like 'err', but constructs a “fancy” 'ParseError'.  errFancy-  :: NonEmpty SourcePos -- ^ 'ParseError' position+  :: Int               -- ^ 'ParseError' offset   -> EF e              -- ^ Error components-  -> ParseError t e    -- ^ Resulting 'ParseError'-errFancy pos (EF xs) = FancyError pos xs--------------------------------------------------------------------------------- Error position---- | Initial source position with empty file name.--posI :: NonEmpty SourcePos-posI = initialPos "" :| []---- | @'posN' n s@ returns source position achieved by applying 'advanceN'--- method corresponding to the type of stream @s@.--posN :: forall s. Stream s-  => Int-  -> s-  -> NonEmpty SourcePos-posN n s =-  case takeN_ n s of-    Nothing -> posI-    Just (ts, _) ->-      advanceN (Proxy :: Proxy s) defaultTabWidth (initialPos "") ts :| []+  -> ParseError s e    -- ^ Resulting 'ParseError'+errFancy p (EF xs) = FancyError p xs  ---------------------------------------------------------------------------- -- Error components  -- | Construct an “unexpected token” error component. -utok :: Ord t => t -> ET t+utok :: Stream s => Token s -> ET s utok = unexp . Tokens . nes --- | Construct an “unexpected tokens” error component. Empty string produces+-- | Construct an “unexpected tokens” error component. Empty chunk produces -- 'EndOfInput'. -utoks :: Ord t => [t] -> ET t-utoks = unexp . canonicalizeTokens+utoks :: forall s. Stream s => Tokens s -> ET s+utoks = unexp . canonicalizeTokens (Proxy :: Proxy s)  -- | Construct an “unexpected label” error component. Do not use with empty -- strings (for empty strings it's bottom). -ulabel :: Ord t => String -> ET t+ulabel :: Stream s => String -> ET s ulabel = unexp . Label . NE.fromList  -- | Construct an “unexpected end of input” error component. -ueof :: Ord t => ET t+ueof :: Stream s => ET s ueof = unexp EndOfInput  -- | Construct an “expected token” error component. -etok :: Ord t => t -> ET t+etok :: Stream s => Token s -> ET s etok = expe . Tokens . nes --- | Construct an “expected tokens” error component. Empty string produces+-- | Construct an “expected tokens” error component. Empty chunk produces -- 'EndOfInput'. -etoks :: Ord t => [t] -> ET t-etoks = expe . canonicalizeTokens+etoks :: forall s. Stream s => Tokens s -> ET s+etoks = expe . canonicalizeTokens (Proxy :: Proxy s)  -- | Construct an “expected label” error component. Do not use with empty -- strings. -elabel :: Ord t => String -> ET t+elabel :: Stream s => String -> ET s elabel = expe . Label . NE.fromList  -- | Construct an “expected end of input” error component. -eeof :: Ord t => ET t+eeof :: Stream s => ET s eeof = expe EndOfInput  -- | Construct a custom error component.@@ -192,20 +174,24 @@ -- | Construct appropriate 'ErrorItem' representation for given token -- stream. Empty string produces 'EndOfInput'. -canonicalizeTokens :: [t] -> ErrorItem t-canonicalizeTokens ts =-  case NE.nonEmpty ts of+canonicalizeTokens+  :: Stream s+  => Proxy s+  -> Tokens s+  -> ErrorItem (Token s)+canonicalizeTokens pxy ts =+  case NE.nonEmpty (chunkToTokens pxy ts) of     Nothing -> EndOfInput     Just xs -> Tokens xs  -- | Lift an unexpected item into 'ET'. -unexp :: ErrorItem t -> ET t+unexp :: Stream s => ErrorItem (Token s) -> ET s unexp u = ET (pure u) E.empty  -- | Lift an expected item into 'ET'. -expe :: ErrorItem t -> ET t+expe :: Stream s => ErrorItem (Token s) -> ET s expe p = ET Nothing (E.singleton p)  -- | Make a singleton non-empty list from a value.

@@ -1,156 +0,0 @@--- |--- Module      :  Text.Megaparsec.Expr--- Copyright   :  © 2015–2018 Megaparsec contributors---                © 2007 Paolo Martini---                © 1999–2001 Daan Leijen--- License     :  FreeBSD------ Maintainer  :  Mark Karpov <markkarpov92@gmail.com>--- Stability   :  experimental--- Portability :  non-portable------ A helper module to parse expressions. It can build a parser given a table--- of operators.--module Text.Megaparsec.Expr-  ( Operator (..)-  , makeExprParser )-where--import Text.Megaparsec---- | This data type specifies operators that work on values of type @a@. An--- operator is either binary infix or unary prefix or postfix. A binary--- operator has also an associated associativity.--data Operator m a-  = InfixN  (m (a -> a -> a)) -- ^ Non-associative infix-  | InfixL  (m (a -> a -> a)) -- ^ Left-associative infix-  | InfixR  (m (a -> a -> a)) -- ^ Right-associative infix-  | Prefix  (m (a -> a))      -- ^ Prefix-  | Postfix (m (a -> a))      -- ^ Postfix---- | @'makeExprParser' term table@ builds an expression parser for terms--- @term@ with operators from @table@, taking the associativity and--- precedence specified in the @table@ into account.------ @table@ is a list of @[Operator m a]@ lists. The list is ordered in--- descending precedence. All operators in one list have the same precedence--- (but may have different associativity).------ Prefix and postfix operators of the same precedence associate to the left--- (i.e. if @++@ is postfix increment, than @-2++@ equals @-1@, not @-3@).------ Unary operators of the same precedence can only occur once (i.e. @--2@ is--- not allowed if @-@ is prefix negate). If you need to parse several prefix--- or postfix operators in a row, (like C pointers—@**i@) you can use this--- approach:------ > manyUnaryOp = foldr1 (.) <$> some singleUnaryOp------ This is not done by default because in some cases allowing repeating--- prefix or postfix operators is not desirable.------ If you want to have an operator that is a prefix of another operator in--- the table, use the following (or similar) wrapper instead of plain--- 'Text.Megaparsec.Char.Lexer.symbol':------ > op n = (lexeme . try) (string n <* notFollowedBy punctuationChar)------ 'makeExprParser' takes care of all the complexity involved in building an--- expression parser. Here is an example of an expression parser that--- handles prefix signs, postfix increment and basic arithmetic:------ > expr = makeExprParser term table <?> "expression"--- >--- > term = parens expr <|> integer <?> "term"--- >--- > table = [ [ prefix  "-"  negate--- >           , prefix  "+"  id ]--- >         , [ postfix "++" (+1) ]--- >         , [ binary  "*"  (*)--- >           , binary  "/"  div  ]--- >         , [ binary  "+"  (+)--- >           , binary  "-"  (-)  ] ]--- >--- > binary  name f = InfixL  (f <$ symbol name)--- > prefix  name f = Prefix  (f <$ symbol name)--- > postfix name f = Postfix (f <$ symbol name)--makeExprParser :: MonadParsec e s m-  => m a               -- ^ Term parser-  -> [[Operator m a]]  -- ^ Operator table, see 'Operator'-  -> m a               -- ^ Resulting expression parser-makeExprParser = foldl addPrecLevel-{-# INLINEABLE makeExprParser #-}---- | @addPrecLevel p ops@ adds the ability to parse operators in table @ops@--- to parser @p@.--addPrecLevel :: MonadParsec e s m => m a -> [Operator m a] -> m a-addPrecLevel term ops =-  term' >>= \x -> choice [ras' x, las' x, nas' x, return x] <?> "operator"-  where (ras, las, nas, prefix, postfix) = foldr splitOp ([],[],[],[],[]) ops-        term' = pTerm (choice prefix) term (choice postfix)-        ras'  = pInfixR (choice ras) term'-        las'  = pInfixL (choice las) term'-        nas'  = pInfixN (choice nas) term'---- | @pTerm prefix term postfix@ parses a @term@ surrounded by optional--- prefix and postfix unary operators. Parsers @prefix@ and @postfix@ are--- allowed to fail, in this case 'id' is used.--pTerm :: MonadParsec e s m => m (a -> a) -> m a -> m (a -> a) -> m a-pTerm prefix term postfix = do-  pre  <- option id (hidden prefix)-  x    <- term-  post <- option id (hidden postfix)-  return . post . pre $ x---- | @pInfixN op p x@ parses non-associative infix operator @op@, then term--- with parser @p@, then returns result of the operator application on @x@--- and the term.--pInfixN :: MonadParsec e s m => m (a -> a -> a) -> m a -> a -> m a-pInfixN op p x = do-  f <- op-  y <- p-  return $ f x y---- | @pInfixL op p x@ parses left-associative infix operator @op@, then term--- with parser @p@, then returns result of the operator application on @x@--- and the term.--pInfixL :: MonadParsec e s m => m (a -> a -> a) -> m a -> a -> m a-pInfixL op p x = do-  f <- op-  y <- p-  let r = f x y-  pInfixL op p r <|> return r---- | @pInfixR op p x@ parses right-associative infix operator @op@, then--- term with parser @p@, then returns result of the operator application on--- @x@ and the term.--pInfixR :: MonadParsec e s m => m (a -> a -> a) -> m a -> a -> m a-pInfixR op p x = do-  f <- op-  y <- p >>= \r -> pInfixR op p r <|> return r-  return $ f x y--type Batch m a =-  ( [m (a -> a -> a)]-  , [m (a -> a -> a)]-  , [m (a -> a -> a)]-  , [m (a -> a)]-  , [m (a -> a)] )---- | A helper to separate various operators (binary, unary, and according to--- associativity) and return them in a tuple.--splitOp :: Operator m a -> Batch m a -> Batch m a-splitOp (InfixR  op) (r, l, n, pre, post) = (op:r, l, n, pre, post)-splitOp (InfixL  op) (r, l, n, pre, post) = (r, op:l, n, pre, post)-splitOp (InfixN  op) (r, l, n, pre, post) = (r, l, op:n, pre, post)-splitOp (Prefix  op) (r, l, n, pre, post) = (r, l, n, op:pre, post)-splitOp (Postfix op) (r, l, n, pre, post) = (r, l, n, pre, op:post)

@@ -14,7 +14,6 @@ -- -- @since 6.5.0 -{-# LANGUAGE BangPatterns               #-} {-# LANGUAGE CPP                        #-} {-# LANGUAGE FlexibleContexts           #-} {-# LANGUAGE FlexibleInstances          #-}@@ -42,7 +41,8 @@   , withHints   , accHints   , refreshLastHint-  , runParsecT )+  , runParsecT+  , withParsecT ) where  import Control.Applicative@@ -52,16 +52,15 @@ import Control.Monad.Fix import Control.Monad.IO.Class import Control.Monad.Reader.Class-import Control.Monad.State.Class hiding (state)+import Control.Monad.State.Class import Control.Monad.Trans import Data.List.NonEmpty (NonEmpty (..)) import Data.Proxy-import Data.Semigroup hiding (option)+import Data.Semigroup 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@@ -72,7 +71,7 @@ -- Data types  -- | 'Hints' represent a collection of 'ErrorItem's to be included into--- 'ParserError' (when it's a 'TrivialError') as “expected” message items+-- 'ParseError' (when it's a 'TrivialError') as “expected” message items -- when a parser fails without consuming input right after successful parser -- that produced the hints. --@@ -83,7 +82,7 @@ -- unexpected 'a' -- expecting end of input ----- We're getting better error messages with help of hints:+-- We're getting better error messages with the help of hints: -- -- >>> parseTest (many (char 'r') <* eof) "ra" -- 1:2:@@ -99,7 +98,7 @@ -- -- See also: 'Consumption', 'Result'. -data Reply e s a = Reply (State s) Consumption (Result (Token s) e a)+data Reply e s a = Reply (State s) Consumption (Result s e a)  -- | This data structure represents an aspect of result of parser's work. --@@ -113,9 +112,9 @@ -- -- See also: 'Consumption', 'Reply'. -data Result t e a+data Result s e a   = OK a                   -- ^ Parser succeeded-  | Error (ParseError t e) -- ^ Parser failed+  | Error (ParseError s 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@.@@ -124,9 +123,9 @@   { 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+      -> (ParseError 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+      -> (ParseError s e -> State s         -> m b) -- empty-error       -> m b }  -- | @since 5.3.0@@ -134,11 +133,7 @@ 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@@ -222,9 +217,9 @@   fail = pFail  pFail :: String -> ParsecT e s m a-pFail msg = ParsecT $ \s@(State _ pos _ _) _ _ _ eerr ->+pFail msg = ParsecT $ \s@(State _ o _) _ _ _ eerr ->   let d = E.singleton (ErrorFail msg)-  in eerr (FancyError pos d) s+  in eerr (FancyError o d) s {-# INLINE pFail #-}  instance (Stream s, MonadIO m) => MonadIO (ParsecT e s m) where@@ -270,8 +265,8 @@   mplus = pPlus  pZero :: ParsecT e s m a-pZero = ParsecT $ \s@(State _ pos _ _) _ _ _ eerr ->-  eerr (TrivialError pos Nothing E.empty) s+pZero = ParsecT $ \s@(State _ o _) _ _ _ eerr ->+  eerr (TrivialError o Nothing E.empty) s {-# INLINE pZero #-}  pPlus :: (Ord e, Stream s)@@ -281,34 +276,34 @@ 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)+            neok x s' hs  = eok x s' (toHints (stateOffset 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+longestMatch s1@(State _ o1 _) s2@(State _ o2 _) =+  case o1 `compare` o2 of     LT -> s2     EQ -> s2     GT -> s1 {-# INLINE longestMatch #-} +-- | @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+ instance MonadTrans (ParsecT e s) where   lift amb = ParsecT $ \s _ _ eok _ ->     amb >>= \a -> eok a s mempty@@ -335,22 +330,24 @@   :: 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+pFailure us ps = ParsecT $ \s@(State _ o _) _ _ _ eerr ->+  eerr (TrivialError o 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+pFancyFailure xs = ParsecT $ \s@(State _ o _) _ _ _ eerr ->+  eerr (FancyError o 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)+      cok' x s' hs =+        case el of+          Nothing -> cok x s' (refreshLastHint hs Nothing)+          Just  _ -> cok x s' hs       eok' x s' hs = eok x s' (refreshLastHint hs el)       eerr'    err = eerr $         case err of@@ -373,9 +370,9 @@ {-# 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 o _) _ _ eok eerr ->   let what = maybe EndOfInput (Tokens . nes . fst) (take1_ input)-      unexpect u = TrivialError pos (pure u) E.empty+      unexpect u = TrivialError o (pure u) E.empty       cok' _ _ _ = eerr (unexpect what) s       cerr'  _ _ = eok () s mempty       eok' _ _ _ = eerr (unexpect what) s@@ -384,74 +381,71 @@ {-# INLINE pNotFollowedBy #-}  pWithRecovery-  :: (ParseError (Token s) e -> ParsecT e s m a)+  :: Stream s+  => (ParseError 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)+            reok x s' _ = eok x s' (toHints (stateOffset 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)+        let rcok x s' _ = cok x s' (toHints (stateOffset s') err)             rcerr   _ _ = eerr err ms-            reok x s' _ = eok x s' (toHints (statePos s') err)+            reok x s' _ = eok x s' (toHints (stateOffset 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)+  :: Stream s+  => ParsecT e s m a+  -> ParsecT e s m (Either (ParseError 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)+      eerr' err s' = eok (Left err) s' (toHints (stateOffset 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 ->+pEof = ParsecT $ \s@(State input o pst) _ _ 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)+      let us = (pure . Tokens . nes) x+          ps = E.singleton EndOfInput+      in eerr (TrivialError o us ps)+          (State input o pst) {-# 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)+  => (Token s -> Maybe a)+  -> Set (ErrorItem (Token s))   -> ParsecT e s m a-pToken test mtoken = ParsecT $ \s@(State input (pos:|z) tp w) cok _ _ eerr ->+pToken test ps = ParsecT $ \s@(State input o pst) 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+      in eerr (TrivialError o 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+        Nothing ->+          let us = (Just . Tokens . nes) c+          in eerr (TrivialError o us ps)+                  (State input o pst)+        Just x ->+          cok x (State cs (o + 1) pst) 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 ->+pTokens f tts = ParsecT $ \s@(State input o pst) cok _ eok eerr ->   let pxy = Proxy :: Proxy s       unexpect pos' u =         let us = pure u@@ -460,42 +454,39 @@       len = chunkLength pxy tts   in case takeN_ len input of     Nothing ->-      eerr (unexpect (pos:|z) EndOfInput) s+      eerr (unexpect o 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+        then let st = State input' (o + len) pst              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)+        else let ps = (Tokens . NE.fromList . chunkToTokens pxy) tts'+             in eerr (unexpect o ps) (State input o pst) {-# 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 _ ->+pTakeWhileP ml f = ParsecT $ \(State input o pst) 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+       then eok ts (State input' (o + len) pst) hs+       else cok ts (State input' (o + len) pst) 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 ->+pTakeWhile1P ml f = ParsecT $ \(State input o pst) cok _ _ eerr ->   let pxy = Proxy :: Proxy s       (ts, input') = takeWhile_ f input       len = chunkLength pxy ts@@ -505,37 +496,33 @@           Nothing -> mempty           Just l -> (Hints . pure . E.singleton) l   in if chunkEmpty pxy ts-       then let !apos = positionAtN pxy pos ts-                us    = pure $+       then let 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+            in eerr (TrivialError o us ps)+                    (State input o pst)+       else cok ts (State input' (o + len) pst) 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 ->+pTakeP ml n = ParsecT $ \s@(State input o pst) 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+         eerr (TrivialError o (pure EndOfInput) ps) s        Just (ts, input') ->-         let len   = chunkLength pxy ts-             !apos = positionAtN pxy pos ts-             !npos = advanceN pxy w pos ts+         let len = chunkLength pxy 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+           then eerr (TrivialError (o + len) (pure EndOfInput) ps)+                     (State input o pst)+           else cok ts (State input' (o + len) pst) mempty {-# INLINE pTakeP #-}  pGetParserState :: ParsecT e s m (State s)@@ -555,28 +542,33 @@  -- | Convert 'ParseError' record into 'Hints'. -toHints :: NonEmpty SourcePos -> ParseError t e -> Hints t+toHints+  :: Stream s+  => Int               -- ^ Current offset in input stream+  -> ParseError s e    -- ^ Parse error to convert+  -> Hints (Token s) toHints streamPos = \case-  TrivialError errPos _ ps ->+  TrivialError errOffset _ 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+    if streamPos == errOffset       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@.+-- | @'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)+withHints+  :: Stream 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+  -> (ParseError s e -> State s -> m b) -- ^ Continuation to influence+  -> ParseError s e    -- ^ First argument of resulting continuation   -> State s           -- ^ Second argument of resulting continuation   -> m b withHints (Hints ps') c e =@@ -585,16 +577,13 @@     _ -> 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' 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+  -> (a -> State s -> Hints t -> m b) -- ^ Altered “OK” continuation accHints hs1 c x s hs2 = c x s (hs1 <> hs2) {-# INLINE accHints #-} @@ -620,3 +609,17 @@     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)++-- | Transform any custom errors thrown by the parser using the given+-- function. Similar in function and purpose to @withExceptT@.+--+-- @since 7.0.0++withParsecT :: (Monad m, Ord e')+  => (e -> e')+  -> ParsecT e s m a+  -> ParsecT e' s m a+withParsecT f p =+  ParsecT $ \s cok cerr eok eerr ->+    unParser p s cok (cerr . mapParseError f) eok (eerr . mapParseError f)+{-# INLINE withParsecT #-}

@@ -0,0 +1,111 @@+-- |+-- Module      :  Text.Megaparsec.Common+-- Copyright   :  © 2018 Megaparsec contributors+-- License     :  FreeBSD+--+-- Maintainer  :  Mark Karpov <markkarpov92@gmail.com>+-- Stability   :  experimental+-- Portability :  portable+--+-- Common token combinators. This module is not public, the functions from+-- it are re-exported in "Text.Megaparsec.Byte" and "Text.Megaparsec.Char".+--+-- @since 7.0.0++{-# LANGUAGE FlexibleContexts #-}++module Text.Megaparsec.Lexer+  ( -- * White space+    space+  , lexeme+  , symbol+  , symbol' )+where++import Text.Megaparsec+import Text.Megaparsec.Common+import qualified Data.CaseInsensitive as CI++----------------------------------------------------------------------------+-- White space++-- | @'space' sc lineComment blockComment@ produces parser that can parse+-- white space in general. It's expected that you create such a parser once+-- and pass it to other functions in this module as needed (when you see+-- @spaceConsumer@ in documentation, usually it means that something like+-- 'space' is expected there).+--+-- @sc@ is used to parse blocks of space characters. You can use 'C.space1'+-- from "Text.Megaparsec.Char" for this purpose as well as your own parser+-- (if you don't want to automatically consume newlines, for example). Make+-- sure the parser does not succeed on empty input though. In earlier+-- version 'C.spaceChar' was recommended, but now parsers based on+-- 'takeWhile1P' are preferred because of their speed.+--+-- @lineComment@ is used to parse line comments. You can use+-- 'skipLineComment' if you don't need anything special.+--+-- @blockComment@ is used to parse block (multi-line) comments. You can use+-- 'skipBlockComment' or 'skipBlockCommentNested' if you don't need anything+-- special.+--+-- If you don't want to allow a kind of comment, simply pass 'empty' which+-- will fail instantly when parsing of that sort of comment is attempted and+-- 'space' will just move on or finish depending on whether there is more+-- white space for it to consume.++space :: MonadParsec e s m+  => m () -- ^ A parser for space characters which does not accept empty+          -- input (e.g. 'C.space1')+  -> m () -- ^ A parser for a line comment (e.g. 'skipLineComment')+  -> m () -- ^ A parser for a block comment (e.g. 'skipBlockComment')+  -> m ()+space sp line block = skipMany $ choice+  [hidden sp, hidden line, hidden block]+{-# INLINEABLE space #-}++-- | This is a wrapper for lexemes. Typical usage is to supply the first+-- argument (parser that consumes white space, probably defined via 'space')+-- and use the resulting function to wrap parsers for every lexeme.+--+-- > lexeme  = L.lexeme spaceConsumer+-- > integer = lexeme L.decimal++lexeme :: MonadParsec e s m+  => m ()              -- ^ How to consume white space after lexeme+  -> m a               -- ^ How to parse actual lexeme+  -> m a+lexeme spc p = p <* spc+{-# INLINEABLE lexeme #-}++-- | This is a helper to parse symbols, i.e. verbatim strings. You pass the+-- first argument (parser that consumes white space, probably defined via+-- 'space') and then you can use the resulting function to parse strings:+--+-- > symbol    = L.symbol spaceConsumer+-- >+-- > parens    = between (symbol "(") (symbol ")")+-- > braces    = between (symbol "{") (symbol "}")+-- > angles    = between (symbol "<") (symbol ">")+-- > brackets  = between (symbol "[") (symbol "]")+-- > semicolon = symbol ";"+-- > comma     = symbol ","+-- > colon     = symbol ":"+-- > dot       = symbol "."++symbol :: MonadParsec e s m+  => m ()              -- ^ How to consume white space after lexeme+  -> Tokens s          -- ^ Symbol to parse+  -> m (Tokens s)+symbol spc = lexeme spc . string+{-# INLINEABLE symbol #-}++-- | Case-insensitive version of 'symbol'. This may be helpful if you're+-- working with case-insensitive languages.++symbol' :: (MonadParsec e s m, CI.FoldCase (Tokens s))+  => m ()              -- ^ How to consume white space after lexeme+  -> Tokens s          -- ^ Symbol to parse (case-insensitive)+  -> m (Tokens s)+symbol' spc = lexeme spc . string'+{-# INLINEABLE symbol' #-}

@@ -1,146 +0,0 @@--- |--- Module      :  Text.Megaparsec.Perm--- Copyright   :  © 2015–2018 Megaparsec contributors---                © 2007 Paolo Martini---                © 1999–2001 Daan Leijen--- License     :  FreeBSD------ Maintainer  :  Mark Karpov <markkarpov92@gmail.com>--- Stability   :  experimental--- Portability :  non-portable------ This module implements permutation parsers. The algorithm is described--- in: /Parsing Permutation Phrases/, by Arthur Baars, Andres Loh and--- Doaitse Swierstra. Published as a functional pearl at the Haskell--- Workshop 2001.--{-# LANGUAGE CPP                       #-}-{-# LANGUAGE ExistentialQuantification #-}--module Text.Megaparsec.Perm-  ( PermParser-  , makePermParser-  , (<$$>)-  , (<$?>)-  , (<||>)-  , (<|?>) )-where--import Text.Megaparsec--#if !MIN_VERSION_base(4,8,0)-import Control.Applicative-#endif--infixl 1 <||>, <|?>-infixl 2 <$$>, <$?>---- | The type @PermParser s m a@ denotes a permutation parser that, when--- converted by the 'makePermParser' function, produces instance of--- 'MonadParsec' @m@ that parses @s@ stream and returns a value of type @a@--- on success.------ Normally, a permutation parser is first build with special operators like--- ('<||>') and than transformed into a normal parser using--- 'makePermParser'.--data PermParser s m a = Perm (Maybe a) [Branch s m a]--data Branch s m a = forall b. Branch (PermParser s m (b -> a)) (m b)---- | The parser @makePermParser perm@ parses a permutation of parser--- described by @perm@. For example, suppose we want to parse a permutation--- of: an optional string of @a@'s, the character @b@ and an optional @c@.--- This can be described by:------ > test = makePermParser $--- >          (,,) <$?> ("", some (char 'a'))--- >               <||> char 'b'--- >               <|?> ('_', char 'c')--makePermParser :: MonadParsec e s m-  => PermParser s m a -- ^ Given permutation parser-  -> m a              -- ^ Normal parser built from it-makePermParser (Perm def xs) = choice (fmap branch xs ++ empty')-  where empty' =-          case def of-            Nothing -> []-            Just x  -> [return x]-        branch (Branch perm p) = flip ($) <$> p <*> makePermParser perm---- | The expression @f \<$$> p@ creates a fresh permutation parser--- consisting of parser @p@. The the final result of the permutation parser--- is the function @f@ applied to the return value of @p@. The parser @p@ is--- not allowed to accept empty input—use the optional combinator ('<$?>')--- instead.------ If the function @f@ takes more than one parameter, the type variable @b@--- is instantiated to a functional type which combines nicely with the adds--- parser @p@ to the ('<||>') combinator. This results in stylized code--- where a permutation parser starts with a combining function @f@ followed--- by the parsers. The function @f@ gets its parameters in the order in--- which the parsers are specified, but actual input can be in any order.--(<$$>) :: MonadParsec e s m-  => (a -> b)          -- ^ Function to use on result of parsing-  -> m a               -- ^ Normal parser-  -> PermParser s m b  -- ^ Permutation parser build from it-f <$$> p = newperm f <||> p---- | The expression @f \<$?> (x, p)@ creates a fresh permutation parser--- consisting of parser @p@. The final result of the permutation parser is--- the function @f@ applied to the return value of @p@. The parser @p@ is--- optional—if it cannot be applied, the default value @x@ will be used--- instead.--(<$?>) :: MonadParsec e s m-  => (a -> b)          -- ^ Function to use on result of parsing-  -> (a, m a)          -- ^ Default value and parser-  -> PermParser s m b  -- ^ Permutation parser-f <$?> xp = newperm f <|?> xp---- | The expression @perm \<||> p@ adds parser @p@ to the permutation parser--- @perm@. The parser @p@ is not allowed to accept empty input—use the--- optional combinator ('<|?>') instead. Returns a new permutation parser--- that includes @p@.--(<||>) :: MonadParsec e s m-  => PermParser s m (a -> b) -- ^ Given permutation parser-  -> m a               -- ^ Parser to add (should not accept empty input)-  -> PermParser s m b  -- ^ Resulting parser-(<||>) = add---- | The expression @perm \<||> (x, p)@ adds parser @p@ to the permutation--- parser @perm@. The parser @p@ is optional—if it cannot be applied, the--- default value @x@ will be used instead. Returns a new permutation parser--- that includes the optional parser @p@.--(<|?>) :: MonadParsec e s m-  => PermParser s m (a -> b) -- ^ Given permutation parser-  -> (a, m a)          -- ^ Default value and parser-  -> PermParser s m b  -- ^ Resulting parser-perm <|?> (x, p) = addopt perm x p--newperm :: (a -> b) -> PermParser s m (a -> b)-newperm f = Perm (Just f) []--add :: MonadParsec e s m => PermParser s m (a -> b) -> m a -> PermParser s m b-add perm@(Perm _mf fs) p = Perm Nothing (first : fmap insert fs)-  where first = Branch perm p-        insert (Branch perm' p') = Branch (add (mapPerms flip perm') p) p'--addopt :: MonadParsec e s m-  => PermParser s m (a -> b)-  -> a-  -> m a-  -> PermParser s m b-addopt perm@(Perm mf fs) x p = Perm (fmap ($ x) mf) (first : fmap insert fs)-  where first   = Branch perm p-        insert (Branch perm' p') = Branch (addopt (mapPerms flip perm') x p) p'--mapPerms :: MonadParsec e s m-  => (a -> b)-  -> PermParser s m a-  -> PermParser s m b-mapPerms f (Perm x xs) = Perm (fmap f x) (fmap mapBranch xs)-  where mapBranch (Branch perm p) = Branch (mapPerms (f .) perm) p

@@ -8,8 +8,8 @@ -- Portability :  portable -- -- Textual source position. The position includes name of file, line number,--- and column number. List of such positions can be used to model a stack of--- include files.+-- and column number. A non-empty list of such positions can be used to+-- model a stack of include files. -- -- You probably do not want to import this module directly because -- "Text.Megaparsec" re-exports it anyway.@@ -108,7 +108,7 @@ -- -- @since 5.0.0 -data InvalidPosException = InvalidPosException Int+newtype InvalidPosException = InvalidPosException Int   -- ^ The first value is the minimal allowed value, the second value is the   -- actual value that was passed to 'mkPos'.   deriving (Eq, Show, Data, Typeable, Generic)

@@ -17,12 +17,12 @@ {-# LANGUAGE DeriveGeneric      #-}  module Text.Megaparsec.State-  ( State (..) )+  ( State (..)+  , PosState (..) ) 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@@ -32,14 +32,34 @@ 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+  , stateOffset :: {-# UNPACK #-} !Int     -- ^ Number of processed tokens so far     ---    -- @since 5.2.0-  , stateTabWidth :: Pos-    -- ^ Tab width to use+    -- @since 7.0.0+  , statePosState :: PosState s+    -- ^ State that is used for line\/column calculation+    --+    -- @since 7.0.0   } deriving (Show, Eq, Data, Typeable, Generic)  instance NFData s => NFData (State s)++-- | Special kind of state that is used to calculate line\/column positions+-- on demand.+--+-- @since 7.0.0++data PosState s = PosState+  { pstateInput :: s+    -- ^ The rest of input to process+  , pstateOffset :: !Int+    -- ^ Offset corresponding to beginning of 'pstateInput'+  , pstateSourcePos :: !SourcePos+    -- ^ Source position corresponding to beginning of 'pstateInput'+  , pstateTabWidth :: Pos+    -- ^ Tab width to use for column calculation+  , pstateLinePrefix :: String+    -- ^ Prefix to prepend to offending line+  } deriving (Show, Eq, Data, Typeable, Generic)++instance NFData s => NFData (PosState s)

@@ -14,27 +14,38 @@ -- -- @since 6.0.0 -{-# LANGUAGE CPP               #-}-{-# LANGUAGE FlexibleContexts  #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE TypeFamilies      #-}+{-# LANGUAGE CPP                 #-}+{-# LANGUAGE FlexibleContexts    #-}+{-# LANGUAGE FlexibleInstances   #-}+{-# LANGUAGE LambdaCase          #-}+{-# LANGUAGE MultiWayIf          #-}+{-# LANGUAGE RankNTypes          #-}+{-# LANGUAGE RecordWildCards     #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeFamilies        #-}  module Text.Megaparsec.Stream   ( Stream (..) ) where -import Data.List (foldl')+import Data.Char (chr)+import Data.Foldable (foldl')+import Data.List.NonEmpty (NonEmpty (..))+import Data.Maybe (fromMaybe) import Data.Proxy-import Data.Semigroup ((<>)) import Data.Word (Word8) import Text.Megaparsec.Pos-import qualified Data.ByteString      as B-import qualified Data.ByteString.Lazy as BL-import qualified Data.Text            as T-import qualified Data.Text.Lazy       as TL+import Text.Megaparsec.State+import qualified Data.ByteString            as B+import qualified Data.ByteString.Char8      as B8+import qualified Data.ByteString.Lazy       as BL+import qualified Data.ByteString.Lazy.Char8 as BL8+import qualified Data.List.NonEmpty         as NE+import qualified Data.Text                  as T+import qualified Data.Text.Lazy             as TL -#if !MIN_VERSION_base(4,8,0)-import Control.Applicative+#if !MIN_VERSION_base(4,11,0)+import Data.Semigroup #endif  -- | Type class for inputs that can be consumed by the library.@@ -87,55 +98,7 @@    chunkEmpty :: Proxy s -> Tokens s -> Bool   chunkEmpty pxy ts = chunkLength pxy ts <= 0-  {-# INLINE chunkEmpty #-} -  -- | Set source position __at__ given token. By default, the given-  -- 'SourcePos' (second argument) is just returned without looking at the-  -- token. This method is important when your stream is a collection of-  -- tokens where every token knows where it begins in the original input.--  positionAt1-    :: Proxy s         -- ^ 'Proxy' clarifying the type of stream-    -> SourcePos       -- ^ Current position-    -> Token s         -- ^ Current token-    -> SourcePos       -- ^ Position of the token-  positionAt1 Proxy = defaultPositionAt-  {-# INLINE positionAt1 #-}--  -- | The same as 'positionAt1', but for chunks of the stream. The function-  -- should return the position where the entire chunk begins. Again, by-  -- default the second argument is returned without modifications and the-  -- chunk is not looked at.--  positionAtN-    :: Proxy s         -- ^ 'Proxy' clarifying the type of stream-    -> SourcePos       -- ^ Current position-    -> Tokens s        -- ^ Current chunk-    -> SourcePos       -- ^ Position of the chunk-  positionAtN Proxy = defaultPositionAt-  {-# INLINE positionAtN #-}--  -- | Advance position given a single token. The returned position is the-  -- position right after the token, or the position where the token ends.--  advance1-    :: Proxy s         -- ^ 'Proxy' clarifying the type of stream-    -> Pos             -- ^ Tab width-    -> SourcePos       -- ^ Current position-    -> Token s         -- ^ Current token-    -> SourcePos       -- ^ Advanced position--  -- | Advance position given a chunk of stream. The returned position is-  -- the position right after the chunk, or the position where the chunk-  -- ends.--  advanceN-    :: Proxy s         -- ^ 'Proxy' clarifying the type of stream-    -> Pos             -- ^ Tab width-    -> SourcePos       -- ^ Current position-    -> Tokens s        -- ^ Current token-    -> SourcePos       -- ^ Advanced position-   -- | Extract a single token form the stream. Return 'Nothing' if the   -- stream is empty. @@ -166,6 +129,64 @@    takeWhile_ :: (Token s -> Bool) -> s -> (Tokens s, s) +  -- | Pretty-print non-empty stream of tokens. This function is also used+  -- to print single tokens (represented as singleton lists).+  --+  -- @since 7.0.0++  showTokens :: Proxy s -> NonEmpty (Token s) -> String++  -- | Given an offset @o@ and initial 'PosState', adjust the state in such+  -- a way that it starts at the offset.+  --+  -- Return three values (in order):+  --+  --     * 'SourcePos' which the given offset @o@ points to.+  --     * 'String' representing the line on which the given offset @o@ is+  --       located. The line should satisfy a number of conditions that are+  --       described below.+  --     * The updated 'PosState' which can be in turn used to locate+  --       another offset @o'@ given that @o' >= o@.+  --+  -- The 'String' representing the offending line in input stream should+  -- satisfy the following:+  --+  --     * It should adequately represent location of token at the offset of+  --       interest, that is, character at 'sourceColumn' of the returned+  --       'SourcePos' should correspond to the token at the offset @o@.+  --     * It should not include the newline at the end.+  --     * It should not be empty, if the line happens to be empty, it+  --       should be replaced with the string @\"\<empty line\>\"@.+  --     * Tab characters should be replaced by appropriate number of+  --       spaces, which is determined by the 'pstateTabWidth' field of+  --       'PosState'.+  --+  -- @since 7.0.0++  reachOffset+    :: Int             -- ^ Offset to reach+    -> PosState s      -- ^ Initial 'PosState' to use+    -> (SourcePos, String, PosState s) -- ^ (See above)++  -- | A version of 'reachOffset' that may be faster because it doesn't need+  -- to fetch the line at which the given offset in located.+  --+  -- The default implementation is this:+  --+  -- > reachOffsetNoLine o pst =+  -- >   let (spos, _, pst')=  reachOffset o pst+  -- >   in (spos, pst')+  --+  -- @since 7.0.0++  reachOffsetNoLine+    :: Int             -- ^ Offset to reach+    -> PosState s      -- ^ Initial 'PosState' to use+    -> (SourcePos, PosState s) -- ^ Reached source position and updated state+  reachOffsetNoLine o pst =+    let (spos, _, pst') = reachOffset o pst+    in (spos, pst')+ instance Stream String where   type Token String = Char   type Tokens String = String@@ -174,8 +195,6 @@   chunkToTokens Proxy = id   chunkLength Proxy = length   chunkEmpty Proxy = null-  advance1 Proxy = defaultAdvance1-  advanceN Proxy w = foldl' (defaultAdvance1 w)   take1_ [] = Nothing   take1_ (t:ts) = Just (t, ts)   takeN_ n s@@ -183,6 +202,12 @@     | null s    = Nothing     | otherwise = Just (splitAt n s)   takeWhile_ = span+  showTokens Proxy = stringPretty+  -- NOTE Do not eta-reduce these (breaks inlining)+  reachOffset o pst =+    reachOffset' splitAt foldl' id id ('\n','\t') o pst+  reachOffsetNoLine o pst =+    reachOffsetNoLine' splitAt foldl' ('\n', '\t') o pst  instance Stream B.ByteString where   type Token B.ByteString = Word8@@ -192,14 +217,18 @@   chunkToTokens Proxy = B.unpack   chunkLength Proxy = B.length   chunkEmpty Proxy = B.null-  advance1 Proxy = defaultAdvance1-  advanceN Proxy w = B.foldl' (defaultAdvance1 w)   take1_ = B.uncons   takeN_ n s     | n <= 0    = Just (B.empty, s)     | B.null s  = Nothing     | otherwise = Just (B.splitAt n s)   takeWhile_ = B.span+  showTokens Proxy = stringPretty . fmap (chr . fromIntegral)+  -- NOTE Do not eta-reduce these (breaks inlining)+  reachOffset o pst =+    reachOffset' B.splitAt B.foldl' B8.unpack (chr . fromIntegral) (10, 9) o pst+  reachOffsetNoLine o pst =+    reachOffsetNoLine' B.splitAt B.foldl' (10, 9) o pst  instance Stream BL.ByteString where   type Token BL.ByteString = Word8@@ -209,14 +238,18 @@   chunkToTokens Proxy = BL.unpack   chunkLength Proxy = fromIntegral . BL.length   chunkEmpty Proxy = BL.null-  advance1 Proxy = defaultAdvance1-  advanceN Proxy w = BL.foldl' (defaultAdvance1 w)   take1_ = BL.uncons   takeN_ n s     | n <= 0    = Just (BL.empty, s)     | BL.null s = Nothing     | otherwise = Just (BL.splitAt (fromIntegral n) s)   takeWhile_ = BL.span+  showTokens Proxy = stringPretty . fmap (chr . fromIntegral)+  -- NOTE Do not eta-reduce these (breaks inlining)+  reachOffset o pst =+    reachOffset' splitAtBL BL.foldl' BL8.unpack (chr . fromIntegral) (10, 9) o pst+  reachOffsetNoLine o pst =+    reachOffsetNoLine' splitAtBL BL.foldl' (10, 9) o pst  instance Stream T.Text where   type Token T.Text = Char@@ -226,14 +259,18 @@   chunkToTokens Proxy = T.unpack   chunkLength Proxy = T.length   chunkEmpty Proxy = T.null-  advance1 Proxy = defaultAdvance1-  advanceN Proxy w = T.foldl' (defaultAdvance1 w)   take1_ = T.uncons   takeN_ n s     | n <= 0    = Just (T.empty, s)     | T.null s  = Nothing     | otherwise = Just (T.splitAt n s)   takeWhile_ = T.span+  showTokens Proxy = stringPretty+  -- NOTE Do not eta-reduce (breaks inlining of reachOffset').+  reachOffset o pst =+    reachOffset' T.splitAt T.foldl' T.unpack id ('\n', '\t') o pst+  reachOffsetNoLine o pst =+    reachOffsetNoLine' T.splitAt T.foldl' ('\n', '\t') o pst  instance Stream TL.Text where   type Token TL.Text  = Char@@ -243,44 +280,232 @@   chunkToTokens Proxy = TL.unpack   chunkLength Proxy = fromIntegral . TL.length   chunkEmpty Proxy = TL.null-  advance1 Proxy = defaultAdvance1-  advanceN Proxy w = TL.foldl' (defaultAdvance1 w)   take1_ = TL.uncons   takeN_ n s     | n <= 0    = Just (TL.empty, s)     | TL.null s = Nothing     | otherwise = Just (TL.splitAt (fromIntegral n) s)   takeWhile_ = TL.span+  showTokens Proxy = stringPretty+  -- NOTE Do not eta-reduce (breaks inlining of reachOffset').+  reachOffset o pst =+    reachOffset' splitAtTL TL.foldl' TL.unpack id ('\n', '\t') o pst+  reachOffsetNoLine o pst =+    reachOffsetNoLine' splitAtTL TL.foldl' ('\n', '\t') o pst  ---------------------------------------------------------------------------- -- Helpers --- | Default positioning function designed to work with simple streams where--- tokens do not contain info about their position in the stream. Thus it--- just returns the given 'SourcePos' without re-positioning.+-- | An internal helper state type combining a difference 'String' and an+-- unboxed 'SourcePos'. -defaultPositionAt :: SourcePos -> a -> SourcePos-defaultPositionAt pos _ = pos-{-# INLINE defaultPositionAt #-}+data St = St SourcePos ShowS --- | Update a source position given a token. The first argument specifies--- the tab width. If the character is a newline (\'\\n\') the line number is--- incremented by 1 and column number is reset to 1. If the character is a--- tab (\'\\t\') the column number is incremented to the nearest tab--- position. In all other cases, the column is incremented by 1.+-- {-# UNPACK #-} -- TODO do we need to unpack or not? -defaultAdvance1 :: Enum t-  => Pos               -- ^ Tab width-  -> SourcePos         -- ^ Current position-  -> t                 -- ^ Current token-  -> SourcePos         -- ^ Incremented position-defaultAdvance1 width (SourcePos n l c) t = npos+-- | A helper definition to facilitate defining 'reachOffset' for various+-- stream types.++reachOffset'+  :: forall s. Stream s+  => (Int -> s -> (Tokens s, s))+     -- ^ How to split input stream at given offset+  -> (forall b. (b -> Token s -> b) -> b -> Tokens s -> b)+     -- ^ How to fold over input stream+  -> (Tokens s -> String)+     -- ^ How to convert chunk of input stream into a 'String'+  -> (Token s -> Char)+     -- ^ How to convert a token into a 'Char'+  -> (Token s, Token s)+     -- ^ Newline token and tab token+  -> Int+     -- ^ Offset to reach+  -> PosState s+     -- ^ Initial 'PosState' to use+  -> (SourcePos, String, PosState s)+     -- ^ Reached 'SourcePos', line at which 'SourcePos' is located, updated+     -- 'PosState'+reachOffset' splitAt'+             foldl''+             fromToks+             fromTok+             (newlineTok, tabTok)+             o+             PosState {..} =+  ( spos+  , case expandTab pstateTabWidth+           . addPrefix+           . f+           . fromToks+           . fst+           $ takeWhile_ (/= newlineTok) post of+      "" -> "<empty line>"+      xs -> xs+  , PosState+      { pstateInput = post+      , pstateOffset = max pstateOffset o+      , pstateSourcePos = spos+      , pstateTabWidth = pstateTabWidth+      , pstateLinePrefix =+          if sameLine+            -- NOTE We don't use difference lists here because it's+            -- desirable for 'PosState' to be an instance of 'Eq' and+            -- 'Show'. So we just do appending here. Fortunately several+            -- parse errors on the same line should be relatively rare.+            then pstateLinePrefix ++ f ""+            else f ""+      }+  )   where-    w  = unPos width-    c' = unPos c-    npos =-      case fromEnum t of-        10 -> SourcePos n (l <> pos1) pos1-        9  -> SourcePos n l (mkPos $ c' + w - ((c' - 1) `rem` w))-        _  -> SourcePos n l (c <> pos1)-{-# INLINE defaultAdvance1 #-}+    addPrefix xs =+      if sameLine+        then pstateLinePrefix ++ xs+        else xs+    sameLine = sourceLine spos == sourceLine pstateSourcePos+    (pre, post) = splitAt' (o - pstateOffset) pstateInput+    St spos f = foldl'' go (St pstateSourcePos id) pre+    go (St apos g) ch =+      let SourcePos n l c = apos+          c' = unPos c+          w  = unPos pstateTabWidth+      in if | ch == newlineTok ->+                St (SourcePos n (l <> pos1) pos1)+                   id+            | ch == tabTok ->+                St (SourcePos n l (mkPos $ c' + w - ((c' - 1) `rem` w)))+                   (g . (fromTok ch :))+            | otherwise ->+                St (SourcePos n l (c <> pos1))+                   (g . (fromTok ch :))+{-# INLINE reachOffset' #-}++-- | Like 'reachOffset'' but for 'reachOffsetNoLine'.++reachOffsetNoLine'+  :: forall s. Stream s+  => (Int -> s -> (Tokens s, s))+     -- ^ How to split input stream at given offset+  -> (forall b. (b -> Token s -> b) -> b -> Tokens s -> b)+     -- ^ How to fold over input stream+  -> (Token s, Token s)+     -- ^ Newline token and tab token+  -> Int+     -- ^ Offset to reach+  -> PosState s+     -- ^ Initial 'PosState' to use+  -> (SourcePos, PosState s)+     -- ^ Reached 'SourcePos' and updated 'PosState'+reachOffsetNoLine' splitAt'+                   foldl''+                   (newlineTok, tabTok)+                   o+                   PosState {..} =+  ( spos+  , PosState+      { pstateInput = post+      , pstateOffset = max pstateOffset o+      , pstateSourcePos = spos+      , pstateTabWidth = pstateTabWidth+      , pstateLinePrefix = pstateLinePrefix+      }+  )+  where+    spos = foldl'' go pstateSourcePos pre+    (pre, post) = splitAt' (o - pstateOffset) pstateInput+    go (SourcePos n l c) ch =+      let c' = unPos c+          w  = unPos pstateTabWidth+      in if | ch == newlineTok ->+                SourcePos n (l <> pos1) pos1+            | ch == tabTok ->+                SourcePos n l (mkPos $ c' + w - ((c' - 1) `rem` w))+            | otherwise ->+                SourcePos n l (c <> pos1)+{-# INLINE reachOffsetNoLine' #-}++-- | Like 'BL.splitAt' but accepts the index as an 'Int'.++splitAtBL :: Int -> BL.ByteString -> (BL.ByteString, BL.ByteString)+splitAtBL n = BL.splitAt (fromIntegral n)+{-# INLINE splitAtBL #-}++-- | Like 'TL.splitAt' but accepts the index as an 'Int'.++splitAtTL :: Int -> TL.Text -> (TL.Text, TL.Text)+splitAtTL n = TL.splitAt (fromIntegral n)+{-# INLINE splitAtTL #-}++-- | @stringPretty s@ returns pretty representation of string @s@. This is+-- used when printing string tokens in error messages.++stringPretty :: NonEmpty Char -> String+stringPretty (x:|[])      = charPretty x+stringPretty ('\r':|"\n") = "crlf newline"+stringPretty xs           = "\"" <> concatMap f (NE.toList xs) <> "\""+  where+    f ch =+      case charPretty' ch of+        Nothing     -> [ch]+        Just pretty -> "<" <> pretty <> ">"++-- | @charPretty ch@ returns user-friendly string representation of given+-- character @ch@, suitable for using in error messages.++charPretty :: Char -> String+charPretty ' ' = "space"+charPretty ch = fromMaybe ("'" <> [ch] <> "'") (charPretty' ch)++-- | If the given character has a pretty representation, return that,+-- otherwise 'Nothing'. This is an internal helper.++charPretty' :: Char -> Maybe String+charPretty' = \case+  '\NUL' -> Just "null"+  '\SOH' -> Just "start of heading"+  '\STX' -> Just "start of text"+  '\ETX' -> Just "end of text"+  '\EOT' -> Just "end of transmission"+  '\ENQ' -> Just "enquiry"+  '\ACK' -> Just "acknowledge"+  '\BEL' -> Just "bell"+  '\BS'  -> Just "backspace"+  '\t'   -> Just "tab"+  '\n'   -> Just "newline"+  '\v'   -> Just "vertical tab"+  '\f'   -> Just "form feed"+  '\r'   -> Just "carriage return"+  '\SO'  -> Just "shift out"+  '\SI'  -> Just "shift in"+  '\DLE' -> Just "data link escape"+  '\DC1' -> Just "device control one"+  '\DC2' -> Just "device control two"+  '\DC3' -> Just "device control three"+  '\DC4' -> Just "device control four"+  '\NAK' -> Just "negative acknowledge"+  '\SYN' -> Just "synchronous idle"+  '\ETB' -> Just "end of transmission block"+  '\CAN' -> Just "cancel"+  '\EM'  -> Just "end of medium"+  '\SUB' -> Just "substitute"+  '\ESC' -> Just "escape"+  '\FS'  -> Just "file separator"+  '\GS'  -> Just "group separator"+  '\RS'  -> Just "record separator"+  '\US'  -> Just "unit separator"+  '\DEL' -> Just "delete"+  '\160' -> Just "non-breaking space"+  _      -> Nothing++-- | Replace tab characters with given number of spaces.++expandTab+  :: Pos+  -> String+  -> String+expandTab w' = go 0+  where+    go 0 []        = []+    go 0 ('\t':xs) = go w xs+    go 0 (x:xs)    = x : go 0 xs+    go n xs        = ' ' : go (n - 1) xs+    w              = unPos w'

@@ -1,15 +1,19 @@ {-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TypeFamilies      #-}  module Main (main) where  import Control.DeepSeq import Control.Monad+import Data.List.NonEmpty (NonEmpty (..)) import Data.Semigroup ((<>)) import Data.Text (Text) import Data.Void import Text.Megaparsec import Text.Megaparsec.Char import Weigh+import qualified Data.List.NonEmpty         as NE+import qualified Data.Set                   as E import qualified Data.Text                  as T import qualified Text.Megaparsec.Char.Lexer as L @@ -47,6 +51,23 @@   bparser "hexadecimal" mkInt (const (L.hexadecimal :: Parser Integer))   bparser "scientific" mkInt (const L.scientific) +  forM_ stdSeries $ \n ->+    bbundle "single error" n [n]++  bbundle "2 errors" 1000 [1, 1000]+  bbundle "4 errors" 1000 [1, 500, 1000]+  bbundle "100 errors" 1000 [10,20..1000]++  breachOffset 0 1000+  breachOffset 0 2000+  breachOffset 0 4000+  breachOffset 1000 1000++  breachOffsetNoLine 0 1000+  breachOffsetNoLine 0 2000+  breachOffsetNoLine 0 4000+  breachOffsetNoLine 1000 1000+ -- | Perform a series of measurements with the same parser.  bparser :: NFData a@@ -57,7 +78,79 @@ 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+  func (name ++ "-" ++ show i) p' arg++-- | Bench the 'errorBundlePretty' function.++bbundle+  :: String            -- ^ Name of the benchmark+  -> Int               -- ^ Number of lines in input stream+  -> [Int]             -- ^ Lines with parse errors+  -> Weigh ()+bbundle name totalLines sps = do+  let s = take (totalLines * 80) (cycle as)+      as = replicate 79 'a' ++ "\n"+      f l = TrivialError+        (20 + l * 80)+        (Just $ Tokens ('a' :| ""))+        (E.singleton $ Tokens ('b' :| ""))+      bundle :: ParseErrorBundle String Void+      bundle = ParseErrorBundle+        { bundleErrors = f <$> NE.fromList sps+        , bundlePosState = PosState+          { pstateInput = s+          , pstateOffset = 0+          , pstateSourcePos = initialPos ""+          , pstateTabWidth = defaultTabWidth+          , pstateLinePrefix = ""+          }+        }+  func ("errorBundlePretty-" ++ show totalLines ++ "-" ++ name)+       errorBundlePretty+       bundle++-- | Bench the 'reachOffset' function.++breachOffset+  :: Int               -- ^ Starting offset in 'PosState'+  -> Int               -- ^ Offset to reach+  -> Weigh ()+breachOffset o0 o1 = func+  ("reachOffset-" ++ show o0 ++ "-" ++ show o1)+  f+  (o0 * 80, o1 * 80)+  where+    f :: (Int, Int) -> (SourcePos, PosState Text)+    f (startOffset, targetOffset) =+      let (x, _, y) = reachOffset targetOffset PosState+            { pstateInput = manyAs (targetOffset - startOffset)+            , pstateOffset = startOffset+            , pstateSourcePos = initialPos ""+            , pstateTabWidth = defaultTabWidth+            , pstateLinePrefix = ""+            }+      in (x, y)++-- | Bench the 'reachOffsetNoLine' function.++breachOffsetNoLine+  :: Int               -- ^ Starting offset in 'PosState'+  -> Int               -- ^ Offset to reach+  -> Weigh ()+breachOffsetNoLine o0 o1 = func+  ("reachOffsetNoLine-" ++ show o0 ++ "-" ++ show o1)+  f+  (o0 * 80, o1 * 80)+  where+    f :: (Int, Int) -> (SourcePos, PosState Text)+    f (startOffset, targetOffset) =+      reachOffsetNoLine targetOffset PosState+        { pstateInput = manyAs (targetOffset - startOffset)+        , pstateOffset = startOffset+        , pstateSourcePos = initialPos ""+        , pstateTabWidth = defaultTabWidth+        , pstateLinePrefix = ""+        }  -- | The series of sizes to try as part of 'bparser'. 

@@ -1,22 +1,21 @@-{-# LANGUAGE CPP               #-} {-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TypeFamilies      #-}  module Main (main) where  import Control.DeepSeq import Criterion.Main+import Data.List.NonEmpty (NonEmpty (..)) import Data.Semigroup ((<>)) import Data.Text (Text) import Data.Void import Text.Megaparsec import Text.Megaparsec.Char+import qualified Data.List.NonEmpty         as NE+import qualified Data.Set                   as E 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.  type Parser = Parsec Void Text@@ -49,6 +48,23 @@   , bparser "octal" mkInt (const (L.octal :: Parser Integer))   , bparser "hexadecimal" mkInt (const (L.hexadecimal :: Parser Integer))   , bparser "scientific" mkInt (const L.scientific)++  , bgroup "" [bbundle "single error" n [n] | n <- stdSeries]++  , bbundle "2 errors" 1000 [1, 1000]+  , bbundle "4 errors" 1000 [1, 500, 1000]+  , bbundle "100 errors" 1000 [10,20..1000]++  , breachOffset 0 1000+  , breachOffset 0 2000+  , breachOffset 0 4000+  , breachOffset 1000 1000++  , breachOffsetNoLine 0 1000+  , breachOffsetNoLine 0 2000+  , breachOffsetNoLine 0 4000+  , breachOffsetNoLine 1000 1000+   ]  -- | Perform a series to measurements with the same parser.@@ -62,6 +78,75 @@   where     bs n = env (return (f n, n)) (bench (show n) . nf p')     p' (s,n) = parse (p (s,n)) "" s++-- | Bench the 'errorBundlePretty' function.++bbundle+  :: String            -- ^ Name of the benchmark+  -> Int               -- ^ Number of lines in input stream+  -> [Int]             -- ^ Lines with parse errors+  -> Benchmark+bbundle name totalLines sps =+  let s = take (totalLines * 80) (cycle as)+      as = replicate 79 'a' ++ "\n"+      f l = TrivialError+        (20 + l * 80)+        (Just $ Tokens ('a' :| ""))+        (E.singleton $ Tokens ('b' :| ""))+      bundle :: ParseErrorBundle String Void+      bundle = ParseErrorBundle+        { bundleErrors = f <$> NE.fromList sps+        , bundlePosState = PosState+          { pstateInput = s+          , pstateOffset = 0+          , pstateSourcePos = initialPos ""+          , pstateTabWidth = defaultTabWidth+          , pstateLinePrefix = ""+          }+        }+  in bench ("errorBundlePretty-" ++ show totalLines ++ "-" ++ name)+           (nf errorBundlePretty bundle)++-- | Bench the 'reachOffset' function.++breachOffset+  :: Int               -- ^ Starting offset in 'PosState'+  -> Int               -- ^ Offset to reach+  -> Benchmark+breachOffset o0 o1 = bench+  ("reachOffset-" ++ show o0 ++ "-" ++ show o1)+  (nf f (o0 * 80, o1 * 80))+  where+    f :: (Int, Int) -> (SourcePos, PosState Text)+    f (startOffset, targetOffset) =+      let (x, _, y) = reachOffset targetOffset PosState+             { pstateInput = manyAs (targetOffset - startOffset)+             , pstateOffset = startOffset+             , pstateSourcePos = initialPos ""+             , pstateTabWidth = defaultTabWidth+             , pstateLinePrefix = ""+             }+      in (x, y)++-- | Bench the 'reachOffsetNoLine' function.++breachOffsetNoLine+  :: Int               -- ^ Starting offset in 'PosState'+  -> Int               -- ^ Offset to reach+  -> Benchmark+breachOffsetNoLine o0 o1 = bench+  ("reachOffsetNoLine-" ++ show o0 ++ "-" ++ show o1)+  (nf f (o0 * 80, o1 * 80))+  where+    f :: (Int, Int) -> (SourcePos, PosState Text)+    f (startOffset, targetOffset) =+      reachOffsetNoLine targetOffset PosState+        { pstateInput = manyAs (targetOffset - startOffset)+        , pstateOffset = startOffset+        , pstateSourcePos = initialPos ""+        , pstateTabWidth = defaultTabWidth+        , pstateLinePrefix = ""+        }  -- | The series of sizes to try as part of 'bparser'. 

@@ -1,7 +1,7 @@ name:                 megaparsec-version:              6.5.0+version:              7.0.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+tested-with:          GHC==7.10.3, GHC==8.0.2, GHC==8.2.2, GHC==8.4.3 license:              BSD2 license-file:         LICENSE.md author:               Megaparsec contributors,@@ -34,13 +34,13 @@   default:            False  library-  build-depends:      base         >= 4.7   && < 5.0+  build-depends:      base         >= 4.8   && < 5.0                     , bytestring   >= 0.2   && < 0.11                     , case-insensitive >= 1.2 && < 1.3-                    , containers   >= 0.5   && < 0.6+                    , containers   >= 0.5   && < 0.7                     , deepseq      >= 1.3   && < 1.5                     , mtl          >= 2.0   && < 3.0-                    , parser-combinators >= 0.4 && < 1.0+                    , parser-combinators >= 1.0 && < 2.0                     , scientific   >= 0.3.1 && < 0.4                     , text         >= 0.2   && < 1.3                     , transformers >= 0.4   && < 0.6@@ -54,14 +54,15 @@                     , Text.Megaparsec.Byte.Lexer                     , Text.Megaparsec.Char                     , Text.Megaparsec.Char.Lexer+                    , Text.Megaparsec.Debug                     , 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.Common+                    , Text.Megaparsec.Lexer                     , Text.Megaparsec.State   if flag(dev)     ghc-options:      -O0 -Wall -Werror@@ -83,8 +84,9 @@     ghc-options:      -O0 -Wall -Werror   else     ghc-options:      -O2 -Wall-  other-modules:      Spec-                    , Control.Applicative.CombinatorsSpec+  other-modules:      Control.Applicative.CombinatorsSpec+                    , Control.Applicative.PermutationsSpec+                    , Control.Monad.Combinators.ExprSpec                     , Control.Monad.CombinatorsSpec                     , Test.Hspec.Megaparsec                     , Test.Hspec.Megaparsec.AdHoc@@ -92,24 +94,24 @@                     , Text.Megaparsec.ByteSpec                     , Text.Megaparsec.Char.LexerSpec                     , Text.Megaparsec.CharSpec+                    , Text.Megaparsec.DebugSpec                     , Text.Megaparsec.ErrorSpec-                    , Text.Megaparsec.ExprSpec-                    , Text.Megaparsec.PermSpec                     , Text.Megaparsec.PosSpec                     , Text.Megaparsec.StreamSpec                     , Text.MegaparsecSpec-  build-depends:      QuickCheck   >= 2.7   && < 2.12-                    , base         >= 4.7   && < 5.0+  build-depends:      QuickCheck   >= 2.7   && < 2.13+                    , base         >= 4.8   && < 5.0                     , bytestring   >= 0.2   && < 0.11-                    , containers   >= 0.5   && < 0.6+                    , case-insensitive >= 1.2 && < 1.3+                    , containers   >= 0.5   && < 0.7                     , hspec        >= 2.0   && < 3.0-                    , hspec-expectations >= 0.5 && < 0.9+                    , hspec-expectations >= 0.8 && < 0.9                     , megaparsec                     , mtl          >= 2.0   && < 3.0+                    , parser-combinators >= 1.0 && < 2.0                     , 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)@@ -120,8 +122,9 @@   main-is:            Main.hs   hs-source-dirs:     bench/speed   type:               exitcode-stdio-1.0-  build-depends:      base         >= 4.7  && < 5.0-                    , criterion    >= 0.6.2.1 && < 1.5+  build-depends:      base         >= 4.8  && < 5.0+                    , containers   >= 0.5  && < 0.7+                    , criterion    >= 0.6.2.1 && < 1.6                     , deepseq      >= 1.3  && < 1.5                     , megaparsec                     , text         >= 0.2  && < 1.3@@ -139,7 +142,8 @@   main-is:            Main.hs   hs-source-dirs:     bench/memory   type:               exitcode-stdio-1.0-  build-depends:      base         >= 4.7  && < 5.0+  build-depends:      base         >= 4.8  && < 5.0+                    , containers   >= 0.5  && < 0.7                     , deepseq      >= 1.3  && < 1.5                     , megaparsec                     , text         >= 0.2  && < 1.3

@@ -3,6 +3,7 @@  module Control.Applicative.CombinatorsSpec (spec) where +import Control.Applicative.Combinators import Data.Char (isLetter, isDigit) import Data.List (intersperse) import Data.Maybe (fromMaybe, maybeToList, isNothing, fromJust)@@ -10,12 +11,8 @@ import Test.Hspec.Megaparsec import Test.Hspec.Megaparsec.AdHoc import Test.QuickCheck-import Text.Megaparsec import Text.Megaparsec.Char -#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@@ -31,7 +28,7 @@           z = replicate n c           s = pre ++ z ++ post       if b > 0-        then prs_ p s `shouldFailWith` err (posN (length pre + n + b) s)+        then prs_ p s `shouldFailWith` err (length pre + n + b)           ( etoks post <> etok c <>             if length post == b               then ueof@@ -45,7 +42,7 @@           s = [s']       if s' `elem` cs         then prs_ p s `shouldParse` s'-        else prs_ p s `shouldFailWith` err posI (utok s' <> mconcat (etok <$> cs))+        else prs_ p s `shouldFailWith` err 0 (utok s' <> mconcat (etok <$> cs))    describe "count" $ do     it "works" . property $ \n x' -> do@@ -64,13 +61,13 @@       if | n <= 0 || m > n ->            if x == 0              then prs_ p s `shouldParse` ""-             else prs_ p s `shouldFailWith` err posI (utok 'x' <> eeof)+             else prs_ p s `shouldFailWith` err 0 (utok 'x' <> eeof)          | m <= x && x <= n ->            prs_ p s `shouldParse` s          | x < m ->-           prs_ p s `shouldFailWith` err (posN x s) (ueof <> etok 'x')+           prs_ p s `shouldFailWith` err x (ueof <> etok 'x')          | otherwise ->-           prs_ p s `shouldFailWith` err (posN n s) (utok 'x' <> eeof)+           prs_ p s `shouldFailWith` err n (utok 'x' <> eeof)     rightOrder (count' 1 3 letterChar) "abc" "abc"    describe "eitherP" $@@ -80,7 +77,7 @@       if | isLetter ch -> prs_ p s `shouldParse` Left ch          | isDigit  ch -> prs_ p s `shouldParse` Right ch          | otherwise   -> prs_ p s `shouldFailWith`-           err posI (utok ch <> elabel "letter" <> elabel "digit")+           err 0 (utok ch <> elabel "letter" <> elabel "digit")    describe "endBy" $ do     it "works" . property $ \n' c -> do@@ -88,13 +85,13 @@           p = endBy (char 'a') (char '-')           s = intersperse '-' (replicate n 'a') ++ [c]       if | c == 'a' && n == 0 ->-           prs_ p s `shouldFailWith` err (posN (1 :: Int) s) (ueof <> etok '-')+           prs_ p s `shouldFailWith` err 1 (ueof <> etok '-')          | c == 'a' ->-           prs_ p s `shouldFailWith` err (posN (g n) s) (utok 'a' <> etok '-')+           prs_ p s `shouldFailWith` err (g n) (utok 'a' <> etok '-')          | c == '-' && n == 0 ->-           prs_ p s `shouldFailWith` err posI (utok '-' <> etok 'a'<> eeof)+           prs_ p s `shouldFailWith` err 0 (utok '-' <> etok 'a'<> eeof)          | c /= '-' ->-           prs_ p s `shouldFailWith` err (posN (g n) s)+           prs_ p s `shouldFailWith` err (g n)              ( utok c <>                (if n > 0 then etok '-' else eeof) <>                (if n == 0 then etok 'a' else mempty) )@@ -107,13 +104,13 @@           p = endBy1 (char 'a') (char '-')           s = intersperse '-' (replicate n 'a') ++ [c]       if | c == 'a' && n == 0 ->-           prs_ p s `shouldFailWith` err (posN (1 :: Int) s) (ueof <> etok '-')+           prs_ p s `shouldFailWith` err 1 (ueof <> etok '-')          | c == 'a' ->-           prs_ p s `shouldFailWith` err (posN (g n) s) (utok 'a' <> etok '-')+           prs_ p s `shouldFailWith` err (g n) (utok 'a' <> etok '-')          | c == '-' && n == 0 ->-           prs_ p s `shouldFailWith` err posI (utok '-' <> etok 'a')+           prs_ p s `shouldFailWith` err 0 (utok '-' <> etok 'a')          | c /= '-' ->-           prs_ p s `shouldFailWith` err (posN (g n) s)+           prs_ p s `shouldFailWith` err (g n)              ( utok c <>                (if n > 0 then etok '-' else mempty) <>                (if n == 0 then etok 'a' else mempty) )@@ -126,7 +123,7 @@           p = (,) <$> manyTill letterChar (char 'c') <*> many letterChar           s = abcRow a b c       if c == 0-        then prs_ p s `shouldFailWith` err (posN (a + b) s)+        then prs_ p s `shouldFailWith` err (a + b)              (ueof <> etok 'c' <> elabel "letter")         else let (pre, post) = break (== 'c') s              in prs_ p s `shouldParse` (pre, drop 1 post)@@ -138,13 +135,12 @@           p = (,) <$> someTill letterChar (char 'c') <*> many letterChar           s = abcRow a b c       if | null s ->-           prs_ p s `shouldFailWith` err posI (ueof <> elabel "letter")+           prs_ p s `shouldFailWith` err 0 (ueof <> elabel "letter")          | c == 0 ->-           prs_ p s `shouldFailWith` err (posN (a + b) s)+           prs_ p s `shouldFailWith` err (a + b)              (ueof <> etok 'c' <> elabel "letter")          | s == "c" ->-           prs_ p s `shouldFailWith` err-             (posN (1 :: Int) s) (ueof <> etok 'c' <> elabel "letter")+           prs_ p s `shouldFailWith` err 1 (ueof <> etok 'c' <> elabel "letter")          | head s == 'c' ->            prs_ p s `shouldParse` ("c", drop 2 s)          | otherwise ->@@ -169,14 +165,11 @@          | c == 'a' && n == 0 ->            prs_ p s `shouldParse` "a"          | n == 0 ->-           prs_ p s `shouldFailWith` err posI-             (utok c <> etok 'a' <> eeof)+           prs_ p s `shouldFailWith` err 0 (utok c <> etok 'a' <> eeof)          | c == '-' ->-           prs_ p s `shouldFailWith` err (posN (length s) s)-             (ueof <> etok 'a')+           prs_ p s `shouldFailWith` err (length s) (ueof <> etok 'a')          | otherwise ->-           prs_ p s `shouldFailWith` err (posN (g n) s)-             (utok c <> etok '-' <> eeof)+           prs_ p s `shouldFailWith` err (g n) (utok c <> etok '-' <> eeof)     rightOrder (sepBy letterChar (char ',')) "a,b,c" "abc"    describe "sepBy1" $ do@@ -188,15 +181,15 @@       if | isNothing c' && n >= 1 ->            prs_ p s `shouldParse` replicate n 'a'          | isNothing c' ->-           prs_ p s `shouldFailWith` err posI (ueof <> etok 'a')+           prs_ p s `shouldFailWith` err 0 (ueof <> etok 'a')          | c == 'a' && n == 0 ->            prs_ p s `shouldParse` "a"          | n == 0 ->-           prs_ p s `shouldFailWith` err posI (utok c <> etok 'a')+           prs_ p s `shouldFailWith` err 0 (utok c <> etok 'a')          | c == '-' ->-           prs_ p s `shouldFailWith` err (posN (length s) s) (ueof <> etok 'a')+           prs_ p s `shouldFailWith` err (length s) (ueof <> etok 'a')          | otherwise ->-           prs_ p s `shouldFailWith` err (posN (g n) s) (utok c <> etok '-' <> eeof)+           prs_ p s `shouldFailWith` err (g n) (utok c <> etok '-' <> eeof)     rightOrder (sepBy1 letterChar (char ',')) "a,b,c" "abc"    describe "sepEndBy" $ do@@ -211,11 +204,11 @@          | c == 'a' && n == 0 ->            prs_ p s `shouldParse` "a"          | n == 0 ->-           prs_ p s `shouldFailWith` err posI (utok c <> etok 'a' <> eeof)+           prs_ p s `shouldFailWith` err 0 (utok c <> etok 'a' <> eeof)          | c == '-' ->            prs_ p s `shouldParse` a          | otherwise ->-           prs_ p s `shouldFailWith` err (posN (g n) s) (utok c <> etok '-' <> eeof)+           prs_ p s `shouldFailWith` err (g n) (utok c <> etok '-' <> eeof)     rightOrder (sepEndBy letterChar (char ',')) "a,b,c," "abc"    describe "sepEndBy1" $ do@@ -228,15 +221,15 @@       if | isNothing c' && n >= 1 ->            prs_ p s `shouldParse` a          | isNothing c' ->-           prs_ p s `shouldFailWith` err posI (ueof <> etok 'a')+           prs_ p s `shouldFailWith` err 0 (ueof <> etok 'a')          | c == 'a' && n == 0 ->            prs_ p s `shouldParse` "a"          | n == 0 ->-           prs_ p s `shouldFailWith` err posI (utok c <> etok 'a')+           prs_ p s `shouldFailWith` err 0 (utok c <> etok 'a')          | c == '-' ->            prs_ p s `shouldParse` a          | otherwise ->-           prs_ p s `shouldFailWith` err (posN (g n) s) (utok c <> etok '-' <> eeof)+           prs_ p s `shouldFailWith` err (g n) (utok c <> etok '-' <> eeof)     rightOrder (sepEndBy1 letterChar (char ',')) "a,b,c," "abc"    describe "skipMany" $@@ -276,7 +269,7 @@           n = getNonNegative n'           s = replicate n c ++ [a]       if n == 0-        then prs_ p s `shouldFailWith` err posI (utok a <> etok c)+        then prs_ p s `shouldFailWith` err 0 (utok a <> etok c)         else prs_ p s `shouldParse` a  ----------------------------------------------------------------------------

@@ -0,0 +1,103 @@+{-# LANGUAGE TypeFamilies #-}++module Control.Applicative.PermutationsSpec (spec) where++import Control.Applicative.Permutations+import Control.Monad+import Data.Void+import Test.Hspec+import Test.Hspec.Megaparsec+import Test.Hspec.Megaparsec.AdHoc+import Test.QuickCheck+import Text.Megaparsec+import Text.Megaparsec.Char++spec :: Spec+spec = do+  describe "runPermutation & Permutation" $ do+    describe "Functor instance" $ do+      it "obeys identity law" $+        property $ \n ->+          prsp (fmap id (pure (n :: Int))) "" ===+          prsp (id (pure n)) ""+      it "obeys composition law" $+        property $ \n m t ->+          let f = (+ m)+              g = (* t)+          in prs (fmap (f . g) (pure (n :: Int))) "" ===+             prs ((fmap f . fmap g) (pure n)) ""+    describe "Applicative instance" $ do+      it "obeys identity law" $+        property $ \n ->+          prsp (pure id <*> pure (n :: Int)) "" ===+          prsp (pure n) ""+      it "obeys composition law" $+        property $ \n m t ->+          let u = pure (+ m)+              v = pure (* t)+              w = pure (n :: Int)+          in prsp (pure (.) <*> u <*> v <*> w) "" ===+             prsp (u <*> (v <*> w)) ""+      it "obeys homomorphism law" $+        property $ \x m ->+          let f = (+ m)+          in prsp (pure f <*> pure (x :: Int)) "" ===+             prsp (pure (f x)) ""+      it "obeys interchange law" $+        property $ \n y ->+          let u = pure (+ n)+          in prsp (u <*> pure (y :: Int)) "" ===+             prsp (pure ($ y) <*> u) ""+  describe "toPermutation" $+    it "works" $+      property $ \xs s' -> forAll (shuffle xs) $ \ys -> do+        let s = ys ++ s'+            p = foldr f (pure []) xs+            f x p' = (:) <$> toPermutation (char x) <*> p'+        prsp p s `shouldParse` xs+        prsp' p s `succeedsLeaving` s'+  describe "toPermutationWithDefault" $ do+    let testCases =+          [ ("abc", "abc", "")+          , ("cba", "abc", "")+          , ("bbc", "xbz", "bc")+          , ("aaa", "ayz", "aa")+          , ("",    "xyz", "")+          ]+    forM_ testCases $ \(i, o, r) ->+      it ("parses \"" ++ i ++ "\" as \"" ++ o ++ "\" leaving \"" ++ r ++ "\"") $ do+        prsp testPermParser i `shouldParse` o+        prsp' testPermParser i `succeedsLeaving` r+  describe "intercalateEffect" $ do+    let p = intercalateEffect (char ',') testPermParser+        testCases =+          [ ("a,b,c", "abc", "")+          , ("c,b,a", "abc", "")+          , ("b,b,c", "xbz", "b,c")+          , ("a,a,a", "ayz", "a,a")+          , (",",     "xyz", ",")+          ]+    forM_ testCases $ \(i, o, r) ->+      it ("parses \"" ++ i ++ "\" as \"" ++ o ++ "\" leaving \"" ++ r ++ "\"") $ do+        prs p i `shouldParse` o+        prs' p i `succeedsLeaving` r++prsp+  :: Permutation Parser a+  -> String+  -> Either (ParseErrorBundle String Void) a+prsp p = prs (runPermutation p)++prsp'+  :: Permutation Parser a+  -> String+  -> (State String, Either (ParseErrorBundle String Void) a)+prsp' p = prs' (runPermutation p)++testPermParser :: Permutation Parser String+testPermParser =+  f <$> toPermutationWithDefault 'x' (char 'a')+    <*> toPermutationWithDefault 'y' (char 'b')+    <*> toPermutationWithDefault 'z' (char 'c')+  where+    f a b c = [a,b,c]

@@ -0,0 +1,160 @@+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE TypeFamilies     #-}++module Control.Monad.Combinators.ExprSpec (spec) where++import Control.Monad.Combinators.Expr+import Data.Monoid ((<>))+import Test.Hspec+import Test.Hspec.Megaparsec+import Test.Hspec.Megaparsec.AdHoc+import Test.QuickCheck+import Text.Megaparsec+import Text.Megaparsec.Char++spec :: Spec+spec =+  describe "makeExprParser" $ do+    context "when given valid rendered AST" $+      it "can parse it back" $+        property $ \node -> do+          let s = showNode node+          prs  expr s `shouldParse`     node+          prs' expr s `succeedsLeaving` ""+    context "when stream in empty" $+      it "signals correct parse error" $+        prs (expr <* eof) "" `shouldFailWith` err 0+          (ueof <> etok '-' <> elabel "term")+    context "when term is missing" $+      it "signals correct parse error" $ do+        let p = expr <* eof+        prs p "-" `shouldFailWith` err 1 (ueof <> elabel "term")+        prs p "(" `shouldFailWith` err 1 (ueof <> etok '-' <> elabel "term")+        prs p "*" `shouldFailWith` err 0 (utok '*' <> etok '-' <> elabel "term")+    context "operator is missing" $+      it "signals correct parse error" $+        property $ \a b -> do+          let p = expr <* eof+              a' = inParens a+              n  = length a' + 1+              s  = a'  ++ " " ++ inParens b+              c  = s !! n+          if c == '-'+            then prs p s `shouldParse` Sub a b+            else prs p s `shouldFailWith`+                 err n (mconcat+                   [ utok c+                   , eeof+                   , etok '!'+                   , etok '%'+                   , etok '*'+                   , etok '+'+                   , etok '-'+                   , etok '/'+                   , etok '^'+                   ])++data Node+  = Val Integer   -- ^ literal value+  | Neg Node      -- ^ negation (prefix unary)+  | Fac Node      -- ^ factorial (postfix unary)+  | Mod Node Node -- ^ modulo+  | Sum Node Node -- ^ summation (addition)+  | Sub Node Node -- ^ subtraction+  | Pro Node Node -- ^ product+  | Div Node Node -- ^ division+  | Exp Node Node -- ^ exponentiation+    deriving (Eq, Show)++instance Enum Node where+  fromEnum (Val _)   = 0+  fromEnum (Neg _)   = 0+  fromEnum (Fac _)   = 0+  fromEnum (Mod _ _) = 0+  fromEnum (Exp _ _) = 1+  fromEnum (Pro _ _) = 2+  fromEnum (Div _ _) = 2+  fromEnum (Sum _ _) = 3+  fromEnum (Sub _ _) = 3+  toEnum   _         = error "Oops!"++instance Ord Node where+  x `compare` y = fromEnum x `compare` fromEnum y++showNode :: Node -> String+showNode (Val x)     = show x+showNode n@(Neg x)   = "-" ++ showGT n x+showNode n@(Fac x)   = showGT n x ++ "!"+showNode n@(Mod x y) = showGE n x ++ " % " ++ showGE n y+showNode n@(Sum x y) = showGT n x ++ " + " ++ showGE n y+showNode n@(Sub x y) = showGT n x ++ " - " ++ showGE n y+showNode n@(Pro x y) = showGT n x ++ " * " ++ showGE n y+showNode n@(Div x y) = showGT n x ++ " / " ++ showGE n y+showNode n@(Exp x y) = showGE n x ++ " ^ " ++ showGT n y++showGT :: Node -> Node -> String+showGT parent node = (if node > parent then showCmp else showNode) node++showGE :: Node -> Node -> String+showGE parent node = (if node >= parent then showCmp else showNode) node++showCmp :: Node -> String+showCmp node = (if fromEnum node == 0 then showNode else inParens) node++inParens :: Node -> String+inParens x = "(" ++ showNode x ++ ")"++instance Arbitrary Node where+  arbitrary = sized arbitraryN0++arbitraryN0 :: Int -> Gen Node+arbitraryN0 n = frequency [ (1, Mod <$> leaf <*> leaf)+                          , (9, arbitraryN1 n) ]+  where+    leaf = arbitraryN1 (n `div` 2)++arbitraryN1 :: Int -> Gen Node+arbitraryN1 n =+ frequency [ (1, Neg <$> arbitraryN2 n)+           , (1, Fac <$> arbitraryN2 n)+           , (7, arbitraryN2 n)]++arbitraryN2 :: Int -> Gen Node+arbitraryN2 0 = Val . getNonNegative <$> arbitrary+arbitraryN2 n = elements [Sum,Sub,Pro,Div,Exp] <*> leaf <*> leaf+  where+    leaf = arbitraryN0 (n `div` 2)++lexeme :: Parser a -> Parser a+lexeme p = p <* hidden space++symbol :: String -> Parser String+symbol = lexeme . string++parens :: Parser a -> Parser a+parens = between (symbol "(") (symbol ")")++integer :: Parser Integer+integer = lexeme (read <$> some digitChar <?> "integer")++-- Here we use a table of operators that makes use of all features of+-- 'makeExprParser'. Then we generate abstract syntax tree (AST) of complex+-- but valid expressions and render them to get their textual+-- representation.++expr :: Parser Node+expr = makeExprParser term table++term :: Parser Node+term = parens expr <|> (Val <$> integer) <?> "term"++table :: [[Operator Parser Node]]+table =+  [ [ Prefix  (Neg <$ symbol "-")+    , Postfix (Fac <$ symbol "!")+    , InfixN  (Mod <$ symbol "%") ]+  , [ InfixR  (Exp <$ symbol "^") ]+  , [ InfixL  (Pro <$ symbol "*")+    , InfixL  (Div <$ symbol "/") ]+  , [ InfixL  (Sum <$ symbol "+")+    , InfixL  (Sub <$ symbol "-")] ]

@@ -3,18 +3,15 @@  module Control.Monad.CombinatorsSpec (spec) where +import Control.Monad.Combinators import Data.List (intersperse) import Data.Maybe (maybeToList, isNothing, fromJust) import Test.Hspec import Test.Hspec.Megaparsec import Test.Hspec.Megaparsec.AdHoc import Test.QuickCheck-import Text.Megaparsec import Text.Megaparsec.Char -#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@@ -39,13 +36,13 @@       if | n <= 0 || m > n ->            if x == 0              then prs_ p s `shouldParse` ""-             else prs_ p s `shouldFailWith` err posI (utok 'x' <> eeof)+             else prs_ p s `shouldFailWith` err 0 (utok 'x' <> eeof)          | m <= x && x <= n ->            prs_ p s `shouldParse` s          | x < m ->-           prs_ p s `shouldFailWith` err (posN x s) (ueof <> etok 'x')+           prs_ p s `shouldFailWith` err x (ueof <> etok 'x')          | otherwise ->-           prs_ p s `shouldFailWith` err (posN n s) (utok 'x' <> eeof)+           prs_ p s `shouldFailWith` err n (utok 'x' <> eeof)     rightOrder (count' 1 3 letterChar) "abc" "abc"    describe "endBy" $ do@@ -54,13 +51,13 @@           p = endBy (char 'a') (char '-')           s = intersperse '-' (replicate n 'a') ++ [c]       if | c == 'a' && n == 0 ->-           prs_ p s `shouldFailWith` err (posN (1 :: Int) s) (ueof <> etok '-')+           prs_ p s `shouldFailWith` err 1 (ueof <> etok '-')          | c == 'a' ->-           prs_ p s `shouldFailWith` err (posN (g n) s) (utok 'a' <> etok '-')+           prs_ p s `shouldFailWith` err (g n) (utok 'a' <> etok '-')          | c == '-' && n == 0 ->-           prs_ p s `shouldFailWith` err posI (utok '-' <> etok 'a'<> eeof)+           prs_ p s `shouldFailWith` err 0 (utok '-' <> etok 'a'<> eeof)          | c /= '-' ->-           prs_ p s `shouldFailWith` err (posN (g n) s)+           prs_ p s `shouldFailWith` err (g n)              ( utok c <>                (if n > 0 then etok '-' else eeof) <>                (if n == 0 then etok 'a' else mempty) )@@ -73,13 +70,13 @@           p = endBy1 (char 'a') (char '-')           s = intersperse '-' (replicate n 'a') ++ [c]       if | c == 'a' && n == 0 ->-           prs_ p s `shouldFailWith` err (posN (1 :: Int) s) (ueof <> etok '-')+           prs_ p s `shouldFailWith` err (1 :: Int) (ueof <> etok '-')          | c == 'a' ->-           prs_ p s `shouldFailWith` err (posN (g n) s) (utok 'a' <> etok '-')+           prs_ p s `shouldFailWith` err (g n) (utok 'a' <> etok '-')          | c == '-' && n == 0 ->-           prs_ p s `shouldFailWith` err posI (utok '-' <> etok 'a')+           prs_ p s `shouldFailWith` err 0 (utok '-' <> etok 'a')          | c /= '-' ->-           prs_ p s `shouldFailWith` err (posN (g n) s)+           prs_ p s `shouldFailWith` err (g n)              ( utok c <>                (if n > 0 then etok '-' else mempty) <>                (if n == 0 then etok 'a' else mempty) )@@ -92,7 +89,7 @@           p = (,) <$> manyTill letterChar (char 'c') <*> many letterChar           s = abcRow a b c       if c == 0-        then prs_ p s `shouldFailWith` err (posN (a + b) s)+        then prs_ p s `shouldFailWith` err (a + b)              (ueof <> etok 'c' <> elabel "letter")         else let (pre, post) = break (== 'c') s              in prs_ p s `shouldParse` (pre, drop 1 post)@@ -104,13 +101,12 @@           p = (,) <$> someTill letterChar (char 'c') <*> many letterChar           s = abcRow a b c       if | null s ->-           prs_ p s `shouldFailWith` err posI (ueof <> elabel "letter")+           prs_ p s `shouldFailWith` err 0 (ueof <> elabel "letter")          | c == 0 ->-           prs_ p s `shouldFailWith` err (posN (a + b) s)+           prs_ p s `shouldFailWith` err (a + b)              (ueof <> etok 'c' <> elabel "letter")          | s == "c" ->-           prs_ p s `shouldFailWith` err-             (posN (1 :: Int) s) (ueof <> etok 'c' <> elabel "letter")+           prs_ p s `shouldFailWith` err 1 (ueof <> etok 'c' <> elabel "letter")          | head s == 'c' ->            prs_ p s `shouldParse` ("c", drop 2 s)          | otherwise ->@@ -129,14 +125,11 @@          | c == 'a' && n == 0 ->            prs_ p s `shouldParse` "a"          | n == 0 ->-           prs_ p s `shouldFailWith` err posI-             (utok c <> etok 'a' <> eeof)+           prs_ p s `shouldFailWith` err 0 (utok c <> etok 'a' <> eeof)          | c == '-' ->-           prs_ p s `shouldFailWith` err (posN (length s) s)-             (ueof <> etok 'a')+           prs_ p s `shouldFailWith` err (length s) (ueof <> etok 'a')          | otherwise ->-           prs_ p s `shouldFailWith` err (posN (g n) s)-             (utok c <> etok '-' <> eeof)+           prs_ p s `shouldFailWith` err (g n) (utok c <> etok '-' <> eeof)     rightOrder (sepBy letterChar (char ',')) "a,b,c" "abc"    describe "sepBy1" $ do@@ -148,15 +141,15 @@       if | isNothing c' && n >= 1 ->            prs_ p s `shouldParse` replicate n 'a'          | isNothing c' ->-           prs_ p s `shouldFailWith` err posI (ueof <> etok 'a')+           prs_ p s `shouldFailWith` err 0 (ueof <> etok 'a')          | c == 'a' && n == 0 ->            prs_ p s `shouldParse` "a"          | n == 0 ->-           prs_ p s `shouldFailWith` err posI (utok c <> etok 'a')+           prs_ p s `shouldFailWith` err 0 (utok c <> etok 'a')          | c == '-' ->-           prs_ p s `shouldFailWith` err (posN (length s) s) (ueof <> etok 'a')+           prs_ p s `shouldFailWith` err (length s) (ueof <> etok 'a')          | otherwise ->-           prs_ p s `shouldFailWith` err (posN (g n) s) (utok c <> etok '-' <> eeof)+           prs_ p s `shouldFailWith` err (g n) (utok c <> etok '-' <> eeof)     rightOrder (sepBy1 letterChar (char ',')) "a,b,c" "abc"    describe "sepEndBy" $ do@@ -171,11 +164,11 @@          | c == 'a' && n == 0 ->            prs_ p s `shouldParse` "a"          | n == 0 ->-           prs_ p s `shouldFailWith` err posI (utok c <> etok 'a' <> eeof)+           prs_ p s `shouldFailWith` err 0 (utok c <> etok 'a' <> eeof)          | c == '-' ->            prs_ p s `shouldParse` a          | otherwise ->-           prs_ p s `shouldFailWith` err (posN (g n) s) (utok c <> etok '-' <> eeof)+           prs_ p s `shouldFailWith` err (g n) (utok c <> etok '-' <> eeof)     rightOrder (sepEndBy letterChar (char ',')) "a,b,c," "abc"    describe "sepEndBy1" $ do@@ -188,15 +181,15 @@       if | isNothing c' && n >= 1 ->            prs_ p s `shouldParse` a          | isNothing c' ->-           prs_ p s `shouldFailWith` err posI (ueof <> etok 'a')+           prs_ p s `shouldFailWith` err 0 (ueof <> etok 'a')          | c == 'a' && n == 0 ->            prs_ p s `shouldParse` "a"          | n == 0 ->-           prs_ p s `shouldFailWith` err posI (utok c <> etok 'a')+           prs_ p s `shouldFailWith` err 0 (utok c <> etok 'a')          | c == '-' ->            prs_ p s `shouldParse` a          | otherwise ->-           prs_ p s `shouldFailWith` err (posN (g n) s) (utok c <> etok '-' <> eeof)+           prs_ p s `shouldFailWith` err (g n) (utok c <> etok '-' <> eeof)     rightOrder (sepEndBy1 letterChar (char ',')) "a,b,c," "abc"    describe "skipMany" $@@ -236,7 +229,7 @@           n = getNonNegative n'           s = replicate n c ++ [a]       if n == 0-        then prs_ p s `shouldFailWith` err posI (utok a <> etok c)+        then prs_ p s `shouldFailWith` err 0 (utok a <> etok c)         else prs_ p s `shouldParse` a  ----------------------------------------------------------------------------

@@ -1,7 +1,52 @@ module Main (main) where +import Test.Hspec import Test.Hspec.Runner-import Spec (spec)++import qualified Control.Applicative.CombinatorsSpec+import qualified Control.Applicative.PermutationsSpec++import qualified Control.Monad.CombinatorsSpec+import qualified Control.Monad.Combinators.ExprSpec++import qualified Text.MegaparsecSpec++import qualified Text.Megaparsec.ByteSpec+import qualified Text.Megaparsec.Byte.LexerSpec++import qualified Text.Megaparsec.CharSpec+import qualified Text.Megaparsec.Char.LexerSpec++import qualified Text.Megaparsec.DebugSpec+import qualified Text.Megaparsec.ErrorSpec+import qualified Text.Megaparsec.PosSpec+import qualified Text.Megaparsec.StreamSpec++-- | Here we define 'spec' manually rather than with @hspec-discover@ so we+-- can disable some tests quickly by commenting out the corresponding lines+-- here (running all the tests takes a while now).++spec :: Spec+spec = do++  Control.Applicative.CombinatorsSpec.spec+  Control.Applicative.PermutationsSpec.spec++  Control.Monad.CombinatorsSpec.spec+  Control.Monad.Combinators.ExprSpec.spec++  Text.MegaparsecSpec.spec++  Text.Megaparsec.ByteSpec.spec+  Text.Megaparsec.Byte.LexerSpec.spec++  Text.Megaparsec.CharSpec.spec+  Text.Megaparsec.Char.LexerSpec.spec++  Text.Megaparsec.DebugSpec.spec+  Text.Megaparsec.ErrorSpec.spec+  Text.Megaparsec.PosSpec.spec+  Text.Megaparsec.StreamSpec.spec  main :: IO () main = hspecWith defaultConfig { configQuickCheckMaxSuccess = Just 1000 } spec

@@ -1,1 +0,0 @@-{-# OPTIONS_GHC -F -pgmF hspec-discover -optF --module-name=Spec #-}

@@ -1,6 +1,6 @@ -- | -- Module      :  Test.Hspec.Megaparsec--- Copyright   :  © 2016–2017 Mark Karpov+-- Copyright   :  © 2016–2018 Mark Karpov -- License     :  BSD 3 clause -- -- Maintainer  :  Mark Karpov <markkarpov92@gmail.com>@@ -8,7 +8,10 @@ -- Portability :  portable -- -- Utility functions for testing Megaparsec parsers with Hspec.+--+-- This version of the library should be used with Megaparsec 7. +{-# LANGUAGE ConstraintKinds     #-} {-# LANGUAGE FlexibleContexts    #-} {-# LANGUAGE RankNTypes          #-} {-# LANGUAGE ScopedTypeVariables #-}@@ -22,19 +25,21 @@   , shouldFailOn     -- * Testing of error messages   , shouldFailWith+  , shouldFailWithM     -- * Incremental parsing   , failsLeaving   , succeedsLeaving   , initialState+  , initialPosState     -- * Re-exports   , module Text.Megaparsec.Error.Builder ) where  import Control.Monad (unless)-import Data.List.NonEmpty (NonEmpty (..)) import Test.Hspec.Expectations import Text.Megaparsec import Text.Megaparsec.Error.Builder+import qualified Data.List.NonEmpty as NE  ---------------------------------------------------------------------------- -- Basic expectations@@ -43,14 +48,20 @@ -- -- > parse letterChar "" "x" `shouldParse` 'x' -shouldParse :: (Ord t, ShowToken t, ShowErrorComponent e, Eq a, Show a)-  => Either (ParseError t e) a+shouldParse+  :: ( HasCallStack+     , ShowErrorComponent e+     , Stream s+     , Show a+     , Eq a+     )+  => Either (ParseErrorBundle s e) a      -- ^ Result of parsing as returned by function like 'parse'   -> a                 -- ^ Desired result   -> Expectation r `shouldParse` v = case r of   Left e -> expectationFailure $ "expected: " ++ show v ++-    "\nbut parsing failed with error:\n" ++ showParseError e+    "\nbut parsing failed with error:\n" ++ showBundle e   Right x -> unless (x == v) . expectationFailure $     "expected: " ++ show v ++ "\nbut got: " ++ show x @@ -59,15 +70,21 @@ -- -- > parse (many punctuationChar) "" "?!!" `parseSatisfies` ((== 3) . length) -parseSatisfies :: (Ord t, ShowToken t, ShowErrorComponent e, Show a)-  => Either (ParseError t e) a+parseSatisfies+  :: ( HasCallStack+     , ShowErrorComponent e+     , Stream s+     , Show a+     , Eq a+     )+  => Either (ParseErrorBundle s e) a      -- ^ Result of parsing as returned by function like 'parse'   -> (a -> Bool)       -- ^ Predicate   -> Expectation r `parseSatisfies` p = case r of   Left e -> expectationFailure $     "expected a parsed value to check against the predicate" ++-    "\nbut parsing failed with error:\n" ++ showParseError e+    "\nbut parsing failed with error:\n" ++ showBundle e   Right x -> unless (p x) . expectationFailure $     "the value did not satisfy the predicate: " ++ show x @@ -75,8 +92,9 @@ -- -- > parse (char 'x') "" `shouldFailOn` "a" -shouldFailOn :: Show a-  => (s -> Either (ParseError t e) a)+shouldFailOn+  :: (HasCallStack, Show a)+  => (s -> Either (ParseErrorBundle s e) a)      -- ^ Parser that takes stream and produces result or error message   -> s                 -- ^ Input that the parser should fail on   -> Expectation@@ -86,8 +104,13 @@ -- -- > parse (char 'x') "" `shouldSucceedOn` "x" -shouldSucceedOn :: (Ord t, ShowToken t, ShowErrorComponent e, Show a)-  => (s -> Either (ParseError t e) a)+shouldSucceedOn+  :: ( HasCallStack+     , ShowErrorComponent e+     , Stream s+     , Show a+     )+  => (s -> Either (ParseErrorBundle s e) a)      -- ^ Parser that takes stream and produces result or error message   -> s                 -- ^ Input that the parser should succeed on   -> Expectation@@ -102,14 +125,45 @@ -- -- > parse (char 'x') "" "b" `shouldFailWith` err posI (utok 'b' <> etok 'x') -shouldFailWith :: (Ord t, ShowToken t, ShowErrorComponent e, Show a)-  => Either (ParseError t e) a-  -> ParseError t e+shouldFailWith+  :: ( HasCallStack+     , ShowErrorComponent e+     , Stream s+     , Show a+     , Eq e+     )+  => Either (ParseErrorBundle s e) a -- ^ The result of parsing+  -> ParseError s e    -- ^ Expected parse errors   -> Expectation-r `shouldFailWith` e = case r of-  Left e' -> unless (e == e') . expectationFailure $-    "the parser is expected to fail with:\n" ++ showParseError e ++-    "but it failed with:\n" ++ showParseError e'+r `shouldFailWith` perr1 = r `shouldFailWithM` [perr1]++-- | Similar to 'shouldFailWith', but allows to check parsers that can+-- report more than one parse error at a time.+--+-- @since 2.0.0++shouldFailWithM+  :: ( HasCallStack+     , ShowErrorComponent e+     , Stream s+     , Show a+     , Eq e+     )+  => Either (ParseErrorBundle s e) a -- ^ The result of parsing+  -> [ParseError s e]+     -- ^ Expected parse errors, the argument is a normal linked list (as+     -- opposed to the more correct 'NonEmpty' list) as a syntactical+     -- convenience for the user, passing empty list here will result in an+     -- error+  -> Expectation+r `shouldFailWithM` perrs1' = case r of+  Left e0 ->+    let e1 = e0 { bundleErrors = perrs1 }+        perrs0 = bundleErrors e0+        perrs1 = NE.fromList perrs1'+    in unless (perrs0 == perrs1) . expectationFailure $+       "the parser is expected to fail with:\n" ++ showBundle e1 +++       "but it failed with:\n" ++ showBundle e0   Right v -> expectationFailure $     "the parser is expected to fail, but it parsed: " ++ show v @@ -125,14 +179,20 @@ -- -- See also: 'initialState'. -failsLeaving :: (Show a, Eq s, Show s, Stream s)-  => (State s, Either (ParseError (Token s) e) a)+failsLeaving+  :: ( HasCallStack+     , Show a+     , Eq s+     , Show s+     )+  => (State s, Either (ParseErrorBundle s e) a)      -- ^ Parser that takes stream and produces result along with actual      -- state information   -> s                 -- ^ Part of input that should be left unconsumed   -> Expectation-(st,r) `failsLeaving` s =-  shouldFail r >> checkUnconsumed s (stateInput st)+(st,r) `failsLeaving` s = do+  shouldFail r+  checkUnconsumed s (stateInput st)  -- | Check that a parser succeeds and leaves certain part of input -- unconsumed. Use it with functions like 'runParser'' and 'runParserT''@@ -143,38 +203,53 @@ -- -- See also: 'initialState'. -succeedsLeaving :: ( ShowToken (Token s)-                   , ShowErrorComponent e-                   , Show a-                   , Eq s-                   , Show s-                   , Stream s )-  => (State s, Either (ParseError (Token s) e) a)+succeedsLeaving+  :: ( HasCallStack+     , Show a+     , Eq s+     , Show s+     , ShowErrorComponent e+     , Stream s+     )+  => (State s, Either (ParseErrorBundle s e) a)      -- ^ Parser that takes stream and produces result along with actual      -- state information   -> s                 -- ^ Part of input that should be left unconsumed   -> Expectation-(st,r) `succeedsLeaving` s =-  shouldSucceed r >> checkUnconsumed s (stateInput st)+(st,r) `succeedsLeaving` s = do+  shouldSucceed r+  checkUnconsumed s (stateInput st) --- | Given input for parsing, construct initial state for parser (that is,--- with empty file name, default tab width and position at 1 line and 1--- column).+-- | Given input for parsing, construct initial state for parser.  initialState :: s -> State s initialState s = State-  { stateInput           = s-  , statePos             = initialPos "" :| []-  , stateTokensProcessed = 0-  , stateTabWidth        = defaultTabWidth }+  { stateInput  = s+  , stateOffset = 0+  , statePosState = initialPosState s+  } +-- | Given input for parsing, construct initial positional state.+--+-- @since 2.0.0++initialPosState :: s -> PosState s+initialPosState s = PosState+  { pstateInput = s+  , pstateOffset = 0+  , pstateSourcePos = initialPos ""+  , pstateTabWidth = defaultTabWidth+  , pstateLinePrefix = ""+  }+ ---------------------------------------------------------------------------- -- Helpers --- | Expectation that argument is result of a failed parser.+-- | Expect that the argument is a result of a failed parser. -shouldFail :: Show a-  => Either (ParseError t e) a+shouldFail+  :: (HasCallStack, Show a)+  => Either (ParseErrorBundle s e) a   -> Expectation shouldFail r = case r of   Left _ -> return ()@@ -183,18 +258,27 @@  -- | Expectation that argument is result of a succeeded parser. -shouldSucceed :: (Ord t, ShowToken t, ShowErrorComponent e, Show a)-  => Either (ParseError t e) a+shouldSucceed+  :: ( HasCallStack+     , ShowErrorComponent e+     , Stream s+     , Show a+     )+  => Either (ParseErrorBundle s e) a   -> Expectation shouldSucceed r = case r of   Left e -> expectationFailure $     "the parser is expected to succeed, but it failed with:\n" ++-    showParseError e+    showBundle e   Right _ -> return ()  -- | Compare two streams for equality and in the case of mismatch report it. -checkUnconsumed :: (Eq s, Show s, Stream s)+checkUnconsumed+  :: ( HasCallStack+     , Eq s+     , Show s+     )   => s                 -- ^ Expected unconsumed input   -> s                 -- ^ Actual unconsumed input   -> Expectation@@ -202,10 +286,17 @@   "the parser is expected to leave unconsumed input: " ++ show e ++   "\nbut it left this: " ++ show a --- | Render parse error in a way that is suitable for inserting it in a test--- suite report.+-- | Render a parse error bundle in a way that is suitable for inserting it+-- in a test suite report. -showParseError :: (Ord t, ShowToken t, ShowErrorComponent e)-  => ParseError t e+showBundle+  :: ( ShowErrorComponent e+     , Stream s+     )+  => ParseErrorBundle s e   -> String-showParseError = unlines . fmap ("  " ++) . lines . parseErrorPretty+showBundle = unlines . fmap indent . lines . errorBundlePretty+  where+    indent x = if null x+      then x+      else "  " ++ x

@@ -1,32 +1,45 @@ {-# LANGUAGE CPP                  #-} {-# LANGUAGE FlexibleContexts     #-} {-# LANGUAGE RankNTypes           #-}+{-# LANGUAGE ScopedTypeVariables  #-}+{-# LANGUAGE TypeFamilies         #-} {-# OPTIONS_GHC -fno-warn-orphans #-}  module Test.Hspec.Megaparsec.AdHoc-  ( -- * Helpers to run parsers-    prs+  ( -- * Types+    Parser+    -- * Helpers to run parsers+  , prs   , prs'   , prs_   , grs   , grs'-    -- * Working with source position-  , updatePosString-  , pos1-  , nes     -- * Other+  , nes   , abcRow-  , toFirstMismatch   , rightOrder-  , Parser )+  , scaleDown+  , getTabWidth+  , setTabWidth+  , strSourcePos+    -- * Char and byte conversion+  , toChar+  , fromChar+    -- * Proxies+  , sproxy+  , bproxy+  , blproxy+  , tproxy+  , tlproxy ) where -import Control.Monad import Control.Monad.Reader import Control.Monad.Trans.Identity+import Data.Char (chr, ord) import Data.List.NonEmpty (NonEmpty (..)) import Data.Proxy import Data.Void+import Data.Word (Word8) import Test.Hspec import Test.Hspec.Megaparsec import Test.QuickCheck@@ -44,10 +57,13 @@ import qualified Data.Text                   as T import qualified Data.Text.Lazy              as TL -#if !MIN_VERSION_base(4,8,0)-import Control.Applicative-#endif+----------------------------------------------------------------------------+-- Types +-- | The type of parser that consumes a 'String'.++type Parser = Parsec Void String+ ---------------------------------------------------------------------------- -- Helpers to run parsers @@ -55,17 +71,23 @@ -- that assumes empty file name.  prs-  :: Parser a          -- ^ Parser to run-  -> String            -- ^ Input for the parser-  -> Either (ParseError Char Void) a -- ^ Result of parsing+  :: Parser a+     -- ^ Parser to run+  -> String+     -- ^ Input for the parser+  -> Either (ParseErrorBundle String Void) a+     -- ^ Result of parsing prs p = parse p ""  -- | Just like 'prs', but allows to inspect the final state of the parser.  prs'-  :: Parser a          -- ^ Parser to run-  -> String            -- ^ Input for the parser-  -> (State String, Either (ParseError Char Void) a) -- ^ Result of parsing+  :: Parser a+     -- ^ Parser to run+  -> String+     -- ^ Input for the parser+  -> (State String, Either (ParseErrorBundle String Void) a)+     -- ^ Result of parsing prs' p s = runParser' p (initialState s)  -- | Just like 'prs', but forces the parser to consume all input by adding@@ -74,9 +96,12 @@ -- > prs_ p = parse (p <* eof) ""  prs_-  :: Parser a          -- ^ Parser to run-  -> String            -- ^ Input for the parser-  -> Either (ParseError Char Void) a -- ^ Result of parsing+  :: Parser a+     -- ^ Parser to run+  -> String+     -- ^ Input for the parser+  -> Either (ParseErrorBundle String Void) a+     -- ^ Result of parsing prs_ p = parse (p <* eof) ""  -- | Just like 'prs', but interprets given parser as various monads (tries@@ -85,7 +110,7 @@ grs   :: (forall m. MonadParsec Void String m => m a) -- ^ Parser to run   -> String            -- ^ Input for the parser-  -> (Either (ParseError Char Void) a -> Expectation)+  -> (Either (ParseErrorBundle String Void) a -> Expectation)     -- ^ How to check result of parsing   -> Expectation grs p s r = do@@ -104,7 +129,7 @@ grs'   :: (forall m. MonadParsec Void String m => m a) -- ^ Parser to run   -> String            -- ^ Input for the parser-  -> ((State String, Either (ParseError Char Void) a) -> Expectation)+  -> ((State String, Either (ParseErrorBundle String Void) a) -> Expectation)     -- ^ How to check result of parsing   -> Expectation grs' p s r = do@@ -119,9 +144,9 @@   r (prs' (evalRWSTS    p)    s)  evalWriterTL :: Monad m => L.WriterT [Int] m a -> m a-evalWriterTL = liftM fst . L.runWriterT+evalWriterTL = fmap fst . L.runWriterT evalWriterTS :: Monad m => S.WriterT [Int] m a -> m a-evalWriterTS = liftM fst . S.runWriterT+evalWriterTS = fmap fst . S.runWriterT  evalRWSTL :: Monad m => L.RWST () [Int] () m a -> m a evalRWSTL m = do@@ -134,25 +159,13 @@   return a  ------------------------------------------------------------------------------- Working with source position---- | A helper function that is used to advance 'SourcePos' given a 'String'.--updatePosString-  :: Pos               -- ^ Tab width-  -> SourcePos         -- ^ Initial position-  -> String            -- ^ 'String' — collection of tokens to process-  -> SourcePos         -- ^ Final position-updatePosString = advanceN (Proxy :: Proxy String)+-- Other  -- | Make a singleton non-empty list from a value.  nes :: a -> NonEmpty a nes x = x :| [] -------------------------------------------------------------------------------- Other- -- | @abcRow a b c@ generates string consisting of character “a” repeated -- @a@ times, character “b” repeated @b@ times, and character “c” repeated -- @c@ times.@@ -160,17 +173,6 @@ abcRow :: Int -> Int -> Int -> String abcRow a b c = replicate a 'a' ++ replicate b 'b' ++ replicate c 'c' --- | Given a comparing function, get prefix of one string till first--- mismatch with another string (including first mismatching character).--toFirstMismatch-  :: (Char -> Char -> Bool) -- ^ Comparing function-  -> String            -- ^ First string-  -> String            -- ^ Second string-  -> String            -- ^ Resulting prefix-toFirstMismatch f str s = take (n + 1) s-  where n = length (takeWhile (uncurry f) (zip str s))- -- | Check that the given parser returns the list in the right order.  rightOrder@@ -182,24 +184,83 @@   it "produces the list in the right order" $     prs_ p s `shouldParse` s' --- | The type of parser that consumes a 'String'.+-- | Get tab width from 'PosState'. Use with care only for testing. -type Parser = Parsec Void String+getTabWidth :: MonadParsec e s m => m Pos+getTabWidth = pstateTabWidth . statePosState <$> getParserState +-- | Set tab width in 'PosState'. Use with care only for testing.++setTabWidth :: MonadParsec e s m => Pos -> m ()+setTabWidth w = updateParserState $ \st ->+  let pst = statePosState st+  in st { statePosState = pst { pstateTabWidth = w } }++-- | Scale down.++scaleDown :: Gen a -> Gen a+scaleDown = scale (`div` 4)++-- | A helper function that is used to advance 'SourcePos' given a 'String'.++strSourcePos :: Pos -> SourcePos -> String -> SourcePos+strSourcePos tabWidth ipos input =+  let (x, _, _) = reachOffset maxBound pstate in x+  where+    pstate = PosState+      { pstateInput = input+      , pstateOffset = 0+      , pstateSourcePos = ipos+      , pstateTabWidth = tabWidth+      , pstateLinePrefix = ""+      }+ ----------------------------------------------------------------------------+-- Char and byte conversion++-- | Convert a byte to char.++toChar :: Word8 -> Char+toChar = chr . fromIntegral++-- | Covert a char to byte.++fromChar :: Char -> Maybe Word8+fromChar x = let p = ord x in+  if p > 0xff+    then Nothing+    else Just (fromIntegral p)++----------------------------------------------------------------------------+-- Proxies++sproxy :: Proxy String+sproxy = Proxy++bproxy :: Proxy B.ByteString+bproxy = Proxy++blproxy :: Proxy BL.ByteString+blproxy = Proxy++tproxy :: Proxy T.Text+tproxy = Proxy++tlproxy :: Proxy TL.Text+tlproxy = Proxy++---------------------------------------------------------------------------- -- Arbitrary instances  instance Arbitrary Void where   arbitrary = error "Arbitrary Void"  instance Arbitrary Pos where-  arbitrary = mkPos <$> (getSmall <$> arbitrary `suchThat` (> 0))+  arbitrary = mkPos <$> (getSmall . getPositive <$> arbitrary)  instance Arbitrary SourcePos where   arbitrary = SourcePos-    <$> sized (\n -> do-          k <- choose (0, n `div` 2)-          vectorOf k arbitrary)+    <$> scaleDown arbitrary     <*> arbitrary     <*> arbitrary @@ -211,28 +272,41 @@  instance Arbitrary (ErrorFancy a) where   arbitrary = oneof-    [ sized (\n -> do-        k <- choose (0, n `div` 2)-        ErrorFail <$> vectorOf k arbitrary)+    [ ErrorFail <$> scaleDown arbitrary     , ErrorIndentation <$> arbitrary <*> arbitrary <*> arbitrary ] -instance (Arbitrary t, Ord t, Arbitrary e, Ord e)-    => Arbitrary (ParseError t e) where+instance (Arbitrary (Token s), Ord (Token s), Arbitrary e, Ord e)+    => Arbitrary (ParseError s e) where   arbitrary = oneof     [ TrivialError-      <$> (NE.fromList . getNonEmpty <$> arbitrary)+      <$> (getNonNegative <$> arbitrary)       <*> arbitrary-      <*> (E.fromList <$> arbitrary)+      <*> (E.fromList <$> scaleDown arbitrary)     , FancyError-      <$> (NE.fromList . getNonEmpty <$> arbitrary)-      <*> (E.fromList <$> arbitrary) ]+      <$> (getNonNegative <$> arbitrary)+      <*> (E.fromList <$> scaleDown arbitrary) ] -instance Arbitrary a => Arbitrary (State a) where-  arbitrary = State+instance Arbitrary s => Arbitrary (State s) where+  arbitrary = do+    input  <- scaleDown arbitrary+    offset <- choose (1, 10000)+    pstate :: PosState s <- arbitrary+    return State+      { stateInput = input+      , stateOffset = offset+      , statePosState = pstate+        { pstateInput = input+        , pstateOffset = offset+        }+      }++instance Arbitrary s => Arbitrary (PosState s) where+  arbitrary = PosState     <$> arbitrary-    <*> (NE.fromList . getNonEmpty <$> arbitrary)     <*> choose (1, 10000)+    <*> arbitrary     <*> (mkPos <$> choose (1, 20))+    <*> scaleDown arbitrary  instance Arbitrary T.Text where   arbitrary = T.pack <$> arbitrary

@@ -4,12 +4,12 @@  import Control.Applicative import Data.ByteString (ByteString)-import Data.Char (toUpper)+import Data.Char (intToDigit, toUpper) import Data.Monoid ((<>)) import Data.Scientific (Scientific, fromFloatDigits) import Data.Void import Data.Word (Word8)-import Numeric (showInt, showHex, showOct, showFFloatAlt)+import Numeric (showInt, showIntAtBase, showHex, showOct, showFFloatAlt) import Test.Hspec import Test.Hspec.Megaparsec import Test.QuickCheck@@ -34,7 +34,7 @@     it "inner characters are labelled properly" $ do       let p = skipLineComment "//" <* empty           s = "// here we go"-      prs  p s `shouldFailWith` err (posN (B.length s) s) (elabel "character")+      prs  p s `shouldFailWith` err (B.length s) (elabel "character")       prs' p s `failsLeaving` ""    describe "skipBlockComment" $@@ -67,12 +67,33 @@         property $ \a as -> not (isDigit a) ==> do           let p = decimal :: Parser Integer               s = B.pack (a : as)-          prs  p s `shouldFailWith` err posI (utok a <> elabel "integer")+          prs  p s `shouldFailWith` err 0 (utok a <> elabel "integer")     context "when stream is empty" $       it "signals correct parse error" $         prs (decimal :: Parser Integer) "" `shouldFailWith`-          err posI (ueof <> elabel "integer")+          err 0 (ueof <> elabel "integer") +  describe "binary" $ do+    context "when stream begins with binary digits" $+      it "they are parsed as an integer" $+        property $ \n' -> do+          let p = binary :: Parser Integer+              n = getNonNegative n'+              s = B8.pack (showIntAtBase 2 intToDigit n "")+          prs  p s `shouldParse` n+          prs' p s `succeedsLeaving` ""+    context "when stream does not begin with binary digits" $+      it "signals correct parse error" $+        property $ \a as -> a /= 48 && a /= 49 ==> do+          let p = binary :: Parser Integer+              s = B.pack (a : as)+          prs  p s `shouldFailWith`+            err 0 (utok a <> elabel "binary integer")+    context "when stream is empty" $+      it "signals correct parse error" $+        prs (binary :: Parser Integer) "" `shouldFailWith`+          err 0 (ueof <> elabel "binary integer")+   describe "octal" $ do     context "when stream begins with octal digits" $       it "they are parsed as an integer" $@@ -88,11 +109,11 @@           let p = octal :: Parser Integer               s = B.pack (a : as)           prs  p s `shouldFailWith`-            err posI (utok a <> elabel "octal integer")+            err 0 (utok a <> elabel "octal integer")     context "when stream is empty" $       it "signals correct parse error" $         prs (octal :: Parser Integer) "" `shouldFailWith`-          err posI (ueof <> elabel "octal integer")+          err 0 (ueof <> elabel "octal integer")    describe "hexadecimal" $ do     context "when stream begins with hexadecimal digits" $@@ -117,11 +138,11 @@           let p = hexadecimal :: Parser Integer               s = B.pack (a : as)           prs  p s `shouldFailWith`-            err posI (utok a <> elabel "hexadecimal integer")+            err 0 (utok a <> elabel "hexadecimal integer")     context "when stream is empty" $       it "signals correct parse error" $         prs (hexadecimal :: Parser Integer) "" `shouldFailWith`-          err posI (ueof <> elabel "hexadecimal integer")+          err 0 (ueof <> elabel "hexadecimal integer")    describe "scientific" $ do     context "when stream begins with a number" $@@ -139,7 +160,7 @@         property $ \(NonNegative n) -> do           let p = scientific <* empty :: Parser Scientific               s = B8.pack (showFFloatAlt Nothing (n :: Double) "")-          prs p s `shouldFailWith` err (posN (B.length s) s)+          prs p s `shouldFailWith` err (B.length s)             (etok 69 <> etok 101 <> elabel "digit")           prs' p s `failsLeaving` ""     context "when whole part is followed by a dot without valid fractional part" $@@ -159,7 +180,7 @@     context "when stream is empty" $       it "signals correct parse error" $         prs (scientific :: Parser Scientific) "" `shouldFailWith`-          err posI (ueof <> elabel "digit")+          err 0 (ueof <> elabel "digit")    describe "float" $ do     context "when stream begins with a float" $@@ -176,7 +197,7 @@           let p = float :: Parser Double               s = B.pack (a : as)           prs  p s `shouldFailWith`-            err posI (utok a <> elabel "digit")+            err 0 (utok a <> elabel "digit")           prs' p s `failsLeaving` s     context "when stream begins with an integer (decimal)" $       it "signals correct parse error" $@@ -184,7 +205,7 @@           let p = float :: Parser Double               n = getNonNegative n'               s = B8.pack $ show (n :: Integer)-          prs  p s `shouldFailWith` err (posN (B.length s) s)+          prs  p s `shouldFailWith` err (B.length s)             (ueof <> etok 46 <> etok 69 <> etok 101 <> elabel "digit")           prs' p s `failsLeaving` ""     context "when number is followed by something starting with 'e'" $@@ -197,7 +218,7 @@     context "when stream is empty" $       it "signals correct parse error" $         prs (float :: Parser Double) "" `shouldFailWith`-          err posI (ueof <> elabel "digit")+          err 0 (ueof <> elabel "digit")     context "when there is float with just exponent" $       it "parses it all right" $ do         let p = float :: Parser Double@@ -248,7 +269,7 @@           let p :: Parser Integer               p = signed (hidden B.space) decimal               s = B8.pack (' ' : show (n :: Integer))-          prs  p s `shouldFailWith` err posI+          prs  p s `shouldFailWith` err 0             (utok 32 <> etok 43 <> etok 45 <> elabel "integer")           prs' p s `failsLeaving` s     context "when there is white space between sign and digits" $@@ -263,15 +284,21 @@ -- Helpers  prs-  :: Parser a          -- ^ Parser to run-  -> ByteString        -- ^ Input for the parser-  -> Either (ParseError Word8 Void) a -- ^ Result of parsing+  :: Parser a+     -- ^ Parser to run+  -> ByteString+     -- ^ Input for the parser+  -> Either (ParseErrorBundle ByteString Void) a+     -- ^ Result of parsing prs p = parse p ""  prs'-  :: Parser a          -- ^ Parser to run-  -> ByteString        -- ^ Input for the parser-  -> (State ByteString, Either (ParseError Word8 Void) a) -- ^ Result of parsing+  :: Parser a+     -- ^ Parser to run+  -> ByteString+     -- ^ Input for the parser+  -> (State ByteString, Either (ParseErrorBundle ByteString Void) a)+     -- ^ Result of parsing prs' p s = runParser' p (initialState s)  isDigit :: Word8 -> Bool

@@ -1,4 +1,3 @@-{-# LANGUAGE CPP               #-} {-# LANGUAGE OverloadedStrings #-}  module Text.Megaparsec.ByteSpec (spec) where@@ -7,22 +6,17 @@ import Data.ByteString (ByteString) import Data.Char import Data.Maybe (fromMaybe)-import Data.Proxy import Data.Semigroup ((<>)) import Data.Void import Data.Word (Word8) import Test.Hspec import Test.Hspec.Megaparsec-import Test.Hspec.Megaparsec.AdHoc (nes)+import Test.Hspec.Megaparsec.AdHoc hiding (prs, prs', Parser) import Test.QuickCheck import Text.Megaparsec import Text.Megaparsec.Byte import qualified Data.ByteString as B -#if !MIN_VERSION_base(4,8,0)-import Control.Applicative-#endif- type Parser = Parsec Void ByteString  spec :: Spec@@ -52,20 +46,20 @@         property $ \ch -> ch /= 10 ==> do           let s = "\r" <> B.singleton ch           prs eol s `shouldFailWith`-            err posI (utoks (B.unpack s) <> elabel "end of line")+            err 0 (utoks s <> elabel "end of line")     context "when input stream is '\\r'" $       it "signals correct parse error" $-        prs eol "\r" `shouldFailWith` err posI+        prs eol "\r" `shouldFailWith` err 0           (utok 13 <> elabel "end of line")     context "when stream does not begin with newline or CRLF sequence" $       it "signals correct parse error" $         property $ \ch s -> (ch /= 13 && ch /= 10) ==> do           let s' = B.singleton ch <> s-          prs eol s' `shouldFailWith` err posI-            (utoks (B.unpack $ B.take 2 s') <> elabel "end of line")+          prs eol s' `shouldFailWith` err 0+            (utoks (B.take 2 s') <> elabel "end of line")     context "when stream is empty" $       it "signals correct parse error" $-        prs eol "" `shouldFailWith` err posI+        prs eol "" `shouldFailWith` err 0           (ueof <> elabel "end of line")    describe "tab" $@@ -85,7 +79,7 @@         property $ \ch s' -> not (isSpace' ch) ==> do           let (s0,s1) = B.partition isSpace' s'               s = B.singleton ch <> s0 <> s1-          prs  space1 s `shouldFailWith` err posI (utok ch <> elabel "white space")+          prs  space1 s `shouldFailWith` err 0 (utok ch <> elabel "white space")           prs' space1 s `failsLeaving` s     context "when stream starts with a space character" $       it "consumes space up to first non-space character" $@@ -96,7 +90,7 @@           prs' space1 s `succeedsLeaving` s1     context "when stream is empty" $       it "signals correct parse error" $-        prs space1 "" `shouldFailWith` err posI (ueof <> elabel "white space")+        prs space1 "" `shouldFailWith` err 0 (ueof <> elabel "white space")    describe "controlChar" $     checkCharPred "control character" (isControl . toChar) controlChar@@ -104,15 +98,6 @@   describe "spaceChar" $     checkCharRange "white space" [9,10,11,12,13,32,160] spaceChar -  -- describe "upperChar" $-  --   checkCharPred "uppercase letter" (isUpper . toChar) upperChar--  -- describe "lowerChar" $-  --   checkCharPred "lowercase letter" (isLower . toChar) lowerChar--  -- describe "letterChar" $-  --   checkCharPred "letter" (isAlpha . toChar) letterChar-   describe "alphaNumChar" $     checkCharPred "alphanumeric character" (isAlphaNum . toChar) alphaNumChar @@ -122,37 +107,40 @@   describe "digitChar" $     checkCharRange "digit" [48..57] digitChar +  describe "binDigitChar" $+    checkCharRange "binary digit" [48..49] binDigitChar+   describe "octDigitChar" $     checkCharRange "octal digit" [48..55] octDigitChar    describe "hexDigitChar" $     checkCharRange "hexadecimal digit" ([48..57] ++ [97..102] ++ [65..70]) hexDigitChar -  -- describe "asciiChar" $-  --   checkCharPred "ASCII character" (isAscii . toChar) asciiChar-   describe "char'" $ do     context "when stream begins with the character specified as argument" $       it "parses the character" $         property $ \ch s -> do           let sl = B.cons (liftChar toLower ch) s               su = B.cons (liftChar toUpper ch) s+              st = B.cons (liftChar toTitle ch) s           prs  (char' ch) sl `shouldParse`     liftChar toLower ch           prs  (char' ch) su `shouldParse`     liftChar toUpper ch+          prs  (char' ch) st `shouldParse`     liftChar toTitle ch           prs' (char' ch) sl `succeedsLeaving` s           prs' (char' ch) su `succeedsLeaving` s+          prs' (char' ch) st `succeedsLeaving` s     context "when stream does not begin with the character specified as argument" $       it "signals correct parse error" $-        property $ \ch ch' s -> liftChar toLower ch /= liftChar toLower ch' ==> do+        property $ \ch ch' s -> not (casei ch ch') ==> do           let s' = B.cons ch' s               ms = utok ch' <> etok (liftChar toLower ch) <> etok (liftChar toUpper ch)-          prs  (char' ch) s' `shouldFailWith` err posI ms+          prs  (char' ch) s' `shouldFailWith` err 0 ms           prs' (char' ch) s' `failsLeaving`   s'     context "when stream is empty" $       it "signals correct parse error" $         property $ \ch -> do           let ms = ueof <> etok (liftChar toLower ch) <> etok (liftChar toUpper ch)-          prs  (char' ch) "" `shouldFailWith` err posI ms+          prs  (char' ch) "" `shouldFailWith` err 0 ms  ---------------------------------------------------------------------------- -- Helpers@@ -169,13 +157,12 @@     it "signals correct parse error" $       property $ \ch s -> ch /= B.head ts ==> do        let s' = B.cons ch s-           us = B.unpack $ B.take (B.length ts) s'-           ps = B.unpack ts-       prs  p s' `shouldFailWith` err posI (utoks us <> etoks ps)+           us = B.take (B.length ts) s'+       prs  p s' `shouldFailWith` err 0 (utoks us <> etoks ts)        prs' p s' `failsLeaving`   s'   context "when stream is empty" $     it "signals correct parse error" $-      prs p "" `shouldFailWith` err posI (ueof <> etoks (B.unpack ts))+      prs p "" `shouldFailWith` err 0 (ueof <> etoks ts)  checkCharPred :: String -> (Word8 -> Bool) -> Parser Word8 -> SpecWith () checkCharPred name f p = do@@ -189,40 +176,43 @@     it "signals correct parse error" $       property $ \ch s -> not (f ch) ==> do        let s' = B.singleton ch <> s-       prs  p s' `shouldFailWith` err posI (utok ch <> elabel name)+       prs  p s' `shouldFailWith` err 0 (utok ch <> elabel name)        prs' p s' `failsLeaving`   s'   context "when stream is empty" $     it "signals correct parse error" $-      prs p "" `shouldFailWith` err posI (ueof <> elabel name)+      prs p "" `shouldFailWith` err 0 (ueof <> elabel name)  checkCharRange :: String -> [Word8] -> Parser Word8 -> SpecWith () checkCharRange name tchs p = do   forM_ tchs $ \tch ->-    context ("when stream begins with " ++ showTokens (nes tch)) $-      it ("parses the " ++ showTokens (nes tch)) $+    context ("when stream begins with " ++ showTokens bproxy (nes tch)) $+      it ("parses the " ++ showTokens bproxy (nes tch)) $         property $ \s -> do           let s' = B.singleton tch <> s           prs  p s' `shouldParse`     tch           prs' p s' `succeedsLeaving` s   context "when stream is empty" $     it "signals correct parse error" $-      prs p "" `shouldFailWith` err posI (ueof <> elabel name)+      prs p "" `shouldFailWith` err 0 (ueof <> elabel name)  prs-  :: Parser a          -- ^ Parser to run-  -> ByteString        -- ^ Input for the parser-  -> Either (ParseError Word8 Void) a -- ^ Result of parsing+  :: Parser a+     -- ^ Parser to run+  -> ByteString+     -- ^ Input for the parser+  -> Either (ParseErrorBundle ByteString Void) a+     -- ^ Result of parsing prs p = parse p ""  prs'-  :: Parser a          -- ^ Parser to run-  -> ByteString        -- ^ Input for the parser-  -> (State ByteString, Either (ParseError Word8 Void) a) -- ^ Result of parsing+  :: Parser a+     -- ^ Parser to run+  -> ByteString+     -- ^ Input for the parser+  -> (State ByteString, Either (ParseErrorBundle ByteString Void) a)+     -- ^ Result of parsing prs' p s = runParser' p (initialState s) -bproxy :: Proxy ByteString-bproxy = Proxy- -- | 'Word8'-specialized version of 'isSpace'.  isSpace' :: Word8 -> Bool@@ -232,20 +222,15 @@   | x == 160          = True   | otherwise         = False --- | Convert a byte to char.--toChar :: Word8 -> Char-toChar = chr . fromIntegral---- | Covert a char to byte.--fromChar :: Char -> Maybe Word8-fromChar x = let p = ord x in-  if p > 0xff-    then Nothing-    else Just (fromIntegral p)- -- | Lift char transformation to byte transformation.  liftChar :: (Char -> Char) -> Word8 -> Word8 liftChar f x = (fromMaybe x . fromChar . f . toChar) x++-- | Compare two characters case-insensitively.++casei :: Word8 -> Word8 -> Bool+casei x y =+  x == liftChar toLower y ||+  x == liftChar toUpper y ||+  x == liftChar toTitle y

@@ -13,19 +13,16 @@ import Data.Monoid ((<>)) import Data.Scientific (Scientific, fromFloatDigits) import Data.Void (Void)-import Numeric (showInt, showHex, showOct, showFFloatAlt)+import Numeric (showInt, showIntAtBase, showHex, showOct, showFFloatAlt) import Test.Hspec import Test.Hspec.Megaparsec import Test.Hspec.Megaparsec.AdHoc import Test.QuickCheck import Text.Megaparsec import Text.Megaparsec.Char.Lexer+import qualified Data.CaseInsensitive as CI import qualified Text.Megaparsec.Char as C -#if !MIN_VERSION_base(4,8,0)-import Control.Applicative hiding (many, some)-#endif- spec :: Spec spec = do @@ -51,11 +48,8 @@           let p = symbol' scn y'               y' = toUpper <$> y               y = takeWhile (not . isSpace) s-          -- NOTE In some rare cases it's possible that y' will have a-          -- different length than y due to the craziness of Unicode. We-          -- cannot deal with those cases due to how the tokens primitive is-          -- implemented. This is a “feature”, not a bug.-          when (length y' /= length y) discard+          -- Rare tricky cases we don't want to deal with.+          when (CI.mk y' /= CI.mk y) discard           prs  p s `shouldParse` y           prs' p s `succeedsLeaving` "" @@ -69,7 +63,7 @@     it "inner characters are labelled properly" $ do       let p = skipLineComment "//" <* empty           s = "// here we go"-      prs  p s `shouldFailWith` err (posN (length s) s) (elabel "character")+      prs  p s `shouldFailWith` err (length s) (elabel "character")       prs' p s `failsLeaving` ""    describe "skipBlockComment" $@@ -90,16 +84,21 @@    describe "indentLevel" $     it "returns current indentation level (column)" $-      property $ \pos -> do-        let p = setPosition pos *> indentLevel-        prs p "" `shouldParse` sourceColumn pos+      property $ \s w o -> do+        let p = do+              setTabWidth w+              setOffset o+              indentLevel+            c = sourceColumn (strSourcePos w (initialPos "") (take o s))+        prs p s `shouldParse` c+        prs' p s `succeedsLeaving` s    describe "incorrectIndent" $     it "signals correct parse error" $       property $ \ord ref actual -> do         let p :: Parser ()             p = incorrectIndent ord ref actual-        prs p "" `shouldFailWith` errFancy posI (ii ord ref actual)+        prs p "" `shouldFailWith` errFancy 0 (ii ord ref actual)    describe "indentGuard" $     it "works as intended" $@@ -115,11 +114,11 @@               ip = indentGuard scn               sp = void (symbol sc sbla <* C.eol)           if | col0 <= pos1 ->-               prs p s `shouldFailWith` errFancy posI (ii GT pos1 col0)+               prs p s `shouldFailWith` errFancy 0 (ii GT pos1 col0)              | col1 /= col0 ->-               prs p s `shouldFailWith` errFancy (posN (getIndent l1 + g 1) s) (ii EQ col0 col1)+               prs p s `shouldFailWith` errFancy (getIndent l1 + g 1) (ii EQ col0 col1)              | col2 <= col0 ->-               prs p s `shouldFailWith` errFancy (posN (getIndent l2 + g 2) s) (ii GT col0 col2)+               prs p s `shouldFailWith` errFancy (getIndent l2 + g 2) (ii GT col0 col2)              | otherwise    ->                prs p s `shouldParse` () @@ -130,7 +129,7 @@             i = getIndent s         if i == 0           then prs p s `shouldParse` sbla-          else prs p s `shouldFailWith` errFancy (posN i s) (ii EQ pos1 (getCol s))+          else prs p s `shouldFailWith` errFancy i (ii EQ pos1 (getCol s))    describe "indentBlock" $ do     it "works as indented" $@@ -159,21 +158,21 @@               l x  = return . (x,)               ib'  = mkPos (fromIntegral ib)           if | col1 <= col0 -> prs p s `shouldFailWith`-               err (posN (getIndent l1 + g 1) s) (utok (head sblb) <> eeof)+               err (getIndent l1 + g 1) (utok (head sblb) <> eeof)              | isJust mn && col1 /= ib' -> prs p s `shouldFailWith`-               errFancy (posN (getIndent l1 + g 1) s) (ii EQ ib' col1)+               errFancy (getIndent l1 + g 1) (ii EQ ib' col1)              | col2 <= col1 -> prs p s `shouldFailWith`-               errFancy (posN (getIndent l2 + g 2) s) (ii GT col1 col2)+               errFancy (getIndent l2 + g 2) (ii GT col1 col2)              | col3 == col2 -> prs p s `shouldFailWith`-               err (posN (getIndent l3 + g 3) s) (utoks sblb <> etoks sblc <> eeof)+               err (getIndent l3 + g 3) (utoks sblb <> etoks sblc <> eeof)              | col3 <= col0 -> prs p s `shouldFailWith`-               err (posN (getIndent l3 + g 3) s) (utok (head sblb) <> eeof)+               err (getIndent l3 + g 3) (utok (head sblb) <> eeof)              | col3 < col1 -> prs p s `shouldFailWith`-               errFancy (posN (getIndent l3 + g 3) s) (ii EQ col1 col3)+               errFancy (getIndent l3 + g 3) (ii EQ col1 col3)              | col3 > col1 -> prs p s `shouldFailWith`-               errFancy (posN (getIndent l3 + g 3) s) (ii EQ col2 col3)+               errFancy (getIndent l3 + g 3) (ii EQ col2 col3)              | col4 <= col3 -> prs p s `shouldFailWith`-               errFancy (posN (getIndent l4 + g 4) s) (ii GT col3 col4)+               errFancy (getIndent l4 + g 4) (ii GT col3 col4)              | otherwise -> prs p s `shouldParse`                (sbla, [(sblb, [sblc]), (sblb, [sblc])])     it "IndentMany works as intended (newline at the end)" $@@ -220,7 +219,7 @@             IndentSome (Just (mkPos 5)) (l sbla) lvlb <$ symbol sc sbla           lvlb = symbol sc sblb           l x = return . (x,)-      prs p s `shouldFailWith` errFancy (posN 6 s)+      prs p s `shouldFailWith` errFancy 6         (fancy $ ErrorIndentation EQ (mkPos 5) (mkPos 3))    describe "lineFold" $@@ -244,29 +243,35 @@               (col0, col1, col2) = (getCol l0, getCol l1, getCol l2)               (end0, end1)       = (getEnd l0, getEnd l1)           if | end0 && col1 <= col0 -> prs p s `shouldFailWith`-               errFancy (posN (getIndent l1 + g 1) s) (ii GT col0 col1)+               errFancy (getIndent l1 + g 1) (ii GT col0 col1)              | end1 && col2 <= col0 -> prs p s `shouldFailWith`-               errFancy (posN (getIndent l2 + g 2) s) (ii GT col0 col2)+               errFancy (getIndent l2 + g 2) (ii GT col0 col2)              | otherwise -> prs p s `shouldParse` (sbla, sblb, sblc)    describe "charLiteral" $ do+    let p = charLiteral     context "when stream begins with a literal character" $       it "parses it" $         property $ \ch -> do-          let p = charLiteral-              s = showLitChar ch ""+          let s = showLitChar ch ""           prs  p s `shouldParse` ch           prs' p s `succeedsLeaving` ""     context "when stream does not begin with a literal character" $       it "signals correct parse error" $ do-        let p = charLiteral-            s = "\\"-        prs  p s `shouldFailWith` err posI (utok '\\' <> elabel "literal character")+        let s = "\\"+        prs  p s `shouldFailWith` err 0 (utok '\\' <> elabel "literal character")         prs' p s `failsLeaving` s     context "when stream is empty" $-      it "signals correct parse error" $ do-        let p = charLiteral-        prs p "" `shouldFailWith` err posI (ueof <> elabel "literal character")+      it "signals correct parse error" $+        prs p "" `shouldFailWith` err 0 (ueof <> elabel "literal character")+#if MIN_VERSION_base(4,9,0)+    context "when given a long escape sequence" $+      it "parses it correctly" $+        property $ \s' -> do+          let s = "\\1114111\\&" ++ s'+          prs p s `shouldParse` '\1114111'+          prs' p s `succeedsLeaving` s'+#endif    describe "decimal" $ do     context "when stream begins with decimal digits" $@@ -282,12 +287,33 @@         property $ \a as -> not (isDigit a) ==> do           let p = decimal :: Parser Integer               s = a : as-          prs  p s `shouldFailWith` err posI (utok a <> elabel "integer")+          prs  p s `shouldFailWith` err 0 (utok a <> elabel "integer")     context "when stream is empty" $       it "signals correct parse error" $         prs (decimal :: Parser Integer) "" `shouldFailWith`-          err posI (ueof <> elabel "integer")+          err 0 (ueof <> elabel "integer") +  describe "binary" $ do+    context "when stream begins with binary digits" $+      it "they are parsed as an integer" $+        property $ \n' -> do+          let p = binary :: Parser Integer+              n = getNonNegative n'+              s = showIntAtBase 2 intToDigit n ""+          prs  p s `shouldParse` n+          prs' p s `succeedsLeaving` ""+    context "when stream does not begin with binary digits" $+      it "signals correct parse error" $+        property $ \a as -> a /= '0' && a /= '1' ==> do+          let p = binary :: Parser Integer+              s = a : as+          prs  p s `shouldFailWith`+            err 0 (utok a <> elabel "binary integer")+    context "when stream is empty" $+      it "signals correct parse error" $+        prs (binary :: Parser Integer) "" `shouldFailWith`+          err 0 (ueof <> elabel "binary integer")+   describe "octal" $ do     context "when stream begins with octal digits" $       it "they are parsed as an integer" $@@ -303,11 +329,11 @@           let p = octal :: Parser Integer               s = a : as           prs  p s `shouldFailWith`-            err posI (utok a <> elabel "octal integer")+            err 0 (utok a <> elabel "octal integer")     context "when stream is empty" $       it "signals correct parse error" $         prs (octal :: Parser Integer) "" `shouldFailWith`-          err posI (ueof <> elabel "octal integer")+          err 0 (ueof <> elabel "octal integer")    describe "hexadecimal" $ do     context "when stream begins with hexadecimal digits" $@@ -324,11 +350,11 @@           let p = hexadecimal :: Parser Integer               s = a : as           prs  p s `shouldFailWith`-            err posI (utok a <> elabel "hexadecimal integer")+            err 0 (utok a <> elabel "hexadecimal integer")     context "when stream is empty" $       it "signals correct parse error" $         prs (hexadecimal :: Parser Integer) "" `shouldFailWith`-          err posI (ueof <> elabel "hexadecimal integer")+          err 0 (ueof <> elabel "hexadecimal integer")    describe "scientific" $ do     context "when stream begins with a number" $@@ -346,7 +372,7 @@         property $ \(NonNegative n) -> do           let p = scientific <* empty :: Parser Scientific               s = showFFloatAlt Nothing (n :: Double) ""-          prs p s `shouldFailWith` err (posN (length s) s)+          prs p s `shouldFailWith` err (length s)             (etok 'E' <> etok 'e' <> elabel "digit")           prs' p s `failsLeaving` ""     context "when whole part is followed by a dot without valid fractional part" $@@ -366,7 +392,7 @@     context "when stream is empty" $       it "signals correct parse error" $         prs (scientific :: Parser Scientific) "" `shouldFailWith`-          err posI (ueof <> elabel "digit")+          err 0 (ueof <> elabel "digit")    describe "float" $ do     context "when stream begins with a float" $@@ -383,7 +409,7 @@           let p = float :: Parser Double               s = a : as           prs  p s `shouldFailWith`-            err posI (utok a <> elabel "digit")+            err 0 (utok a <> elabel "digit")           prs' p s `failsLeaving` s     context "when stream begins with an integer (decimal)" $       it "signals correct parse error" $@@ -391,7 +417,7 @@           let p = float :: Parser Double               n = getNonNegative n'               s = show (n :: Integer)-          prs  p s `shouldFailWith` err (posN (length s) s)+          prs  p s `shouldFailWith` err (length s)             (ueof <> etok '.' <> etok 'E' <> etok 'e' <> elabel "digit")           prs' p s `failsLeaving` ""     context "when number is followed by something starting with 'e'" $@@ -404,7 +430,7 @@     context "when stream is empty" $       it "signals correct parse error" $         prs (float :: Parser Double) "" `shouldFailWith`-          err posI (ueof <> elabel "digit")+          err 0 (ueof <> elabel "digit")     context "when there is float with just exponent" $       it "parses it all right" $ do         let p = float :: Parser Double@@ -455,7 +481,7 @@           let p :: Parser Integer               p = signed (hidden C.space) decimal               s = ' ' : show (n :: Integer)-          prs  p s `shouldFailWith` err posI+          prs  p s `shouldFailWith` err 0             (utok ' ' <> etok '+' <> etok '-' <> elabel "integer")           prs' p s `failsLeaving` s     context "when there is white space between sign and digits" $@@ -488,18 +514,18 @@ mkIndent :: String -> Int -> Gen String mkIndent x n = (++) <$> mkIndent' x n <*> eol   where-    eol = frequency [(5, return "\n"), (1, listOf1 (return '\n'))]+    eol = frequency [(5, return "\n"), (1, (scaleDown . listOf1 . return) '\n')]  mkIndent' :: String -> Int -> Gen String mkIndent' x n = concat <$> sequence [spc, sym, tra]   where-    spc = frequency [(5, vectorOf n itm), (1, listOf itm)]-    tra = listOf itm+    spc = frequency [(5, vectorOf n itm), (1, scaleDown (listOf itm))]+    tra = scaleDown (listOf itm)     itm = elements " \t"     sym = return x  whiteChars :: Gen String-whiteChars = listOf (elements "\t\n ")+whiteChars = scaleDown $ listOf (elements "\t\n ")  whiteLine :: Gen String whiteLine = commentOut <$> arbitrary `suchThat` goodEnough@@ -532,7 +558,7 @@  getCol :: String -> Pos getCol x = sourceColumn .-  updatePosString defaultTabWidth (initialPos "") $ take (getIndent x) x+  strSourcePos defaultTabWidth (initialPos "") $ takeWhile isSpace x  sbla, sblb, sblc :: String sbla = "aaa"

@@ -13,10 +13,7 @@ import Test.QuickCheck import Text.Megaparsec import Text.Megaparsec.Char--#if !MIN_VERSION_base(4,8,0)-import Control.Applicative-#endif+import qualified Data.CaseInsensitive as CI  instance Arbitrary GeneralCategory where   arbitrary = elements [minBound..maxBound]@@ -47,20 +44,20 @@       it "signals correct parse error" $         property $ \ch -> ch /= '\n' ==> do           let s = ['\r',ch]-          prs eol s `shouldFailWith` err posI (utoks s <> elabel "end of line")+          prs eol s `shouldFailWith` err 0 (utoks s <> elabel "end of line")     context "when input stream is '\\r'" $       it "signals correct parse error" $-        prs eol "\r" `shouldFailWith` err posI+        prs eol "\r" `shouldFailWith` err 0           (utok '\r' <> elabel "end of line")     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-          prs eol s' `shouldFailWith` err posI+          prs eol s' `shouldFailWith` err 0             (utoks (take 2 s') <> elabel "end of line")     context "when stream is empty" $       it "signals correct parse error" $-        prs eol "" `shouldFailWith` err posI+        prs eol "" `shouldFailWith` err 0           (ueof <> elabel "end of line")    describe "tab" $@@ -80,7 +77,7 @@         property $ \ch s' -> not (isSpace ch) ==> do           let (s0,s1) = partition isSpace s'               s = ch : s0 ++ s1-          prs  space1 s `shouldFailWith` err posI (utok ch <> elabel "white space")+          prs  space1 s `shouldFailWith` err 0 (utok ch <> elabel "white space")           prs' space1 s `failsLeaving` s     context "when stream starts with a space character" $       it "consumes space up to first non-space character" $@@ -91,7 +88,7 @@           prs' space1 s `succeedsLeaving` s1     context "when stream is empty" $       it "signals correct parse error" $-        prs space1 "" `shouldFailWith` err posI (ueof <> elabel "white space")+        prs space1 "" `shouldFailWith` err 0 (ueof <> elabel "white space")    describe "controlChar" $     checkCharPred "control character" isControl controlChar@@ -117,6 +114,9 @@   describe "digitChar" $     checkCharRange "digit" ['0'..'9'] digitChar +  describe "binDigitChar" $+    checkCharRange "binary digit" ['0'..'1'] binDigitChar+   describe "octDigitChar" $     checkCharRange "octal digit" ['0'..'7'] octDigitChar @@ -138,11 +138,7 @@     checkCharPred "punctuation" isPunctuation punctuationChar    describe "symbolChar" $-#if MIN_VERSION_base(4,8,0)     checkCharRange "symbol" "<>$£`~|×÷^®°¸¯=¬+¤±¢¨´©¥¦" symbolChar-#else-    checkCharRange "symbol" "<>$£`~|×÷^®°¸¯=¬+¤±¢¨´©¥¦§¶" symbolChar-#endif   describe "separatorChar" $     checkCharRange "separator" " \160" separatorChar @@ -159,11 +155,11 @@     context "when stream does not begin with Latin-1 character" $       it "signals correct parse error" $ do         prs  latin1Char "б" `shouldFailWith`-          err posI (utok 'б' <> elabel "Latin-1 character")+          err 0 (utok 'б' <> elabel "Latin-1 character")         prs' latin1Char "в" `failsLeaving`   "в"     context "when stream is empty" $       it "signals correct parse error" $-        prs latin1Char "" `shouldFailWith` err posI (ueof <> elabel "Latin-1 character")+        prs latin1Char "" `shouldFailWith` err 0 (ueof <> elabel "Latin-1 character")    describe "charCategory" $ do     context "when parser corresponding to general category of next char is used" $@@ -178,13 +174,13 @@         property $ \g ch s -> (generalCategory ch /= g) ==> do           let s' = ch : s           prs  (charCategory g) s' `shouldFailWith`-            err posI (utok ch <> elabel (categoryName g))+            err 0 (utok ch <> elabel (categoryName g))           prs' (charCategory g) s' `failsLeaving` s'     context "when stream is empty" $       it "signals correct parse error" $         property $ \g ->           prs (charCategory g) "" `shouldFailWith`-            err posI (ueof <> elabel (categoryName g))+            err 0 (ueof <> elabel (categoryName g))    describe "char" $ do     context "when stream begins with the character specified as argument" $@@ -197,106 +193,51 @@       it "signals correct parse error" $         property $ \ch ch' s -> ch /= ch' ==> do           let s' = ch' : s-          prs  (char ch) s' `shouldFailWith` err posI (utok ch' <> etok ch)+          prs  (char ch) s' `shouldFailWith` err 0 (utok ch' <> etok ch)           prs' (char ch) s' `failsLeaving`   s'     context "when stream is empty" $       it "signals correct parse error" $         property $ \ch ->-          prs  (char ch) "" `shouldFailWith` err posI (ueof <> etok ch)+          prs  (char ch) "" `shouldFailWith` err 0 (ueof <> etok ch)    describe "char'" $ do-    let goodChar x =-          (toUpper x == toLower x) || (isUpper x || isLower x)-    context "when stream begins with the character specified as argument" $+    context "when stream begins with the character specified as argument" $ do       it "parses the character" $-        property $ \ch s -> goodChar ch ==> do+        property $ \ch s -> do           let sl = toLower ch : s               su = toUpper ch : s+              st = toTitle ch : s           prs  (char' ch) sl `shouldParse`     toLower ch           prs  (char' ch) su `shouldParse`     toUpper ch+          prs  (char' ch) st `shouldParse`     toTitle ch           prs' (char' ch) sl `succeedsLeaving` s           prs' (char' ch) su `succeedsLeaving` s-    context "when stream does not begin with the character specified as argument" $+      context "when the character is not upper or lower" $+        -- See https://ghc.haskell.org/trac/ghc/ticket/14589+        it "matches it against a form obtained via one of the conversion functions" $+          property $ \s -> do+            let ch = '\9438'+                s' = '\9412' : s+            prs (char' ch) s' `shouldParse` '\9412'+            prs' (char' ch) s' `succeedsLeaving` s+    context "when stream does not begin with the character specified as argument" $ do       it "signals correct parse error" $-        property $ \ch ch' s -> goodChar ch && toLower ch /= toLower ch' ==> do+        property $ \ch ch' s -> not (casei ch ch') ==> do           let s' = ch' : s-              ms = utok ch' <> etok (toLower ch) <> etok (toUpper ch)-          prs  (char' ch) s' `shouldFailWith` err posI ms+              ms = utok ch' <> etok (toLower ch) <> etok (toUpper ch) <> etok (toTitle ch)+          prs  (char' ch) s' `shouldFailWith` err 0 ms           prs' (char' ch) s' `failsLeaving`   s'+      context "when the character is not upper or lower" $+        it "lists correct options in the error message" $+          property $ \ch s -> not (casei '\9438' ch) ==> do+            let ms = utok ch <> etok '\9438' <> etok '\9412'+                s' = ch : s+            prs (char' '\9438') s' `shouldFailWith` err 0 ms     context "when stream is empty" $       it "signals correct parse error" $-        property $ \ch -> goodChar ch ==> do+        property $ \ch -> do           let ms = ueof <> etok (toLower ch) <> etok (toUpper ch)-          prs  (char' ch) "" `shouldFailWith` err posI ms--  describe "anyChar" $ do-    context "when stream is not empty" $-      it "succeeds consuming next character in the stream" $-        property $ \ch s -> do-          let s' = ch : s-          prs  anyChar s' `shouldParse`     ch-          prs' anyChar s' `succeedsLeaving` s-    context "when stream is empty" $-      it "signals correct parse error" $-        prs anyChar "" `shouldFailWith` err posI (ueof <> elabel "character")--  describe "notChar" $ do-    context "when stream begins with the character specified as argument" $-      it "signals correct parse error" $-        property $ \ch s' -> do-          let p = notChar ch-              s = ch : s'-          prs p s `shouldFailWith` err posI (utok ch)-          prs' p s `failsLeaving` s-    context "when stream does not begin with the character specified as argument" $-      it "parses first character in the stream" $-        property $ \ch s -> not (null s) && ch /= head s ==> do-          let p = notChar ch-          prs  p s `shouldParse` head s-          prs' p s `succeedsLeaving` tail s-    context "when stream is empty" $-      it "signals correct parse error" $-        prs (notChar 'a') "" `shouldFailWith` err posI ueof--  describe "oneOf" $ do-    context "when stream begins with one of specified characters" $-      it "parses the character" $-        property $ \chs' n s -> do-          let chs = getNonEmpty chs'-              ch  = chs !! (getNonNegative n `rem` length chs)-              s'  = ch : s-          prs  (oneOf chs) s' `shouldParse`     ch-          prs' (oneOf chs) s' `succeedsLeaving` s-    context "when stream does not begin with any of specified characters" $-      it "signals correct parse error" $-        property $ \chs ch s  -> ch `notElem` (chs :: String) ==> do-          let s' = ch : s-          prs  (oneOf chs) s' `shouldFailWith` err posI (utok ch)-          prs' (oneOf chs) s' `failsLeaving`   s'-    context "when stream is empty" $-      it "signals correct parse error" $-        property $ \chs ->-          prs (oneOf (chs :: String)) "" `shouldFailWith` err posI ueof--  describe "noneOf" $ do-    context "when stream does not begin with any of specified characters" $-      it "parses the character" $-        property $ \chs ch s  -> ch `notElem` (chs :: String) ==> do-          let s' = ch : s-          prs  (noneOf chs) s' `shouldParse`     ch-          prs' (noneOf chs) s' `succeedsLeaving` s-    context "when stream begins with one of specified characters" $-      it "signals correct parse error" $-        property $ \chs' n s -> do-          let chs = getNonEmpty chs'-              ch  = chs !! (getNonNegative n `rem` length chs)-              s'  = ch : s-          prs  (noneOf chs) s' `shouldFailWith` err posI (utok ch)-          prs' (noneOf chs) s' `failsLeaving`   s'-    context "when stream is empty" $-      it "signals correct parse error" $-        property $ \chs ->-          prs (noneOf (chs :: String)) "" `shouldFailWith` err posI ueof+          prs  (char' ch) "" `shouldFailWith` err 0 ms    describe "string" $ do     context "when stream is prefixed with given string" $@@ -309,8 +250,7 @@       it "signals correct parse error" $         property $ \str s -> not (str `isPrefixOf` s) ==> do           let us = take (length str) s-          prs (string str) s `shouldFailWith`-            err posI (utoks us <> etoks str)+          prs (string str) s `shouldFailWith` err 0 (utoks us <> etoks str)    describe "string'" $ do     context "when stream is prefixed with given string" $@@ -318,14 +258,15 @@         property $ \str s ->           forAll (fuzzyCase str) $ \str' -> do             let s' = str' ++ s+            -- Rare tricky cases we don't want to deal with.+            when (CI.mk str /= CI.mk str') discard             prs  (string' str) s' `shouldParse`     str'             prs' (string' str) s' `succeedsLeaving` s     context "when stream is not prefixed with given string" $       it "signals correct parse error" $         property $ \str s -> not (str `isPrefixOfI` s) ==> do           let us = take (length str) s-          prs  (string' str) s `shouldFailWith`-            err posI (utoks us <> etoks str)+          prs  (string' str) s `shouldFailWith` err 0 (utoks us <> etoks str)  ---------------------------------------------------------------------------- -- Helpers@@ -343,11 +284,11 @@       property $ \ch s -> ch /= head ts ==> do        let s' = ch : s            us = take (length ts) s'-       prs  p s' `shouldFailWith` err posI (utoks us <> etoks ts)+       prs  p s' `shouldFailWith` err 0 (utoks us <> etoks ts)        prs' p s' `failsLeaving`   s'   context "when stream is empty" $     it "signals correct parse error" $-      prs p "" `shouldFailWith` err posI (ueof <> etoks ts)+      prs p "" `shouldFailWith` err 0 (ueof <> etoks ts)  checkCharPred :: String -> (Char -> Bool) -> Parser Char -> SpecWith () checkCharPred name f p = do@@ -361,24 +302,24 @@     it "signals correct parse error" $       property $ \ch s -> not (f ch) ==> do        let s' = ch : s-       prs  p s' `shouldFailWith` err posI (utok ch <> elabel name)+       prs  p s' `shouldFailWith` err 0 (utok ch <> elabel name)        prs' p s' `failsLeaving`   s'   context "when stream is empty" $     it "signals correct parse error" $-      prs p "" `shouldFailWith` err posI (ueof <> elabel name)+      prs p "" `shouldFailWith` err 0 (ueof <> elabel name)  checkCharRange :: String -> String -> Parser Char -> SpecWith () checkCharRange name tchs p = do   forM_ tchs $ \tch ->-    context ("when stream begins with " ++ showTokens (nes tch)) $-      it ("parses the " ++ showTokens (nes tch)) $+    context ("when stream begins with " ++ showTokens sproxy (nes tch)) $+      it ("parses the " ++ showTokens sproxy (nes tch)) $         property $ \s -> do           let s' = tch : s           prs  p s' `shouldParse`     tch           prs' p s' `succeedsLeaving` s   context "when stream is empty" $     it "signals correct parse error" $-      prs p "" `shouldFailWith` err posI (ueof <> elabel name)+      prs p "" `shouldFailWith` err 0 (ueof <> elabel name)  -- | Randomly change the case in the given string. @@ -388,11 +329,6 @@     f k True  = if isLower k then toUpper k else toLower k     f k False = k --- | Case-insensitive equality test for characters.--casei :: Char -> Char -> Bool-casei x y = toUpper x == toUpper y- -- | The 'isPrefixOf' function takes two 'String's and returns 'True' iff -- the first list is a prefix of the second with case-insensitive -- comparison.@@ -401,3 +337,11 @@ isPrefixOfI [] _  =  True isPrefixOfI _  [] =  False isPrefixOfI (x:xs) (y:ys) = x `casei` y && isPrefixOf xs ys++-- | Case-insensitive equality test for characters.++casei :: Char -> Char -> Bool+casei x y =+  x == toLower y ||+  x == toUpper y ||+  x == toTitle y

@@ -0,0 +1,55 @@+{-# LANGUAGE OverloadedStrings #-}++module Text.Megaparsec.DebugSpec+  ( spec )+where++import Control.Monad+import Data.Monoid ((<>))+import Test.Hspec+import Test.Hspec.Megaparsec+import Test.Hspec.Megaparsec.AdHoc+import Text.Megaparsec+import Text.Megaparsec.Char+import Text.Megaparsec.Debug++spec :: Spec+spec = do++  describe "dbg" $ do+    -- NOTE We don't test properties here to avoid flood of debugging output+    -- when the test runs.+    context "when inner parser succeeds consuming input" $ do+      it "has no effect on how parser works" $ do+        let p = dbg "char" (char 'a')+            s = "ab"+        prs  p s `shouldParse` 'a'+        prs' p s `succeedsLeaving` "b"+      it "its hints are preserved" $ do+        let p = dbg "many chars" (many (char 'a')) <* empty+            s = "abcd"+        prs  p s `shouldFailWith` err 1 (etok 'a')+        prs' p s `failsLeaving` "bcd"+    context "when inner parser fails consuming input" $+      it "has no effect on how parser works" $ do+        let p = dbg "chars" (char 'a' *> char 'c')+            s = "abc"+        prs  p s `shouldFailWith` err 1 (utok 'b' <> etok 'c')+        prs' p s `failsLeaving` "bc"+    context "when inner parser succeeds without consuming" $ do+      it "has no effect on how parser works" $ do+        let p = dbg "return" (return 'a')+            s = "abc"+        prs  p s `shouldParse` 'a'+        prs' p s `succeedsLeaving` s+      it "its hints are preserved" $ do+        let p = dbg "many chars" (many (char 'a')) <* empty+            s = "bcd"+        prs  p s `shouldFailWith` err 0 (etok 'a')+        prs' p s `failsLeaving` "bcd"+    context "when inner parser fails without consuming" $+      it "has no effect on how parser works" $ do+        let p = dbg "empty" (void empty)+            s = "abc"+        prs  p s `shouldFailWith` err 0 mempty+        prs' p s `failsLeaving` s

@@ -3,36 +3,23 @@  module Text.Megaparsec.ErrorSpec (spec) where -import Data.ByteString (ByteString)-import Data.Char (isControl, isSpace)-import Data.List (isInfixOf, isSuffixOf)+import Control.Exception (Exception (..))+import Data.Functor.Identity+import Data.List (isSuffixOf, isInfixOf, sort) import Data.List.NonEmpty (NonEmpty (..)) import Data.Void-import Data.Word (Word8) import Test.Hspec+import Test.Hspec.Megaparsec import Test.Hspec.Megaparsec.AdHoc () import Test.QuickCheck-import Text.Megaparsec.Error-import Text.Megaparsec.Error.Builder-import Text.Megaparsec.Pos-import qualified Data.ByteString    as B-import qualified Data.List.NonEmpty as NE+import Text.Megaparsec import qualified Data.Semigroup     as S import qualified Data.Set           as E -#if !MIN_VERSION_base(4,8,0)-import Data.Foldable (Foldable, all)-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-type PW = ParseError Word8 Void- spec :: Spec spec = do @@ -52,15 +39,10 @@       property $ \x y z ->         (x <> y) <> z === (x <> (y <> z) :: PE) -  describe "Read and Show instances of ParseError" $-    it "printed representation of ParseError can be read back" $-      property $ \x ->-        read (show x) === (x :: PE)-   describe "error merging with (<>)" $ do-    it "selects greater source position" $+    it "selects greater offset" $       property $ \x y ->-        errorPos (x <> y :: PE) === max (errorPos x) (errorPos y)+        errorOffset (x <> y :: PE) === max (errorOffset x) (errorOffset y)     context "when combining two trivial parse errors at the same position" $       it "merges their unexpected and expected items" $ do         let n Nothing  Nothing = Nothing@@ -85,227 +67,214 @@           TrivialError pos us ps <> FancyError pos xs `shouldBe`             (FancyError pos xs :: PE) -  describe "errorPos" $+  describe "errorOffset" $     it "returns error position" $       property $ \e ->-        errorPos e `shouldBe`+        errorOffset e `shouldBe`           (case e :: PE of-            TrivialError pos _ _ -> pos-            FancyError   pos _   -> pos)+            TrivialError o _ _ -> o+            FancyError   o _   -> o) -  describe "showTokens (Char instance)" $ do-    let f :: String -> String -> Expectation-        f x y = showTokens (NE.fromList x) `shouldBe` y-    it "shows CRLF newline correctly"-      (f "\r\n" "crlf newline")-    it "shows null byte correctly"-      (f "\NUL" "null")-    it "shows start of heading correctly"-      (f "\SOH" "start of heading")-    it "shows start of text correctly"-      (f "\STX" "start of text")-    it "shows end of text correctly"-      (f "\ETX" "end of text")-    it "shows end of transmission correctly"-      (f "\EOT" "end of transmission")-    it "shows enquiry correctly"-      (f "\ENQ" "enquiry")-    it "shows acknowledge correctly"-      (f "\ACK" "acknowledge")-    it "shows bell correctly"-      (f "\BEL" "bell")-    it "shows backspace correctly"-      (f "\BS" "backspace")-    it "shows tab correctly"-      (f "\t" "tab")-    it "shows newline correctly"-      (f "\n" "newline")-    it "shows vertical tab correctly"-      (f "\v" "vertical tab")-    it "shows form feed correctly"-      (f "\f" "form feed")-    it "shows carriage return correctly"-      (f "\r" "carriage return")-    it "shows shift out correctly"-      (f "\SO" "shift out")-    it "shows shift in correctly"-      (f "\SI" "shift in")-    it "shows data link escape correctly"-      (f "\DLE" "data link escape")-    it "shows device control one correctly"-      (f "\DC1" "device control one")-    it "shows device control two correctly"-      (f "\DC2" "device control two")-    it "shows device control three correctly"-      (f "\DC3" "device control three")-    it "shows device control four correctly"-      (f "\DC4" "device control four")-    it "shows negative acknowledge correctly"-      (f "\NAK" "negative acknowledge")-    it "shows synchronous idle correctly"-      (f "\SYN" "synchronous idle")-    it "shows end of transmission block correctly"-      (f "\ETB" "end of transmission block")-    it "shows cancel correctly"-      (f "\CAN" "cancel")-    it "shows end of medium correctly"-      (f "\EM"  "end of medium")-    it "shows substitute correctly"-      (f "\SUB" "substitute")-    it "shows escape correctly"-      (f "\ESC" "escape")-    it "shows file separator correctly"-      (f "\FS"  "file separator")-    it "shows group separator correctly"-      (f "\GS"  "group separator")-    it "shows record separator correctly"-      (f "\RS"  "record separator")-    it "shows unit separator correctly"-      (f "\US"  "unit separator")-    it "shows delete correctly"-      (f "\DEL" "delete")-    it "shows space correctly"-      (f " "    "space")-    it "shows non-breaking space correctly"-      (f "\160" "non-breaking space")-    it "shows other single characters in single quotes" $-      property $ \ch ->-        not (isControl ch) && not (isSpace ch) ==>-          showTokens (ch :| []) === "\'" <> [ch] <> "\'"-    it "shows strings in double quotes" $-      property $ \str' ->-        let str = filter (not . g) str'-            g x = isControl x || x `elem` ['\160']-        in length str > 1 ==>-             showTokens (NE.fromList str) === ("\"" <> str <> "\"")-    it "shows control characters in long strings property"-      (f "{\n" "\"{<newline>\"")+  describe "attachSourcePos" $+    it "attaches the positions correctly" $+      property $ \xs' s -> do+        let xs = sort $ getSmall . getPositive <$> xs'+            pst = initialPosState (s :: String)+            pst' =+              if null xs+                then pst+                else snd $ reachOffsetNoLine (last xs) pst+            rs = f <$> xs+            f x = (x, fst (reachOffsetNoLine x pst))+        attachSourcePos id (xs :: [Int]) pst `shouldBe` (rs, pst') -  describe "showTokens (Word8 instance)" $-    it "basically works" $ do-      -- NOTE Currently the Word8 instance is defined via Char intance, so-      -- the testing is rather shallow.-      let ts = NE.fromList [10,48,49,50] :: NonEmpty Word8-      showTokens ts `shouldBe` "\"<newline>012\""+  describe "errorBundlePretty" $ do+    it "shows empty line correctly" $ do+      let s = "" :: String+      mkBundlePE s (mempty :: PE) `shouldBe`+        "1:1:\n  |\n1 | <empty line>\n  | ^\nunknown parse error\n"+    it "shows position on first line correctly" $ do+      let s = "abc" :: String+          pe = err 1 (utok 'b' <> etok 'd') :: PE+      mkBundlePE s pe `shouldBe`+        "1:2:\n  |\n1 | abc\n  |  ^\nunexpected 'b'\nexpecting 'd'\n"+    it "skips to second line correctly" $ do+      let s = "one\ntwo\n" :: String+          pe = err 4 (utok 't' <> etok 'x') :: PE+      mkBundlePE s pe `shouldBe`+        "2:1:\n  |\n2 | two\n  | ^\nunexpected 't'\nexpecting 'x'\n"+    it "shows position on 1000 line correctly" $ do+      let s = replicate 999 '\n' ++ "abc"+          pe = err 999 (utok 'a' <> etok 'd') :: PE+      mkBundlePE s pe `shouldBe`+        "1000:1:\n     |\n1000 | abc\n     | ^\nunexpected 'a'\nexpecting 'd'\n"+    it "shows offending line in the presence of tabs correctly" $ do+      let s = "\tsomething" :: String+          pe = err 1 (utok 's' <> etok 'x') :: PE+      mkBundlePE s pe `shouldBe`+        "1:9:\n  |\n1 |         something\n  |         ^\nunexpected 's'\nexpecting 'x'\n"+    it "uses continuous highlighting properly (trivial)" $ do+      let s = "\tfoobar" :: String+          pe = err 1 (utoks "foo" <> utoks "rar") :: PE+      mkBundlePE s pe `shouldBe`+        "1:9:\n  |\n1 |         foobar\n  |         ^^^\nunexpected \"rar\"\n"+    it "uses continuous highlighting properly (fancy)" $ do+      let s = "\tfoobar" :: String+          pe = errFancy 1+            (fancy $ ErrorCustom (CustomErr 5)) :: ParseError String CustomErr+      mkBundlePE s pe `shouldBe`+        "1:9:\n  |\n1 |         foobar\n  |         ^^^^^\ncustom thing\n"+    it "adjusts continuous highlighting so it doesn't get too long" $ do+      let s = "foobar\n" :: String+          pe = err 4 (utoks "foobar" <> etoks "foobar") :: PE+      mkBundlePE s pe `shouldBe`+        "1:5:\n  |\n1 | foobar\n  |     ^^^\nunexpected \"foobar\"\nexpecting \"foobar\"\n"+    context "stream of insufficient size is provided in the bundle" $+      it "handles the situation reasonably" $ do+        let s = "" :: String+            pe = err 3 (ueof <> etok 'x') :: PE+        mkBundlePE s pe `shouldBe`+          "1:1:\n  |\n1 | <empty line>\n  | ^\nunexpected end of input\nexpecting 'x'\n"+    context "starting column in bundle is greater than 1" $ do+      context "and less than parse error column" $+        it "is rendered correctly" $ do+          let s = "foo" :: String+              pe = err 5 (utok 'o' <> etok 'x') :: PE+              bundle = ParseErrorBundle+                { bundleErrors = pe :| []+                , bundlePosState = PosState+                  { pstateInput = s+                  , pstateOffset = 4+                  , pstateSourcePos = SourcePos "" pos1 (mkPos 5)+                  , pstateTabWidth = defaultTabWidth+                  , pstateLinePrefix = ""+                  }+                }+          errorBundlePretty bundle `shouldBe`+            "1:6:\n  |\n1 | ????foo\n  |      ^\nunexpected 'o'\nexpecting 'x'\n"+      context "and greater than parse error column" $+        it "is rendered correctly" $ do+          let s = "foo" :: String+              pe = err 5 (utok 'o' <> etok 'x') :: PE+              bundle = ParseErrorBundle+                { bundleErrors = pe :| []+                , bundlePosState = PosState+                  { pstateInput = s+                  , pstateOffset = 9+                  , pstateSourcePos = SourcePos "" pos1 (mkPos 10)+                  , pstateTabWidth = defaultTabWidth+                  , pstateLinePrefix = ""+                  }+                }+          errorBundlePretty bundle `shouldBe`+            "1:10:\n  |\n1 | ?????????foo\n  |          ^\nunexpected 'o'\nexpecting 'x'\n"+    it "takes tab width into account correctly" $+      property $ \w' -> do+        let s  = "\tsomething\t" :: String+            pe = err 1 (utok 's' <> etok 'x') :: PE+            bundle = ParseErrorBundle+              { bundleErrors = pe :| []+              , bundlePosState = PosState+                { pstateInput = s+                , pstateOffset = 0+                , pstateSourcePos = initialPos ""+                , pstateTabWidth = w'+                , pstateLinePrefix = ""+                }+              }+            w  = unPos w'+            tabRep = replicate w ' '+        errorBundlePretty bundle `shouldBe`+          ("1:" ++ show (w + 1) ++ ":\n  |\n1 | " ++ tabRep +++           "something" ++ tabRep +++           "\n  | " ++ tabRep ++ "^\nunexpected 's'\nexpecting 'x'\n")+    it "displays multi-error bundle correctly" $ do+      let s = "something\ngood\n" :: String+          pe0 = err 0 (utok 's' <> etok 'x') :: PE+          pe1 = err 10 (utok 'g' <> etok 'y') :: PE+          bundle = ParseErrorBundle+            { bundleErrors = pe0 :| [pe1]+            , bundlePosState = PosState+              { pstateInput = s+              , pstateOffset = 0+              , pstateSourcePos = initialPos ""+              , pstateTabWidth = defaultTabWidth+              , pstateLinePrefix = ""+              }+            }+      errorBundlePretty bundle `shouldBe`+        "1:1:\n  |\n1 | something\n  | ^\nunexpected 's'\nexpecting 'x'\n\n2:1:\n  |\n2 | good\n  | ^\nunexpected 'g'\nexpecting 'y'\n"    describe "parseErrorPretty" $ do     it "shows unknown ParseError correctly" $-      parseErrorPretty (mempty :: PE) `shouldBe` "1:1:\nunknown parse error\n"+      parseErrorPretty (mempty :: PE) `shouldBe` "offset=0:\nunknown parse error\n"     it "result always ends with a newline" $       property $ \x ->         parseErrorPretty (x :: PE) `shouldSatisfy` ("\n" `isSuffixOf`)-    it "result contains representation of source pos stack" $-      property (contains errorPos sourcePosPretty)-    it "result contains representation of unexpected items" $ do-      let f (TrivialError _ us _) = us-          f _                     = Nothing-      property (contains f showErrorComponent)-    it "result contains representation of expected items" $ do-      let f (TrivialError _ _ ps) = ps-          f _                     = E.empty-      property (contains f showErrorComponent)+    it "result contains representation of offset" $+      property (contains (Identity . errorOffset) show)+    it "result contains unexpected/expected items" $ do+      let e = err 0 (utoks "foo" <> etoks "bar" <> etoks "baz") :: PE+      parseErrorPretty e `shouldBe` "offset=0:\nunexpected \"foo\"\nexpecting \"bar\" or \"baz\"\n"     it "result contains representation of custom items" $ do-      let f (FancyError _ xs) = xs-          f _                 = E.empty-      property (contains f showErrorComponent)+      let e = errFancy 0 (fancy (ErrorFail "Ooops!")) :: PE+      parseErrorPretty e `shouldBe` "offset=0:\nOoops!\n"     it "several fancy errors look not so bad" $ do       let pe :: PE-          pe = errFancy posI $+          pe = errFancy 0 $             mempty <> fancy (ErrorFail "foo") <> fancy (ErrorFail "bar")-      parseErrorPretty pe `shouldBe` "1:1:\nbar\nfoo\n"--  describe "parseErrorPretty'" $ do-    context "with Char tokens" $ do-      it "shows empty line correctly" $ do-        let s = "" :: String-        parseErrorPretty' s (mempty :: PE) `shouldBe`-          "1:1:\n  |\n1 | <empty line>\n  | ^\nunknown parse error\n"-      it "shows position on first line correctly" $ do-        let s = "abc" :: String-            pe = err (posN 1 s) (utok 'b' <> etok 'd') :: PE-        parseErrorPretty' s pe `shouldBe`-          "1:2:\n  |\n1 | abc\n  |  ^\nunexpected 'b'\nexpecting 'd'\n"-      it "skips to second line correctly" $ do-        let s = "one\ntwo\n" :: String-            pe = err (posN 4 s) (utok 't' <> etok 'x') :: PE-        parseErrorPretty' s pe `shouldBe`-          "2:1:\n  |\n2 | two\n  | ^\nunexpected 't'\nexpecting 'x'\n"-      it "shows position on 1000 line correctly" $ do-        let s = replicate 999 '\n' ++ "abc"-            pe = err (posN 999 s) (utok 'a' <> etok 'd') :: PE-        parseErrorPretty' s pe `shouldBe`-          "1000:1:\n     |\n1000 | abc\n     | ^\nunexpected 'a'\nexpecting 'd'\n"-      it "shows offending line in the presence of tabs correctly" $ do-        let s = "\tsomething" :: String-            pe = err (posN 1 s) (utok 's' <> etok 'x') :: PE-        parseErrorPretty' s pe `shouldBe`-          "1:9:\n  |\n1 |         something\n  |         ^\nunexpected 's'\nexpecting 'x'\n"-    context "with Word8 tokens" $ do-      it "shows empty line correctly" $ do-        let s = "" :: ByteString-        parseErrorPretty' s (mempty :: PW) `shouldBe`-          "1:1:\n  |\n1 | <empty line>\n  | ^\nunknown parse error\n"-      it "shows position on first line correctly" $ do-        let s = "abc" :: ByteString-            pe = err (posN 1 s) (utok 98 <> etok 100) :: PW-        parseErrorPretty' s pe `shouldBe`-          "1:2:\n  |\n1 | abc\n  |  ^\nunexpected 'b'\nexpecting 'd'\n"-      it "skips to second line correctly" $ do-        let s = "one\ntwo\n" :: ByteString-            pe = err (posN 4 s) (utok 116 <> etok 120) :: PW-        parseErrorPretty' s pe `shouldBe`-          "2:1:\n  |\n2 | two\n  | ^\nunexpected 't'\nexpecting 'x'\n"-      it "shows position on 1000 line correctly" $ do-        let s = B.replicate 999 10 <> "abc"-            pe = err (posN 999 s) (utok 97 <> etok 100) :: PW-        parseErrorPretty' s pe `shouldBe`-          "1000:1:\n     |\n1000 | abc\n     | ^\nunexpected 'a'\nexpecting 'd'\n"-      it "shows offending line in the presence of tabs correctly" $ do-        let s = "\tsomething" :: ByteString-            pe = err (posN 1 s) (utok 115 <> etok 120) :: PW-        parseErrorPretty' s pe `shouldBe`-          "1:9:\n  |\n1 |         something\n  |         ^\nunexpected 's'\nexpecting 'x'\n"--  describe "parseErrorPretty_" $-    it "takes tab width into account correctly" $-      property $ \w' -> do-        let s  = "\tsomething\t" :: String-            pe = err (posN 1 s) (utok 's' <> etok 'x') :: PE-            w  = unPos w'-        parseErrorPretty_ w' s pe `shouldBe`-          ("1:9:\n  |\n1 | " ++ replicate w ' ' ++ "something" ++ replicate w ' '-           ++ "\n  |         ^\nunexpected 's'\nexpecting 'x'\n")--  describe "sourcePosStackPretty" $-    it "result never ends with a newline " $-      property $ \x ->-        let pos = errorPos (x :: PE)-        in sourcePosStackPretty pos `shouldNotSatisfy` ("\n" `isSuffixOf`)+      parseErrorPretty pe `shouldBe` "offset=0:\nbar\nfoo\n"    describe "parseErrorTextPretty" $ do     it "shows trivial unknown ParseError correctly" $       parseErrorTextPretty (mempty :: PE)         `shouldBe` "unknown parse error\n"     it "shows fancy unknown ParseError correctly" $-      parseErrorTextPretty (FancyError posI E.empty :: PE)+      parseErrorTextPretty (FancyError 0 E.empty :: PE)         `shouldBe` "unknown fancy parse error\n"     it "result always ends with a newline" $       property $ \x ->         parseErrorTextPretty (x :: PE)           `shouldSatisfy` ("\n" `isSuffixOf`) -#if MIN_VERSION_base(4,8,0)   describe "displayException" $     it "produces the same result as parseErrorPretty" $       property $ \x ->         displayException x `shouldBe` parseErrorPretty (x :: PE)-#endif  ---------------------------------------------------------------------------- -- Helpers +-- | Custom error component to test continuous highlighting for custom+-- components.++newtype CustomErr = CustomErr Int+  deriving (Eq, Ord, Show)++instance ShowErrorComponent CustomErr where+  showErrorComponent _ = "custom thing"+  errorComponentLen (CustomErr n) = n++type PE = ParseError String Void+ contains :: Foldable t => (PE -> t a) -> (a -> String) -> PE -> Property contains g r e = property (all f (g e))   where     rendered = parseErrorPretty e     f x = r x `isInfixOf` rendered++mkBundlePE+  :: (Stream s, ShowErrorComponent e)+  => s+  -> ParseError s e+  -> String+mkBundlePE s e = errorBundlePretty $ ParseErrorBundle+  { bundleErrors = e :| []+  , bundlePosState = PosState+    { pstateInput = s+    , pstateOffset = 0+    , pstateSourcePos = initialPos ""+    , pstateTabWidth = defaultTabWidth+    , pstateLinePrefix = ""+    }+  }