megaparsec 9.2.2 → 9.8.1

raw patch · 22 files changed

Files

• CHANGELOG.md +99/−0
• README.md +4/−1
• Setup.hs +0/−6
• Text/Megaparsec.hs +41/−51
• Text/Megaparsec/Byte/Binary.hs +1/−1
• Text/Megaparsec/Byte/Lexer.hs +7/−7
• Text/Megaparsec/Char/Lexer.hs +16/−17
• Text/Megaparsec/Class.hs +23/−7
• Text/Megaparsec/Common.hs +1/−1
• Text/Megaparsec/Debug.hs +240/−81
• Text/Megaparsec/Error.hs +92/−31
• Text/Megaparsec/Error/Builder.hs +19/−20
• Text/Megaparsec/Internal.hs +149/−73
• Text/Megaparsec/Internal.hs-boot +10/−0
• Text/Megaparsec/Lexer.hs +3/−3
• Text/Megaparsec/Pos.hs +3/−4
• Text/Megaparsec/State.hs +42/−4
• Text/Megaparsec/Stream.hs +288/−72
• Text/Megaparsec/Unicode.hs +223/−0
• bench/memory/Main.hs +2/−2
• bench/speed/Main.hs +2/−2
• megaparsec.cabal +35/−27

@@ -1,5 +1,104 @@ *Megaparsec follows [SemVer](https://semver.org/).* +## Megaparsec 9.8.1++* Fixed the regression introduced by the fix for the [issue+  572](https://github.com/mrkkrp/megaparsec/issues/572) which caused the+  position marker `^` to be missing in certain cases.+* This release officially supports GHC 9.6. This is the oldest GHC version+  we support at this time.++## Megaparsec 9.8.0++* Fixed the associativity of the `(<|>)` operator. [Issue+  412](https://github.com/mrkkrp/megaparsec/issues/412).+* Fixed the loss of precision in `decimal`, `binary`, `octal`, and+  `hexadecimal` functions in `Text.Megaparsec.Byte.Lexer` and+  `Text.Megaparsec.Char.Lexer` when they are used to parse floating point+  numbers. [Issue 479](https://github.com/mrkkrp/megaparsec/issues/479).+* Fixed handling of zero-width characters in error messages. To that end,+  added `isZeroWidthChar` function in `Text.Megaparsec.Unicode`. [Issue+  572](https://github.com/mrkkrp/megaparsec/issues/572).++## Megaparsec 9.7.1++* Typo fixes and compatibility with `QuickCheck >= 2.17` for+  `megaparsec-tests`.++## Megaparsec 9.7.0++* Implemented correct handling of wide Unicode characters in error messages.+  To that end, a new module `Text.Megaparsec.Unicode` was introduced. [Issue+  370](https://github.com/mrkkrp/megaparsec/issues/370).+* Inlined `Applicative` operators `(<*)` and `(*>)`. [PR+  566](https://github.com/mrkkrp/megaparsec/pull/566).+* `many` and `some` of the `Alternative` instance of `ParsecT` are now more+  efficient, since they use the monadic implementations under the hood.+  [Issue 567](https://github.com/mrkkrp/megaparsec/issues/567).+* Added `Text.Megaparsec.Error.errorBundlePrettyForGhcPreProcessors`. [PR+  573](https://github.com/mrkkrp/megaparsec/pull/573).++## Megaparsec 9.6.1++* Exposed `Text.Megaparsec.State`, so that the new functions (`initialState`+  and `initialPosState`) can be actually imported from it. [PR+  549](https://github.com/mrkkrp/megaparsec/pull/549).++## Megaparsec 9.6.0++* Added the functions `initialState` and `initialPosState` to+  `Text.Megaparsec.State`. [Issue+  449](https://github.com/mrkkrp/megaparsec/issues/449).++## Megaparsec 9.5.0++* Dropped a number of redundant constraints here and there. [PR+  523](https://github.com/mrkkrp/megaparsec/pull/523).++* Added a `MonadWriter` instance for `ParsecT`. [PR+  534](https://github.com/mrkkrp/megaparsec/pull/534).++## Megaparsec 9.4.1++* Removed `Monad m` constraints in several places where they were introduced+  in 9.4.0. [Issue 532](https://github.com/mrkkrp/megaparsec/issues/532).++## Megaparsec 9.4.0++* `dbg` now prints hints among other debug information. [PR+  530](https://github.com/mrkkrp/megaparsec/pull/530).++* Hints are no longer lost in certain methods of MTL instances for+  `ParsecT`. [Issue 528](https://github.com/mrkkrp/megaparsec/issues/528).++* Added a new method to the `MonadParsec` type class—`mkParsec`. This can be+  used to construct “new primitives” with arbitrary behavior at the expense+  of having to dive into Megaparsec's internals. [PR+  514](https://github.com/mrkkrp/megaparsec/pull/514).++## Megaparsec 9.3.1++* Fixed a bug related to processing of tabs when error messages are+  rendered. [Issue 524](https://github.com/mrkkrp/megaparsec/issues/524).++## Megaparsec 9.3.0++* Now `label` can override more than one group of hints in the parser it+  wraps. [Issue 482](https://github.com/mrkkrp/megaparsec/issues/482).++* `takeP n` now returns the empty chunk of the input stream when `n` is+  negative, similar to when `n == 0`. [Issue+  497](https://github.com/mrkkrp/megaparsec/issues/497).++* Added the `MonadParsecDbg` type class in `Text.Megaparsec.Debug`. The type+  class allows us to use `dbg` in MTL monad transformers. [Issue+  488](https://github.com/mrkkrp/megaparsec/issues/488).++* Introduced the `ShareInput` and `NoShareInput` newtype wrappers in+  `Text.Megaparsec.Stream` in order to allow the user to choose how the+  input should be sliced and shared during the parsing. [Issue+  492](https://github.com/mrkkrp/megaparsec/issues/492).+ ## Megaparsec 9.2.2  * Fixed a space leak in the implementations of the `reachOffset` and

@@ -4,7 +4,7 @@ [![Hackage](https://img.shields.io/hackage/v/megaparsec.svg?style=flat)](https://hackage.haskell.org/package/megaparsec) [![Stackage Nightly](http://stackage.org/package/megaparsec/badge/nightly)](http://stackage.org/nightly/package/megaparsec) [![Stackage LTS](http://stackage.org/package/megaparsec/badge/lts)](http://stackage.org/lts/package/megaparsec)-![CI](https://github.com/mrkkrp/megaparsec/workflows/CI/badge.svg?branch=master)+[![CI](https://github.com/mrkkrp/megaparsec/actions/workflows/ci.yaml/badge.svg)](https://github.com/mrkkrp/megaparsec/actions/workflows/ci.yaml)  * [Features](#features)     * [Core features](#core-features)@@ -281,6 +281,9 @@   library for easily using   [TagSoup](https://hackage.haskell.org/package/tagsoup) as a token type in   Megaparsec.+* [`parser-combinators`](https://hackage.haskell.org/package/parser-combinators)—provides permutation and expression parsers [previously bundled with Megaparsec](https://markkarpov.com/post/megaparsec-7.html#parsercombinators-grows-megaparsec-shrinks).+* [`faster-megaparsec`](https://hackage.haskell.org/package/faster-megaparsec)—speeds up parsing+  by trying a simple `MonadParsec` instance and falls back to `ParsecT` to report errors.  ## Prominent projects that use Megaparsec 

@@ -1,6 +0,0 @@-module Main (main) where--import Distribution.Simple--main :: IO ()-main = defaultMain

@@ -130,12 +130,16 @@ -- -- Note that we re-export monadic combinators from -- "Control.Monad.Combinators" because these are more efficient than--- 'Applicative'-based ones. Thus 'many' and 'some' may clash with the+-- 'Applicative'-based ones (†). Thus 'many' and 'some' may clash with the -- functions from "Control.Applicative". You need to hide the functions like -- this: -- -- > import Control.Applicative hiding (many, some) --+-- † As of Megaparsec 9.7.0 'Control.Applicative.many' and+-- 'Control.Applicative.some' are as efficient as their monadic+-- counterparts.+-- -- Also note that you can import "Control.Monad.Combinators.NonEmpty" if you -- wish that combinators like 'some' return 'NonEmpty' lists. The module -- lives in the @parser-combinators@ package (you need at least version@@ -174,6 +178,8 @@ -- >          Right xs -> print (sum xs) -- > -- > numbers = decimal `sepBy` char ','+--+-- 'parse' is the same as 'runParser'. parse ::   -- | Parser to run   Parsec e s a ->@@ -223,6 +229,8 @@ -- 'ParseErrorBundle' ('Left') or a value of type @a@ ('Right'). -- -- > parseFromFile p file = runParser p file <$> readFile file+--+-- 'runParser' is the same as 'parse'. runParser ::   -- | Parser to run   Parsec e s a ->@@ -253,7 +261,7 @@ -- underlying monad @m@ that returns either a 'ParseErrorBundle' ('Left') or -- a value of type @a@ ('Right'). runParserT ::-  Monad m =>+  (Monad m) =>   -- | Parser to run   ParsecT e s m a ->   -- | Name of source file@@ -269,7 +277,7 @@ -- -- @since 4.2.0 runParserT' ::-  Monad m =>+  (Monad m) =>   -- | Parser to run   ParsecT e s m a ->   -- | Initial state@@ -284,31 +292,13 @@             bundlePosState = statePosState s           }   return $ case result of-    OK x ->+    OK _ x ->       case NE.nonEmpty (stateParseErrors s') of         Nothing -> (s', Right x)         Just de -> (s', Left (toBundle de))     Error e ->       (s', Left (toBundle (e :| stateParseErrors s'))) --- | Given the name of source file and the input construct the initial state--- for a parser.-initialState :: String -> s -> State s e-initialState name s =-  State-    { stateInput = s,-      stateOffset = 0,-      statePosState =-        PosState-          { pstateInput = s,-            pstateOffset = 0,-            pstateSourcePos = initialPos name,-            pstateTabWidth = defaultTabWidth,-            pstateLinePrefix = ""-          },-      stateParseErrors = []-    }- ---------------------------------------------------------------------------- -- Signaling parse errors @@ -323,7 +313,7 @@ -- -- @since 6.0.0 failure ::-  MonadParsec e s m =>+  (MonadParsec e s m) =>   -- | Unexpected item (if any)   Maybe (ErrorItem (Token s)) ->   -- | Expected items@@ -339,7 +329,7 @@ -- -- @since 6.0.0 fancyFailure ::-  MonadParsec e s m =>+  (MonadParsec e s m) =>   -- | Fancy error components   Set (ErrorFancy e) ->   m a@@ -352,7 +342,7 @@ -- about unexpected item @item@ without consuming any input. -- -- > unexpected item = failure (Just item) Set.empty-unexpected :: MonadParsec e s m => ErrorItem (Token s) -> m a+unexpected :: (MonadParsec e s m) => ErrorItem (Token s) -> m a unexpected item = failure (Just item) E.empty {-# INLINE unexpected #-} @@ -362,7 +352,7 @@ -- > customFailure = fancyFailure . Set.singleton . ErrorCustom -- -- @since 6.3.0-customFailure :: MonadParsec e s m => e -> m a+customFailure :: (MonadParsec e s m) => e -> m a customFailure = fancyFailure . E.singleton . ErrorCustom {-# INLINE customFailure #-} @@ -370,12 +360,12 @@ -- wrapper. This applies to both normal and delayed 'ParseError's. -- -- As a side-effect of the implementation the inner computation will start--- with empty collection of delayed errors and they will be updated and+-- with an empty collection of delayed errors and they will be updated and -- “restored” on the way out of 'region'. -- -- @since 5.3.0 region ::-  MonadParsec e s m =>+  (MonadParsec e s m) =>   -- | How to process 'ParseError's   (ParseError s e -> ParseError s e) ->   -- | The “region” that the processing applies to@@ -396,12 +386,12 @@ -- | Register a 'ParseError' for later reporting. This action does not end -- parsing and has no effect except for adding the given 'ParseError' to the -- collection of “delayed” 'ParseError's which will be taken into--- consideration at the end of parsing. Only if this collection is empty the--- parser will succeed. This is the main way to report several parse errors+-- consideration at the end of parsing. Only if this collection is empty will+-- the parser succeed. This is the main way to report several parse errors -- at once. -- -- @since 8.0.0-registerParseError :: MonadParsec e s m => ParseError s e -> m ()+registerParseError :: (MonadParsec e s m) => ParseError s e -> m () registerParseError e = updateParserState $ \s ->   s {stateParseErrors = e : stateParseErrors s} {-# INLINE registerParseError #-}@@ -410,7 +400,7 @@ -- -- @since 8.0.0 registerFailure ::-  MonadParsec e s m =>+  (MonadParsec e s m) =>   -- | Unexpected item (if any)   Maybe (ErrorItem (Token s)) ->   -- | Expected items@@ -425,7 +415,7 @@ -- -- @since 8.0.0 registerFancyFailure ::-  MonadParsec e s m =>+  (MonadParsec e s m) =>   -- | Fancy error components   Set (ErrorFancy e) ->   m ()@@ -446,7 +436,7 @@ -- -- @since 7.0.0 single ::-  MonadParsec e s m =>+  (MonadParsec e s m) =>   -- | Token to match   Token s ->   m (Token s)@@ -470,7 +460,7 @@ -- -- @since 7.0.0 satisfy ::-  MonadParsec e s m =>+  (MonadParsec e s m) =>   -- | Predicate to apply   (Token s -> Bool) ->   m (Token s)@@ -487,7 +477,7 @@ -- See also: 'satisfy', 'anySingleBut'. -- -- @since 7.0.0-anySingle :: MonadParsec e s m => m (Token s)+anySingle :: (MonadParsec e s m) => m (Token s) anySingle = satisfy (const True) {-# INLINE anySingle #-} @@ -500,7 +490,7 @@ -- -- @since 7.0.0 anySingleBut ::-  MonadParsec e s m =>+  (MonadParsec e s m) =>   -- | Token we should not match   Token s ->   m (Token s)@@ -530,10 +520,10 @@   -- | Collection of matching tokens   f (Token s) ->   m (Token s)-oneOf cs = satisfy (`elem` cs)+oneOf cs = satisfy (\x -> elem x cs) {-# INLINE oneOf #-} --- | As the dual of 'oneOf', @'noneOf' ts@ succeeds if the current token+-- | As the dual of 'oneOf', @'noneOf' ts@ succeeds if the current token is -- /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@@ -549,10 +539,10 @@ -- @since 7.0.0 noneOf ::   (Foldable f, MonadParsec e s m) =>-  -- | Collection of taken we should not match+  -- | Collection of tokens we should not match   f (Token s) ->   m (Token s)-noneOf cs = satisfy (`notElem` cs)+noneOf cs = satisfy (\x -> notElem x cs) {-# INLINE noneOf #-}  -- | @'chunk' chk@ only matches the chunk @chk@.@@ -564,7 +554,7 @@ -- -- @since 7.0.0 chunk ::-  MonadParsec e s m =>+  (MonadParsec e s m) =>   -- | Chunk to match   Tokens s ->   m (Tokens s)@@ -574,7 +564,7 @@ -- | A synonym for 'label' in the form of an operator. infix 0 <?> -(<?>) :: MonadParsec e s m => m a -> String -> m a+(<?>) :: (MonadParsec e s m) => m a -> String -> m a (<?>) = flip label {-# INLINE (<?>) #-} @@ -584,7 +574,7 @@ -- manually in the argument parser, prepare for troubles. -- -- @since 5.3.0-match :: MonadParsec e s m => m a -> m (Tokens s, a)+match :: (MonadParsec e s m) => m a -> m (Tokens s, a) match p = do   o <- getOffset   s <- getInput@@ -604,7 +594,7 @@ -- > takeRest = takeWhileP Nothing (const True) -- -- @since 6.0.0-takeRest :: MonadParsec e s m => m (Tokens s)+takeRest :: (MonadParsec e s m) => m (Tokens s) takeRest = takeWhileP Nothing (const True) {-# INLINE takeRest #-} @@ -613,7 +603,7 @@ -- > atEnd = option False (True <$ hidden eof) -- -- @since 6.0.0-atEnd :: MonadParsec e s m => m Bool+atEnd :: (MonadParsec e s m) => m Bool atEnd = option False (True <$ hidden eof) {-# INLINE atEnd #-} @@ -621,12 +611,12 @@ -- Parser state combinators  -- | Return the current input.-getInput :: MonadParsec e s m => m s+getInput :: (MonadParsec e s m) => m s getInput = stateInput <$> getParserState {-# INLINE getInput #-}  -- | @'setInput' input@ continues parsing with @input@.-setInput :: MonadParsec e s m => s -> m ()+setInput :: (MonadParsec e s m) => s -> m () setInput s = updateParserState (\(State _ o pst de) -> State s o pst de) {-# INLINE setInput #-} @@ -652,7 +642,7 @@ -- See also: 'setOffset'. -- -- @since 7.0.0-getOffset :: MonadParsec e s m => m Int+getOffset :: (MonadParsec e s m) => m Int getOffset = stateOffset <$> getParserState {-# INLINE getOffset #-} @@ -661,7 +651,7 @@ -- See also: 'getOffset'. -- -- @since 7.0.0-setOffset :: MonadParsec e s m => Int -> m ()+setOffset :: (MonadParsec e s m) => Int -> m () setOffset o = updateParserState $ \(State s _ pst de) ->   State s o pst de {-# INLINE setOffset #-}@@ -669,6 +659,6 @@ -- | @'setParserState' st@ sets the parser state to @st@. -- -- See also: 'getParserState', 'updateParserState'.-setParserState :: MonadParsec e s m => State s e -> m ()+setParserState :: (MonadParsec e s m) => State s e -> m () setParserState st = updateParserState (const st) {-# INLINE setParserState #-}

@@ -185,7 +185,7 @@ -- -- Performs ceiling division, so byte-unaligned types (bitsize not a -- multiple of 8) should work, but further usage is not tested.-finiteByteSize :: forall a. FiniteBits a => Int+finiteByteSize :: forall a. (FiniteBits a) => Int finiteByteSize = finiteBitSize @a undefined `ceilDiv` 8   where     ceilDiv x y = (x + y - 1) `div` y

@@ -41,7 +41,7 @@  import Control.Applicative import Data.Functor (void)-import Data.List (foldl')+import qualified Data.List import Data.Proxy import Data.Scientific (Scientific) import qualified Data.Scientific as Sci@@ -69,7 +69,7 @@ -- | @'skipBlockComment' start end@ skips non-nested block comment starting -- with @start@ and ending with @end@. skipBlockComment ::-  (MonadParsec e s m, Token s ~ Word8) =>+  (MonadParsec e s m) =>   -- | Start of block comment   Tokens s ->   -- | End of block comment@@ -122,7 +122,7 @@   m a decimal_ = mkNum <$> takeWhile1P (Just "digit") isDigit   where-    mkNum = foldl' step 0 . chunkToTokens (Proxy :: Proxy s)+    mkNum = fromInteger . Data.List.foldl' step 0 . chunkToTokens (Proxy :: Proxy s)     step a w = a * 10 + fromIntegral (w - 48) {-# INLINE decimal_ #-} @@ -145,7 +145,7 @@     <$> takeWhile1P Nothing isBinDigit     <?> "binary integer"   where-    mkNum = foldl' step 0 . chunkToTokens (Proxy :: Proxy s)+    mkNum = fromInteger . Data.List.foldl' step 0 . chunkToTokens (Proxy :: Proxy s)     step a w = a * 2 + fromIntegral (w - 48)     isBinDigit w = w == 48 || w == 49 {-# INLINEABLE binary #-}@@ -170,7 +170,7 @@     <$> takeWhile1P Nothing isOctDigit     <?> "octal integer"   where-    mkNum = foldl' step 0 . chunkToTokens (Proxy :: Proxy s)+    mkNum = fromInteger . Data.List.foldl' step 0 . chunkToTokens (Proxy :: Proxy s)     step a w = a * 8 + fromIntegral (w - 48)     isOctDigit w = w - 48 < 8 {-# INLINEABLE octal #-}@@ -195,7 +195,7 @@     <$> takeWhile1P Nothing isHexDigit     <?> "hexadecimal integer"   where-    mkNum = foldl' step 0 . chunkToTokens (Proxy :: Proxy s)+    mkNum = fromInteger . Data.List.foldl' step 0 . chunkToTokens (Proxy :: Proxy s)     step a w       | w >= 48 && w <= 57 = a * 16 + fromIntegral (w - 48)       | w >= 97 = a * 16 + fromIntegral (w - 87)@@ -256,7 +256,7 @@   m SP dotDecimal_ pxy c' = do   void (B.char 46)-  let mkNum = foldl' step (SP c' 0) . chunkToTokens pxy+  let mkNum = Data.List.foldl' step (SP c' 0) . chunkToTokens pxy       step (SP a e') w =         SP           (a * 10 + fromIntegral (w - 48))

@@ -69,7 +69,7 @@ import Control.Applicative import Control.Monad (void) import qualified Data.Char as Char-import Data.List (foldl')+import qualified Data.List import Data.List.NonEmpty (NonEmpty (..)) import Data.Maybe (fromMaybe, isJust, listToMaybe) import Data.Proxy@@ -99,7 +99,7 @@ -- | @'skipBlockComment' start end@ skips non-nested block comment starting -- with @start@ and ending with @end@. skipBlockComment ::-  (MonadParsec e s m, Token s ~ Char) =>+  (MonadParsec e s m) =>   -- | Start of block comment   Tokens s ->   -- | End of block comment@@ -152,7 +152,7 @@ -- -- @since 5.0.0 incorrectIndent ::-  MonadParsec e s m =>+  (MonadParsec e s m) =>   -- | Desired ordering between reference level and actual level   Ordering ->   -- | Reference indentation level@@ -229,9 +229,8 @@ -- the “reference” token. The reference token can influence parsing, see -- 'IndentOpt' for more information. ----- Tokens /must not/ consume newlines after them. On the other hand, the--- first argument of this function /must/ consume newlines among other white--- space characters.+-- __Note__: the first argument of this function /must/ consume newlines+-- among other white space characters. -- -- @since 4.3.0 indentBlock ::@@ -259,9 +258,9 @@       let lvl = fromMaybe pos indent       x <-         if-            | pos <= ref -> incorrectIndent GT ref pos-            | pos == lvl -> p-            | otherwise -> incorrectIndent EQ lvl pos+          | pos <= ref -> incorrectIndent GT ref pos+          | pos == lvl -> p+          | otherwise -> incorrectIndent EQ lvl pos       xs <- indentedItems ref lvl sc p       f (x : xs) {-# INLINEABLE indentBlock #-}@@ -289,9 +288,9 @@         then return []         else           if-              | pos <= ref -> return []-              | pos == lvl -> (:) <$> p <*> go-              | otherwise -> incorrectIndent EQ lvl pos+            | pos <= ref -> return []+            | pos == lvl -> (:) <$> p <*> go+            | otherwise -> incorrectIndent EQ lvl pos  -- | Create a parser that supports line-folding. The first argument is used -- to consume white space between components of line fold, thus it /must/@@ -373,7 +372,7 @@   m a decimal_ = mkNum <$> takeWhile1P (Just "digit") Char.isDigit   where-    mkNum = foldl' step 0 . chunkToTokens (Proxy :: Proxy s)+    mkNum = fromInteger . Data.List.foldl' step 0 . chunkToTokens (Proxy :: Proxy s)     step a c = a * 10 + fromIntegral (Char.digitToInt c) {-# INLINE decimal_ #-} @@ -396,7 +395,7 @@     <$> takeWhile1P Nothing isBinDigit     <?> "binary integer"   where-    mkNum = foldl' step 0 . chunkToTokens (Proxy :: Proxy s)+    mkNum = fromInteger . Data.List.foldl' step 0 . chunkToTokens (Proxy :: Proxy s)     step a c = a * 2 + fromIntegral (Char.digitToInt c)     isBinDigit x = x == '0' || x == '1' {-# INLINEABLE binary #-}@@ -424,7 +423,7 @@     <$> takeWhile1P Nothing Char.isOctDigit     <?> "octal integer"   where-    mkNum = foldl' step 0 . chunkToTokens (Proxy :: Proxy s)+    mkNum = fromInteger . Data.List.foldl' step 0 . chunkToTokens (Proxy :: Proxy s)     step a c = a * 8 + fromIntegral (Char.digitToInt c) {-# INLINEABLE octal #-} @@ -451,7 +450,7 @@     <$> takeWhile1P Nothing Char.isHexDigit     <?> "hexadecimal integer"   where-    mkNum = foldl' step 0 . chunkToTokens (Proxy :: Proxy s)+    mkNum = fromInteger . Data.List.foldl' step 0 . chunkToTokens (Proxy :: Proxy s)     step a c = a * 16 + fromIntegral (Char.digitToInt c) {-# INLINEABLE hexadecimal #-} @@ -511,7 +510,7 @@   m SP dotDecimal_ pxy c' = do   void (C.char '.')-  let mkNum = foldl' step (SP c' 0) . chunkToTokens pxy+  let mkNum = Data.List.foldl' step (SP c' 0) . chunkToTokens pxy       step (SP a e') c =         SP           (a * 10 + fromIntegral (Char.digitToInt c))

@@ -37,6 +37,7 @@ import qualified Control.Monad.Trans.Writer.Strict as S import Data.Set (Set) import Text.Megaparsec.Error+import {-# SOURCE #-} Text.Megaparsec.Internal (Reply) import Text.Megaparsec.State import Text.Megaparsec.Stream @@ -125,7 +126,7 @@   -- to the point where the next object starts.   --   -- Note that if @r@ fails, the original error message is reported as if-  -- without 'withRecovery'. In no way recovering parser @r@ can influence+  -- without 'withRecovery'. In no way can the recovering parser @r@ influence   -- error messages.   --   -- @since 4.4.0@@ -244,7 +245,7 @@     m (Tokens s)    -- | Extract the specified number of tokens from the input stream and-  -- return them packed as a chunk of stream. If there is not enough tokens+  -- return them packed as a chunk of stream. If there are not enough tokens   -- in the stream, a parse error will be signaled. It's guaranteed that if   -- the parser succeeds, the requested number of tokens will be returned.   --@@ -272,10 +273,17 @@   -- | @'updateParserState' f@ applies the function @f@ to the parser state.   updateParserState :: (State s e -> State s e) -> m () +  -- | An escape hatch for defining custom 'MonadParsec' primitives. You+  -- will need to import "Text.Megaparsec.Internal" in order to construct+  -- 'Reply'.+  --+  -- @since 9.4.0+  mkParsec :: (State s e -> Reply e s a) -> m a+ ---------------------------------------------------------------------------- -- Lifting through MTL -instance MonadParsec e s m => MonadParsec e s (L.StateT st m) where+instance (MonadParsec e s m) => MonadParsec e s (L.StateT st m) where   parseError e = lift (parseError e)   label n (L.StateT m) = L.StateT $ label n . m   try (L.StateT m) = L.StateT $ try . m@@ -295,8 +303,9 @@   takeP l n = lift (takeP l n)   getParserState = lift getParserState   updateParserState f = lift (updateParserState f)+  mkParsec f = lift (mkParsec f) -instance MonadParsec e s m => MonadParsec e s (S.StateT st m) where+instance (MonadParsec e s m) => MonadParsec e s (S.StateT st m) where   parseError e = lift (parseError e)   label n (S.StateT m) = S.StateT $ label n . m   try (S.StateT m) = S.StateT $ try . m@@ -316,8 +325,9 @@   takeP l n = lift (takeP l n)   getParserState = lift getParserState   updateParserState f = lift (updateParserState f)+  mkParsec f = lift (mkParsec f) -instance MonadParsec e s m => MonadParsec e s (L.ReaderT r m) where+instance (MonadParsec e s m) => MonadParsec e s (L.ReaderT r m) where   parseError e = lift (parseError e)   label n (L.ReaderT m) = L.ReaderT $ label n . m   try (L.ReaderT m) = L.ReaderT $ try . m@@ -334,6 +344,7 @@   takeP l n = lift (takeP l n)   getParserState = lift getParserState   updateParserState f = lift (updateParserState f)+  mkParsec f = lift (mkParsec f)  instance (Monoid w, MonadParsec e s m) => MonadParsec e s (L.WriterT w m) where   parseError e = lift (parseError e)@@ -359,6 +370,7 @@   takeP l n = lift (takeP l n)   getParserState = lift getParserState   updateParserState f = lift (updateParserState f)+  mkParsec f = lift (mkParsec f)  instance (Monoid w, MonadParsec e s m) => MonadParsec e s (S.WriterT w m) where   parseError e = lift (parseError e)@@ -384,6 +396,7 @@   takeP l n = lift (takeP l n)   getParserState = lift getParserState   updateParserState f = lift (updateParserState f)+  mkParsec f = lift (mkParsec f)  -- | @since 5.2.0 instance (Monoid w, MonadParsec e s m) => MonadParsec e s (L.RWST r w st m) where@@ -408,6 +421,7 @@   takeP l n = lift (takeP l n)   getParserState = lift getParserState   updateParserState f = lift (updateParserState f)+  mkParsec f = lift (mkParsec f)  -- | @since 5.2.0 instance (Monoid w, MonadParsec e s m) => MonadParsec e s (S.RWST r w st m) where@@ -432,8 +446,9 @@   takeP l n = lift (takeP l n)   getParserState = lift getParserState   updateParserState f = lift (updateParserState f)+  mkParsec f = lift (mkParsec f) -instance MonadParsec e s m => MonadParsec e s (IdentityT m) where+instance (MonadParsec e s m) => MonadParsec e s (IdentityT m) where   parseError e = lift (parseError e)   label n (IdentityT m) = IdentityT $ label n m   try = IdentityT . try . runIdentityT@@ -451,13 +466,14 @@   takeP l n = lift (takeP l n)   getParserState = lift getParserState   updateParserState f = lift $ updateParserState f+  mkParsec f = lift (mkParsec f)  fixs :: s -> Either a (b, s) -> (Either a b, s) fixs s (Left a) = (Left a, s) fixs _ (Right (b, s)) = (Right b, s) {-# INLINE fixs #-} -fixs' :: Monoid w => s -> Either a (b, s, w) -> (Either a b, s, w)+fixs' :: (Monoid w) => s -> Either a (b, s, w) -> (Either a b, s, w) fixs' s (Left a) = (Left a, s, mempty) fixs' _ (Right (b, s, w)) = (Right b, s, w) {-# INLINE fixs' #-}

@@ -25,7 +25,7 @@ import Text.Megaparsec  -- | A synonym for 'chunk'.-string :: MonadParsec e s m => Tokens s -> m (Tokens s)+string :: (MonadParsec e s m) => Tokens s -> m (Tokens s) string = chunk {-# INLINE string #-} 

@@ -1,4 +1,6 @@ {-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE Unsafe #-} @@ -15,109 +17,235 @@ -- -- @since 7.0.0 module Text.Megaparsec.Debug-  ( dbg,+  ( MonadParsecDbg (..),     dbg',   ) where +import Control.Monad.Identity (IdentityT, mapIdentityT)+import qualified Control.Monad.Trans.RWS.Lazy as L+import qualified Control.Monad.Trans.RWS.Strict as S+import qualified Control.Monad.Trans.Reader as L+import qualified Control.Monad.Trans.State.Lazy as L+import qualified Control.Monad.Trans.State.Strict as S+import qualified Control.Monad.Trans.Writer.Lazy as L+import qualified Control.Monad.Trans.Writer.Strict as S+import Data.Bifunctor (Bifunctor (first))+import qualified Data.List as List import qualified Data.List.NonEmpty as NE import Data.Proxy+import qualified Data.Set as E import Debug.Trace+import Text.Megaparsec.Class (MonadParsec) import Text.Megaparsec.Error import Text.Megaparsec.Internal import Text.Megaparsec.State import Text.Megaparsec.Stream --- | @'dbg' label p@ parser works exactly like @p@, but when it's evaluated--- it 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.+-- | Type class describing parser monads that can trace during evaluation. ----- 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.+-- @since 9.3.0+class (MonadParsec e s m) => MonadParsecDbg e s m where+  -- | @'dbg' label p@ parser works exactly like @p@, but when it's evaluated+  -- it 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.+  --+  -- __Note__: up until the version /9.3.0/ this was a non-polymorphic+  -- function that worked only in 'ParsecT'. It was first introduced in the+  -- version /7.0.0/.+  dbg ::+    (Show a) =>+    -- | Debugging label+    String ->+    -- | Parser to debug+    m a ->+    -- | Parser that prints debugging messages+    m a++-- | @dbg (p :: StateT st m)@ prints state __after__ running @p@: ----- The output itself is pretty self-explanatory, although the following--- abbreviations should be clarified (they are derived from the low-level--- source code):+-- >>> p = modify succ >> dbg "a" (single 'a' >> modify succ)+-- >>> parseTest (runStateT p 0) "a"+-- a> IN: 'a'+-- a> MATCH (COK): 'a'+-- a> VALUE: () (STATE: 2)+-- ((),2)+instance+  (Show st, MonadParsecDbg e s m) =>+  MonadParsecDbg e s (L.StateT st m)+  where+  dbg str sma = L.StateT $ \s ->+    dbgWithComment "STATE" str $ L.runStateT sma s++-- | @dbg (p :: StateT st m)@ prints state __after__ running @p@: -----     * @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.+-- >>> p = modify succ >> dbg "a" (single 'a' >> modify succ)+-- >>> parseTest (runStateT p 0) "a"+-- a> IN: 'a'+-- a> MATCH (COK): 'a'+-- a> VALUE: () (STATE: 2)+-- ((),2)+instance+  (Show st, MonadParsecDbg e s m) =>+  MonadParsecDbg e s (S.StateT st m)+  where+  dbg str sma = S.StateT $ \s ->+    dbgWithComment "STATE" str $ S.runStateT sma s++instance+  (MonadParsecDbg e s m) =>+  MonadParsecDbg e s (L.ReaderT r m)+  where+  dbg = L.mapReaderT . dbg++-- | @dbg (p :: WriterT st m)@ prints __only__ log produced by @p@: ----- 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 'Text.Megaparsec.MonadParsec' in--- general.-dbg ::-  forall e s m a.-  ( VisualStream s,-    ShowErrorComponent e,-    Show a-  ) =>-  -- | Debugging label-  String ->-  -- | Parser to debug-  ParsecT e s m a ->-  -- | Parser that prints debugging messages-  ParsecT e s m a-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'+-- >>> p = tell [0] >> dbg "a" (single 'a' >> tell [1])+-- >>> parseTest (runWriterT p) "a"+-- a> IN: 'a'+-- a> MATCH (COK): 'a'+-- a> VALUE: () (LOG: [1])+-- ((),[0,1])+instance+  (Monoid w, Show w, MonadParsecDbg e s m) =>+  MonadParsecDbg e s (L.WriterT w m)+  where+  dbg str wma = L.WriterT $ dbgWithComment "LOG" str $ L.runWriterT wma --- | Just like 'dbg', but doesn't require the return value of the parser to--- be 'Show'-able.+-- | @dbg (p :: WriterT st m)@ prints __only__ log produced by @p@: ----- @since 9.1.0-dbg' ::-  forall e s m a.-  ( VisualStream s,-    ShowErrorComponent e-  ) =>-  -- | Debugging label+-- >>> p = tell [0] >> dbg "a" (single 'a' >> tell [1])+-- >>> parseTest (runWriterT p) "a"+-- a> IN: 'a'+-- a> MATCH (COK): 'a'+-- a> VALUE: () (LOG: [1])+-- ((),[0,1])+instance+  (Monoid w, Show w, MonadParsecDbg e s m) =>+  MonadParsecDbg e s (S.WriterT w m)+  where+  dbg str wma = S.WriterT $ dbgWithComment "LOG" str $ S.runWriterT wma++-- | @RWST@ works like @StateT@ inside a @WriterT@: subparser's log and its+-- final state is printed:+--+-- >>> p = tell [0] >> modify succ >> dbg "a" (single 'a' >> tell [1] >> modify succ)+-- >>> parseTest (runRWST p () 0) "a"+-- a> IN: 'a'+-- a> MATCH (COK): 'a'+-- a> VALUE: () (STATE: 2) (LOG: [1])+-- ((),2,[0,1])+instance+  (Monoid w, Show w, Show st, MonadParsecDbg e s m) =>+  MonadParsecDbg e s (L.RWST r w st m)+  where+  dbg str sma = L.RWST $ \r s -> do+    let smth =+          (\(a, st, w) -> ShowComment "LOG" (ShowComment "STATE" (a, st), w))+            <$> L.runRWST sma r s+    ((a, st), w) <- first unComment . unComment <$> dbg str smth+    pure (a, st, w)++-- | @RWST@ works like @StateT@ inside a @WriterT@: subparser's log and its+-- final state is printed:+--+-- >>> p = tell [0] >> modify succ >> dbg "a" (single 'a' >> tell [1] >> modify succ)+-- >>> parseTest (runRWST p () 0) "a"+-- a> IN: 'a'+-- a> MATCH (COK): 'a'+-- a> VALUE: () (STATE: 2) (LOG: [1])+-- ((),2,[0,1])+instance+  (Monoid w, Show w, Show st, MonadParsecDbg e s m) =>+  MonadParsecDbg e s (S.RWST r w st m)+  where+  dbg str sma = S.RWST $ \r s -> do+    let smth =+          (\(a, st, w) -> ShowComment "LOG" (ShowComment "STATE" (a, st), w))+            <$> S.runRWST sma r s+    ((a, st), w) <- first unComment . unComment <$> dbg str smth+    pure (a, st, w)++instance (MonadParsecDbg e s m) => MonadParsecDbg e s (IdentityT m) where+  dbg = mapIdentityT . dbg++-- | @'dbgWithComment' label_a label_c m@ traces the first component of the+-- result produced by @m@ with @label_a@ and the second component with+-- @label_b@.+dbgWithComment ::+  (MonadParsecDbg e s m, Show a, Show c) =>+  -- | Debugging label (for @a@)   String ->+  -- | Extra component label (for @c@)+  String ->   -- | Parser to debug-  ParsecT e s m a ->+  m (a, c) ->   -- | Parser that prints debugging messages-  ParsecT e s m a-dbg' lbl p = unBlind <$> dbg lbl (Blind <$> p)+  m (a, c)+dbgWithComment lbl str ma =+  unComment <$> dbg str (ShowComment lbl <$> ma) --- | A wrapper type with a dummy 'Show' instance.-newtype Blind x = Blind {unBlind :: x}+-- | A wrapper with a special show instance:+--+-- >>> show (ShowComment "STATE" ("Hello, world!", 42))+-- Hello, world! (STATE: 42)+data ShowComment c a = ShowComment String (a, c) -instance Show (Blind x) where-  show _ = "NOT SHOWN"+unComment :: ShowComment c a -> (a, c)+unComment (ShowComment _ val) = val +instance (Show c, Show a) => Show (ShowComment c a) where+  show (ShowComment lbl (a, c)) = show a ++ " (" ++ lbl ++ ": " ++ show c ++ ")"++instance+  (VisualStream s, ShowErrorComponent e) =>+  MonadParsecDbg e s (ParsecT e s m)+  where+  dbg lbl p = ParsecT $ \s cok cerr eok eerr ->+    let l = dbgLog lbl+        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 hs)+        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 hs)+        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+  | DbgCOK [Token s] a (Hints (Token s))   | DbgCERR [Token s] (ParseError s e)-  | DbgEOK [Token s] a+  | DbgEOK [Token s] a (Hints (Token s))   | DbgEERR [Token s] (ParseError s e)  -- | Render a single piece of debugging info.@@ -134,20 +262,31 @@   where     prefix = unlines . fmap ((lbl ++ "> ") ++) . lines     pxy = Proxy :: Proxy s+    showHints hs = "[" ++ List.intercalate "," (showErrorItem pxy <$> E.toAscList hs) ++ "]"     msg = case item of       DbgIn ts ->         "IN: " ++ showStream pxy ts-      DbgCOK ts a ->-        "MATCH (COK): " ++ showStream pxy ts ++ "\nVALUE: " ++ show a+      DbgCOK ts a (Hints hs) ->+        "MATCH (COK): "+          ++ showStream pxy ts+          ++ "\nVALUE: "+          ++ show a+          ++ "\nHINTS: "+          ++ showHints hs       DbgCERR ts e ->         "MATCH (CERR): " ++ showStream pxy ts ++ "\nERROR:\n" ++ parseErrorPretty e-      DbgEOK ts a ->-        "MATCH (EOK): " ++ showStream pxy ts ++ "\nVALUE: " ++ show a+      DbgEOK ts a (Hints hs) ->+        "MATCH (EOK): "+          ++ showStream pxy ts+          ++ "\nVALUE: "+          ++ show a+          ++ "\nHINTS: "+          ++ showHints hs       DbgEERR ts e ->         "MATCH (EERR): " ++ showStream pxy ts ++ "\nERROR:\n" ++ parseErrorPretty e  -- | Pretty-print a list of tokens.-showStream :: VisualStream s => Proxy s -> [Token s] -> String+showStream :: (VisualStream s) => Proxy s -> [Token s] -> String showStream pxy ts =   case NE.nonEmpty ts of     Nothing -> "<EMPTY>"@@ -167,8 +306,28 @@ 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 :: 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++-- | Just like 'dbg', but doesn't require the return value of the parser to+-- be 'Show'-able.+--+-- @since 9.1.0+dbg' ::+  (MonadParsecDbg e s m) =>+  -- | Debugging label+  String ->+  -- | Parser to debug+  m a ->+  -- | Parser that prints debugging messages+  m a+dbg' lbl p = unBlind <$> dbg lbl (Blind <$> p)++-- | A wrapper type with a dummy 'Show' instance.+newtype Blind x = Blind {unBlind :: x}++instance Show (Blind x) where+  show _ = "NOT SHOWN"

@@ -41,11 +41,15 @@     -- * Pretty-printing     ShowErrorComponent (..),     errorBundlePretty,+    errorBundlePrettyForGhcPreProcessors,+    errorBundlePrettyWith,     parseErrorPretty,     parseErrorTextPretty,+    showErrorItem,   ) where +import Control.Arrow ((>>>)) import Control.DeepSeq import Control.Exception import Control.Monad.State.Strict@@ -63,6 +67,7 @@ import Text.Megaparsec.Pos import Text.Megaparsec.State import Text.Megaparsec.Stream+import qualified Text.Megaparsec.Unicode as Unicode  ---------------------------------------------------------------------------- -- Parse error type@@ -78,9 +83,9 @@     Label (NonEmpty Char)   | -- | End of input     EndOfInput-  deriving (Show, Read, Eq, Ord, Data, Typeable, Generic, Functor)+  deriving (Show, Read, Eq, Ord, Data, Generic, Functor) -instance NFData t => NFData (ErrorItem t)+instance (NFData t) => NFData (ErrorItem t)  -- | Additional error data, extendable by user. When no custom data is -- necessary, the type is typically indexed by 'Void' to “cancel” the@@ -96,9 +101,9 @@     ErrorIndentation Ordering Pos Pos   | -- | Custom error data     ErrorCustom e-  deriving (Show, Read, Eq, Ord, Data, Typeable, Generic, Functor)+  deriving (Show, Read, Eq, Ord, Data, Generic, Functor) -instance NFData a => NFData (ErrorFancy a) where+instance (NFData a) => NFData (ErrorFancy a) where   rnf (ErrorFail str) = rnf str   rnf (ErrorIndentation ord ref act) = ord `seq` rnf ref `seq` rnf act   rnf (ErrorCustom a) = rnf a@@ -124,7 +129,7 @@     --     -- Type of the first argument was changed in the version /7.0.0/.     FancyError Int (Set (ErrorFancy e))-  deriving (Typeable, Generic)+  deriving (Generic)  deriving instance   ( Show (Token s),@@ -163,8 +168,7 @@   {-# INLINE mappend #-}  instance-  ( Show s,-    Show (Token s),+  ( Show (Token s),     Show e,     ShowErrorComponent e,     VisualStream s,@@ -180,7 +184,7 @@ -- -- @since 7.0.0 mapParseError ::-  Ord e' =>+  (Ord e') =>   (e -> e') ->   ParseError s e ->   ParseError s e'@@ -265,13 +269,6 @@   Eq (ParseErrorBundle s e)  deriving instance-  ( Typeable s,-    Typeable (Token s),-    Typeable e-  ) =>-  Typeable (ParseErrorBundle s e)--deriving instance   ( Data s,     Data (Token s),     Ord (Token s),@@ -332,7 +329,7 @@ -- | The type class defines how to print a custom component of 'ParseError'. -- -- @since 5.0.0-class Ord a => ShowErrorComponent a where+class (Ord a) => ShowErrorComponent a where   -- | Pretty-print a component of 'ParseError'.   showErrorComponent :: a -> String @@ -347,24 +344,24 @@   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 pass over the input stream. The rendered 'String'--- always ends with a newline.+-- be pretty-printed in order, by applying a provided format function, with+-- a single pass over the input stream. ----- @since 7.0.0-errorBundlePretty ::+-- @since 9.7.0+errorBundlePrettyWith ::   forall s e.   ( VisualStream s,-    TraversableStream s,-    ShowErrorComponent e+    TraversableStream s   ) =>+  -- | Format function for a single 'ParseError'+  (Maybe String -> SourcePos -> ParseError s e -> String) ->   -- | Parse error bundle to display   ParseErrorBundle s e ->   -- | Textual rendition of the bundle   String-errorBundlePretty ParseErrorBundle {..} =+errorBundlePrettyWith format ParseErrorBundle {..} =   let (r, _) = foldl f (id, bundlePosState) bundleErrors-   in drop 1 (r "")+   in r ""   where     f ::       (ShowS, PosState s) ->@@ -374,6 +371,33 @@       where         (msline, pst') = reachOffset (errorOffset e) pst         epos = pstateSourcePos pst'+        outChunk = format msline epos e++-- | 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 pass over the input stream. The rendered 'String'+-- always ends with a newline.+--+-- @since 7.0.0+errorBundlePretty ::+  forall s e.+  ( VisualStream s,+    TraversableStream s,+    ShowErrorComponent e+  ) =>+  -- | Parse error bundle to display+  ParseErrorBundle s e ->+  -- | Textual rendition of the bundle+  String+errorBundlePretty = drop 1 . errorBundlePrettyWith format+  where+    format ::+      Maybe String ->+      SourcePos ->+      ParseError s e ->+      String+    format msline epos e = outChunk+      where         outChunk =           "\n"             <> sourcePosPretty epos@@ -391,12 +415,12 @@                   pointerLen =                     if rpshift + elen > slineLen                       then slineLen - rpshift + 1-                      else elen+                      else max 1 elen                   pointer = replicate pointerLen '^'                   lineNumber = (show . unPos . sourceLine) epos                   padding = replicate (length lineNumber + 1) ' '                   rpshift = unPos (sourceColumn epos) - 1-                  slineLen = length sline+                  slineLen = Unicode.stringLength sline                in padding                     <> "|\n"                     <> lineNumber@@ -416,6 +440,41 @@             FancyError _ xs ->               E.foldl' (\a b -> max a (errorFancyLength b)) 1 xs +-- | Pretty-print a 'ParseErrorBundle'. All 'ParseError's in the bundle will+-- be pretty-printed in order by doing a single pass over the input stream.+--+-- The rendered format is suitable for custom GHC pre-processors (as can be+-- specified with -F -pgmF).+--+-- @since 9.7.0+errorBundlePrettyForGhcPreProcessors ::+  forall s e.+  ( VisualStream s,+    TraversableStream s,+    ShowErrorComponent e+  ) =>+  -- | Parse error bundle to display+  ParseErrorBundle s e ->+  -- | Textual rendition of the bundle+  String+errorBundlePrettyForGhcPreProcessors = errorBundlePrettyWith format+  where+    format ::+      Maybe String ->+      SourcePos ->+      ParseError s e ->+      String+    format _msline epos e =+      sourcePosPretty epos+        <> ":"+        <> indent (parseErrorTextPretty e)++    indent :: String -> String+    indent =+      lines >>> \case+        [err] -> err+        err -> intercalate "\n" $ map (" " <>) err+ -- | Pretty-print a 'ParseError'. The rendered 'String' always ends with a -- newline. --@@ -458,20 +517,22 @@ -- Helpers  -- | Pretty-print an 'ErrorItem'.-showErrorItem :: VisualStream s => Proxy s -> ErrorItem (Token s) -> String+--+-- @since 9.4.0+showErrorItem :: (VisualStream s) => Proxy s -> ErrorItem (Token s) -> String showErrorItem pxy = \case   Tokens ts -> showTokens pxy ts   Label label -> NE.toList label   EndOfInput -> "end of input"  -- | Get length of the “pointer” to display under a given 'ErrorItem'.-errorItemLength :: VisualStream s => Proxy s -> ErrorItem (Token s) -> Int+errorItemLength :: (VisualStream s) => Proxy s -> ErrorItem (Token s) -> Int errorItemLength pxy = \case   Tokens ts -> tokensLength pxy ts   _ -> 1  -- | Pretty-print an 'ErrorFancy'.-showErrorFancy :: ShowErrorComponent e => ErrorFancy e -> String+showErrorFancy :: (ShowErrorComponent e) => ErrorFancy e -> String showErrorFancy = \case   ErrorFail msg -> msg   ErrorIndentation ord ref actual ->@@ -489,7 +550,7 @@   ErrorCustom a -> showErrorComponent a  -- | Get length of the “pointer” to display under a given 'ErrorFancy'.-errorFancyLength :: ShowErrorComponent e => ErrorFancy e -> Int+errorFancyLength :: (ShowErrorComponent e) => ErrorFancy e -> Int errorFancyLength = \case   ErrorCustom a -> errorComponentLen a   _ -> 1

@@ -47,7 +47,6 @@ import Data.Proxy import Data.Set (Set) import qualified Data.Set as E-import Data.Typeable (Typeable) import GHC.Generics import Text.Megaparsec.Error import Text.Megaparsec.Stream@@ -57,11 +56,11 @@  -- | Auxiliary type for construction of trivial parse errors. data ET s = ET (Maybe (ErrorItem (Token s))) (Set (ErrorItem (Token s)))-  deriving (Typeable, Generic)+  deriving (Generic) -deriving instance Eq (Token s) => Eq (ET s)+deriving instance (Eq (Token s)) => Eq (ET s) -deriving instance Ord (Token s) => Ord (ET s)+deriving instance (Ord (Token s)) => Ord (ET s)  deriving instance   ( Data s,@@ -70,7 +69,7 @@   ) =>   Data (ET s) -instance Stream s => Semigroup (ET s) where+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@@ -78,18 +77,18 @@       n Nothing (Just y) = Just y       n (Just x) (Just y) = Just (max x y) -instance Stream s => Monoid (ET s) where+instance (Stream s) => Monoid (ET s) where   mempty = ET Nothing E.empty   mappend = (<>)  -- | Auxiliary type for construction of fancy parse errors. newtype EF e = EF (Set (ErrorFancy e))-  deriving (Eq, Ord, Data, Typeable, Generic)+  deriving (Eq, Ord, Data, Generic) -instance Ord e => Semigroup (EF e) where+instance (Ord e) => Semigroup (EF e) where   EF xs0 <> EF xs1 = EF (E.union xs0 xs1) -instance Ord e => Monoid (EF e) where+instance (Ord e) => Monoid (EF e) where   mempty = EF E.empty   mappend = (<>) @@ -122,43 +121,43 @@ -- Error components  -- | Construct an “unexpected token” error component.-utok :: Stream s => Token s -> ET s+utok :: Token s -> ET s utok = unexp . Tokens . nes  -- | Construct an “unexpected tokens” error component. Empty chunk produces -- 'EndOfInput'.-utoks :: forall s. Stream s => Tokens s -> ET s+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 :: Stream s => String -> ET s+ulabel :: String -> ET s ulabel label   | label == "" = error "Text.Megaparsec.Error.Builder.ulabel: empty label"   | otherwise = unexp . Label . NE.fromList $ label  -- | Construct an “unexpected end of input” error component.-ueof :: Stream s => ET s+ueof :: ET s ueof = unexp EndOfInput  -- | Construct an “expected token” error component.-etok :: Stream s => Token s -> ET s+etok :: Token s -> ET s etok = expe . Tokens . nes  -- | Construct an “expected tokens” error component. Empty chunk produces -- 'EndOfInput'.-etoks :: forall s. Stream s => Tokens s -> ET s+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 :: Stream s => String -> ET s+elabel :: String -> ET s elabel label   | label == "" = error "Text.Megaparsec.Error.Builder.elabel: empty label"   | otherwise = expe . Label . NE.fromList $ label  -- | Construct an “expected end of input” error component.-eeof :: Stream s => ET s+eeof :: ET s eeof = expe EndOfInput  -- | Construct a custom error component.@@ -171,7 +170,7 @@ -- | Construct the appropriate 'ErrorItem' representation for the given -- token stream. The empty string produces 'EndOfInput'. canonicalizeTokens ::-  Stream s =>+  (Stream s) =>   Proxy s ->   Tokens s ->   ErrorItem (Token s)@@ -181,11 +180,11 @@     Just xs -> Tokens xs  -- | Lift an unexpected item into 'ET'.-unexp :: Stream s => ErrorItem (Token s) -> ET s+unexp :: ErrorItem (Token s) -> ET s unexp u = ET (pure u) E.empty  -- | Lift an expected item into 'ET'.-expe :: Stream s => ErrorItem (Token s) -> ET s+expe :: ErrorItem (Token s) -> ET s expe p = ET Nothing (E.singleton p)  -- | Make a singleton non-empty list from a value.

@@ -1,3 +1,4 @@+{-# LANGUAGE DeriveFunctor #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE LambdaCase #-}@@ -5,6 +6,7 @@ {-# LANGUAGE RankNTypes #-} {-# LANGUAGE Safe #-} {-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TupleSections #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeOperators #-} {-# LANGUAGE UndecidableInstances #-}@@ -36,7 +38,7 @@     toHints,     withHints,     accHints,-    refreshLastHint,+    refreshHints,     runParsecT,     withParsecT,   )@@ -44,6 +46,7 @@  import Control.Applicative import Control.Monad+import qualified Control.Monad.Combinators import Control.Monad.Cont.Class import Control.Monad.Error.Class import qualified Control.Monad.Fail as Fail@@ -52,6 +55,7 @@ import Control.Monad.Reader.Class import Control.Monad.State.Class import Control.Monad.Trans+import Control.Monad.Writer.Class import Data.List.NonEmpty (NonEmpty (..)) import qualified Data.List.NonEmpty as NE import Data.Proxy@@ -85,20 +89,22 @@ -- 1:2: -- unexpected 'a' -- expecting 'r' or end of input-newtype Hints t = Hints [Set (ErrorItem t)]+newtype Hints t = Hints (Set (ErrorItem t)) -instance Semigroup (Hints t) where+instance (Ord t) => Semigroup (Hints t) where   Hints xs <> Hints ys = Hints $ xs <> ys -instance Monoid (Hints t) where+instance (Ord t) => Monoid (Hints t) where   mempty = Hints mempty  -- | All information available after parsing. This includes consumption of -- input, success (with the returned value) or failure (with the parse--- error), and parser state at the end of parsing.+-- error), and parser state at the end of parsing. 'Reply' can also be used+-- to resume parsing. -- -- See also: 'Consumption', 'Result'. data Reply e s a = Reply (State s e) Consumption (Result s e a)+  deriving (Functor)  -- | Whether the input has been consumed or not. --@@ -107,17 +113,18 @@   = -- | Some part of input stream was consumed     Consumed   | -- | No input was consumed-    Virgin+    NotConsumed  -- | Whether the parser has failed or not. On success we include the -- resulting value, on failure we include a 'ParseError'. -- -- See also: 'Consumption', 'Reply'. data Result s e a-  = -- | Parser succeeded-    OK a+  = -- | Parser succeeded (includes hints)+    OK (Hints (Token s)) a   | -- | Parser failed     Error (ParseError s e)+  deriving (Functor)  -- | @'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@.@@ -164,18 +171,20 @@ {-# INLINE pMap #-}  -- | 'pure' returns a parser that __succeeds__ without consuming input.-instance Stream s => Applicative (ParsecT e s m) where+instance (Stream s) => Applicative (ParsecT e s m) where   pure = pPure   (<*>) = pAp   p1 *> p2 = p1 `pBind` const p2+  {-# INLINE (*>) #-}   p1 <* p2 = do x1 <- p1; void p2; return x1+  {-# INLINE (<*) #-} -pPure :: a -> ParsecT e s m a+pPure :: (Stream s) => a -> ParsecT e s m a pPure x = ParsecT $ \s _ _ eok _ -> eok x s mempty {-# INLINE pPure #-}  pAp ::-  Stream s =>+  (Stream s) =>   ParsecT e s m (a -> b) ->   ParsecT e s m a ->   ParsecT e s m b@@ -203,14 +212,16 @@ instance (Ord e, Stream s) => Alternative (ParsecT e s m) where   empty = mzero   (<|>) = mplus+  many = Control.Monad.Combinators.many+  some = Control.Monad.Combinators.some  -- | 'return' returns a parser that __succeeds__ without consuming input.-instance Stream s => Monad (ParsecT e s m) where+instance (Stream s) => Monad (ParsecT e s m) where   return = pure   (>>=) = pBind  pBind ::-  Stream s =>+  (Stream s) =>   ParsecT e s m a ->   (a -> ParsecT e s m b) ->   ParsecT e s m b@@ -234,7 +245,7 @@    in unParser m s mcok cerr meok eerr {-# INLINE pBind #-} -instance Stream s => Fail.MonadFail (ParsecT e s m) where+instance (Stream s) => Fail.MonadFail (ParsecT e s m) where   fail = pFail  pFail :: String -> ParsecT e s m a@@ -248,44 +259,82 @@  instance (Stream s, MonadReader r m) => MonadReader r (ParsecT e s m) where   ask = lift ask-  local f p = mkPT $ \s -> local f (runParsecT p s)+  local f = hoistP (local f)  instance (Stream s, MonadState st m) => MonadState st (ParsecT e s m) where   get = lift get   put = lift . put +hoistP ::+  (Monad m) =>+  (m (Reply e s a) -> m (Reply e s b)) ->+  ParsecT e s m a ->+  ParsecT e s m b+hoistP h p = mkParsecT (h . runParsecT p)++-- | @since 9.5.0+instance (Stream s, MonadWriter w m) => MonadWriter w (ParsecT e s m) where+  tell w = lift (tell w)+  listen = hoistP (fmap (\(repl, w) -> fmap (,w) repl) . listen)+  pass = hoistP $ \m -> pass $ do+    Reply st consumption r <- m+    let (r', ww') = case r of+          OK hs (x, ww) -> (OK hs x, ww)+          Error e -> (Error e, id)+    return (Reply st consumption r', ww')+ instance (Stream s, MonadCont m) => MonadCont (ParsecT e s m) where-  callCC f = mkPT $ \s ->+  callCC f = mkParsecT $ \s ->     callCC $ \c ->-      runParsecT (f (\a -> mkPT $ \s' -> c (pack s' a))) s+      runParsecT (f (\a -> mkParsecT $ \s' -> c (pack s' a))) s     where-      pack s a = Reply s Virgin (OK a)+      pack s a = Reply s NotConsumed (OK mempty a)  instance (Stream s, MonadError e' m) => MonadError e' (ParsecT e s m) where   throwError = lift . throwError-  p `catchError` h = mkPT $ \s ->+  p `catchError` h = mkParsecT $ \s ->     runParsecT p s `catchError` \e ->       runParsecT (h e) s -mkPT :: Monad m => (State s e -> m (Reply e s a)) -> ParsecT e s m a-mkPT k = ParsecT $ \s cok cerr eok eerr -> do+mkParsecT ::+  (Monad m) =>+  (State s e -> m (Reply e s a)) ->+  ParsecT e s m a+mkParsecT k = ParsecT $ \s cok cerr eok eerr -> do   (Reply s' consumption result) <- k s   case consumption of     Consumed ->       case result of-        OK x -> cok x s' mempty+        OK hs x -> cok x s' hs         Error e -> cerr e s'-    Virgin ->+    NotConsumed ->       case result of-        OK x -> eok x s' mempty+        OK hs x -> eok x s' hs         Error e -> eerr e s'+{-# INLINE mkParsecT #-} +pmkParsec ::+  (State s e -> Reply e s a) ->+  ParsecT e s m a+pmkParsec k = ParsecT $ \s cok cerr eok eerr ->+  let (Reply s' consumption result) = k s+   in case consumption of+        Consumed ->+          case result of+            OK hs x -> cok x s' hs+            Error e -> cerr e s'+        NotConsumed ->+          case result of+            OK hs x -> eok x s' hs+            Error e -> eerr e s'+{-# INLINE pmkParsec #-}+ -- | 'mzero' is a parser that __fails__ without consuming input. -- -- __Note__: strictly speaking, this instance is unlawful. The right -- identity law does not hold, e.g. in general this is not true: ----- > v >> mzero = mero+-- > v >> mzero = mzero -- -- However the following holds: --@@ -308,9 +357,32 @@   let meerr err ms =         let ncerr err' s' = cerr (err' <> err) (longestMatch ms s')             neok x s' hs = eok x s' (toHints (stateOffset s') err <> hs)-            neerr err' s' = eerr (err' <> err) (longestMatch ms s')+            neerr err' s' =+              let combinedErr = combineErrors (stateOffset s) err err'+               in eerr combinedErr (longestMatch ms s')          in unParser n s cok ncerr neok neerr    in unParser m s cok cerr eok meerr+  where+    combineErrors altOffset e1 e2 = case (e1, e2) of+      (TrivialError o1 u1 p1, TrivialError o2 u2 p2) ->+        -- When merging alternative errors, if one is ahead due to try, we+        -- bring both to the alternative position and union their expected+        -- tokens.+        if o1 > altOffset || o2 > altOffset+          then+            -- At least one error is ahead, normalize to alt position. Only+            -- include expected tokens from errors at the alt position.+            let p1' = if o1 == altOffset then p1 else E.empty+                p2' = if o2 == altOffset then p2 else E.empty+                -- Use the unexpected from the error at alt position, or the+                -- furthest.+                unexp = case (o1 `compare` altOffset, o2 `compare` altOffset) of+                  (EQ, _) -> u1+                  (_, EQ) -> u2+                  _ -> if o1 >= o2 then u1 else u2+             in TrivialError altOffset unexp (E.union p1' p2')+          else e2 <> e1+      _ -> e2 <> e1 {-# INLINE pPlus #-}  -- | From two states, return the one with the greater number of processed@@ -326,13 +398,13 @@  -- | @since 6.0.0 instance (Stream s, MonadFix m) => MonadFix (ParsecT e s m) where-  mfix f = mkPT $ \s -> mfix $ \(~(Reply _ _ result)) -> do+  mfix f = mkParsecT $ \s -> mfix $ \(~(Reply _ _ result)) -> do     let a = case result of-          OK a' -> a'+          OK _ a' -> a'           Error _ -> error "mfix ParsecT"     runParsecT (f a) s -instance Stream s => MonadTrans (ParsecT e s) where+instance (Stream s) => MonadTrans (ParsecT e s) where   lift amb = ParsecT $ \s _ _ eok _ ->     amb >>= \a -> eok a s mempty @@ -352,6 +424,7 @@   takeP = pTakeP   getParserState = pGetParserState   updateParserState = pUpdateParserState+  mkParsec = pmkParsec  pParseError ::   ParseError s e ->@@ -364,9 +437,9 @@   let el = Label <$> NE.nonEmpty l       cok' x s' hs =         case el of-          Nothing -> cok x s' (refreshLastHint hs Nothing)+          Nothing -> cok x s' (refreshHints hs Nothing)           Just _ -> cok x s' hs-      eok' x s' hs = eok x s' (refreshLastHint hs el)+      eok' x s' hs = eok x s' (refreshHints hs el)       eerr' err = eerr $         case err of           (TrivialError pos us _) ->@@ -381,25 +454,25 @@    in unParser p s cok eerr' eok eerr' {-# INLINE pTry #-} -pLookAhead :: ParsecT e s m a -> ParsecT e s m a+pLookAhead :: (Stream s) => ParsecT e s m a -> ParsecT e s m a pLookAhead p = ParsecT $ \s _ cerr eok eerr ->   let eok' a _ _ = eok a s mempty    in unParser p s eok' cerr eok' eerr {-# INLINE pLookAhead #-} -pNotFollowedBy :: Stream s => ParsecT e s m a -> ParsecT e s m ()+pNotFollowedBy :: (Stream s) => ParsecT e s m a -> ParsecT e s m () pNotFollowedBy p = ParsecT $ \s@(State input o _ _) _ _ eok eerr ->   let what = maybe EndOfInput (Tokens . nes . fst) (take1_ input)-      unexpect u = TrivialError o (pure u) E.empty-      cok' _ _ _ = eerr (unexpect what) s+      unexpected u = TrivialError o (pure u) E.empty+      cok' _ _ _ = eerr (unexpected what) s       cerr' _ _ = eok () s mempty-      eok' _ _ _ = eerr (unexpect what) s+      eok' _ _ _ = eerr (unexpected what) s       eerr' _ _ = eok () s mempty    in unParser p s cok' cerr' eok' eerr' {-# INLINE pNotFollowedBy #-}  pWithRecovery ::-  Stream s =>+  (Stream s) =>   (ParseError s e -> ParsecT e s m a) ->   ParsecT e s m a ->   ParsecT e s m a@@ -420,7 +493,7 @@ {-# INLINE pWithRecovery #-}  pObserving ::-  Stream s =>+  (Stream s) =>   ParsecT e s m a ->   ParsecT e s m (Either (ParseError s e) a) pObserving p = ParsecT $ \s cok _ eok _ ->@@ -429,7 +502,7 @@    in unParser p s (cok . Right) cerr' (eok . Right) eerr' {-# INLINE pObserving #-} -pEof :: forall e s m. Stream s => ParsecT e s m ()+pEof :: forall e s m. (Stream s) => ParsecT e s m () pEof = ParsecT $ \s@(State input o pst de) _ _ eok eerr ->   case take1_ input of     Nothing -> eok () s mempty@@ -443,7 +516,7 @@  pToken ::   forall e s m a.-  Stream s =>+  (Stream s) =>   (Token s -> Maybe a) ->   Set (ErrorItem (Token s)) ->   ParsecT e s m a@@ -465,20 +538,20 @@  pTokens ::   forall e s m.-  Stream s =>+  (Stream s) =>   (Tokens s -> Tokens s -> Bool) ->   Tokens s ->   ParsecT e s m (Tokens s) pTokens f tts = ParsecT $ \s@(State input o pst de) cok _ eok eerr ->   let pxy = Proxy :: Proxy s-      unexpect pos' u =+      unexpected pos' u =         let us = pure u             ps = (E.singleton . Tokens . NE.fromList . chunkToTokens pxy) tts          in TrivialError pos' us ps       len = chunkLength pxy tts    in case takeN_ len input of         Nothing ->-          eerr (unexpect o EndOfInput) s+          eerr (unexpected o EndOfInput) s         Just (tts', input') ->           if f tts tts'             then@@ -488,12 +561,12 @@                     else cok tts' st mempty             else               let ps = (Tokens . NE.fromList . chunkToTokens pxy) tts'-               in eerr (unexpect o ps) (State input o pst de)+               in eerr (unexpected o ps) (State input o pst de) {-# INLINE pTokens #-}  pTakeWhileP ::   forall e s m.-  Stream s =>+  (Stream s) =>   Maybe String ->   (Token s -> Bool) ->   ParsecT e s m (Tokens s)@@ -504,7 +577,7 @@       hs =         case ml >>= NE.nonEmpty of           Nothing -> mempty-          Just l -> (Hints . pure . E.singleton . Label) l+          Just l -> (Hints . E.singleton . Label) l    in if chunkEmpty pxy ts         then eok ts (State input' (o + len) pst de) hs         else cok ts (State input' (o + len) pst de) hs@@ -512,7 +585,7 @@  pTakeWhile1P ::   forall e s m.-  Stream s =>+  (Stream s) =>   Maybe String ->   (Token s -> Bool) ->   ParsecT e s m (Tokens s)@@ -524,7 +597,7 @@       hs =         case el of           Nothing -> mempty-          Just l -> (Hints . pure . E.singleton) l+          Just l -> (Hints . E.singleton) l    in if chunkEmpty pxy ts         then           let us = pure $@@ -540,12 +613,13 @@  pTakeP ::   forall e s m.-  Stream s =>+  (Stream s) =>   Maybe String ->   Int ->   ParsecT e s m (Tokens s)-pTakeP ml n = ParsecT $ \s@(State input o pst de) cok _ _ eerr ->-  let pxy = Proxy :: Proxy s+pTakeP ml n' = ParsecT $ \s@(State input o pst de) cok _ _ eerr ->+  let n = max 0 n'+      pxy = Proxy :: Proxy s       el = Label <$> (ml >>= NE.nonEmpty)       ps = maybe E.empty E.singleton el    in case takeN_ n input of@@ -561,11 +635,11 @@                 else cok ts (State input' (o + len) pst de) mempty {-# INLINE pTakeP #-} -pGetParserState :: ParsecT e s m (State s e)+pGetParserState :: (Stream s) => ParsecT e s m (State s e) pGetParserState = ParsecT $ \s _ _ eok _ -> eok s s mempty {-# INLINE pGetParserState #-} -pUpdateParserState :: (State s e -> State s e) -> ParsecT e s m ()+pUpdateParserState :: (Stream s) => (State s e -> State s e) -> ParsecT e s m () pUpdateParserState f = ParsecT $ \s _ _ eok _ -> eok () (f s) mempty {-# INLINE pUpdateParserState #-} @@ -578,7 +652,7 @@  -- | Convert a 'ParseError' record into 'Hints'. toHints ::-  Stream s =>+  (Stream s) =>   -- | Current offset in input stream   Int ->   -- | Parse error to convert@@ -591,7 +665,7 @@     -- there might have been backtracking with 'try' and in that case we     -- must not convert such a parse error to hints.     if streamPos == errOffset-      then Hints (if E.null ps then [] else [ps])+      then Hints (if E.null ps then E.empty else ps)       else mempty   FancyError _ _ -> mempty {-# INLINE toHints #-}@@ -601,7 +675,7 @@ -- __Note__ that if resulting continuation gets 'ParseError' that has custom -- data in it, hints are ignored. withHints ::-  Stream s =>+  (Stream s) =>   -- | Hints to use   Hints (Token s) ->   -- | Continuation to influence@@ -613,34 +687,36 @@   m b withHints (Hints ps') c e =   case e of-    TrivialError pos us ps -> c (TrivialError pos us (E.unions (ps : ps')))+    TrivialError pos us ps -> c (TrivialError pos us (E.union ps ps'))     _ -> c e {-# INLINE withHints #-}  -- | @'accHints' hs c@ results in “OK” continuation that will add given -- hints @hs@ to third argument of original continuation @c@. accHints ::+  (Stream s) =>   -- | 'Hints' to add-  Hints t ->+  Hints (Token s) ->   -- | An “OK” continuation to alter-  (a -> State s e -> Hints t -> m b) ->+  (a -> State s e -> Hints (Token s) -> m b) ->   -- | Altered “OK” continuation-  (a -> State s e -> Hints t -> m b)+  (a -> State s e -> Hints (Token s) -> m b) accHints hs1 c x s hs2 = c x s (hs1 <> hs2) {-# INLINE accHints #-} --- | Replace the most recent group of hints (if any) with the given--- 'ErrorItem' (or delete it if 'Nothing' is given). This is used in the--- 'label' primitive.-refreshLastHint :: Hints t -> Maybe (ErrorItem t) -> Hints t-refreshLastHint (Hints []) _ = Hints []-refreshLastHint (Hints (_ : xs)) Nothing = Hints xs-refreshLastHint (Hints (_ : xs)) (Just m) = Hints (E.singleton m : xs)-{-# INLINE refreshLastHint #-}+-- | Replace the hints with the given 'ErrorItem' (or delete it if 'Nothing'+-- is given). This is used in the 'label' primitive.+refreshHints :: Hints t -> Maybe (ErrorItem t) -> Hints t+refreshHints (Hints _) Nothing = Hints E.empty+refreshHints (Hints hs) (Just m) =+  if E.null hs+    then Hints hs+    else Hints (E.singleton m)+{-# INLINE refreshHints #-}  -- | Low-level unpacking of the 'ParsecT' type. runParsecT ::-  Monad m =>+  (Monad m) =>   -- | Parser to run   ParsecT e s m a ->   -- | Initial state@@ -648,10 +724,10 @@   m (Reply e s a) runParsecT p s = unParser p s cok cerr eok eerr   where-    cok a s' _ = return $ Reply s' Consumed (OK a)+    cok a s' hs = return $ Reply s' Consumed (OK hs a)     cerr err s' = return $ Reply s' Consumed (Error err)-    eok a s' _ = return $ Reply s' Virgin (OK a)-    eerr err s' = return $ Reply s' Virgin (Error err)+    eok a s' hs = return $ Reply s' NotConsumed (OK hs a)+    eerr err s' = return $ Reply s' NotConsumed (Error err)  -- | Transform any custom errors thrown by the parser using the given -- function. Similar in function and purpose to @withExceptT@.@@ -664,7 +740,7 @@ -- @since 7.0.0 withParsecT ::   forall e e' s m a.-  (Monad m, Ord e') =>+  (Ord e') =>   (e -> e') ->   -- | Inner parser   ParsecT e s m a ->

@@ -0,0 +1,10 @@+{-# LANGUAGE RoleAnnotations #-}++module Text.Megaparsec.Internal+  ( Reply,+  )+where++type role Reply nominal nominal representational++data Reply e s a

@@ -56,7 +56,7 @@ -- 'space' will just move on or finish depending on whether there is more -- white space for it to consume. space ::-  MonadParsec e s m =>+  (MonadParsec e s m) =>   -- | A parser for space characters which does not accept empty   -- input (e.g. 'Text.Megaparsec.Char.space1')   m () ->@@ -78,7 +78,7 @@ -- > lexeme  = L.lexeme spaceConsumer -- > integer = lexeme L.decimal lexeme ::-  MonadParsec e s m =>+  (MonadParsec e s m) =>   -- | How to consume white space after lexeme   m () ->   -- | How to parse actual lexeme@@ -102,7 +102,7 @@ -- > colon     = symbol ":" -- > dot       = symbol "." symbol ::-  MonadParsec e s m =>+  (MonadParsec e s m) =>   -- | How to consume white space after lexeme   m () ->   -- | Symbol to parse

@@ -36,7 +36,6 @@ import Control.DeepSeq import Control.Exception import Data.Data (Data)-import Data.Typeable (Typeable) import GHC.Generics  ----------------------------------------------------------------------------@@ -49,7 +48,7 @@ -- -- @since 5.0.0 newtype Pos = Pos Int-  deriving (Show, Eq, Ord, Data, Generic, Typeable, NFData)+  deriving (Show, Eq, Ord, Data, Generic, NFData)  -- | Construction of 'Pos' from 'Int'. The function throws -- 'InvalidPosException' when given a non-positive argument.@@ -105,7 +104,7 @@ newtype InvalidPosException   = -- | Contains the actual value that was passed to 'mkPos'     InvalidPosException Int-  deriving (Eq, Show, Data, Typeable, Generic)+  deriving (Eq, Show, Data, Generic)  instance Exception InvalidPosException @@ -126,7 +125,7 @@     -- | Column number     sourceColumn :: !Pos   }-  deriving (Show, Read, Eq, Ord, Data, Typeable, Generic)+  deriving (Show, Read, Eq, Ord, Data, Generic)  instance NFData SourcePos 

@@ -21,13 +21,14 @@ -- @since 6.5.0 module Text.Megaparsec.State   ( State (..),+    initialState,     PosState (..),+    initialPosState,   ) where  import Control.DeepSeq (NFData) import Data.Data (Data)-import Data.Typeable (Typeable) import GHC.Generics import {-# SOURCE #-} Text.Megaparsec.Error (ParseError) import Text.Megaparsec.Pos@@ -51,7 +52,7 @@     -- @since 8.0.0     stateParseErrors :: [ParseError s e]   }-  deriving (Typeable, Generic)+  deriving (Generic)  deriving instance   ( Show (ParseError s e),@@ -74,6 +75,24 @@  instance (NFData s, NFData (ParseError s e)) => NFData (State s e) +-- | Given the name of the source file and the input construct the initial+-- state for a parser.+--+-- @since 9.6.0+initialState ::+  -- | Name of the file the input is coming from+  FilePath ->+  -- | Input+  s ->+  State s e+initialState name s =+  State+    { stateInput = s,+      stateOffset = 0,+      statePosState = initialPosState name s,+      stateParseErrors = []+    }+ -- | A special kind of state that is used to calculate line\/column -- positions on demand. --@@ -90,6 +109,25 @@     -- | Prefix to prepend to offending line     pstateLinePrefix :: String   }-  deriving (Show, Eq, Data, Typeable, Generic)+  deriving (Show, Eq, Data, Generic) -instance NFData s => NFData (PosState s)+instance (NFData s) => NFData (PosState s)++-- | Given the name of source file and the input construct the initial+-- positional state.+--+-- @since 9.6.0+initialPosState ::+  -- | Name of the file the input is coming from+  FilePath ->+  -- | Input+  s ->+  PosState s+initialPosState name s =+  PosState+    { pstateInput = s,+      pstateOffset = 0,+      pstateSourcePos = initialPos name,+      pstateTabWidth = defaultTabWidth,+      pstateLinePrefix = ""+    }

@@ -1,3 +1,4 @@+{-# LANGUAGE BangPatterns #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE LambdaCase #-}@@ -7,6 +8,7 @@ {-# LANGUAGE Safe #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE UndecidableInstances #-}  -- | -- Module      :  Text.Megaparsec.Stream@@ -25,18 +27,22 @@ -- @since 6.0.0 module Text.Megaparsec.Stream   ( Stream (..),+    ShareInput (..),+    NoShareInput (..),     VisualStream (..),     TraversableStream (..),   ) where +import Data.Bifunctor (second) 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 Data.Char (chr)-import Data.Foldable (foldl', toList)+import Data.Foldable (toList) import Data.Kind (Type)+import qualified Data.List import Data.List.NonEmpty (NonEmpty (..)) import qualified Data.List.NonEmpty as NE import Data.Maybe (fromMaybe)@@ -47,9 +53,16 @@ import Data.Word (Word8) import Text.Megaparsec.Pos import Text.Megaparsec.State+import qualified Text.Megaparsec.Unicode as Unicode  -- | Type class for inputs that can be consumed by the library. --+-- Note that the 'Stream' instances for 'Text' and 'ByteString' (strict and+-- lazy) default to "input sharing" (see 'ShareInput', 'NoShareInput'). We plan+-- to move away from input sharing in a future major release; if you want to+-- retain the current behaviour and are concerned with maximum performance you+-- should consider using the 'ShareInput' wrapper explicitly.+-- -- __Note__: before the version /9.0.0/ the class included the methods from -- 'VisualStream' and 'TraversableStream'. class (Ord (Token s), Ord (Tokens s)) => Stream s where@@ -121,7 +134,7 @@   takeWhile_ :: (Token s -> Bool) -> s -> (Tokens s, s)  -- | @since 9.0.0-instance Ord a => Stream [a] where+instance (Ord a) => Stream [a] where   type Token [a] = a   type Tokens [a] = [a]   tokenToChunk Proxy = pure@@ -138,7 +151,7 @@   takeWhile_ = span  -- | @since 9.0.0-instance Ord a => Stream (S.Seq a) where+instance (Ord a) => Stream (S.Seq a) where   type Token (S.Seq a) = a   type Tokens (S.Seq a) = S.Seq a   tokenToChunk Proxy = pure@@ -154,70 +167,251 @@     | otherwise = Just (S.splitAt n s)   takeWhile_ = S.spanl -instance Stream B.ByteString where-  type Token B.ByteString = Word8-  type Tokens B.ByteString = B.ByteString+-- | This wrapper selects the input-sharing 'Stream' implementation for+-- 'T.Text' ('TL.Text') and 'B.ByteString' ('BL.ByteString'). By input+-- sharing we mean that our parsers will use slices whenever possible to+-- avoid having to copy parts of the input. See also the documentation of+-- 'T.split'.+--+-- Note that using slices is in general faster than copying; on the other+-- hand it also has the potential for causing surprising memory leaks: if+-- any slice of the input survives in the output, holding on to the output+-- will force the entire input 'T.Text'/'B.ByteString' to stay in memory!+-- Even when using lazy 'TL.Text'/'BL.ByteString' we will hold on to whole+-- chunks at a time leading to to significantly worse memory residency in+-- some cases.+--+-- See 'NoShareInput' for a somewhat slower implementation that avoids this+-- memory leak scenario.+--+-- @since 9.3.0+newtype ShareInput a = ShareInput {unShareInput :: a}++instance Stream (ShareInput B.ByteString) where+  type Token (ShareInput B.ByteString) = Word8+  type Tokens (ShareInput B.ByteString) = B.ByteString   tokenToChunk Proxy = B.singleton   tokensToChunk Proxy = B.pack   chunkToTokens Proxy = B.unpack   chunkLength Proxy = B.length   chunkEmpty Proxy = B.null-  take1_ = B.uncons-  takeN_ n s-    | n <= 0 = Just (B.empty, s)+  take1_ (ShareInput s) = second ShareInput <$> B.uncons s+  takeN_ n (ShareInput s)+    | n <= 0 = Just (B.empty, ShareInput s)     | B.null s = Nothing-    | otherwise = Just (B.splitAt n s)-  takeWhile_ = B.span+    | otherwise = Just . second ShareInput $ B.splitAt n s+  takeWhile_ p (ShareInput s) = second ShareInput $ B.span p s -instance Stream BL.ByteString where-  type Token BL.ByteString = Word8-  type Tokens BL.ByteString = BL.ByteString+instance Stream (ShareInput BL.ByteString) where+  type Token (ShareInput BL.ByteString) = Word8+  type Tokens (ShareInput BL.ByteString) = BL.ByteString   tokenToChunk Proxy = BL.singleton   tokensToChunk Proxy = BL.pack   chunkToTokens Proxy = BL.unpack   chunkLength Proxy = fromIntegral . BL.length   chunkEmpty Proxy = BL.null-  take1_ = BL.uncons-  takeN_ n s-    | n <= 0 = Just (BL.empty, s)+  take1_ (ShareInput s) = second ShareInput <$> BL.uncons s+  takeN_ n (ShareInput s)+    | n <= 0 = Just (BL.empty, ShareInput s)     | BL.null s = Nothing-    | otherwise = Just (BL.splitAt (fromIntegral n) s)-  takeWhile_ = BL.span+    | otherwise = Just . second ShareInput $ BL.splitAt (fromIntegral n) s+  takeWhile_ p (ShareInput s) = second ShareInput $ BL.span p s -instance Stream T.Text where-  type Token T.Text = Char-  type Tokens T.Text = T.Text+instance Stream (ShareInput T.Text) where+  type Token (ShareInput T.Text) = Char+  type Tokens (ShareInput T.Text) = T.Text   tokenToChunk Proxy = T.singleton   tokensToChunk Proxy = T.pack   chunkToTokens Proxy = T.unpack   chunkLength Proxy = T.length   chunkEmpty Proxy = T.null-  take1_ = T.uncons-  takeN_ n s-    | n <= 0 = Just (T.empty, s)+  take1_ (ShareInput s) = second ShareInput <$> T.uncons s+  takeN_ n (ShareInput s)+    | n <= 0 = Just (T.empty, ShareInput s)     | T.null s = Nothing-    | otherwise = Just (T.splitAt n s)-  takeWhile_ = T.span+    | otherwise = Just . second ShareInput $ T.splitAt n s+  takeWhile_ p (ShareInput s) = second ShareInput $ T.span p s -instance Stream TL.Text where-  type Token TL.Text = Char-  type Tokens TL.Text = TL.Text+instance Stream (ShareInput TL.Text) where+  type Token (ShareInput TL.Text) = Char+  type Tokens (ShareInput TL.Text) = TL.Text   tokenToChunk Proxy = TL.singleton   tokensToChunk Proxy = TL.pack   chunkToTokens Proxy = TL.unpack   chunkLength Proxy = fromIntegral . TL.length   chunkEmpty Proxy = TL.null-  take1_ = TL.uncons-  takeN_ n s-    | n <= 0 = Just (TL.empty, s)+  take1_ (ShareInput s) = second ShareInput <$> TL.uncons s+  takeN_ n (ShareInput s)+    | n <= 0 = Just (TL.empty, ShareInput s)     | TL.null s = Nothing-    | otherwise = Just (TL.splitAt (fromIntegral n) s)-  takeWhile_ = TL.span+    | otherwise = Just . second ShareInput $ TL.splitAt (fromIntegral n) s+  takeWhile_ p (ShareInput s) = second ShareInput $ TL.span p s +-- | This wrapper selects the no-input-sharing 'Stream' implementation for+-- 'T.Text' ('TL.Text') and 'B.ByteString' ('BL.ByteString'). This means+-- that our parsers will create independent copies rather than using slices+-- of the input. See also the documentation of 'T.copy'.+--+-- More importantly, any parser output will be independent of the input, and+-- holding on to parts of the output will never prevent the input from being+-- garbage collected.+--+-- For maximum performance you might consider using 'ShareInput' instead,+-- but beware of its pitfalls!+--+-- @since 9.3.0+newtype NoShareInput a = NoShareInput {unNoShareInput :: a}++instance Stream (NoShareInput B.ByteString) where+  type Token (NoShareInput B.ByteString) = Word8+  type Tokens (NoShareInput B.ByteString) = B.ByteString+  tokenToChunk Proxy = B.singleton+  tokensToChunk Proxy = B.pack+  chunkToTokens Proxy = B.unpack+  chunkLength Proxy = B.length+  chunkEmpty Proxy = B.null+  take1_ (NoShareInput s) = second NoShareInput <$> B.uncons s+  takeN_ n (NoShareInput s)+    | n <= 0 = Just (B.empty, NoShareInput s)+    | B.null s = Nothing+    | otherwise =+        let (result, rest) = B.splitAt n s+            -- To avoid sharing the entire input we create a clean copy of the result.+            unSharedResult = B.copy result+         in Just (unSharedResult, NoShareInput rest)+  takeWhile_ p (NoShareInput s) =+    let (result, rest) = B.span p s+        -- Ditto.+        unSharedResult = B.copy result+     in (unSharedResult, NoShareInput rest)++instance Stream (NoShareInput BL.ByteString) where+  type Token (NoShareInput BL.ByteString) = Word8+  type Tokens (NoShareInput BL.ByteString) = BL.ByteString+  tokenToChunk Proxy = BL.singleton+  tokensToChunk Proxy = BL.pack+  chunkToTokens Proxy = BL.unpack+  chunkLength Proxy = fromIntegral . BL.length+  chunkEmpty Proxy = BL.null+  take1_ (NoShareInput s) = second NoShareInput <$> BL.uncons s+  takeN_ n (NoShareInput s)+    | n <= 0 = Just (BL.empty, NoShareInput s)+    | BL.null s = Nothing+    | otherwise =+        let (result, rest) = BL.splitAt (fromIntegral n) s+            -- To avoid sharing the entire input we create a clean copy of the result.+            unSharedResult = BL.copy result+         in Just (unSharedResult, NoShareInput rest)+  takeWhile_ p (NoShareInput s) =+    let (result, rest) = BL.span p s+        -- Ditto.+        unSharedResult = BL.copy result+     in (unSharedResult, NoShareInput rest)++instance Stream (NoShareInput T.Text) where+  type Token (NoShareInput T.Text) = Char+  type Tokens (NoShareInput T.Text) = T.Text+  tokenToChunk Proxy = T.singleton+  tokensToChunk Proxy = T.pack+  chunkToTokens Proxy = T.unpack+  chunkLength Proxy = T.length+  chunkEmpty Proxy = T.null+  take1_ (NoShareInput s) = second NoShareInput <$> T.uncons s+  takeN_ n (NoShareInput s)+    | n <= 0 = Just (T.empty, NoShareInput s)+    | T.null s = Nothing+    | otherwise =+        let (result, rest) = T.splitAt n s+            -- To avoid sharing the entire input we create a clean copy of the result.+            unSharedResult = T.copy result+         in Just (unSharedResult, NoShareInput rest)+  takeWhile_ p (NoShareInput s) =+    let (result, rest) = T.span p s+        unSharedResult = T.copy result+     in (unSharedResult, NoShareInput rest)++instance Stream (NoShareInput TL.Text) where+  type Token (NoShareInput TL.Text) = Char+  type Tokens (NoShareInput TL.Text) = TL.Text+  tokenToChunk Proxy = TL.singleton+  tokensToChunk Proxy = TL.pack+  chunkToTokens Proxy = TL.unpack+  chunkLength Proxy = fromIntegral . TL.length+  chunkEmpty Proxy = TL.null+  take1_ (NoShareInput s) = second NoShareInput <$> TL.uncons s+  takeN_ n (NoShareInput s)+    | n <= 0 = Just (TL.empty, NoShareInput s)+    | TL.null s = Nothing+    | otherwise =+        let (result, rest) = TL.splitAt (fromIntegral n) s+            -- To avoid sharing the entire input we create a clean copy of the result.+            unSharedResult = tlCopy result+         in Just (unSharedResult, NoShareInput rest)+  takeWhile_ p (NoShareInput s) =+    let (result, rest) = TL.span p s+        unSharedResult = tlCopy result+     in (unSharedResult, NoShareInput rest)++-- | Create an independent copy of a TL.Text, akin to BL.copy.+tlCopy :: TL.Text -> TL.Text+tlCopy = TL.fromStrict . T.copy . TL.toStrict+{-# INLINE tlCopy #-}++-- Since we are using @{-# LANGUAGE Safe #-}@ we can't use deriving via in+-- these cases.++instance Stream B.ByteString where+  type Token B.ByteString = Token (ShareInput B.ByteString)+  type Tokens B.ByteString = Tokens (ShareInput B.ByteString)+  tokenToChunk Proxy = tokenToChunk (Proxy :: Proxy (ShareInput B.ByteString))+  tokensToChunk Proxy = tokensToChunk (Proxy :: Proxy (ShareInput B.ByteString))+  chunkToTokens Proxy = chunkToTokens (Proxy :: Proxy (ShareInput B.ByteString))+  chunkLength Proxy = chunkLength (Proxy :: Proxy (ShareInput B.ByteString))+  chunkEmpty Proxy = chunkEmpty (Proxy :: Proxy (ShareInput B.ByteString))+  take1_ s = second unShareInput <$> take1_ (ShareInput s)+  takeN_ n s = second unShareInput <$> takeN_ n (ShareInput s)+  takeWhile_ p s = second unShareInput $ takeWhile_ p (ShareInput s)++instance Stream BL.ByteString where+  type Token BL.ByteString = Token (ShareInput BL.ByteString)+  type Tokens BL.ByteString = Tokens (ShareInput BL.ByteString)+  tokenToChunk Proxy = tokenToChunk (Proxy :: Proxy (ShareInput BL.ByteString))+  tokensToChunk Proxy = tokensToChunk (Proxy :: Proxy (ShareInput BL.ByteString))+  chunkToTokens Proxy = chunkToTokens (Proxy :: Proxy (ShareInput BL.ByteString))+  chunkLength Proxy = chunkLength (Proxy :: Proxy (ShareInput BL.ByteString))+  chunkEmpty Proxy = chunkEmpty (Proxy :: Proxy (ShareInput BL.ByteString))+  take1_ s = second unShareInput <$> take1_ (ShareInput s)+  takeN_ n s = second unShareInput <$> takeN_ n (ShareInput s)+  takeWhile_ p s = second unShareInput $ takeWhile_ p (ShareInput s)++instance Stream T.Text where+  type Token T.Text = Token (ShareInput T.Text)+  type Tokens T.Text = Tokens (ShareInput T.Text)+  tokenToChunk Proxy = tokenToChunk (Proxy :: Proxy (ShareInput T.Text))+  tokensToChunk Proxy = tokensToChunk (Proxy :: Proxy (ShareInput T.Text))+  chunkToTokens Proxy = chunkToTokens (Proxy :: Proxy (ShareInput T.Text))+  chunkLength Proxy = chunkLength (Proxy :: Proxy (ShareInput T.Text))+  chunkEmpty Proxy = chunkEmpty (Proxy :: Proxy (ShareInput T.Text))+  take1_ s = second unShareInput <$> take1_ (ShareInput s)+  takeN_ n s = second unShareInput <$> takeN_ n (ShareInput s)+  takeWhile_ p s = second unShareInput $ takeWhile_ p (ShareInput s)++instance Stream TL.Text where+  type Token TL.Text = Token (ShareInput TL.Text)+  type Tokens TL.Text = Tokens (ShareInput TL.Text)+  tokenToChunk Proxy = tokenToChunk (Proxy :: Proxy (ShareInput TL.Text))+  tokensToChunk Proxy = tokensToChunk (Proxy :: Proxy (ShareInput TL.Text))+  chunkToTokens Proxy = chunkToTokens (Proxy :: Proxy (ShareInput TL.Text))+  chunkLength Proxy = chunkLength (Proxy :: Proxy (ShareInput TL.Text))+  chunkEmpty Proxy = chunkEmpty (Proxy :: Proxy (ShareInput TL.Text))+  take1_ s = second unShareInput <$> take1_ (ShareInput s)+  takeN_ n s = second unShareInput <$> takeN_ n (ShareInput s)+  takeWhile_ p s = second unShareInput $ takeWhile_ p (ShareInput s)+ -- | Type class for inputs that can also be used for debugging. -- -- @since 9.0.0-class Stream s => VisualStream s where+class (Stream s) => VisualStream s where   -- | Pretty-print non-empty stream of tokens. This function is also used   -- to print single tokens (represented as singleton lists).   --@@ -234,6 +428,7 @@  instance VisualStream String where   showTokens Proxy = stringPretty+  tokensLength Proxy = Unicode.stringLength  instance VisualStream B.ByteString where   showTokens Proxy = stringPretty . fmap (chr . fromIntegral)@@ -243,14 +438,16 @@  instance VisualStream T.Text where   showTokens Proxy = stringPretty+  tokensLength Proxy = Unicode.stringLength  instance VisualStream TL.Text where   showTokens Proxy = stringPretty+  tokensLength Proxy = Unicode.stringLength  -- | Type class for inputs that can also be used for error reporting. -- -- @since 9.0.0-class Stream s => TraversableStream s where+class (Stream s) => TraversableStream s where   {-# MINIMAL reachOffset | reachOffsetNoLine #-}    -- | Given an offset @o@ and initial 'PosState', adjust the state in such@@ -318,37 +515,37 @@ instance TraversableStream String where   -- NOTE Do not eta-reduce these (breaks inlining)   reachOffset o pst =-    reachOffset' splitAt foldl' id id ('\n', '\t') o pst+    reachOffset' splitAt Data.List.foldl' id id ('\n', '\t') charInc o pst   reachOffsetNoLine o pst =-    reachOffsetNoLine' splitAt foldl' ('\n', '\t') o pst+    reachOffsetNoLine' splitAt Data.List.foldl' ('\n', '\t') charInc o pst  instance TraversableStream B.ByteString where   -- NOTE Do not eta-reduce these (breaks inlining)   reachOffset o pst =-    reachOffset' B.splitAt B.foldl' B8.unpack (chr . fromIntegral) (10, 9) o pst+    reachOffset' B.splitAt B.foldl' B8.unpack (chr . fromIntegral) (10, 9) byteInc o pst   reachOffsetNoLine o pst =-    reachOffsetNoLine' B.splitAt B.foldl' (10, 9) o pst+    reachOffsetNoLine' B.splitAt B.foldl' (10, 9) byteInc o pst  instance TraversableStream BL.ByteString where   -- NOTE Do not eta-reduce these (breaks inlining)   reachOffset o pst =-    reachOffset' splitAtBL BL.foldl' BL8.unpack (chr . fromIntegral) (10, 9) o pst+    reachOffset' splitAtBL BL.foldl' BL8.unpack (chr . fromIntegral) (10, 9) byteInc o pst   reachOffsetNoLine o pst =-    reachOffsetNoLine' splitAtBL BL.foldl' (10, 9) o pst+    reachOffsetNoLine' splitAtBL BL.foldl' (10, 9) byteInc o pst  instance TraversableStream T.Text where   -- NOTE Do not eta-reduce (breaks inlining of reachOffset').   reachOffset o pst =-    reachOffset' T.splitAt T.foldl' T.unpack id ('\n', '\t') o pst+    reachOffset' T.splitAt T.foldl' T.unpack id ('\n', '\t') charInc o pst   reachOffsetNoLine o pst =-    reachOffsetNoLine' T.splitAt T.foldl' ('\n', '\t') o pst+    reachOffsetNoLine' T.splitAt T.foldl' ('\n', '\t') charInc o pst  instance TraversableStream TL.Text where   -- NOTE Do not eta-reduce (breaks inlining of reachOffset').   reachOffset o pst =-    reachOffset' splitAtTL TL.foldl' TL.unpack id ('\n', '\t') o pst+    reachOffset' splitAtTL TL.foldl' TL.unpack id ('\n', '\t') charInc o pst   reachOffsetNoLine o pst =-    reachOffsetNoLine' splitAtTL TL.foldl' ('\n', '\t') o pst+    reachOffsetNoLine' splitAtTL TL.foldl' ('\n', '\t') charInc o pst  ---------------------------------------------------------------------------- -- Helpers@@ -361,7 +558,7 @@ -- stream types. reachOffset' ::   forall s.-  Stream s =>+  (Stream s) =>   -- | How to split input stream at given offset   (Int -> s -> (Tokens s, s)) ->   -- | How to fold over input stream@@ -372,6 +569,8 @@   (Token s -> Char) ->   -- | Newline token and tab token   (Token s, Token s) ->+  -- | Update column position for a token+  (Token s -> Pos -> Pos) ->   -- | Offset to reach   Int ->   -- | Initial 'PosState' to use@@ -384,6 +583,7 @@   fromToks   fromTok   (newlineTok, tabTok)+  columnIncrement   o   PosState {..} =     ( Just $ case expandTab pstateTabWidth@@ -422,30 +622,32 @@             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 :))+              | 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 (columnIncrement ch c))+                    (g . (fromTok ch :)) {-# INLINE reachOffset' #-}  -- | Like 'reachOffset'' but for 'reachOffsetNoLine'. reachOffsetNoLine' ::   forall s.-  Stream s =>+  (Stream s) =>   -- | How to split input stream at given offset   (Int -> s -> (Tokens s, s)) ->   -- | How to fold over input stream   (forall b. (b -> Token s -> b) -> b -> Tokens s -> b) ->   -- | Newline token and tab token   (Token s, Token s) ->+  -- | Update column position for a token+  (Token s -> Pos -> Pos) ->   -- | Offset to reach   Int ->   -- | Initial 'PosState' to use@@ -456,6 +658,7 @@   splitAt'   foldl''   (newlineTok, tabTok)+  columnIncrement   o   PosState {..} =     ( PosState@@ -473,12 +676,12 @@         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)+              | ch == newlineTok ->+                  SourcePos n (l <> pos1) pos1+              | ch == tabTok ->+                  SourcePos n l (mkPos $ c' + w - ((c' - 1) `rem` w))+              | otherwise ->+                  SourcePos n l (columnIncrement ch c) {-# INLINE reachOffsetNoLine' #-}  -- | Like 'BL.splitAt' but accepts the index as an 'Int'.@@ -554,10 +757,23 @@   Pos ->   String ->   String-expandTab w' = go 0+expandTab w' = go 0 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+    go _ 0 [] = []+    go !i 0 ('\t' : xs) = go i (w - (i `rem` w)) xs+    go !i 0 (x : xs) = x : go (i + 1) 0 xs+    go !i n xs = ' ' : go (i + 1) (n - 1) xs     w = unPos w'++-- | Return updated column position that corresponds to the given 'Char'.+charInc :: Char -> Pos -> Pos+charInc ch c+  | Unicode.isZeroWidthChar ch = c+  | Unicode.isWideChar ch = c <> pos1 <> pos1+  | otherwise = c <> pos1++-- | Return updated column position that corresponds to the given 'Word8'.+byteInc :: Word8 -> Pos -> Pos+byteInc w c+  | w < 0x20 || (w >= 0x7f && w < 0xa0) = c -- C0 and C1 control chars+  | otherwise = c <> pos1

@@ -0,0 +1,223 @@+{-# LANGUAGE Safe #-}++-- |+-- Module      :  Text.Megaparsec.Unicode+-- Copyright   :  © 2024–present Megaparsec contributors+-- License     :  FreeBSD+--+-- Maintainer  :  Mark Karpov <markkarpov92@gmail.com>+-- Stability   :  experimental+-- Portability :  portable+--+-- Utility functions for working with Unicode.+--+-- @since 9.7.0+module Text.Megaparsec.Unicode+  ( stringLength,+    charLength,+    isWideChar,+    isZeroWidthChar,+  )+where++import Data.Array (Array, bounds, listArray, (!))+import Data.Char (ord)++-- | Calculate length of a string taking into account the fact that certain+-- 'Char's may span more than 1 column.+--+-- @since 9.7.0+stringLength :: (Traversable t) => t Char -> Int+stringLength = sum . fmap charLength++-- | Return length of an individual 'Char'.+--+-- @since 9.7.0+charLength :: Char -> Int+charLength ch+  | isZeroWidthChar ch = 0+  | isWideChar ch = 2+  | otherwise = 1++-- | Determine whether the given 'Char' is “wide”, that is, whether it spans+-- 2 columns instead of one.+--+-- @since 9.7.0+isWideChar :: Char -> Bool+isWideChar c = go (bounds wideCharRanges)+  where+    go (lo, hi)+      | hi < lo = False+      | a <= n && n <= b = True+      | n < a = go (lo, pred mid)+      | otherwise = go (succ mid, hi)+      where+        mid = (lo + hi) `div` 2+        (a, b) = wideCharRanges ! mid+    n = ord c++-- | Determine whether the given 'Char' is "zero-width", that is, whether it+-- has no visible representation and does not advance the cursor position.+-- This includes control characters and certain Unicode zero-width characters.+--+-- @since 9.8.0+isZeroWidthChar :: Char -> Bool+isZeroWidthChar c = go (bounds zeroWidthCharRanges)+  where+    go (lo, hi)+      | hi < lo = False+      | a <= n && n <= b = True+      | n < a = go (lo, pred mid)+      | otherwise = go (succ mid, hi)+      where+        mid = (lo + hi) `div` 2+        (a, b) = zeroWidthCharRanges ! mid+    n = ord c++-- | Wide character ranges.+wideCharRanges :: Array Int (Int, Int)+wideCharRanges =+  listArray+    (0, 118)+    [ (0x001100, 0x00115f),+      (0x00231a, 0x00231b),+      (0x002329, 0x00232a),+      (0x0023e9, 0x0023ec),+      (0x0023f0, 0x0023f0),+      (0x0023f3, 0x0023f3),+      (0x0025fd, 0x0025fe),+      (0x002614, 0x002615),+      (0x002648, 0x002653),+      (0x00267f, 0x00267f),+      (0x002693, 0x002693),+      (0x0026a1, 0x0026a1),+      (0x0026aa, 0x0026ab),+      (0x0026bd, 0x0026be),+      (0x0026c4, 0x0026c5),+      (0x0026ce, 0x0026ce),+      (0x0026d4, 0x0026d4),+      (0x0026ea, 0x0026ea),+      (0x0026f2, 0x0026f3),+      (0x0026f5, 0x0026f5),+      (0x0026fa, 0x0026fa),+      (0x0026fd, 0x0026fd),+      (0x002705, 0x002705),+      (0x00270a, 0x00270b),+      (0x002728, 0x002728),+      (0x00274c, 0x00274c),+      (0x00274e, 0x00274e),+      (0x002753, 0x002755),+      (0x002757, 0x002757),+      (0x002795, 0x002797),+      (0x0027b0, 0x0027b0),+      (0x0027bf, 0x0027bf),+      (0x002b1b, 0x002b1c),+      (0x002b50, 0x002b50),+      (0x002b55, 0x002b55),+      (0x002e80, 0x002e99),+      (0x002e9b, 0x002ef3),+      (0x002f00, 0x002fd5),+      (0x002ff0, 0x002ffb),+      (0x003000, 0x00303e),+      (0x003041, 0x003096),+      (0x003099, 0x0030ff),+      (0x003105, 0x00312f),+      (0x003131, 0x00318e),+      (0x003190, 0x0031ba),+      (0x0031c0, 0x0031e3),+      (0x0031f0, 0x00321e),+      (0x003220, 0x003247),+      (0x003250, 0x004db5),+      (0x004e00, 0x009fef),+      (0x00a000, 0x00a48c),+      (0x00a490, 0x00a4c6),+      (0x00a960, 0x00a97c),+      (0x00ac00, 0x00d7a3),+      (0x00f900, 0x00fa6d),+      (0x00fa70, 0x00fad9),+      (0x00fe10, 0x00fe19),+      (0x00fe30, 0x00fe52),+      (0x00fe54, 0x00fe66),+      (0x00fe68, 0x00fe6b),+      (0x00ff01, 0x00ff60),+      (0x00ffe0, 0x00ffe6),+      (0x016fe0, 0x016fe3),+      (0x017000, 0x0187f7),+      (0x018800, 0x018af2),+      (0x01b000, 0x01b11e),+      (0x01b150, 0x01b152),+      (0x01b164, 0x01b167),+      (0x01b170, 0x01b2fb),+      (0x01f004, 0x01f004),+      (0x01f0cf, 0x01f0cf),+      (0x01f18e, 0x01f18e),+      (0x01f191, 0x01f19a),+      (0x01f200, 0x01f202),+      (0x01f210, 0x01f23b),+      (0x01f240, 0x01f248),+      (0x01f250, 0x01f251),+      (0x01f260, 0x01f265),+      (0x01f300, 0x01f320),+      (0x01f32d, 0x01f335),+      (0x01f337, 0x01f37c),+      (0x01f37e, 0x01f393),+      (0x01f3a0, 0x01f3ca),+      (0x01f3cf, 0x01f3d3),+      (0x01f3e0, 0x01f3f0),+      (0x01f3f4, 0x01f3f4),+      (0x01f3f8, 0x01f43e),+      (0x01f440, 0x01f440),+      (0x01f442, 0x01f4fc),+      (0x01f4ff, 0x01f53d),+      (0x01f54b, 0x01f54e),+      (0x01f550, 0x01f567),+      (0x01f57a, 0x01f57a),+      (0x01f595, 0x01f596),+      (0x01f5a4, 0x01f5a4),+      (0x01f5fb, 0x01f64f),+      (0x01f680, 0x01f6c5),+      (0x01f6cc, 0x01f6cc),+      (0x01f6d0, 0x01f6d2),+      (0x01f6d5, 0x01f6d5),+      (0x01f6eb, 0x01f6ec),+      (0x01f6f4, 0x01f6fa),+      (0x01f7e0, 0x01f7eb),+      (0x01f90d, 0x01f971),+      (0x01f973, 0x01f976),+      (0x01f97a, 0x01f9a2),+      (0x01f9a5, 0x01f9aa),+      (0x01f9ae, 0x01f9ca),+      (0x01f9cd, 0x01f9ff),+      (0x01fa70, 0x01fa73),+      (0x01fa78, 0x01fa7a),+      (0x01fa80, 0x01fa82),+      (0x01fa90, 0x01fa95),+      (0x020000, 0x02a6d6),+      (0x02a700, 0x02b734),+      (0x02b740, 0x02b81d),+      (0x02b820, 0x02cea1),+      (0x02ceb0, 0x02ebe0),+      (0x02f800, 0x02fa1d)+    ]+{-# NOINLINE wideCharRanges #-}++-- | Zero-width character ranges.+zeroWidthCharRanges :: Array Int (Int, Int)+zeroWidthCharRanges =+  listArray+    (0, 12)+    [ (0x0000, 0x001f), -- C0 control characters+      (0x007f, 0x009f), -- DEL and C1 control characters+      (0x00ad, 0x00ad), -- Soft Hyphen+      (0x0300, 0x036f), -- Combining Diacritical Marks+      (0x0483, 0x0489), -- Combining Cyrillic+      (0x0591, 0x05bd), -- Hebrew combining marks+      (0x05bf, 0x05bf), -- Hebrew point+      (0x05c1, 0x05c2), -- Hebrew points+      (0x05c4, 0x05c5), -- Hebrew marks+      (0x05c7, 0x05c7), -- Hebrew point+      (0x0610, 0x061a), -- Arabic combining marks+      (0x200b, 0x200f), -- Zero width chars and directional marks+      (0x202a, 0x202e) -- Directional formatting+    ]+{-# NOINLINE zeroWidthCharRanges #-}

@@ -76,7 +76,7 @@  -- | Perform a series of measurements with the same parser. bparser ::-  NFData a =>+  (NFData a) =>   -- | Name of the benchmark group   String ->   -- | How to construct input@@ -91,7 +91,7 @@  -- | Perform a series of measurements with the same parser. bparserBs ::-  NFData a =>+  (NFData a) =>   -- | Name of the benchmark group   String ->   -- | How to construct input

@@ -71,7 +71,7 @@  -- | Perform a series to measurements with the same parser. bparser ::-  NFData a =>+  (NFData a) =>   -- | Name of the benchmark group   String ->   -- | How to construct input@@ -87,7 +87,7 @@  -- | Perform a series to measurements with the same parser. bparserBs ::-  NFData a =>+  (NFData a) =>   -- | Name of the benchmark group   String ->   -- | How to construct input

@@ -1,6 +1,6 @@ cabal-version:   2.4 name:            megaparsec-version:         9.2.2+version:         9.8.1 license:         BSD-2-Clause license-file:    LICENSE.md maintainer:      Mark Karpov <markkarpov92@gmail.com>@@ -9,7 +9,9 @@     Paolo Martini <paolo@nemail.it>,     Daan Leijen <daan@microsoft.com> -tested-with:     ghc ==9.0.2 ghc ==9.2.4 ghc ==9.4.1+tested-with:+    ghc ==9.6.7 ghc ==9.8.4 ghc ==9.10.3 ghc ==9.12.4 ghc ==9.14.1+ homepage:        https://github.com/mrkkrp/megaparsec bug-reports:     https://github.com/mrkkrp/megaparsec/issues synopsis:        Monadic parser combinators@@ -46,37 +48,39 @@         Text.Megaparsec.Error.Builder         Text.Megaparsec.Internal         Text.Megaparsec.Pos+        Text.Megaparsec.State         Text.Megaparsec.Stream+        Text.Megaparsec.Unicode      other-modules:         Text.Megaparsec.Class         Text.Megaparsec.Common         Text.Megaparsec.Lexer-        Text.Megaparsec.State      default-language: Haskell2010     build-depends:-        base >=4.15 && <5.0,-        bytestring >=0.2 && <0.12,+        array >=0.5.3 && <0.6,+        base >=4.18 && <5,+        bytestring >=0.2 && <0.13,         case-insensitive >=1.2 && <1.3,-        containers >=0.5 && <0.7,-        deepseq >=1.3 && <1.5,-        mtl >=2.2.2 && <3.0,-        parser-combinators >=1.0 && <2.0,+        containers >=0.5 && <0.9,+        deepseq >=1.3 && <1.6,+        mtl >=2.2.2 && <3,+        parser-combinators >=1.0 && <2,         scientific >=0.3.7 && <0.4,-        text >=0.2 && <2.1,+        text >=0.2 && <2.2,         transformers >=0.4 && <0.7      if flag(dev)-        ghc-options: -O0 -Wall -Werror+        ghc-options:+            -Wall -Werror -Wredundant-constraints -Wpartial-fields+            -Wunused-packages      else         ghc-options: -O2 -Wall -    if flag(dev)-        ghc-options:-            -Wcompat -Wincomplete-record-updates -Wincomplete-uni-patterns-            -Wnoncanonical-monad-instances -Wno-missing-home-modules+    if impl(ghc >=9.8)+        ghc-options: -Wno-x-partial  benchmark bench-speed     type:             exitcode-stdio-1.0@@ -84,16 +88,18 @@     hs-source-dirs:   bench/speed     default-language: Haskell2010     build-depends:-        base >=4.15 && <5.0,-        bytestring >=0.2 && <0.12,-        containers >=0.5 && <0.7,+        base >=4.18 && <5,+        bytestring >=0.2 && <0.13,+        containers >=0.5 && <0.9,         criterion >=0.6.2.1 && <1.7,-        deepseq >=1.3 && <1.5,+        deepseq >=1.3 && <1.6,         megaparsec,-        text >=0.2 && <2.1+        text >=0.2 && <2.2      if flag(dev)-        ghc-options: -O2 -Wall -Werror+        ghc-options:+            -Wall -Werror -Wredundant-constraints -Wpartial-fields+            -Wunused-packages      else         ghc-options: -O2 -Wall@@ -104,16 +110,18 @@     hs-source-dirs:   bench/memory     default-language: Haskell2010     build-depends:-        base >=4.15 && <5.0,-        bytestring >=0.2 && <0.12,-        containers >=0.5 && <0.7,-        deepseq >=1.3 && <1.5,+        base >=4.18 && <5,+        bytestring >=0.2 && <0.13,+        containers >=0.5 && <0.9,+        deepseq >=1.3 && <1.6,         megaparsec,-        text >=0.2 && <2.1,+        text >=0.2 && <2.2,         weigh >=0.0.4      if flag(dev)-        ghc-options: -O2 -Wall -Werror+        ghc-options:+            -Wall -Werror -Wredundant-constraints -Wpartial-fields+            -Wunused-packages      else         ghc-options: -O2 -Wall