gigaparsec 0.1.0.0 → 0.2.0.0

raw patch · 22 files changed

+2120/−369 lines, 22 filesdep +deepseqdep +gaugedep +tasty-expected-failurePVP ok

version bump matches the API change (PVP)

Dependencies added: deepseq, gauge, tasty-expected-failure

API changes (from Hackage documentation)

Files

• CHANGELOG.md +7/−1
• benchmarks/Main.hs +21/−0
• gigaparsec.cabal +31/−3
• includes/portable-unlifted.h +25/−0
• src/Text/Gigaparsec.hs +35/−17
• src/Text/Gigaparsec/Char.hs +75/−65
• src/Text/Gigaparsec/Combinator.hs +90/−90
• src/Text/Gigaparsec/Errors/Combinator.hs +342/−6
• src/Text/Gigaparsec/Errors/DefaultErrorBuilder.hs +135/−0
• src/Text/Gigaparsec/Errors/ErrorBuilder.hs +379/−0
• src/Text/Gigaparsec/Internal.hs +65/−17
• src/Text/Gigaparsec/Internal/Errors.hs +271/−0
• test/Main.hs +2/−0
• test/Text/Gigaparsec/CharTests.hs +33/−33
• test/Text/Gigaparsec/CombinatorTests.hs +67/−67
• test/Text/Gigaparsec/ErrorsTests.hs +384/−0
• test/Text/Gigaparsec/Expr/ChainTests.hs +18/−18
• test/Text/Gigaparsec/Expr/InfixTests.hs +5/−5
• test/Text/Gigaparsec/ExprTests.hs +20/−20
• test/Text/Gigaparsec/Internal/Test.hs +46/−17
• test/Text/Gigaparsec/Internal/TestError.hs +59/−0
• test/Text/Gigaparsec/PrimitiveTests.hs +10/−10

@@ -1,5 +1,11 @@ # Revision history for gigaparsec -## 0.1.0.0 -- YYYY-mm-dd+## 0.1.0.0 -- 2023-10-17  * First version. Released on an unsuspecting world.++## 0.2.0.0 -- 2023-11-09++* Added error system.+* `parse` now has a type parameter, `parse @String` restores old behaviour+* for convenience `parseRepl` will print a parse to the terminal with the `String` error messages.

@@ -0,0 +1,21 @@+{-# LANGUAGE Trustworthy #-}+{-# LANGUAGE StandaloneDeriving, DeriveAnyClass, DeriveGeneric #-}+{-# OPTIONS_GHC -Wno-orphans #-}+module Main (main) where++import Gauge (defaultMain, bench, nf)+import Text.Gigaparsec (Parsec, Result(Success, Failure), parse, atomic, (<|>))+import Text.Gigaparsec.Char (string)+import Control.DeepSeq (NFData)+import GHC.Generics (Generic)++p :: Parsec String+p = atomic (string "hello wold") <|> atomic (string "hi") <|> string "hello world"++deriving stock instance Generic (Result e a)+deriving anyclass instance (NFData a, NFData e) => NFData (Result e a)++main :: IO ()+main = defaultMain [+    bench "consumption" $ nf (parse @String p) "hello world"+  ]

@@ -20,7 +20,7 @@ -- PVP summary:     +-+------- breaking API changes --                  | | +----- non-breaking API additions --                  | | | +--- code changes with no API change-version:            0.1.0.0+version:            0.2.0.0  -- A short (one-line) description of the package. synopsis:@@ -84,6 +84,8 @@                       Text.Gigaparsec.Combinator,                       Text.Gigaparsec.Combinator.NonEmpty,                       Text.Gigaparsec.Errors.Combinator,+                      Text.Gigaparsec.Errors.DefaultErrorBuilder,+                      Text.Gigaparsec.Errors.ErrorBuilder,                       Text.Gigaparsec.Expr,                       Text.Gigaparsec.Expr.Chain,                       Text.Gigaparsec.Expr.Infix,@@ -92,6 +94,7 @@                        -- Internals                       Text.Gigaparsec.Internal,+                      Text.Gigaparsec.Internal.Errors,                       Text.Gigaparsec.Internal.RT,                       Text.Gigaparsec.Internal.Require @@ -107,6 +110,8 @@      -- Directories containing source files.     hs-source-dirs:   src+    include-dirs:     includes+    install-includes: includes/portable-unlifted.h      -- Base language which the package is written in.     default-language: Haskell2010@@ -124,9 +129,11 @@                    Text.Gigaparsec.CharTests,                    Text.Gigaparsec.CombinatorTests,                    Text.Gigaparsec.ExprTests,+                   Text.Gigaparsec.ErrorsTests,                    Text.Gigaparsec.Expr.ChainTests,                    Text.Gigaparsec.Expr.InfixTests,                    Text.Gigaparsec.Internal.Test,+                   Text.Gigaparsec.Internal.TestError,                    Text.Gigaparsec.Internal.PlainString      ghc-options: -Wno-missing-export-lists -Wno-missing-safe-haskell-mode -Wno-safe@@ -146,11 +153,32 @@     build-depends:         gigaparsec,         containers >= 0.6 && < 0.7,+        --deriving-compat >= 0.6 && < 0.7,         tasty >=1.1 && <1.6,-        --tasty-expected-failure,-        tasty-hunit >=0.9 && <0.11+        tasty-expected-failure >=0.11 && <0.13,+        tasty-hunit >=0.9 && <0.11,         --TODO: property based testing will be useful when we optimise combinators         --      to test against their base implementations         --tasty-quickcheck         --TODO: performance testing with tasty-bench?+        --tasty-bench         -- we'd need to keep the basefile files somewhere, cache in CI or keep in repo?++benchmark perf-test+    import:           warnings, extensions, base++    type:             exitcode-stdio-1.0++    default-extensions: OverloadedStrings, TypeOperators, BlockArguments, GADTs++    -- Base language which the package is written in.+    default-language: Haskell2010++    hs-source-dirs:  benchmarks+    build-depends:+        gigaparsec,+        --containers >= 0.6 && < 0.7,+        gauge >= 0.1 && < 0.3,+        deepseq >= 1.4 && < 1.6++    main-is:          Main.hs

@@ -0,0 +1,25 @@+#ifdef false+/*+ * Copyright 2023 Gigaparsec Contributors <https://github.com/j-mie6/gigaparsec/graphs/contributors>+ *+ * SPDX-License-Identifier: BSD-3-Clause+ */++// This file enables the use of `UnliftedDatatypes` from 9.2 in a portable way+// include this file at the top underneath the requisite `CPP` extension, then+// have a `CPP_import_PortableUnlifted` import; `UnliftedDatatype` is now a kind+// that can be freely used.+#endif++#if __GLASGOW_HASKELL__ >= 902+{-# LANGUAGE UnliftedDatatypes #-}++#define CPP_import_PortableUnlifted import GHC.Exts (TYPE, RuntimeRep(BoxedRep), Levity(Unlifted))+#define UnliftedDatatype (TYPE ('BoxedRep 'Unlifted))++#else++#define CPP_import_PortableUnlifted+#define UnliftedDatatype *++#endif

@@ -15,7 +15,7 @@ @since 0.1.0.0 -} module Text.Gigaparsec (-    Parsec, Result(..), parse,+    Parsec, Result(..), result, parse, parseRepl,   -- * Primitive Combinators   -- | These combinators are specific to parser combinators. In one way or another, they influence   -- how a parser consumes input, or under what conditions a parser does or does not fail. These are@@ -83,26 +83,43 @@ -- `Internal`: when they are in the public API, we are locked into them!  import Text.Gigaparsec.Internal (Parsec(Parsec), emptyState, manyr, somer)-import Text.Gigaparsec.Internal qualified as Internal.State (State(..))-import Text.Gigaparsec.Internal.RT (runRT)+import Text.Gigaparsec.Internal qualified as Internal (State(..), useHints, expectedErr)+import Text.Gigaparsec.Internal.RT qualified as Internal (RT, runRT)+import Text.Gigaparsec.Internal.Errors qualified as Internal (ParseError, ExpectItem(ExpectEndOfInput), fromParseError) +import Text.Gigaparsec.Errors.ErrorBuilder (ErrorBuilder)+ import Data.Functor (void) import Control.Applicative (liftA2, (<|>), empty, many, some, (<**>)) -- liftA2 required until 9.6 import Control.Selective (select, branch) +import Data.Set qualified as Set (singleton, empty)+ -- Hiding the Internal module seems like the better bet: nobody needs to see it anyway :) -- re-expose like this to prevent hlint suggesting import refinement into internal --type Parsec :: * -> * --type Parsec = Internal.Parsec -type Result :: * -> *-data Result a = Success a | Failure deriving stock (Show, Eq)+type Result :: * -> * -> *+data Result e a = Success a | Failure e deriving stock (Show, Eq) -parse :: Parsec a -> String -> Result a-parse (Parsec p) inp = runRT $ p (emptyState inp) good bad-  where good x _ = return (Success x)-        bad _    = return Failure+result :: (e -> b) -> (a -> b) -> Result e a -> b+result _ success (Success x) = success x+result failure _ (Failure err) = failure err +{-# SPECIALISE parse :: Parsec a -> String -> Result String a #-}+{-# INLINABLE parse #-}+parse :: forall err a. ErrorBuilder err => Parsec a -> String -> Result err a+parse (Parsec p) inp = Internal.runRT $ p (emptyState inp) good bad+  where good :: a -> Internal.State -> Internal.RT (Result err a)+        good x _  = return (Success x)+        bad :: Internal.ParseError -> Internal.State -> Internal.RT (Result err a)+        bad err _ = return (Failure (Internal.fromParseError Nothing inp err))++-- TODO: documentation+parseRepl :: Show a => Parsec a -> String -> IO ()+parseRepl p inp = result putStrLn print (parse p inp)+ {-| This combinator parses its argument @p@, but rolls back any consumed input on failure. @@ -122,8 +139,7 @@ -} atomic :: Parsec a -- ^ the parser, @p@, to execute, if it fails, it will not have consumed input.        -> Parsec a -- ^ a parser that tries @p@, but never consumes input if it fails.-atomic (Parsec p) = Parsec $ \st ok err ->-  p st ok (const $ err st)+atomic (Parsec p) = Parsec $ \st ok bad -> p st ok (\err _ -> bad err st)  {-| This combinator parses its argument @p@, but does not consume input if it succeeds. @@ -142,8 +158,7 @@ -} lookAhead :: Parsec a -- ^ the parser, @p@, to execute           -> Parsec a -- ^ a parser that parses @p@ and never consumes input if it succeeds.-lookAhead (Parsec p) = Parsec $ \st ok err ->-  p st (\x _ -> ok x st) err+lookAhead (Parsec p) = Parsec $ \st ok err -> p st (\x _ -> ok x st) err  {-| This combinator parses its argument @p@, and succeeds when @p@ fails and vice-versa, never consuming@@ -168,8 +183,10 @@ -} notFollowedBy :: Parsec a  -- ^ the parser, @p@, to execute, it must fail in order for this combinator to succeed.               -> Parsec () -- ^ a parser which fails when @p@ succeeds and succeeds otherwise, never consuming input.-notFollowedBy (Parsec p) = Parsec $ \st ok err ->-  p st (\_ _ -> err st) (\_ -> ok () st)+notFollowedBy (Parsec p) = Parsec $ \st ok bad ->+  p st (\_ st' -> let !width = Internal.consumed st' - Internal.consumed st+                  in Internal.useHints bad (Internal.expectedErr st Set.empty width) st)+       (\_ _ -> ok () st)  -- eof is usually `notFollowedBy item`, but this requires annoying cyclic dependencies on Char {- This parser only succeeds at the end of the input.@@ -185,8 +202,9 @@ @since 0.1.0.0 -} eof :: Parsec ()-eof = Parsec $ \st good bad -> case Internal.State.input st of-  (:){} -> bad st+eof = Parsec $ \st good bad -> case Internal.input st of+  (:){} -> Internal.useHints bad+             (Internal.expectedErr st (Set.singleton Internal.ExpectEndOfInput) 1) st   []    -> good () st  {-|

@@ -1,6 +1,6 @@ {-# LANGUAGE Safe #-} {-# LANGUAGE OverloadedLists #-}-{-# OPTIONS_GHC -Wno-all-missed-specialisations #-}+{-# OPTIONS_GHC -Wno-all-missed-specialisations -Wno-overflowed-literals #-} {-| Module      : Text.Gigaparsec.Char Description : Contains the combinators needed to read characters and strings, as well as combinators@@ -49,7 +49,8 @@ import Text.Gigaparsec.Combinator (skipMany) import Text.Gigaparsec.Errors.Combinator ((<?>)) -- We want to use this to make the docs point to the right definition for users.-import Text.Gigaparsec.Internal qualified as Internal (Parsec(Parsec), State(..))+import Text.Gigaparsec.Internal qualified as Internal (Parsec(Parsec, unParsec), State(..), expectedErr, useHints)+import Text.Gigaparsec.Internal.Errors qualified as Internal (ExpectItem(ExpectRaw), ParseError) import Text.Gigaparsec.Internal.Require (require)  import Data.Bits (Bits((.&.), (.|.)))@@ -59,7 +60,7 @@ import Data.Maybe (isJust, fromJust) import Data.Monoid (Alt(Alt, getAlt)) import Data.Set (Set)-import Data.Set qualified as Set (member, size, findMin, findMax, mapMonotonic)+import Data.Set qualified as Set (empty, member, size, findMin, findMax, mapMonotonic, singleton) import Data.Map (Map) import Data.Map qualified as Map (fromSet, toAscList, member) @@ -67,6 +68,24 @@ -- Primitives ------------------------------------------------- +_satisfy :: Set Internal.ExpectItem -> (Char -> Bool) -> Parsec Char+_satisfy expecteds test = Internal.Parsec $ \st ok bad ->+  case Internal.input st of+    c:cs | test c -> ok c (updateState st c cs)+    _             -> Internal.useHints bad (Internal.expectedErr st expecteds 1) st+  where+  -- The duplicated input & consumed update avoids double allocation+  -- that occurs if they were done separately to the line and col updates.+  updateState st '\n' cs = st+    { Internal.line = Internal.line st + 1, Internal.col = 1,+      Internal.input = cs, Internal.consumed = Internal.consumed st + 1 }+  updateState st '\t' cs = st+    { Internal.col = ((Internal.col st + 3) .&. (-4)) .|. 1,+      Internal.input = cs, Internal.consumed = Internal.consumed st + 1 }+  updateState st _ cs = st+    { Internal.col = Internal.col st + 1,+      Internal.input = cs, Internal.consumed = Internal.consumed st + 1 }+ {-| This combinator tries to parse a single character from the input that matches the given predicate. @@ -75,11 +94,11 @@ consumed and this combinator will fail.  ==== __Examples__->>> parse (satisfy Data.Char.isDigit) ""+>>> parse @String (satisfy Data.Char.isDigit) "" Failure ..->>> parse (satisfy Data.Char.isDigit) "7"+>>> parse @String (satisfy Data.Char.isDigit) "7" Success '7'->>> parse (satisfy Data.Char.isDigit) "a5"+>>> parse @String (satisfy Data.Char.isDigit) "a5" Failure ..  Roughly speaking:@@ -94,23 +113,7 @@                           -- exist.         -> Parsec Char    -- ^ a parser that tries to read a single character @c@, such that @pred c@                           -- is true, or fails.-satisfy test = Internal.Parsec $ \st ok err ->-  case Internal.input st of-    c: cs | test c  ->-      ok c (updateState st c cs)-    _                 -> err st-  where-  -- The duplicated input & consumed update avoids double allocation-  -- that occurs if they were done separately to the line and col updates.-  updateState st '\n' cs = st-    { Internal.line = Internal.line st + 1, Internal.col = 1,-      Internal.input = cs, Internal.consumed = True }-  updateState st '\t' cs = st-    { Internal.col = ((Internal.col st + 3) .&. (-4)) .|. 1,-      Internal.input = cs, Internal.consumed = True }-  updateState st _ cs = st-    { Internal.col = Internal.col st + 1,-      Internal.input = cs, Internal.consumed = True }+satisfy = _satisfy Set.empty  -- Needs to be primitive for the raw expected item down the line {-|@@ -121,18 +124,18 @@ combinator will fail.  ==== __Examples__->>> parse (char 'a') ""+>>> parse @String (char 'a') "" Failure ..->>> parse (char 'a') "a"+>>> parse @String (char 'a') "a" Success 'a'->>> parse (char 'a') "ba"+>>> parse @String (char 'a') "ba" Failure ..  @since 0.1.0.0 -} char :: Char        -- ^ the character to parse, @c@.      -> Parsec Char -- ^ a parser that tries to read a single @c@, or fails.-char c = satisfy (== c)+char c = _satisfy (Set.singleton (Internal.ExpectRaw (pure c))) (== c)  -- Needs to be primitive for the raw expected item and wide caret down the line {-|@@ -145,11 +148,11 @@ matched are consumed from the input.  ==== __Examples__->>> parse (string "abc") ""+>>> parse @String (string "abc") "" Failure ..->>> parse (string "abc") "abcd"+>>> parse @String (string "abc") "abcd" Success "abc"->>> parse (string "abc") "xabc"+>>> parse @String (string "abc") "xabc" Failure ..  ==== Notes@@ -163,7 +166,12 @@        -> Parsec String -- ^ a parser that either parses the string @s@ or fails at the first                         -- mismatched character. string s = require (not (null s)) "Text.Gigaparsec.Char.string" "cannot pass empty string" $-  traverse char s+  --TODO: this could be much improved+  Internal.Parsec $ \st ok bad ->+    let bad' (_ :: Internal.ParseError) =+          Internal.useHints bad (Internal.expectedErr st [Internal.ExpectRaw s]+                                                         (fromIntegral (length s)))+    in Internal.unParsec (traverse char s) st ok bad'  ------------------------------------------------- -- Composite Combinators@@ -179,11 +187,11 @@  ==== __Examples__ >>> let digit = satisfyMap (\c -> if isDigit c then Just (digitToInt c) else Nothing)->>> parse digit ""+>>> parse @String digit "" Failure ..->>> parse digit "7"+>>> parse @String digit "7" Success 7->>> parse digit "a5"+>>> parse @String digit "a5" Failure ..  @since 0.1.0.0@@ -204,11 +212,11 @@  ==== __Examples__ >>> let p = oneOf (Set.fromList ['a'..'c'])->>> parse p "a"+>>> parse @String p "a" Success 'a'->>> parse p "c"+>>> parse @String p "c" Success 'c'->>> parse p "xb"+>>> parse @String p "xb" Failure ..  @since 0.1.0.0@@ -220,14 +228,14 @@   | sz == 1                     = char c1   -- if the smallest and largest characters are as far apart   -- as the size of the set, it must be contiguous-  | sz == (ord c2 - ord c1 + 1) = satisfy (\c -> c1 <= c && c <= c2) <?> Set.mapMonotonic show cs-  | otherwise                   = satisfy (`Set.member` cs) <?> [rangeLabel]+  | sz == (ord c2 - ord c1 + 1) = satisfy (\c -> c1 <= c && c <= c2) <?> [rangeLabel]+  | otherwise                   = satisfy (`Set.member` cs) <?> Set.mapMonotonic (show . (: [])) cs   where !sz = Set.size cs         -- must be left lazy until sz known not to be 0         c1 = Set.findMin cs         c2 = Set.findMax cs         --FIXME: control character safe show (and for the map above!)-        rangeLabel = "one of " ++ show c1 ++ " to " ++ show c2+        rangeLabel = "one of " ++ show @String [c1] ++ " to " ++ show @String [c2]  {-| This combinator tries to parse any character __not__ from supplied set of characters @cs@,@@ -238,13 +246,13 @@  ==== __Examples__ >>> let p = noneOf (Set.from ['a'..'c'])->>> parse p "a"+>>> parse @String p "a" Failure ..->>> parse p "c"+>>> parse @String p "c" Failure ..->>> parse p "xb"+>>> parse @String p "xb" Success 'x'->>> parse p ""+>>> parse @String p "" Failure ..  @since 0.1.0.0@@ -261,7 +269,7 @@         c1 = Set.findMin cs         c2 = Set.findMax cs         --FIXME: control character safe show-        rangeLabel = "anything outside of " ++ show c1 ++ " to " ++ show c2+        rangeLabel = "anything outside of " ++ show @String [c1] ++ " to " ++ show @String [c2]  {-| This combinator parses characters matching the given predicate __zero__ or more times, collecting@@ -273,11 +281,11 @@  ==== __Examples__ >>> let ident = letter <:> stringOfMany isAlphaNum->>> parse ident "abdc9d"+>>> parse @String ident "abdc9d" Success "abdc9d"->>> parse ident "a"+>>> parse @String ident "a" Success "a"->>> parser ident "9"+>>> parse @Stringr ident "9" Failure ..  ==== Notes@@ -301,11 +309,11 @@  ==== __Examples__ >>> let ident = stringOfSome isAlpha->>> parse ident "abdc9d"+>>> parse @String ident "abdc9d" Success "abdc"->>> parse ident "a"+>>> parse @String ident "a" Success "a"->>> parser ident "9"+>>> parse @Stringr ident "9" Failure ..  ==== Notes@@ -329,15 +337,15 @@  ==== __Examples__ >>> let p = strings (Set.fromList ["hell", "hello", "goodbye", "g", "abc"])->>> parse p "hell"+>>> parse @String p "hell" Success "hell"->>> parse p "hello"+>>> parse @String p "hello" Success "hello"->>> parse p "good"+>>> parse @String p "good" Success "g"->>> parse p "goodbye"+>>> parse @String p "goodbye" Success "goodbye"->>> parse p "a"+>>> parse @String p "a" Failure ..  @since 0.1.0.0@@ -363,15 +371,15 @@                                 , ("g", pure 1)                                 , ("abc", pure 3)                                 ]->>> parse p "hell"+>>> parse @String p "hell" Success 4->>> parse p "hello"+>>> parse @String p "hello" Success 5->>> parse p "good"+>>> parse @String p "good" Success 1->>> parse p "goodbye"+>>> parse @String p "goodbye" Success 7->>> parse p "a"+>>> parse @String p "a" Failure ..  ==== Notes@@ -496,8 +504,9 @@  An uppercase letter is any character whose Unicode /Category Type/ is Uppercase Letter (@Lu@). Examples of characters within this category include:-  * the Latin letters @'A'@ through @'Z'@-  * Latin special character such as @'Å'@, @'Ç'@, @'Õ'@++  * the Latin letters @\'A\'@ through @\'Z\'@+  * Latin special character such as @\'Å\'@, @\'Ç\'@, @\'Õ\'@   * Cryillic letters   * Greek letters   * Coptic letters@@ -514,8 +523,9 @@ Letter (@Ll@).  Examples of characters within this category include:-  * the Latin letters @'a'@ through @'z'@-  * Latin special character such as @'é'@, @'ß'@, @'ð'@++  * the Latin letters @\'a\'@ through @\'z\'@+  * Latin special character such as @\'é\'@, @\'ß\'@, @\'ð\'@   * Cryillic letters   * Greek letters   * Coptic letters

@@ -1,6 +1,4 @@ {-# LANGUAGE Safe #-}-{-# OPTIONS_GHC -Wno-unrecognised-pragmas #-}-{-# HLINT ignore "Use optional" #-} {-| Module      : Text.Gigaparsec.Combinator Description : This module contains a huge number of pre-made combinators that are@@ -67,13 +65,13 @@  ==== __Examples__ >>> let p = choice [string "abc", string "ab", string "bc", string "d"]->>> parse p "abc"+>>> parse @String p "abc" Success "abc"->>> parse p "ab"+>>> parse @String p "ab" Failure ..->>> parse p "bc"+>>> parse @String p "bc" Success "bc"->>> parse p "x"+>>> parse @String p "x" Failure ..  @since 0.1.0.0@@ -91,9 +89,9 @@  ==== __Examples__ >>> let p = skip [char'a', item, char 'c']->>> parse p "abc"+>>> parse @String p "abc" Success ()->>> parse p "ab"+>>> parse @String p "ab" Failure ..  @since 0.1.0.0@@ -110,11 +108,11 @@  ==== __Examples__ >>> let p = option (string "abc")->>> parse p ""+>>> parse @String p "" Success Nothing->>> parse p "abc"+>>> parse @String p "abc" Success (Just "abc")->>> parse p "ab"+>>> parse @String p "ab" Failure ..  @since 0.1.0.0@@ -131,11 +129,11 @@  ==== __Examples__ >>> let p = optional (string "abc")->>> parse p ""+>>> parse @String p "" Success ()->>> parse p "abc"+>>> parse @String p "abc" Success ()->>> parse p "ab"+>>> parse @String p "ab" Failure ..  @since 0.1.0.0@@ -152,11 +150,11 @@  ==== __Examples__ >>> let p = optionalAs 7 (string "abc")->>> parse p ""+>>> parse @String p "" Success 7->>> parse p "abc"+>>> parse @String p "abc" Success 7->>> parse p "ab"+>>> parse @String p "ab" Failure ..  @since 0.1.0.0@@ -208,13 +206,13 @@  ==== __Examples__ >>> let p = manyN 2 (string "ab")->>> parse p ""+>>> parse @String p "" Failure ..->>> parse p "ab"+>>> parse @String p "ab" Failure ..->>> parse p "abababab"+>>> parse @String p "abababab" Success ["ab", "ab", "ab", "ab"]->>> parse p "aba"+>>> parse @String p "aba" Failure ..  ==== Notes@@ -238,13 +236,13 @@  ==== __Examples__ >>> let p = skipMany (string "ab")->>> parse p ""+>>> parse @String p "" Success ()->>> parse p "ab"+>>> parse @String p "ab" Success ()->>> parse p "abababab"+>>> parse @String p "abababab" Success ()->>> parse p "aba"+>>> parse @String p "aba" Failure ..  @since 0.1.0.0@@ -262,13 +260,13 @@  ==== __Examples__ >>> let p = skipSome (string "ab")->>> parse p ""+>>> parse @String p "" Failure ..->>> parse p "ab"+>>> parse @String p "ab" Success ()->>> parse p "abababab"+>>> parse @String p "abababab" Success ()->>> parse p "aba"+>>> parse @String p "aba" Failure ..  @since 0.1.0.0@@ -286,13 +284,13 @@  ==== __Examples__ >>> let p = skipManyN 2 (string "ab")->>> parse p ""+>>> parse @String p "" Failure ..->>> parse p "ab"+>>> parse @String p "ab" Failure ..->>> parse p "abababab"+>>> parse @String p "abababab" Success ()->>> parse p "aba"+>>> parse @String p "aba" Failure ..  @since 0.1.0.0@@ -313,13 +311,13 @@  ==== __Examples__ >>> let p = count (string "ab")->>> parse p ""+>>> parse @String p "" Success 0->>> parse p "ab"+>>> parse @String p "ab" Success 1->>> parse p "abababab"+>>> parse @String p "abababab" Success 4->>> parse p "aba"+>>> parse @String p "aba" Failure ..  @since 0.1.0.0@@ -337,13 +335,13 @@  ==== __Examples__ >>> let p = count1 (string "ab")->>> parse p ""+>>> parse @String p "" Failure ..->>> parse p "ab"+>>> parse @String p "ab" Success 1->>> parse p "abababab"+>>> parse @String p "abababab" Success 4->>> parse p "aba"+>>> parse @String p "aba" Failure ..  @since 0.1.0.0@@ -360,13 +358,13 @@ ==== __Examples__ >>> ... >>> let args = sepBy int (string ", ")->>> parse args "7, 3, 2"+>>> parse @String args "7, 3, 2" Success [7, 3, 2]->>> parse args ""+>>> parse @String args "" Success []->>> parse args "1"+>>> parse @String args "1" Success [1]->>> parse args "1, 2, "+>>> parse @String args "1, 2, " Failure ..  @since 0.1.0.0@@ -387,13 +385,13 @@ ==== __Examples__ >>> ... >>> let args = sepBy1 int (string ", ")->>> parse args "7, 3, 2"+>>> parse @String args "7, 3, 2" Success [7, 3, 2]->>> parse args ""+>>> parse @String args "" Failure ..->>> parse args "1"+>>> parse @String args "1" Success [1]->>> parse args "1, 2, "+>>> parse @String args "1, 2, " Failure ..  @since 0.1.0.0@@ -411,13 +409,13 @@ ==== __Examples__ >>> ... >>> let args = sepEndBy int (string ";\n")->>> parse args "7;\n3;\n2"+>>> parse @String args "7;\n3;\n2" Success [7, 3, 2]->>> parse args ""+>>> parse @String args "" Success Nil->>> parse args "1"+>>> parse @String args "1" Success [1]->>> parse args "1;\n2;\n"+>>> parse @String args "1;\n2;\n" Success [1, 2]  @since 0.1.0.0@@ -438,13 +436,13 @@ ==== __Examples__ >>> ... >>> let args = sepEndBy1 int (string ";\n")->>> parse args "7;\n3;\n2"+>>> parse @String args "7;\n3;\n2" Success [7, 3, 2]->>> parse args ""+>>> parse @String args "" Failure ..->>> parse args "1"+>>> parse @String args "1" Success [1]->>> parse args "1;\n2;\n"+>>> parse @String args "1;\n2;\n" Success [1, 2]  @since 0.1.0.0@@ -462,13 +460,13 @@ ==== __Examples__ >>> ... >>> let args = endBy int (string ";\n")->>> parse args "7;\n3;\n2"+>>> parse @String args "7;\n3;\n2" Failure ..->>> parse args ""+>>> parse @String args "" Success Nil->>> parse args "1;\n"+>>> parse @String args "1;\n" Success [1]->>> parse args "1;\n2;\n"+>>> parse @String args "1;\n2;\n" Success [1, 2]  @since 0.1.0.0@@ -488,13 +486,13 @@ ==== __Examples__ >>> ... >>> let args = endBy1 int (string ";\n")->>> parse args "7;\n3;\n2"+>>> parse @String args "7;\n3;\n2" Failure ..->>> parse args ""+>>> parse @String args "" Failure ..->>> parse args "1;\n"+>>> parse @String args "1;\n" Success [1]->>> parse args "1;\n2;\n"+>>> parse @String args "1;\n2;\n" Success [1, 2]  @since 0.1.0.0@@ -513,12 +511,13 @@  ==== __Examples__ This can be useful for scanning comments:+ >>> let comment = string "--" *> manyUntil item endOfLine->>> parse p "--hello world"+>>> parse @String p "--hello world" Failure ..->>> parse p "--hello world\n"+>>> parse @String p "--hello world\n" Success ['h', 'e', 'l', 'l', 'o', ' ', 'w', 'o', 'r', 'l', 'd']->>> parse p "--\n"+>>> parse @String p "--\n" Success Nil  @since 0.1.0.0@@ -538,14 +537,15 @@  ==== __Examples__ This can be useful for scanning comments:+ >>> let comment = string "--" *> someUntil item endOfLine->>> parse p "--hello world"+>>> parse @String p "--hello world" Failure ..->>> parse p "--hello world\n"+>>> parse @String p "--hello world\n" Success ['h', 'e', 'l', 'l', 'o', ' ', 'w', 'o', 'r', 'l', 'd']->>> parse p "--\n"+>>> parse @String p "--\n" Failure ..->>> parse p "--a\n"+>>> parse @String p "--a\n" Success ['a']  @since 0.1.0.0@@ -646,11 +646,11 @@  ==== __Examples__ >>> let p = exactly 3 item->>> parse p "ab"+>>> parse @String p "ab" Failure ..->>> parse p "abc"+>>> parse @String p "abc" Success ['a', 'b', 'c']->>> parse p "abcd"+>>> parse @String p "abcd" Success ['a', 'b', 'c']  @since 0.1.0.0@@ -669,15 +669,15 @@  ==== __Examples__ >>> let p = range 3 5 item->>> parse p "ab"+>>> parse @String p "ab" Failure ..->>> parse p "abc"+>>> parse @String p "abc" Success ['a', 'b', 'c']->>> parse p "abcd"+>>> parse @String p "abcd" Success ['a', 'b', 'c', 'd']->>> parse p "abcde"+>>> parse @String p "abcde" Success ['a', 'b', 'c', 'd', 'e']->>> parse p "abcdef"+>>> parse @String p "abcdef" Success ['a', 'b', 'c', 'd', 'e']  @since 0.1.0.0@@ -703,15 +703,15 @@  ==== __Examples__ >>> let p = range_ 3 5 item->>> parse p "ab"+>>> parse @String p "ab" Failure ..->>> parse p "abc"+>>> parse @String p "abc" Success ()->>> parse p "abcd"+>>> parse @String p "abcd" Success ()->>> parse p "abcde"+>>> parse @String p "abcde" Success ()->>> parse p "abcdef"+>>> parse @String p "abcdef" Success ()  @since 0.1.0.0@@ -739,15 +739,15 @@  ==== __Examples__ >>> let p = count 3 5 item->>> parse p "ab"+>>> parse @String p "ab" Failure ..->>> parse p "abc"+>>> parse @String p "abc" Success 3->>> parse p "abcd"+>>> parse @String p "abcd" Success 4->>> parse p "abcde"+>>> parse @String p "abcde" Success 5->>> parse p "abcdef"+>>> parse @String p "abcdef" Success 5  @since 0.1.0.0

@@ -1,18 +1,354 @@ {-# LANGUAGE Safe #-}-module Text.Gigaparsec.Errors.Combinator (module Text.Gigaparsec.Errors.Combinator) where+{-# OPTIONS_GHC -Wno-missing-import-lists #-}+{-|+Module      : Text.Gigaparsec.Errors.Combinator+Description : This module contains combinators that can be used to directly influence error+              messages of parsers.+License     : BSD-3-Clause+Maintainer  : Jamie Willis, Gigaparsec Maintainers+Stability   : stable +Error messages are, by default, not /particularly/ descriptive. However, the combinators in this+module can be used to improve the generation of error messages by providing labels for expected+items, explanations for why things went wrong, custom error messages, custom unexpected error messages,+as well as correcting the offsets that error messages actually occurred at.++==== Terminology++__Observably consumes input__: a parser is said to /observably/ consume input when error messages generated by a parser @p@ occur at a deeper+offset than @p@ originally started at. While this sounds like it is the same as "having consumed input" for the+purposes of backtracking, they are disjoint concepts:++  1. in @atomic p@, @p@ can /observably/ consume input even though the wider parser does not consume input due to the @atomic@.+  2. in @amend p@, @p@ can consume input and may not backtrack even though the consumption is not /observable/ in the error+     message due to the @amend@.++@since 0.2.0.0+-}+module Text.Gigaparsec.Errors.Combinator (+  -- * Error Enrichment Combinators+  -- | These combinators add additional information - or refine the existing information within - to+  -- an error message that has been generated within the scope of the parser they have been called on.+  -- These are a very basic, but effective, way of improving the quality of error messages generated+  -- by gigaparsec.+    label, (<?>), hide, explain,+  -- * Failure Combinators+  -- | These combinators immediately fail the parser, with a more bespoke message.+    emptyWide,+    fail, failWide,+    unexpected, unexpectedWide,+  -- * Error Adjustment Combinators+  -- | These combinators can affect at what position an error is caused at. They are+  -- opposites: where 'amend' will ensure an error message is said to have generated+  -- at the position on entry to the combinator, 'entrench' will resist these changes.+    amend, partialAmend, entrench, dislodge, dislodgeBy,+    amendThenDislodge, amendThenDislodgeBy, partialAmendThenDislodge, partialAmendThenDislodgeBy,+    markAsToken+  ) where++{-+Future doc headings:++Filtering Combinators+=====================+These combinators perform filtering on a parser, with particular emphasis on generating meaningful+error messages if the filtering fails. This is particularly useful for data validation within the+parser, as very instructive error messages describing what went wrong can be generated. These combinators+often filter using a `PartialFunction`: this may be because they combine filtering with mapping (in which+case, the error message is provided separately), or the function may produce a `String`.++In these cases, the partial function is producing the error messages: if the input to the function is+defined, this means that it is invalid and the filtering will fail using the message obtained from the+successful partial function invocation.++Generic Filtering Combinators+=============================+This combinators generalise the combinators from above, which are all special cases of them. Each of these+takes the characteristic predicate or function of the regular variants, but takes an `errGen` object that+can be used to fine-tune the error messages. These offer some flexiblity not offered by the specialised+filtering combinators, but are a little more verbose to use.+-}++import Prelude hiding (fail)+ import Text.Gigaparsec (Parsec) -- We want to use this to make the docs point to the right definition for users.---import Text.Gigaparsec.Internal qualified as Internal (Parsec(Parsec))+import Text.Gigaparsec.Internal qualified as Internal (Parsec(Parsec), line, col, emptyErr, specialisedErr, raise, unexpectedErr, hints, consumed, useHints, adjustErr, hints, hintsValidOffset)+import Text.Gigaparsec.Internal.Errors (ParseError, CaretWidth(FlexibleCaret, RigidCaret), ExpectItem(ExpectNamed))+import Text.Gigaparsec.Internal.Errors qualified as Internal (setLexical, amendErr, entrenchErr, dislodgeErr, partialAmendErr, labelErr, explainErr) import Text.Gigaparsec.Internal.Require (require)  import Data.Set (Set)+import Data.Set qualified as Set (empty, map)+import Data.List.NonEmpty (NonEmpty)+import Data.List.NonEmpty qualified as NonEmpty (toList) --- the empty set is weird here, do we require non-empty or just make it id?-label :: Set String -> Parsec a -> Parsec a-label ls =-  require (not (any null ls)) "Text.Gigaparsec.Errors.Combinator.label" "labels cannot be empty" id --TODO:+{-|+This combinator changes the expected component of any errors generated by this parser. +When this parser fails having not /observably/ consumed input, the expected component of the generated+error message is set to be the given items.+-}+label :: Set String -- ^ the names to give to the expected component of any qualifying errors.+      -> Parsec a   -- ^ the parser to apply the labels to+      -> Parsec a+label ls (Internal.Parsec p) =+  require (not (null ls) && not (any null ls)) "Text.Gigaparsec.Errors.Combinator.label"+                                               "labels cannot be empty" $+    Internal.Parsec $ \st good bad ->+      let !origConsumed = Internal.consumed st+          good' x st'+            | Internal.consumed st' /= origConsumed = good x st'+            | otherwise = good x st' { Internal.hints = Set.map ExpectNamed ls }+          bad' err = Internal.useHints bad (Internal.labelErr origConsumed ls err)+      in p st good' bad'++{-|+This combinator suppresses the entire error message generated by a given parser.++When this parser fails having not /observably/ consumed input, this combinator+replaces any error generated by the given parser to match the 'Text.Gigaparsec.empty' combinator.++This can be useful, say, for hiding whitespace labels, which are not normally useful+information to include in an error message for whitespace insensitive grammars.+-}+hide :: Parsec a -> Parsec a+hide (Internal.Parsec p) =+  Internal.Parsec $ \st good bad ->+    let !origConsumed = Internal.consumed st+        good' x st' = good x st' { Internal.hints = Set.empty }+        bad' err st'+          | Internal.consumed st' /= origConsumed = bad err st'+          | otherwise = Internal.useHints bad (Internal.emptyErr st' 0) st'+    in p st good' bad'++{-|+This combinator adds a reason to error messages generated by this parser.++When this parser fails having not /observably/ consumed input, this combinator adds+a reason to the error message, which should justify why the error occured. Unlike error+labels, which may persist if more progress is made having not consumed input, reasons+are not carried forward in the error message, and are lost.+-}+explain :: String   -- ^ reason the reason why a parser failed.+        -> Parsec a -- ^ the parser to apply the reason to+        -> Parsec a+explain reason (Internal.Parsec p) =+  Internal.Parsec $ \st good bad ->+    let !origConsumed = Internal.consumed st+        bad' err = Internal.useHints bad (Internal.explainErr origConsumed reason err)+    in p st good bad'++{-|+This combinator fails immediately, with a caret of the given width and no other information.++By producing basically no information, this combinator is principally for adjusting the+caret-width of another error, rather than the value 'Text.Gigaparsec.empty', which is used to fail with+no effect on error content.+-}+emptyWide :: Word     -- ^ the width of the caret for the error produced by this combinator.+          -> Parsec a+emptyWide width = Internal.raise (`Internal.emptyErr` width)++{-|+This combinator consumes no input and fails immediately with the given error messages.++Produces a /specialised/ error message where all the lines of the error are the+given @msgs@ in order of appearance.++==== __Examples__+>>> let failing = fail ["hello,", "this is an error message", "broken across multiple lines"]++-}+fail :: NonEmpty String -- ^ the messages that will make up the error message.+     -> Parsec a+fail = _fail (FlexibleCaret 1)++{-|+This combinator consumes no input and fails immediately with the given error messages.++Produces a /specialised/ error message where all the lines of the error are the+given @msgs@ in order of appearance. The caret width of the message is set to the+given value.++==== __Examples__+>>> let failing = fail 3 ["hello,", "this is an error message", "broken across multiple lines"]++-}+failWide :: Word            -- ^ the width of the caret for the error produced by this combinator.+         -> NonEmpty String -- ^ the messages that will make up the error message.+         -> Parsec a+failWide width = _fail (RigidCaret width)++{-# INLINE _fail #-}+_fail :: CaretWidth -> NonEmpty String -> Parsec a+_fail width msgs = Internal.raise (\st -> Internal.specialisedErr st (NonEmpty.toList msgs) width)++{-|+This combinator consumes no input and fails immediately, setting the unexpected component+to the given item.++Produces a /trivial/ error message where the unexpected component of the error is+replaced with the given item.+-}+unexpected :: String   -- ^ the unexpected message for the error generated.+           -> Parsec a+unexpected = _unexpected (FlexibleCaret 1)++{-|+This combinator consumes no input and fails immediately, setting the unexpected component+to the given item.++Produces a /trivial/ error message where the unexpected component of the error is+replaced with the given item. The caret width of the message is set to the+given value.+-}+unexpectedWide :: Word     -- ^ the width of the caret for the error produced by this combinator.+               -> String   -- ^ the unexpected message for the error generated.+               -> Parsec a+unexpectedWide width = _unexpected (RigidCaret width)++{-# INLINE _unexpected #-}+_unexpected :: CaretWidth -> String -> Parsec a+_unexpected width name = Internal.raise $ \st -> Internal.unexpectedErr st Set.empty name width++{-|+This combinator adjusts any error messages generated by the given parser so that they+occur at the position recorded on entry to this combinator (effectively as if no+input were consumed).++This is useful if validation work is done+on the output of a parser that may render it invalid, but the error should point to the+beginning of the structure. This combinators effect can be cancelled with [[entrench `entrench`]].++==== __Examples__+>>> let greeting = string "hello world" <* char '!'+>>> parseRepl (greeting <?> ["greeting"]) "hello world."+(line 1, column 12):+  unexpected "."+  expected "!"+  >hello world.+              ^+>>> parseRepl (amend greeting <?> ["greeting"]) "hello world."+(line 1, column 1):+  unexpected "h"+  expected greeting+  >hello world.+   ^+-}+amend :: Parsec a -> Parsec a+amend = _amend Internal.amendErr++--TODO: examples+{-|+This combinator adjusts any error messages generated by the given parser so that they+occur at the position recorded on entry to this combinator, but retains the original offset.++Similar to 'amend', but retains the original offset the error occurred at. This is known+as its /underlying offset/ as opposed to the visual /presentation offset/. To the reader, the+error messages appears as if no input was consumed, but for the purposes of error message merging+the error is still deeper. A key thing to note is that two errors can only merge if they are at+the same presentation /and/ underlying offsets: if they are not the deeper of the two /dominates/.++The ability for an error to still dominate others after partial amendment can be useful for allowing+it to avoid being lost when merging with errors that are deeper than the presentation offset but+shallower than the underlying.+-}+partialAmend :: Parsec a -> Parsec a+partialAmend = _amend Internal.partialAmendErr++{-# INLINE _amend #-}+_amend :: (Word -> Word -> Word -> ParseError -> ParseError) -> Parsec a -> Parsec a+_amend f (Internal.Parsec p) =+  Internal.Parsec $ \st good bad ->+    let !origConsumed = Internal.consumed st+        !origLine = Internal.line st+        !origCol = Internal.col st+        !origHints = Internal.hints st+        !origHintsValidOffset = Internal.hintsValidOffset st+    in p st good $ \err st' -> bad (f origConsumed origLine origCol err)+                                   st' { Internal.hints = origHints+                                       , Internal.hintsValidOffset = origHintsValidOffset }++--TODO: examples+{-|+This combinator prevents the action of any enclosing 'amend' on the errors generated by the given+parser.++Sometimes, the error adjustments performed by 'amend' should only affect errors generated+within a certain part of a parser and not the whole thing; in this case, 'entrench' can be used+to protect sub-parsers from having their errors adjusted, providing a much more fine-grained+scope for error adjustment.+-}+entrench :: Parsec a -> Parsec a+entrench = Internal.adjustErr Internal.entrenchErr++{-|+This combinator undoes the action of any 'entrench' combinators on the given parser.++Entrenchment is important for preventing the incorrect amendment of certain parts of sub-errors+for a parser, but it may be then undesireable to block further amendments from elsewhere in the+parser. This combinator can be used to cancel all entrenchment after the critical section has+passed.+-}+dislodge :: Parsec a -> Parsec a+dislodge = dislodgeBy maxBound++{-|+This combinator undoes the action of the given number of 'entrench' combinators on the given parser.++Entrenchment is important for preventing the incorrect amendment of certain parts of sub-errors+for a parser, but it may be then undesireable to block further amendments from elsewhere in the+parser. This combinator can be used to cancel all entrenchment after the critical section has+passed.+-}+dislodgeBy :: Word -> Parsec a -> Parsec a+dislodgeBy by = Internal.adjustErr (Internal.dislodgeErr by)++{-|+This combinator first tries to amend the position of any error generated by the given parser,+and if the error was entrenched will dislodge it instead.+-}+amendThenDislodge :: Parsec a -> Parsec a+amendThenDislodge = dislodge . amend++{-|+This combinator first tries to amend the position of any error generated by the given parser,+and if the error was entrenched will dislodge it the given number of times instead.+-}+amendThenDislodgeBy :: Word -> Parsec a -> Parsec a+amendThenDislodgeBy n = dislodgeBy n . amend++{-|+This combinator first tries to partially amend the position of any error generated by the given parser,+and if the error was entrenched will dislodge it instead.+-}+partialAmendThenDislodge :: Parsec a -> Parsec a+partialAmendThenDislodge = dislodge . partialAmend++{-|+This combinator first tries to partially amend the position of any error generated by the given parser,+and if the error was entrenched will dislodge it the given number of times instead.+-}+partialAmendThenDislodgeBy :: Word -> Parsec a -> Parsec a+partialAmendThenDislodgeBy n = dislodgeBy n . partialAmend++{-|+This combinator marks any errors within the given parser as being /lexical errors/.++When an error is marked as a /lexical error/, it sets a flag within the error that is+passed to 'Text.Gigaparsec.Errors.ErrorBuilder.unexpectedToken': this+should be used to prevent @Lexer@-based token extraction from being performed on an error,+since lexing errors cannot be the result of unexpected tokens.+-}+markAsToken :: Parsec a -> Parsec a+markAsToken = Internal.adjustErr Internal.setLexical++{-|+This combinator changes the expected component of any errors generated by this parser.++This is just an alias for the 'label' combinator.+-} {-# INLINE (<?>) #-} infix 0 <?> (<?>) :: Parsec a -> Set String -> Parsec a

@@ -0,0 +1,135 @@+{-# LANGUAGE Trustworthy #-}+{-# LANGUAGE DerivingVia, OverloadedStrings #-}+{-# OPTIONS_GHC -Wno-missing-import-lists #-}+module Text.Gigaparsec.Errors.DefaultErrorBuilder (module Text.Gigaparsec.Errors.DefaultErrorBuilder) where++import Prelude hiding (lines)++import Data.Monoid (Endo(Endo))+import Data.String (IsString(fromString))+import Data.List (intersperse, sortBy)+import Data.Maybe (mapMaybe)+import Data.Foldable (toList)+import Data.Ord (comparing, Down (Down))++-- For now, this is the home of the default formatting functions++type StringBuilder :: *+newtype StringBuilder = StringBuilder (String -> String)+  deriving (Semigroup, Monoid) via Endo String++instance IsString StringBuilder where+  {-# INLINE fromString #-}+  fromString :: String -> StringBuilder+  fromString str = StringBuilder (str ++)++{-# INLINE toString #-}+toString :: StringBuilder -> String+toString (StringBuilder build) = build mempty++{-# INLINE from #-}+from :: Show a => a -> StringBuilder+from = StringBuilder . shows++{-# INLINABLE formatDefault #-}+formatDefault :: StringBuilder -> Maybe StringBuilder -> [StringBuilder] -> String+formatDefault pos source lines = toString (blockError header lines 2)+  where header = maybe mempty (\src -> "In " <> src <> " ") source <> pos++{-# INLINABLE vanillaErrorDefault #-}+vanillaErrorDefault :: Foldable t => Maybe StringBuilder -> Maybe StringBuilder -> t StringBuilder -> [StringBuilder] -> [StringBuilder]+vanillaErrorDefault unexpected expected reasons =+  combineInfoWithLines (maybe id (:) unexpected (maybe id (:) expected (toList reasons)))++{-# INLINABLE specialisedErrorDefault #-}+specialisedErrorDefault :: [StringBuilder] -> [StringBuilder] -> [StringBuilder]+specialisedErrorDefault = combineInfoWithLines++{-# INLINABLE combineInfoWithLines #-}+combineInfoWithLines :: [StringBuilder] -> [StringBuilder] -> [StringBuilder]+combineInfoWithLines [] lines = "unknown parse error" : lines+combineInfoWithLines info lines = info ++ lines++--TODO: this needs to deal with whitespace and unprintables+{-# INLINABLE rawDefault #-}+rawDefault :: String -> String+rawDefault n = "\"" <> n <> "\""++{-# INLINABLE namedDefault #-}+namedDefault :: String -> String+namedDefault = id++{-# INLINABLE endOfInputDefault #-}+endOfInputDefault :: String+endOfInputDefault = "end of input"++{-# INLINABLE messageDefault #-}+messageDefault :: String -> String+messageDefault = id++{-# INLINABLE expectedDefault #-}+expectedDefault :: Maybe StringBuilder -> Maybe StringBuilder+expectedDefault = fmap ("expected " <>)++{-# INLINABLE unexpectedDefault #-}+unexpectedDefault :: Maybe String -> Maybe StringBuilder+unexpectedDefault = fmap (("unexpected " <>) . fromString)++{-# INLINABLE disjunct #-}+disjunct :: Bool -> [String] -> Maybe StringBuilder+disjunct oxford elems = junct oxford elems "or"++{-# INLINABLE junct #-}+junct :: Bool -> [String] -> String -> Maybe StringBuilder+junct oxford elems junction = junct' (sortBy (comparing Down) elems)+  where+    j :: StringBuilder+    j = fromString junction++    junct' [] = Nothing+    junct' [alt] = Just (fromString alt)+    junct' [alt1, alt2] = Just (fromString alt2 <> " " <> fromString junction <> " " <> fromString alt1)+    junct' as@(alt:alts)+      -- use a semi-colon here, it is more correct+      | any (elem ',') as = Just (junct'' (reverse alts) alt "; ")+      | otherwise         = Just (junct'' (reverse alts) alt ", ")++    junct'' is l delim = front <> back+      where front = intercalate (fromString delim) (map fromString is) :: StringBuilder+            back+              | oxford    = fromString delim <> j <> " " <> fromString l+              | otherwise = " " <> j <> " " <> fromString l++{-# INLINABLE combineMessagesDefault #-}+combineMessagesDefault :: Foldable t => t String -> [StringBuilder]+combineMessagesDefault = mapMaybe (\msg -> if null msg then Nothing else Just (fromString msg)) . toList++{-# INLINABLE blockError #-}+blockError :: StringBuilder -> [StringBuilder] -> Int -> StringBuilder+blockError header lines indent = header <> ":\n" <> indentAndUnlines lines indent++{-# INLINABLE indentAndUnlines #-}+indentAndUnlines :: [StringBuilder] -> Int -> StringBuilder+indentAndUnlines lines indent = fromString pre <> intercalate (fromString ('\n' : pre)) lines+  where pre = replicate indent ' '++{-# INLINABLE lineInfoDefault #-}+lineInfoDefault :: String -> [String] -> [String] -> Word -> Word -> [StringBuilder]+lineInfoDefault curLine beforeLines afterLines pointsAt width =+  concat [map inputLine beforeLines, [inputLine curLine, caretLine], map inputLine afterLines]+  where inputLine :: String -> StringBuilder+        inputLine = fromString . ('>' :)+        caretLine :: StringBuilder+        caretLine = fromString (replicate (fromIntegral (pointsAt + 1)) ' ') <> fromString (replicate (fromIntegral width) '^')++{-# INLINABLE formatPosDefault #-}+formatPosDefault :: Word -> Word -> StringBuilder+formatPosDefault line col = "(line "+                         <> from line+                         <> ", column "+                         <> from col+                         <> ")"++{-# INLINABLE intercalate #-}+intercalate :: Monoid m => m -> [m] -> m+intercalate x xs = mconcat (intersperse x xs)

@@ -0,0 +1,379 @@+{-# LANGUAGE Safe #-}+{-# LANGUAGE TypeFamilies, AllowAmbiguousTypes, FlexibleInstances, FlexibleContexts #-}+{-|+Module      : Text.Gigaparsec.Errors.ErrorBuilder+Description : This typeclass specifies how to format an error from a parser as a specified type.+License     : BSD-3-Clause+Maintainer  : Jamie Willis, Gigaparsec Maintainers+Stability   : stable++This typeclass specifies how to format an error from a parser+as a specified type.++An instance of this typeclass is required when calling 'Text.Gigaparsec.parse'+(or similar). By default, @gigaparsec@ defines its own instance for+@ErrorBuilder String@ found in this module.++To implement @ErrorBuilder@, a number of methods must be defined,+as well the representation types for a variety of different components;+the relation between the various methods is closely linked+to the types that they both produce and consume. To only change+the basics of formatting without having to define the entire instance,+use the methods found in "Text.Gigaparsec.Errors.DefaultErrorBuilder".++= How an Error is Structured+There are two kinds of error messages that are generated by @gigaparsec@:+/Specialised/ and /Vanilla/. These are produced by different combinators+and can be merged with other errors of the same type if both errors appear+at the same offset. However, /Specialised/ errors will take precedence+over /Vanilla/ errors if they appear at the same offset. The most+common form of error is the /Vanilla/ variant, which is generated by+most combinators, except for some in "Text.Gigaparsec.Errors.Combinator".++Both types of error share some common structure, namely:++  - The error preamble, which has the file and the position.+  - The content lines, the specifics of which differ between the two types of error.+  - The context lines, which has the surrounding lines of input for contextualisation.++== /Vanilla/ Errors+There are three kinds of content line found in a /Vanilla/ error:++  1. Unexpected info: this contains information about the kind of token that caused the error.+  2. Expected info: this contains the information about what kinds of token could have avoided the error.+  3. Reasons: these are the bespoke reasons that an error has occurred (as generated by 'Text.Gigaparsec.Errors.Combinator.explain').++There can be at most one unexpected line, at most one expected line, and zero or more reasons.+Both of the unexpected and expected info are built up of /error items/, which are either:+the end of input, a named token, raw input taken from the parser definition. These can all be+formatted separately.++The overall structure of a /Vanilla/ error is given in the following diagram:++> ┌───────────────────────────────────────────────────────────────────────┐+> │   Vanilla Error                                                       │+> │                          ┌────────────────┐◄──────── position         │+> │                  source  │                │                           │+> │                     │    │   line      col│                           │+> │                     ▼    │     │         ││                           │+> │                  ┌─────┐ │     ▼         ▼│   end of input            │+> │               In foo.txt (line 1, column 5):       │                  │+> │                 ┌─────────────────────┐            │                  │+> │unexpected ─────►│                     │            │  ┌───── expected │+> │                 │          ┌──────────┐ ◄──────────┘  │               │+> │                 unexpected end of input               ▼               │+> │                 ┌──────────────────────────────────────┐              │+> │                 expected "(", "negate", digit, or letter              │+> │                          │    └──────┘  └───┘     └────┘ ◄────── named│+> │                          │       ▲        └──────────┘ │              │+> │                          │       │                     │              │+> │                          │      raw                    │              │+> │                          └─────────────────┬───────────┘              │+> │                 '-' is a binary operator   │                          │+> │                 └──────────────────────┘   │                          │+> │                ┌──────┐        ▲           │                          │+> │                │>3+4- │        │           expected items             │+> │                │     ^│        │                                      │+> │                └──────┘        └───────────────── reason              │+> │                   ▲                                                   │+> │                   │                                                   │+> │                   line info                                           │+> └───────────────────────────────────────────────────────────────────────┘+++== /Specialised/ Errors+There is only one kind of content found in a /Specialised/ error:+a message. These are completely free-form, and are generated by the+'Text.Gigaparsec.Errors.Combinator.failWide' combinator, as well as its derived combinators.+There can be one or more messages in a /Specialised/ error.++The overall structure of a /Specialised/ error is given in the following diagram:++> ┌───────────────────────────────────────────────────────────────────────┐+> │   Specialised Error                                                   │+> │                          ┌────────────────┐◄──────── position         │+> │                  source  │                │                           │+> │                     │    │   line       col                           │+> │                     ▼    │     │         │                            │+> │                  ┌─────┐ │     ▼         ▼                            │+> │               In foo.txt (line 1, column 5):                          │+> │                                                                       │+> │           ┌───► something went wrong                                  │+> │           │                                                           │+> │ message ──┼───► it looks like a binary operator has no argument       │+> │           │                                                           │+> │           └───► '-' is a binary operator                              │+> │                ┌──────┐                                               │+> │                │>3+4- │                                               │+> │                │     ^│                                               │+> │                └──────┘                                               │+> │                   ▲                                                   │+> │                   │                                                   │+> │                   line info                                           │+> └───────────────────────────────────────────────────────────────────────┘++@since 0.2.0.0+-}+module Text.Gigaparsec.Errors.ErrorBuilder (ErrorBuilder(..), Token(..)) where++import Text.Gigaparsec.Errors.DefaultErrorBuilder ( StringBuilder, formatDefault+                                                  , vanillaErrorDefault, specialisedErrorDefault+                                                  , rawDefault, namedDefault, endOfInputDefault+                                                  , expectedDefault, unexpectedDefault+                                                  , disjunct, combineMessagesDefault+                                                  , formatPosDefault, lineInfoDefault+                                                  )++import Data.Char (isSpace, generalCategory, ord, GeneralCategory(Format, Surrogate, PrivateUse, NotAssigned, Control))+import Data.Kind (Constraint)+import Data.List.NonEmpty (NonEmpty((:|)))+import Data.Set (Set)+import Data.Set qualified as Set (toList)+import Data.String (IsString(fromString))+import Numeric (showHex)++{-|+This class describes how to format an error message generated by a parser into+a form the parser writer desires.+-}+type ErrorBuilder :: * -> Constraint+class (Ord (Item err)) => ErrorBuilder err where+  {-|+  This is the top level function, which finally compiles all the formatted+  sub-parts into a finished value of type @err@.+  -}+  format :: Position err       -- ^ the representation of the position of the error in the input (see the 'pos' method).+         -> Source err         -- ^ the representation of the filename, if it exists (see the 'source' method).+         -> ErrorInfoLines err -- ^ the main body of the error message (see 'vanillaError' or 'specialisedError' methods).+         -> err                -- ^ the final error message++  -- | The representation type of position information within the generated message.+  type Position err+  -- | The representation of the file information.+  type Source err+  {-|+  Formats a position into the representation type given by 'Position'.+  -}+  pos :: Word         -- ^ the line the error occurred at.+      -> Word         -- ^ the column the error occurred at.+      -> Position err -- ^ a representation of the position.+  {-|+  Formats the name of the file parsed from, if it exists, into the type given by 'Source'.+  -}+  source :: Maybe FilePath -- ^ the source name of the file, if any.+         -> Source err++  -- | The representation type of the main body within the error message.+  type ErrorInfoLines err+  {-|+  Vanilla errors are those produced such that they have information about+  both @expected@ and @unexpected@ tokens. These are usually the default,+  and are not produced by @fail@ (or any derivative) combinators.+  -}+  vanillaError :: UnexpectedLine err -- ^ information about which token(s) caused the error (see the 'unexpected' method).+               -> ExpectedLine err   -- ^ information about which token(s) would have avoided the error (see the 'expected' method).+               -> Messages err       -- ^ additional information about why the error occured (see the 'combineMessages' method).+               -> LineInfo err       -- ^ representation of the line of input that this error occured on (see the 'lineInfo' method).+               -> ErrorInfoLines err+  {-|+  Specialised errors are triggered by @fail@ and any combinators that are+  implemented in terms of @fail@. These errors take precedence over+  the vanilla errors, and contain less, more specialised, information.+  -}+  specialisedError :: Messages err -- ^ information detailing the error (see the 'combineMessages' method).+                   -> LineInfo err -- ^ representation of the line of input that this error occured on (see the 'lineInfo' method).+                   -> ErrorInfoLines err++  -- | The representation of all the different possible tokens that could have prevented an error.+  type ExpectedItems err+  -- | The representation of the combined reasons or failure messages from the parser.+  type Messages err++  {-|+  Details how to combine the various expected items into a single representation.+  -}+  combineExpectedItems :: Set (Item err) -- ^ the possible items that fix the error.+                       -> ExpectedItems err+  {-|+  Details how to combine any reasons or messages generated within a+  single error. Reasons are used by @vanilla@ messages and messages+  are used by @specialised@ messages.+  -}+  combineMessages :: [Message err] -- ^  the messages to combine (see the 'message' or 'reason' methods).+                  -> Messages err++  -- | The representation of the information regarding the problematic token.+  type UnexpectedLine err+  -- | The representation of the information regarding the solving tokens.+  type ExpectedLine err+  -- | The representation of a reason or a message generated by the parser.+  type Message err+  -- | The representation of the line of input where the error occurred.+  type LineInfo err++  {-|+  Describes how to handle the (potentially missing) information+  about what token(s) caused the error.+  -}+  unexpected :: Maybe (Item err) -- ^ the @Item@ that caused this error.+             -> UnexpectedLine err+  {-|+  Describes how to handle the information about the tokens that+  could have avoided the error.+  -}+  expected :: ExpectedItems err -- ^ the tokens that could have prevented the error (see 'combineExpectedItems').+           -> ExpectedLine err+  {-|+  Describes how to represent the reasons behind a parser fail.+  These reasons originate from the 'Text.Gigaparsec.Errors.Combinator.explain' combinator.+  -}+  reason :: String -- ^ the reason produced by the parser.+         -> Message err+  {-|+  Describes how to represent the messages produced by the+  'Text.Gigaparsec.Errors.Combinator.fail' combinator (or any that are implemented using it).+  -}+  message :: String -- ^ the message produced by the parser.+          -> Message err++  {-|+  Describes how to format the information about the line that the error occured on,+  and its surrounding context.+  -}+  lineInfo :: String   -- ^ the full line of input that produced this error message.+           -> [String] -- ^ the lines of input from just before the one that produced this message (up to 'numLinesBefore').+           -> [String] -- ^ the lines of input from just after the one that produced this message (up to 'numLinesAfter').+           -> Word     -- ^ the offset into the line that the error points at.+           -> Word     -- ^ how wide the caret in the message should be.+           -> LineInfo err++  -- | The number of lines of input to request before an error occured.+  numLinesBefore :: Int+  -- | The number of lines of input to request after an error occured.+  numLinesAfter :: Int++  -- | The type that represents the individual items within the error. It must be+  -- orderable, as it is used within @Set@.+  type Item err++  {-|+  Formats a raw item generated by either the input string or a input+  reading combinator without a label.+  -}+  raw :: String -- ^ the raw, unprocessed input.+      -> Item err+  -- | Formats a named item generated by a label.+  named :: String -- ^ the name given to the label.+        -> Item err+  -- | Value that represents the end of the input in the error message.+  endOfInput :: Item err++  {-|+  Extracts an unexpected token from the remaining input.++  When a parser fails, by default an error reports an unexpected token of a specific width.+  This works well for some parsers, but often it is nice to have the illusion of a dedicated+  lexing pass: instead of reporting the next few characters as unexpected, an unexpected token+  can be reported instead. This can take many forms, for instance trimming the token to the+  next whitespace, only taking one character, or even trying to lex a token out of the stream.++  TODO: talk about the token extractors when they are added.+  -}+  unexpectedToken :: NonEmpty Char -- ^ the remaining input, @cs@, at point of failure.+                  -> Word          -- ^ the input the parser tried to read when it failed+                                   --   (this is __not__ guaranteed to be smaller than the length of+                                   --    @cs@, but is __guaranteed to be greater than 0__).+                  -> Bool          -- ^ was this error generated as part of \"lexing\", or in a wider parser (see 'Text.Gigaparsec.Errors.Combinator.markAsToken').+                  -> Token         -- ^ a token extracted from @cs@ that will be used as part of the unexpected message.++{-|+This type represents an extracted token returned by 'unexpectedToken' in 'ErrorBuilder'.++There is deliberately no analogue for @EndOfInput@ because we guarantee that non-empty+residual input is provided to token extraction.+-}+type Token :: *+data Token = Raw                   -- ^ This is a token that is directly extracted from the residual input itself.+              !String              -- ^ the input extracted.+           | Named                 -- ^ This is a token that has been given a name, and is treated like a labelled item.+              !String              -- ^ the description of the token.+              {-# UNPACK #-} !Word -- ^ the amount of residual input this token ate.++{-|+Formats error messages as a string, using the functions found in+"Text.Gigaparsec.Errors.DefaultErrorBuilder".+-}+instance ErrorBuilder String where+  {-# INLINE format #-}+  format = formatDefault++  type Position String = StringBuilder+  type Source String = Maybe StringBuilder++  {-# INLINE pos #-}+  pos = formatPosDefault+  {-# INLINE source #-}+  source = fmap fromString++  type ErrorInfoLines String = [StringBuilder]+  {-# INLINE vanillaError #-}+  vanillaError = vanillaErrorDefault+  {-# INLINE specialisedError #-}+  specialisedError = specialisedErrorDefault++  type ExpectedItems String = Maybe StringBuilder+  type Messages String = [StringBuilder]++  {-# INLINE combineExpectedItems #-}+  combineExpectedItems = disjunct True . Set.toList+  {-# INLINE combineMessages #-}+  combineMessages = combineMessagesDefault++  type UnexpectedLine String = Maybe StringBuilder+  type ExpectedLine String = Maybe StringBuilder+  type Message String = String+  type LineInfo String = [StringBuilder]++  {-# INLINE unexpected #-}+  unexpected = unexpectedDefault+  {-# INLINE expected #-}+  expected = expectedDefault+  {-# INLINE reason #-}+  reason = id+  {-# INLINE message #-}+  message = id++  {-# INLINE lineInfo #-}+  lineInfo = lineInfoDefault++  {-# INLINE numLinesBefore #-}+  numLinesBefore = 1+  {-# INLINE numLinesAfter #-}+  numLinesAfter = 1++  type Item String = String++  {-# INLINE raw #-}+  raw = rawDefault+  {-# INLINE named #-}+  named = namedDefault+  {-# INLINE endOfInput #-}+  endOfInput = endOfInputDefault++  {-# INLINABLE unexpectedToken #-}+  -- TillNextWhitespace with matches parser demand+  unexpectedToken ('\n' :| _) _ _ = Named "newline" 1+  unexpectedToken ('\r' :| _) _ _ = Named "carriage return" 1+  unexpectedToken ('\t' :| _) _ _ = Named "tab" 1+  unexpectedToken (' ' :| _) _ _ = Named "space" 1+  unexpectedToken (c :| cs) parserDemanded _+    | isSpace c = Named "whitespace character" 1+    | otherwise = case generalCategory c of+                    Format -> unprintable+                    Surrogate -> unprintable+                    PrivateUse -> unprintable+                    NotAssigned -> unprintable+                    Control -> unprintable+                    _ -> Raw (take (fromIntegral parserDemanded) (tillNextWhitespace (c:cs)))+    where unprintable = Named ("non-printable character (\\x" ++ showHex (ord c) ")") 1+          tillNextWhitespace = takeWhile (not . isSpace)

@@ -1,5 +1,6 @@ {-# LANGUAGE Trustworthy #-}-{-# LANGUAGE DeriveFunctor, StandaloneDeriving #-}+{-# LANGUAGE DeriveFunctor, StandaloneDeriving, RecordWildCards, NamedFieldPuns, CPP #-}+#include "portable-unlifted.h" {-# OPTIONS_HADDOCK hide #-} {-| Module      : Text.Gigaparsec.Internal@@ -17,10 +18,20 @@ module Text.Gigaparsec.Internal (module Text.Gigaparsec.Internal) where  import Text.Gigaparsec.Internal.RT (RT)+import Text.Gigaparsec.Internal.Errors (ParseError, ExpectItem, CaretWidth)+import Text.Gigaparsec.Internal.Errors qualified as Errors (+    emptyErr, expectedErr, specialisedErr, mergeErr, unexpectedErr,+    expecteds, isExpectedEmpty, presentationOffset, useHints+  )  import Control.Applicative (Applicative(liftA2), Alternative(empty, (<|>), many, some)) -- liftA2 required until 9.6 import Control.Selective (Selective(select)) +import Data.Set (Set)+import Data.Set qualified as Set (empty, union)++CPP_import_PortableUnlifted+ {- Notes: @@ -38,7 +49,7 @@ newtype Parsec a = Parsec {     unParsec :: forall r. State              -> (a -> State -> RT r) -- the good continuation-             -> (State -> RT r)      -- the bad continuation+             -> (ParseError -> State -> RT r)      -- the bad continuation              -> RT r   } @@ -106,21 +117,23 @@   {-# INLINE return #-}   {-# INLINE (>>=) #-} +raise :: (State -> ParseError) -> Parsec a+raise mkErr = Parsec $ \st _ bad -> useHints bad (mkErr st) st+ instance Alternative Parsec where   empty :: Parsec a-  empty = Parsec $ \st _ err -> err st+  empty = raise (`emptyErr` 0) +  -- FIXME: I feel like there is something missing here with hint merging from ctx.mergeHints+  -- if the hint stack is not real then it lives in the continuation trace, but I don't know... which   (<|>) :: Parsec a -> Parsec a -> Parsec a-  Parsec p <|> Parsec q = Parsec $ \st ok err ->-    let !initConsumed = consumed st-        ok' x st' = ok x (st' { consumed = initConsumed || consumed st' })-          --  ^ revert to old st.consumed if p didn't consume-        err' st'-          | consumed st' = err st'+  Parsec p <|> Parsec q = Parsec $ \st ok bad ->+    let bad' err st'+          | consumed st' > consumed st = bad err st'           --  ^ fail if p failed *and* consumed-          | otherwise    = q (st' { consumed = initConsumed }) ok err--    in  p (st { consumed = False }) ok' err'+          | otherwise    = q st' (\x st'' -> ok x (errorToHints st'' err))+                                 (\err' -> bad (Errors.mergeErr err err'))+    in  p st ok bad'    many :: Parsec a -> Parsec [a]   many = manyr (:) []@@ -153,21 +166,56 @@    {-# INLINE mempty #-} -type State :: *+type State :: UnliftedDatatype data State = State {     -- | the input string, in future this may be generalised     input :: !String,     -- | has the parser consumed input since the last relevant handler?-    consumed :: !Bool, -- this could be an Int offset instead, perhaps?+    consumed :: {-# UNPACK #-} !Word,     -- | the current line number (incremented by \n)-    line :: {-# UNPACK #-} !Int,+    line :: {-# UNPACK #-} !Word,     -- | the current column number (have to settle on a tab handling scheme)-    col  :: {-# UNPACK #-} !Int+    col  :: {-# UNPACK #-} !Word,+    -- | the valid for which hints can be used+    hintsValidOffset :: {-# UNPACK #-} !Word,+    -- | the hints at this point in time+    hints :: !(Set ExpectItem)   }  emptyState :: String -> State emptyState !str = State { input = str-                        , consumed = False+                        , consumed = 0                         , line = 1                         , col = 1+                        , hintsValidOffset = 0+                        , hints = Set.empty                         }++emptyErr :: State -> Word -> ParseError+emptyErr State{..} = Errors.emptyErr consumed line col++expectedErr :: State -> Set ExpectItem -> Word -> ParseError+expectedErr State{..} = Errors.expectedErr input consumed line col++specialisedErr :: State -> [String] -> CaretWidth -> ParseError+specialisedErr State{..} = Errors.specialisedErr consumed line col++unexpectedErr :: State -> Set ExpectItem -> String -> CaretWidth -> ParseError+unexpectedErr State{..} = Errors.unexpectedErr consumed line col++errorToHints :: State -> ParseError -> State+errorToHints st@State{..} err+  | consumed == Errors.presentationOffset err+  , not (Errors.isExpectedEmpty err) =+    if hintsValidOffset < consumed then st { hints = Errors.expecteds err, hintsValidOffset = consumed }+    else                                st { hints = Set.union hints (Errors.expecteds err) }+errorToHints st _ = st++useHints :: (ParseError -> State -> RT r) -> (ParseError -> State -> RT r)+useHints bad err st@State{hintsValidOffset, hints}+  | presentationOffset == hintsValidOffset = bad (Errors.useHints hints err) st+  | otherwise                              = bad err st{ hintsValidOffset = presentationOffset, hints = Set.empty }+  where !presentationOffset = Errors.presentationOffset err++adjustErr :: (ParseError -> ParseError) -> Parsec a -> Parsec a+adjustErr f (Parsec p) = Parsec $ \st good bad -> p st good $ \err -> bad (f err)

@@ -0,0 +1,271 @@+{-# LANGUAGE Trustworthy #-}+{-# LANGUAGE RecordWildCards, BangPatterns, NamedFieldPuns, CPP #-}+#include "portable-unlifted.h"+{-# OPTIONS_GHC -Wno-partial-fields -Wno-all-missed-specialisations #-}+{-# OPTIONS_HADDOCK hide #-}+{-# OPTIONS_GHC -Wno-missing-import-lists #-}+module Text.Gigaparsec.Internal.Errors (module Text.Gigaparsec.Internal.Errors) where++import Prelude hiding (lines)++import Data.List.NonEmpty (NonEmpty((:|)), nonEmpty, (<|))+import Data.Set (Set)+import Data.Set qualified as Set (empty, map, union, null, foldr, insert)++import Text.Gigaparsec.Errors.ErrorBuilder (ErrorBuilder, Token)+import Text.Gigaparsec.Errors.ErrorBuilder qualified as Builder (ErrorBuilder(..))+import Text.Gigaparsec.Errors.ErrorBuilder qualified as Token (Token(..))++CPP_import_PortableUnlifted++type Span :: *+type Span = Word++type CaretWidth :: UnliftedDatatype+data CaretWidth = FlexibleCaret { width :: {-# UNPACK #-} !Span }+                | RigidCaret { width :: {-# UNPACK #-} !Span }++isFlexible :: CaretWidth -> Bool+isFlexible FlexibleCaret{} = True+isFlexible _               = False++type ParseError :: UnliftedDatatype+data ParseError = VanillaError { presentationOffset :: {-# UNPACK #-} !Word+                               , line :: {-# UNPACK #-} !Word+                               , col :: {-# UNPACK #-} !Word+                               , unexpected :: !(Either Word UnexpectItem) -- TODO: unlift this!+                               -- sadly, this prevents unlifting of ExpectItem+                               -- perhaps we should make an unlifted+levity polymorphic Set?+                               , expecteds :: !(Set ExpectItem)+                               , reasons :: !(Set String)+                               , lexicalError :: !Bool -- TODO: strict bools+                               -- TODO: remove:+                               , underlyingOffset :: {-# UNPACK #-} !Word+                               , entrenchment :: {-# UNPACK #-} !Word+                               }+                | SpecialisedError { presentationOffset :: {-# UNPACK #-} !Word+                                   , line :: {-# UNPACK #-} !Word+                                   , col :: {-# UNPACK #-} !Word+                                   , msgs :: ![String]+                                   --, caretWidth :: {-# UNPACK #-} !Span --FIXME: need defunc before this goes away+                                   , caretWidth :: CaretWidth+                                   -- TODO: remove:+                                   , underlyingOffset :: {-# UNPACK #-} !Word+                                   , entrenchment :: {-# UNPACK #-} !Word+                                   }++type Input :: *+type Input = NonEmpty Char+type UnexpectItem :: *+data UnexpectItem = UnexpectRaw !Input {-# UNPACK #-} !Word+                  | UnexpectNamed !String CaretWidth+                  | UnexpectEndOfInput+type ExpectItem :: *+data ExpectItem = ExpectRaw !String+                | ExpectNamed !String+                | ExpectEndOfInput+                deriving stock (Eq, Ord, Show)++entrenched :: ParseError -> Bool+entrenched err = entrenchment err /= 0++emptyErr :: Word -> Word -> Word -> Word -> ParseError+emptyErr !presentationOffset !line !col !width = VanillaError {+    presentationOffset = presentationOffset,+    line = line,+    col = col,+    unexpected = Left width,+    expecteds = Set.empty,+    reasons = Set.empty,+    lexicalError = False,+    underlyingOffset = presentationOffset,+    entrenchment = 0+  }++expectedErr :: String -> Word -> Word -> Word -> Set ExpectItem -> Word -> ParseError+expectedErr !input !presentationOffset !line !col !expecteds !width = VanillaError {+    presentationOffset = presentationOffset,+    line = line,+    col = col,+    unexpected = case nonEmpty input of+      Nothing -> Right UnexpectEndOfInput+      Just cs -> Right (UnexpectRaw cs width),+    expecteds = expecteds,+    reasons = Set.empty,+    lexicalError = False,+    underlyingOffset = presentationOffset,+    entrenchment = 0+}++specialisedErr :: Word -> Word -> Word -> [String] -> CaretWidth -> ParseError+specialisedErr !presentationOffset !line !col !msgs caretWidth = SpecialisedError {..}+  where !underlyingOffset = presentationOffset+        !entrenchment = 0 :: Word++unexpectedErr :: Word -> Word -> Word -> Set ExpectItem -> String -> CaretWidth -> ParseError+unexpectedErr !presentationOffset !line !col !expecteds !name caretWidth = VanillaError {+    presentationOffset = presentationOffset,+    line = line,+    col = col,+    expecteds = expecteds,+    unexpected = Right (UnexpectNamed name caretWidth),+    reasons = Set.empty,+    lexicalError = False,+    underlyingOffset = presentationOffset,+    entrenchment = 0+  }++labelErr :: Word -> Set String -> ParseError -> ParseError+labelErr !offset expecteds err@VanillaError{}+  | offset == presentationOffset err = err { expecteds = Set.map ExpectNamed expecteds }+labelErr _ _ err = err++explainErr :: Word -> String -> ParseError -> ParseError+explainErr !offset reason err@VanillaError{}+  | offset == presentationOffset err = err { reasons = Set.insert reason (reasons err) }+explainErr _ _ err = err++amendErr :: Word -> Word -> Word -> ParseError -> ParseError+amendErr !offset !line !col err+  | not (entrenched err) = err {+      presentationOffset = offset,+      underlyingOffset = offset,+      line = line,+      col = col+    }+amendErr _ _ _ err = err++partialAmendErr :: Word -> Word -> Word -> ParseError -> ParseError+partialAmendErr !offset !line !col err+  | not (entrenched err) =  err {+      presentationOffset = offset,+      line = line,+      col = col+    }+partialAmendErr _ _ _ err = err++entrenchErr :: ParseError -> ParseError+entrenchErr err = err { entrenchment = entrenchment err + 1 }++dislodgeErr :: Word -> ParseError -> ParseError+dislodgeErr by err+  | entrenchment err == 0  = err+  -- this case is important to avoid underflow on the unsigned Word+  | by >= entrenchment err = err { entrenchment = 0 }+  | otherwise              = err { entrenchment = entrenchment err - by }++setLexical :: ParseError -> ParseError+setLexical err@VanillaError{} = err { lexicalError = True }+setLexical err = err++useHints :: Set ExpectItem -> ParseError -> ParseError+useHints !hints err@VanillaError{expecteds} = err { expecteds = Set.union hints expecteds }+useHints _ err = err++mergeErr :: ParseError -> ParseError -> ParseError+mergeErr err1 err2+  | underlyingOffset err1 > underlyingOffset err2 = err1+  | underlyingOffset err1 < underlyingOffset err2 = err2+  | presentationOffset err1 > presentationOffset err2 = err1+  | presentationOffset err1 < presentationOffset err2 = err2+-- offsets are all equal, kinds must match+mergeErr err1@SpecialisedError{caretWidth} _err2@VanillaError{}+  | isFlexible caretWidth = err1 -- TODO: flexible caret merging from err2+  | otherwise             = err1+mergeErr _err1@VanillaError{} err2@SpecialisedError{caretWidth}+  | isFlexible caretWidth = err2 -- TODO: flexible caret merging from err1+  | otherwise             = err2+mergeErr err1@VanillaError{} err2@VanillaError{} =+  err1 { unexpected = mergeUnexpect (unexpected err1) (unexpected err2)+       , expecteds = Set.union (expecteds err1) (expecteds err2)+       , reasons = Set.union (reasons err1) (reasons err2)+       , lexicalError = lexicalError err1 || lexicalError err2+       }+mergeErr err1@SpecialisedError{} err2@SpecialisedError{} =+  err1 { msgs = msgs err1 ++ msgs err2+       , caretWidth = mergeCaret (caretWidth err1) (caretWidth err2)+       }++mergeCaret :: CaretWidth -> CaretWidth -> CaretWidth+mergeCaret caret@RigidCaret{} FlexibleCaret{} = caret+mergeCaret FlexibleCaret{} caret@RigidCaret{} = caret+mergeCaret caret1 caret2 = caret1 { width = max (width caret1) (width caret2) }++mergeUnexpect :: Either Word UnexpectItem -> Either Word UnexpectItem -> Either Word UnexpectItem+mergeUnexpect (Left w1) (Left w2) = Left (max w1 w2)+-- TODO: widening can occur with flexible or raw tokens+mergeUnexpect Left{} w@Right{} = w+mergeUnexpect w@Right{} Left{} = w+-- finally, two others will merge independently+mergeUnexpect (Right item1) (Right item2) = Right (mergeItem item1 item2)+  where mergeItem UnexpectEndOfInput _ = UnexpectEndOfInput+        mergeItem _ UnexpectEndOfInput = UnexpectEndOfInput+        mergeItem it1@(UnexpectNamed _ cw1) it2@(UnexpectNamed _ cw2)+          | isFlexible cw1, not (isFlexible cw2) = it2+          | not (isFlexible cw1), isFlexible cw2 = it1+          | width cw1 < width cw2                = it2+          | otherwise                            = it1+        mergeItem item@UnexpectNamed{} _ = item+        mergeItem _ item@UnexpectNamed{} = item+        mergeItem (UnexpectRaw cs w1) (UnexpectRaw _ w2) = UnexpectRaw cs (max w1 w2)++isExpectedEmpty :: ParseError -> Bool+isExpectedEmpty VanillaError{expecteds} = Set.null expecteds+isExpectedEmpty _                       = True++{-# INLINABLE fromParseError #-}+fromParseError :: forall err. ErrorBuilder err => Maybe FilePath -> String -> ParseError -> err+fromParseError srcFile input err =+  Builder.format (Builder.pos @err (line err) (col err)) (Builder.source @err srcFile)+                 (formatErr err)+  where formatErr :: ParseError -> Builder.ErrorInfoLines err+        formatErr VanillaError{..} =+          Builder.vanillaError @err+            (Builder.unexpected @err (either (const Nothing) (Just . fst) unexpectedTok))+            (Builder.expected @err (Builder.combineExpectedItems @err (Set.map expectItem expecteds)))+            (Builder.combineMessages @err (Set.foldr (\r -> (Builder.reason @err r :)) [] reasons))+            (Builder.lineInfo @err curLine linesBefore linesAfter caret (trimToLine caretSize))+          where unexpectedTok = unexpectItem lexicalError <$> unexpected+                caretSize = either id snd unexpectedTok++        formatErr SpecialisedError{..} =+          Builder.specialisedError @err+            (Builder.combineMessages @err (map (Builder.message @err) msgs))+            (Builder.lineInfo @err curLine linesBefore linesAfter caret (trimToLine (width caretWidth)))++        expectItem :: ExpectItem -> Builder.Item err+        expectItem (ExpectRaw t) = Builder.raw @err t+        expectItem (ExpectNamed n) = Builder.named @err n+        expectItem ExpectEndOfInput = Builder.endOfInput @err++        unexpectItem :: Bool -> UnexpectItem -> (Builder.Item err, Span)+        unexpectItem lexical (UnexpectRaw cs demanded) =+          case Builder.unexpectedToken @err cs demanded lexical of+            t@(Token.Raw tok) -> (Builder.raw @err tok, tokenSpan t)+            Token.Named name w -> (Builder.named @err name, w)+        unexpectItem _ (UnexpectNamed name caretWidth) = (Builder.named @err name, width caretWidth)+        unexpectItem _ UnexpectEndOfInput = (Builder.endOfInput @err, 1)++        -- it is definitely the case that there are at least `line` lines+        (allLinesBefore, curLine, allLinesAfter) = breakLines (line err - 1) (lines input)+        linesBefore = drop (length allLinesBefore - Builder.numLinesBefore @err) allLinesBefore+        linesAfter = take (Builder.numLinesAfter @err) allLinesAfter++        caret = col err - 1+        trimToLine width = min width (fromIntegral (length curLine) - caret + 1)++        lines :: String -> NonEmpty String+        lines [] = "" :| []+        lines ('\n':cs) = "" <| lines cs+        lines (c:cs) = let l :| ls = lines cs in (c:l) :| ls++        breakLines :: Word -> NonEmpty String -> ([String], String, [String])+        breakLines 0 (l :| ls) = ([], l, ls)+        breakLines n (l :| ls) = case nonEmpty ls of+          Nothing -> error "the focus line is guaranteed to exist"+          Just ls' -> let (before, focus, after) = breakLines (n - 1) ls'+                      in (l : before, focus, after)++        tokenSpan :: Token -> Word+        tokenSpan (Token.Raw cs) = fromIntegral (length cs)+        tokenSpan (Token.Named _ w) = w

@@ -6,6 +6,7 @@ import Text.Gigaparsec.CharTests qualified as Char import Text.Gigaparsec.CombinatorTests qualified as Combinator import Text.Gigaparsec.ExprTests qualified as Expr+import Text.Gigaparsec.ErrorsTests qualified as Errors  main :: IO () main = defaultMain $ testGroup "gigaparsec"@@ -13,4 +14,5 @@   , Char.tests   , Combinator.tests   , Expr.tests+  , Errors.tests   ]

@@ -33,9 +33,9 @@       pureParseWith (satisfy (== 'a')) "b"   , testCase "be impure otherwise" do impureParseWith (satisfy (== 'a')) "a"   , testCase "return the parsed character" do-      parse item "a" @?= Success 'a'-      parse item "ba" @?= Success 'b'-      parse item "\NUL" @?= Success '\NUL'+      testParse item "a" @?= Success 'a'+      testParse item "ba" @?= Success 'b'+      testParse item "\NUL" @?= Success '\NUL'   , testCase "fail otherwise" do       ensureFails (satisfy (== 'b')) ""       ensureFails item ""@@ -48,7 +48,7 @@       pureParseWith (char 'a') ""       pureParseWith (char 'a') "b"   , testCase "be impure otherwise" do impureParseWith (char 'a') "a"-  , testCase "return the parsed character" do parse (char 'a') "a" @?= Success 'a'+  , testCase "return the parsed character" do testParse (char 'a') "a" @?= Success 'a'   , testCase "fail otherwise" do       ensureFails (char 'a') ""       ensureFails (char 'a') "b"@@ -56,13 +56,13 @@  stringTests :: TestTree stringTests = testGroup "string should"-  [ testCase "reject the empty string" (throws @RequirementUnsatisfied (parse (string "") "")) -- don't ask why `string ""` doesn't work all the time+  [ testCase "reject the empty string" (throws @RequirementUnsatisfied (testParse (string "") "")) -- don't ask why `string ""` doesn't work all the time   , testCase "be pure if it cannot read at all" do       pureParseWith (string "abc") ""       pureParseWith (string "abc") "123"   , testCase "be impure if there is a partial read" do impureParseWith (string "abc") "abd"   , testCase "be impure if full read" do impureParseWith (string "abc") "abc"-  , testCase "return the parsed string" do parse (string "123") "123" @?= Success "123"+  , testCase "return the parsed string" do testParse (string "123") "123" @?= Success "123"   , testCase "fail otherwise" do       ensureFails (string "123") "124"       ensureFails (string "123") "12"@@ -74,8 +74,8 @@       ensureFails p ""       ensureFails p "a"   , testCase "succeed performing the mapping otherwise" do-      parse p "4" @?= Success 4-      parse p "9" @?= Success 9+      testParse p "4" @?= Success 4+      testParse p "9" @?= Success 9   ]   where p = satisfyMap (\c -> digitToInt c <$ guard (isDigit c)) @@ -89,7 +89,7 @@       pureParseWith q ""       pureParseWith q "b"       impureParseWith q "a"-      parse q "a" @?= Success 'a'+      testParse q "a" @?= Success 'a'       ensureFails q ""       ensureFails q "b"   , testCase "parse within a contiguous range" do@@ -97,7 +97,7 @@       pureParseWith r "a"       forM_ @[] ['0'..'9'] $ \c -> do         impureParseWith r (pure c)-        parse r (pure c) @?= Success c+        testParse r (pure c) @?= Success c       ensureFails r "a"       ensureFails r "\NUL"       ensureFails r ":"@@ -107,7 +107,7 @@       pureParseWith s "a"       forM_ @[] ['.', ';', ',', ':'] $ \c -> do         impureParseWith s (pure c)-        parse s (pure c) @?= Success c+        testParse s (pure c) @?= Success c       ensureFails s "a"       ensureFails s "\NUL"   ]@@ -121,13 +121,13 @@   [ testCase "act like item when given no characters" do       pureParseWith p ""       ensureFails p ""-      parse p "a" @?= Success 'a'-      parse p "\ACK" @?= Success '\ACK'+      testParse p "a" @?= Success 'a'+      testParse p "\ACK" @?= Success '\ACK'   , testCase "accept all but a specific character" do       pureParseWith q ""       pureParseWith q "a"       impureParseWith q "b"-      parse q "5" @?= Success '5'+      testParse q "5" @?= Success '5'       ensureFails q ""       ensureFails q "a"   , testCase "parse within a contiguous range" do@@ -136,18 +136,18 @@       forM_ @[] ['0'..'9'] $ \c -> do         pureParseWith r (pure c)         ensureFails r (pure c)-      parse r "a" @?= Success 'a'-      parse r "\NUL" @?= Success '\NUL'-      parse r ":" @?= Success ':'-      parse r "/" @?= Success '/'+      testParse r "a" @?= Success 'a'+      testParse r "\NUL" @?= Success '\NUL'+      testParse r ":" @?= Success ':'+      testParse r "/" @?= Success '/'   , testCase "parse any other sets" do       pureParseWith s ""       impureParseWith s "a"       forM_ @[] ['.', ';', ',', ':'] $ \c -> do         pureParseWith s (pure c)         ensureFails s (pure c)-      parse s "a" @?= Success 'a'-      parse s "\NUL" @?= Success '\NUL'+      testParse s "a" @?= Success 'a'+      testParse s "\NUL" @?= Success '\NUL'   ]   where p = noneOf []         q = noneOf ['a']@@ -158,11 +158,11 @@ stringsTests = testGroup "strings should"   [ testCase "reject any empty strings" do throws @RequirementUnsatisfied (strings ["abc", "323", ""])   , testCase "have longest match behaviour" do-      parse p "hello" @?= Success "hello"-      parse p "hell" @?= Success "hell"-      parse p "he" @?= Success "h"-      parse p "123" @?= Success "123"-      parse p "124" @?= Success "1"+      testParse p "hello" @?= Success "hello"+      testParse p "hell" @?= Success "hell"+      testParse p "he" @?= Success "h"+      testParse p "123" @?= Success "123"+      testParse p "124" @?= Success "1"   , testCase "reject anything outside of the set" do       ensureFails p "543"       ensureFails p "good"@@ -173,14 +173,14 @@ trieTests = testGroup "trie should"   [ testCase "reject any empty strings" do throws @RequirementUnsatisfied (trie' ["" --> unit])   , testCase "have longest match behaviour" do-      parse p "hello" @?= Success "hello"-      parse p "hell" @?= Success "hell"-      parse p "h" @?= Success "h"-      parse p "he" @?= Success "h"-      parse p "hi" @?= Success "hi"-      parse p "good" @?= Success "good"-      parse p "goodby" @?= Success "good"-      parse p "goodbye" @?= Success "goodbye"+      testParse p "hello" @?= Success "hello"+      testParse p "hell" @?= Success "hell"+      testParse p "h" @?= Success "h"+      testParse p "he" @?= Success "h"+      testParse p "hi" @?= Success "hi"+      testParse p "good" @?= Success "good"+      testParse p "goodby" @?= Success "good"+      testParse p "goodbye" @?= Success "goodbye"   , testCase "reject anything outside of the set" do       ensureFails p "543"       ensureFails p "god"

@@ -40,7 +40,7 @@   , testCase "behave like p for [p]" do       (choice [char 'a'] ~~ char 'a') ["", "a", "b"]   , testCase "parse in order" do-      parse (choice [string "a", string "b", string "bc"]) "bcd" @?= Success "b"+      testParse (choice [string "a", string "b", string "bc"]) "bcd" @?= Success "b"   , testCase "fail if none of the parsers succeed" do       ensureFails (choice [string "a", string "b", string "bc"]) "c"   ]@@ -48,9 +48,9 @@ optionTests :: TestTree optionTests = testGroup "option should"   [ testCase "succeed with Just if p succeeds" do-      parse (option (char 'a')) "a" @?= Success (Just 'a')+      testParse (option (char 'a')) "a" @?= Success (Just 'a')   , testCase "succeed with Nothing if p fails withot consumption" do-      parse (option (char 'a')) "b" @?= Success Nothing+      testParse (option (char 'a')) "b" @?= Success Nothing   , testCase "fail if p fails with consumption" do       ensureFails (option (string "ab")) "a"   ]@@ -58,7 +58,7 @@ decideTests :: TestTree decideTests = testGroup "decide should"   [ testCase "succeed for Just" do-      parse (decide (Just <$> char 'a')) "a" @?= Success 'a'+      testParse (decide (Just <$> char 'a')) "a" @?= Success 'a'   , testCase "fail for Nothing" do ensureFails @() (decide (pure Nothing)) ""   , testCase "compose with option to become identity" do       let id' = decide . option@@ -70,17 +70,17 @@ fromMaybeSTests :: TestTree fromMaybeSTests = testGroup "fromMaybeS should"   [ testCase "succeed for Just" do-      parse (fromMaybeS (pure 'b') (Just <$> char 'a')) "a" @?= Success 'a'+      testParse (fromMaybeS (pure 'b') (Just <$> char 'a')) "a" @?= Success 'a'   , testCase "succeed for None" do-      parse (fromMaybeS (pure 'b') (Nothing <$ char 'a')) "a" @?= Success 'b'+      testParse (fromMaybeS (pure 'b') (Nothing <$ char 'a')) "a" @?= Success 'b'   ]  optionalTests :: TestTree optionalTests = testGroup "optional should"   [ testCase "succeed if p succeeds" do-      parse (optional (char 'a')) "a" @?= Success ()+      testParse (optional (char 'a')) "a" @?= Success ()   , testCase "also succeed if p fails without consumption" do-      parse (optional (char 'a')) "b" @?= Success ()+      testParse (optional (char 'a')) "b" @?= Success ()   , testCase "fail if p failed with consumption" do       ensureFails (optional (string "ab")) "a"   ]@@ -89,64 +89,64 @@ manyNTests = testGroup "manyN should"   [ testCase "ensure that n are parsed" do       forM_ [0..10] \n -> do-        parse (manyN n item) (replicate n 'a') @?= Success (replicate n 'a')+        testParse (manyN n item) (replicate n 'a') @?= Success (replicate n 'a')         ensureFails (manyN (n + 1) item) (replicate n 'a')   , testCase "not care if more are present" do       forM_ [0..10] \n ->-        parse (manyN n item) (replicate (n + 1) 'a') @?= Success (replicate (n + 1) 'a')+        testParse (manyN n item) (replicate (n + 1) 'a') @?= Success (replicate (n + 1) 'a')   ]  skipManyNTests :: TestTree skipManyNTests = testGroup "skipManyN should"   [ testCase "ensure that n are parsed" do       forM_ [0..10] \n -> do-        parse (skipManyN n item) (replicate n 'a') @?= Success ()+        testParse (skipManyN n item) (replicate n 'a') @?= Success ()         ensureFails (skipManyN (n + 1) item) (replicate n 'a')   , testCase "not care if more are present" do       forM_ [0..10] \n ->-        parse (skipManyN n item) (replicate (n + 1) 'a') @?= Success ()+        testParse (skipManyN n item) (replicate (n + 1) 'a') @?= Success ()   ]  sepByTests :: TestTree sepByTests = testGroup "sepBy should"   [ testCase "accept empty input" do-      parse (sepBy (char 'a') (char 'b')) "" @?= Success []+      testParse (sepBy (char 'a') (char 'b')) "" @?= Success []   , testCase "parse more than 1" do-      parse (sepBy (char 'a') (char 'b')) "aba" @?= Success ['a', 'a']+      testParse (sepBy (char 'a') (char 'b')) "aba" @?= Success ['a', 'a']   ]  sepBy1Tests :: TestTree sepBy1Tests = testGroup "sepBy1 should"   [ testCase "not allow sep at the end of chain" do ensureFails p "ab"-  , testCase "be able to parse 2 or more p" do-      parse p "aba" @?= Success ['a', 'a']-      parse p "ababa" @?= Success ['a', 'a', 'a']-      parse p "abababa" @?= Success ['a', 'a', 'a', 'a']+  , testCase "be able to testParse 2 or more p" do+      testParse p "aba" @?= Success ['a', 'a']+      testParse p "ababa" @?= Success ['a', 'a', 'a']+      testParse p "abababa" @?= Success ['a', 'a', 'a', 'a']   , testCase "require a p" do       ensureFails p ""-      parse p "a" @?= Success ['a']+      testParse p "a" @?= Success ['a']   ]   where p = sepBy1 (char 'a') (char 'b')  sepEndByTests :: TestTree sepEndByTests = testGroup "sepEndBy should"   [ testCase "accept empty input" do-      parse (sepEndBy (char 'a') (char 'b')) "" @?= Success []+      testParse (sepEndBy (char 'a') (char 'b')) "" @?= Success []   , testCase "parse more than 1" do-       parse (sepEndBy (char 'a') (char 'b')) "aba" @?= Success ['a', 'a']+       testParse (sepEndBy (char 'a') (char 'b')) "aba" @?= Success ['a', 'a']   ]  sepEndBy1Tests :: TestTree sepEndBy1Tests = testGroup "sepEndBy1 should"   [ testCase "require a p" do ensureFails p ""-  , testCase "not require sep at end of chain" do parse p "aa" @?= Success ["aa"]-  , testCase "be able to parse 2 or more p" do-      parse p "aabbaa" @?= Success ["aa", "aa"]-      parse p "aabbaabbaa" @?= Success ["aa", "aa", "aa"]-  , testCase "be able to parse a final sep" do-      parse p "aabb" @?= Success ["aa"]-      parse p "aabbaabb" @?= Success ["aa", "aa"]-      parse p "aabbaabbaabb" @?= Success ["aa", "aa", "aa"]+  , testCase "not require sep at end of chain" do testParse p "aa" @?= Success ["aa"]+  , testCase "be able to testParse 2 or more p" do+      testParse p "aabbaa" @?= Success ["aa", "aa"]+      testParse p "aabbaabbaa" @?= Success ["aa", "aa", "aa"]+  , testCase "be able to testParse a final sep" do+      testParse p "aabb" @?= Success ["aa"]+      testParse p "aabbaabb" @?= Success ["aa", "aa"]+      testParse p "aabbaabbaabb" @?= Success ["aa", "aa", "aa"]   , testCase "fail if p fails after consuming input" do       ensureFails p "aabab"   , testCase "fail if sep fails after consuming input" do@@ -157,9 +157,9 @@ endByTests :: TestTree endByTests = testGroup "endBy should"   [ testCase "accept empty input" do-      parse (endBy (char 'a') (char 'b')) "" @?= Success []+      testParse (endBy (char 'a') (char 'b')) "" @?= Success []   , testCase "parse more than 1" do-       parse (endBy (char 'a') (char 'b')) "abab" @?= Success ['a', 'a']+       testParse (endBy (char 'a') (char 'b')) "abab" @?= Success ['a', 'a']   ]  endBy1Tests :: TestTree@@ -167,10 +167,10 @@   [ testCase "require a p" do ensureFails p ""   , testCase "require a sep at the end of chain" do       ensureFails p "aa"-      parse p "aabb" @?= Success ["aa"]-  , testCase "be able to parse 2 or more p" do-      parse p "aabbaabb" @?= Success ["aa", "aa"]-      parse p "aabbaabbaabb" @?= Success ["aa", "aa", "aa"]+      testParse p "aabb" @?= Success ["aa"]+  , testCase "be able to testParse 2 or more p" do+      testParse p "aabbaabb" @?= Success ["aa", "aa"]+      testParse p "aabbaabbaabb" @?= Success ["aa", "aa", "aa"]   , testCase "fail if p fails after consuming input" do       ensureFails p "aaba"   ]@@ -180,10 +180,10 @@ manyTillTests = testGroup "manyTill should"   [ testCase "require an end" do       ensureFails p "aa"-      parse p "ab" @?= Success ['a']-  , testCase "parse the end without result" do parse p "b" @?= Success []+      testParse p "ab" @?= Success ['a']+  , testCase "parse the end without result" do testParse p "b" @?= Success []   , testCase "parse p until the end is found" do-      parse p "aaaaaaaaaab" @?= Success (replicate 10 'a')+      testParse p "aaaaaaaaaab" @?= Success (replicate 10 'a')       ensureFails (manyTill (string "aa") (char 'b')) "aaab"   ]   where p = manyTill (char 'a') (char 'b')@@ -191,7 +191,7 @@ someTillTests :: TestTree someTillTests = testGroup "someTill should"   [ testCase "parse at least 1 p" do-      parse p "ab" @?= Success ['a']+      testParse p "ab" @?= Success ['a']       ensureFails p "a"       ensureFails p "b"   ]@@ -200,12 +200,12 @@ countTests :: TestTree countTests = testGroup "count should"   [ testCase "report how many successful parses occurred" do-      parse p "" @?= Success 0+      testParse p "" @?= Success 0       ensureFails q ""-      parse p "ab" @?= Success 1-      parse q "ab" @?= Success 1-      parse p "ababab" @?= Success 3-      parse q "ababab" @?= Success 3+      testParse p "ab" @?= Success 1+      testParse q "ab" @?= Success 1+      testParse p "ababab" @?= Success 3+      testParse q "ababab" @?= Success 3   , testCase "not allow partial results" do       ensureFails p "aba"   ]@@ -217,9 +217,9 @@   [ testCase "should be pure [] for n <= 0" do       (exactly 0 (char 'a') ~~ pure []) ["", "a"]       (exactly (-1) (char 'a') ~~ pure []) ["", "a"]-  , testCase "should parse n times for n > 0" do+  , testCase "should testParse n times for n > 0" do       forM_ [0..100] \n ->-        parse (exactly n (char 'a')) (replicate n 'a') @?= Success (replicate n 'a')+        testParse (exactly n (char 'a')) (replicate n 'a') @?= Success (replicate n 'a')   , testCase "fail if n inputs are not present" do       ensureFails (exactly 2 (char 'a')) "a"   ]@@ -228,11 +228,11 @@ rangeTests = testGroup "range should"   [ testCase "collect results up instead of count" do       ensureFails p "a"-      parse p "ab" @?= Success ['a', 'b']-      parse p "abc" @?= Success ['a', 'b', 'c']-      parse p "abcd" @?= Success ['a', 'b', 'c', 'd']-      parse p "abcde" @?= Success ['a', 'b', 'c', 'd', 'e']-      parse q "abcdef" @?= Success ['a', 'b', 'c', 'd', 'e']+      testParse p "ab" @?= Success ['a', 'b']+      testParse p "abc" @?= Success ['a', 'b', 'c']+      testParse p "abcd" @?= Success ['a', 'b', 'c', 'd']+      testParse p "abcde" @?= Success ['a', 'b', 'c', 'd', 'e']+      testParse q "abcdef" @?= Success ['a', 'b', 'c', 'd', 'e']   , testCase "should act as pure [] when range is bad" do       (range (-1) 3 item ~~ pure []) ["", "a"]       (range 2 1 item ~~ pure []) ["", "a"]@@ -244,11 +244,11 @@ range_Tests = testGroup "range_ should"   [ testCase "perform a range with no results" do       ensureFails p "a"-      parse p "ab" @?= Success ()-      parse p "abc" @?= Success ()-      parse p "abcd" @?= Success ()-      parse p "abcde" @?= Success ()-      parse q "abcdef" @?= Success ()+      testParse p "ab" @?= Success ()+      testParse p "abc" @?= Success ()+      testParse p "abcd" @?= Success ()+      testParse p "abcde" @?= Success ()+      testParse q "abcdef" @?= Success ()   , testCase "should act as unit when range is bad" do       (range_ (-1) 3 item ~~ unit) ["", "a"]       (range_ 2 1 item ~~ unit) ["", "a"]@@ -260,19 +260,19 @@ countRangeTests = testGroup "countRange should"   [ testCase "count the parses within the range" do       ensureFails p "ab"-      parse p "abab" @?= Success 2-      parse p "ababab" @?= Success 3-      parse p "abababab" @?= Success 4-      parse p "ababababab" @?= Success 5-      parse p "abababababab" @?= Success 5+      testParse p "abab" @?= Success 2+      testParse p "ababab" @?= Success 3+      testParse p "abababab" @?= Success 4+      testParse p "ababababab" @?= Success 5+      testParse p "abababababab" @?= Success 5       ensureFails p "ababababa"       ensureFails q "ab"-      parse q "abab" @?= Success 2-      parse q "ababab" @?= Success 3-      parse q "abababab" @?= Success 4-      parse q "ababababab" @?= Success 5-      parse q "abababababab" @?= Success 5-      parse q "ababababa" @?= Success 4+      testParse q "abab" @?= Success 2+      testParse q "ababab" @?= Success 3+      testParse q "abababab" @?= Success 4+      testParse q "ababababab" @?= Success 5+      testParse q "abababababab" @?= Success 5+      testParse q "ababababa" @?= Success 4   , testCase "should act as unit when range is bad" do       (countRange (-1) 3 item ~~ pure 0) ["", "a"]       (countRange 2 1 item ~~ pure 0) ["", "a"]

@@ -0,0 +1,384 @@+{-# LANGUAGE OverloadedLists #-}+{-# OPTIONS_GHC -Wno-unrecognised-pragmas #-}+{-# HLINT ignore "Alternative law, right identity" #-}+module Text.Gigaparsec.ErrorsTests where++import Prelude hiding (fail)++import Test.Tasty+import Test.Tasty.HUnit+import Test.Tasty.ExpectedFailure++import Text.Gigaparsec+import Text.Gigaparsec.Char+import Text.Gigaparsec.Combinator+import Text.Gigaparsec.Errors.Combinator+import Text.Gigaparsec.Internal.Test+import Text.Gigaparsec.Internal.TestError++import Data.Set qualified as Set (map)++tests :: TestTree+tests = testGroup "Errors" [ labelTests+                           , hideTests+                           , explainTests+                           , emptyTests+                           , failTests+                           , unexpectedTests+                           , lookAheadTests+                           , notFollowedByTests+                           , amendTests+                           , entrenchTests+                           , dislodgeTests+                           , amendThenDislodgeTests+                           , partialAmendTests+                           , oneOfTests+                           , noneOfTests+                           , regressionTests+                           ]++labelTests :: TestTree+labelTests = testGroup "label should"+  [ testCase "affect base error messages" do+      testParse (char 'a' <?> ["ay!"]) "b" @?=+        Failure (TestError (1, 1) (VanillaError (Just (Raw "b")) [Named "ay!"] [] 1))+      testParse (char 'a' <?> ["ay!", "see!"]) "b" @?=+        Failure (TestError (1, 1) (VanillaError (Just (Raw "b")) [Named "ay!", Named "see!"] [] 1))+  , testCase "work across a recursion boundary" do+      let r = string "correct error message" <:> r+      let p = r <?> ["nothing but this :)"]+      testParse p "" @?=+        Failure (TestError (1, 1) (VanillaError (Just EndOfInput) [Named "nothing but this :)"] [] 1))+      testParse p "correct error message" @?=+        Failure (TestError (1, 22) (VanillaError (Just EndOfInput) [Raw "correct error message"] [] 1))+  , testCase "replace everything under the label" do+      let s = label ["hi"] (optional (char 'a') *> optional (char 'b')) *> char 'c'+      testParse s "e" @?=+        Failure (TestError (1, 1) (VanillaError (Just (Raw "e")) [Named "hi", Raw "c"] [] 1))+      let t = label ["hi"] (optional (char 'a') *> label ["bee"] (optional (char 'b'))) *> char 'c'+      testParse t "e" @?=+        Failure (TestError (1, 1) (VanillaError (Just (Raw "e")) [Named "hi", Raw "c"] [] 1))+      testParse t "ae" @?=+        Failure (TestError (1, 2) (VanillaError (Just (Raw "e")) [Named "bee", Raw "c"] [] 1))+      let v = label ["hi"] (hide (optional (char 'a')) *> label ["bee"] (optional (char 'b'))) *> char 'c'+      testParse v "e" @?=+        Failure (TestError (1, 1) (VanillaError (Just (Raw "e")) [Named "hi", Raw "c"] [] 1))+      testParse v "ae" @?=+        Failure (TestError (1, 2) (VanillaError (Just (Raw "e")) [Named "bee", Raw "c"] [] 1))+  , testCase "should not replace hints if input is consumed" do+      testParse ((many digit <?> ["number"]) <* eof) "1e" @?=+        Failure (TestError (1, 2) (VanillaError (Just (Raw "e")) [Named "digit", EndOfInput] [] 1))+  ]++hideTests :: TestTree+hideTests = testGroup "hide should"+  [ testCase "not produce any visible output" do+      testParse (hide (char 'a')) "" @?=+        Failure (TestError (1, 1) (VanillaError Nothing [] [] 0))+      testParse (hide (string "a")) "" @?=+        Failure (TestError (1, 1) (VanillaError Nothing [] [] 0))+      testParse (hide digit) "" @?=+        Failure (TestError (1, 1) (VanillaError Nothing [] [] 0))+  , testCase "suppress hints even if input is consumed" do+      testParse (hide (many digit) <* eof) "1e" @?=+        Failure (TestError (1, 2) (VanillaError (Just (Raw "e")) [EndOfInput] [] 1))+  , testCase "not allow hints to be unsuppressed by another label" do+      testParse (label ["hey"] (hide (many digit)) <* eof) "1e" @?=+        Failure (TestError (1, 2) (VanillaError (Just (Raw "e")) [EndOfInput] [] 1))+  ]++emptyTests :: TestTree+emptyTests = testGroup "empty should"+  [ testCase "produce unknown error messages" do+      testParse @() empty "b" @?= Failure (TestError (1, 1) (VanillaError Nothing [] [] 0))+  , testCase "produce no unknown message under influence of label" do+      testParse @() (empty <?> ["something, at least"]) "b" @?=+        Failure (TestError (1, 1) (VanillaError Nothing [Named "something, at least"] [] 0))+  , testCase "not produce an error message at end of <|> chain" do+      testParse (char 'a' <|> empty) "b" @?=+        Failure (TestError (1, 1) (VanillaError (Just (Raw "b")) [Raw "a"] [] 1))+  , testCase "produce an expected error under the influence of label in <|> chain" do+      testParse (char 'a' <|> label ["something, at least"] empty) "b" @?=+        Failure (TestError (1, 1) (VanillaError (Just (Raw "b")) [Raw "a", Named "something, at least"] [] 1))+  , expectFailBecause "no widening for carets in vanilla" $ testCase "have an effect if its caret is wider" do+      testParse (char 'a' <|> emptyWide 3) "bcd" @?=+        Failure (TestError (1, 1) (VanillaError (Just (Raw "bcd")) [Raw "a"] [] 3))+  ]++explainTests :: TestTree+explainTests = testGroup "explain should"+  [ testCase "provide a message but only on failure" do+      testParse @Int (explain "oops!" empty) "" @?=+        Failure (TestError (1, 1) (VanillaError Nothing [] ["oops!"] 0))+      testParse (explain "requires an a" (char 'a')) "b" @?=+        Failure (TestError (1, 1) (VanillaError (Just (Raw "b")) [Raw "a"] ["requires an a"] 1))+      testParse (explain "an a" (char 'a') <|> explain "a b" (char 'b')) "c" @?=+        Failure (TestError (1, 1) (VanillaError (Just (Raw "c")) [Raw "a", Raw "b"] ["an a", "a b"] 1))+  , testCase "not have any effect when more input has been consumed since it was added" do+      testParse (explain "should be absent" (char 'a') *> char 'b') "a" @?=+        Failure (TestError (1, 2) (VanillaError (Just EndOfInput) [Raw "b"] [] 1))+      testParse (explain "should be absent" (char 'a') <|> (char 'b' *> digit)) "b" @?=+        Failure (TestError (1, 2) (VanillaError (Just EndOfInput) [Named "digit"] [] 1))+  ]++failTests :: TestTree+failTests = testGroup "fail should"+  [ testCase "yield a raw message" do+      testParse @Int (fail ["hi"]) "b" @?=+        Failure (TestError (1, 1) (SpecialisedError ["hi"] 1))+  , expectFailBecause "no cross-error width merging" $ testCase "be flexible when the width is unspecified" do+      testParse (string "abc" <|> fail ["hi"]) "xyz" @?=+        Failure (TestError (1, 1) (SpecialisedError ["hi"] 3))+  , testCase "dominate otherwise" do+      testParse (string "abc" <|> failWide 2 ["hi"]) "xyz" @?=+        Failure (TestError (1, 1) (SpecialisedError ["hi"] 2))+  ]++unexpectedTests :: TestTree+unexpectedTests = testGroup "unexpected should"+  [ testCase "yield changes to unexpected messages" do+      testParse @() (unexpected "bee") "b" @?=+        Failure (TestError (1, 1) (VanillaError (Just (Named "bee")) [] [] 1))+  , testCase "produce expected message under influence of label, along with original message" do+      testParse (char 'a' <|> label ["something less cute"] (unexpected "bee")) "b" @?=+        Failure (TestError (1, 1) (VanillaError (Just (Named "bee")) [Raw "a", Named "something less cute"] [] 1))+  , expectFailBecause "no widening for carets in vanilla" $ testCase "be flexible when the width is unspecified" do+      testParse (string "abc" <|> unexpected "bee") "xyz" @?=+        Failure (TestError (1, 1) (VanillaError (Just (Named "bee")) [Raw "abc"] [] 3))+  , testCase "dominate otherwise" do+      testParse (string "abc" <|> unexpectedWide 2 "bee") "xyz" @?=+        Failure (TestError (1, 1) (VanillaError (Just (Named "bee")) [Raw "abc"] [] 2))+  ]++lookAheadTests :: TestTree+lookAheadTests = testGroup "lookAhead should"+  [ testCase "produce no hints following it" do+      let p = char 'a' <|> lookAhead (optional digit *> char 'c') <|> char 'b'+      testParse p "d" @?=+        Failure (TestError (1, 1) (VanillaError (Just (Raw "d")) [Raw "a", Raw "b", Raw "c", Named "digit"] [] 1))+      let q = char 'a' <|> lookAhead (optional digit) *> char 'c' <|> char 'b'+      testParse q "d" @?=+        Failure (TestError (1, 1) (VanillaError (Just (Raw "d")) [Raw "a", Raw "b", Raw "c"] [] 1))+      let r = char 'a' <|> lookAhead digit *> char 'c' <|> char 'b'+      testParse r "d" @?=+        Failure (TestError (1, 1) (VanillaError (Just (Raw "d")) [Raw "a", Raw "b", Named "digit"] [] 1))+  ]++notFollowedByTests :: TestTree+notFollowedByTests = testGroup "notFollowedBy should"+  [ testCase "produce no hints" do+      let p = char 'a' <|> notFollowedBy (optional digit) *> char 'c' <|> char 'b'+      testParse p "d" @?=+        Failure (TestError (1, 1) (VanillaError (Just (Raw "d")) [Raw "a", Raw "b"] [] 1))+      let q = char 'a' <|> notFollowedBy digit *> char 'c' <|> char 'b'+      testParse q "d" @?=+        Failure (TestError (1, 1) (VanillaError (Just (Raw "d")) [Raw "a", Raw "b", Raw "c"] [] 1))+  ]++eofTests :: TestTree+eofTests = testGroup "eof should"+  [ testCase "produce expected end of input" do+      testParse eof "a" @?=+        Failure (TestError (1, 1) (VanillaError (Just (Raw "a")) [EndOfInput] [] 1))+  , testCase "change message under the influence of label" do+      testParse (label ["something more"] eof) "a" @?=+        Failure (TestError (1, 1) (VanillaError (Just (Raw "a")) [Named "something more"] [] 1))+  ]++amendTests :: TestTree+amendTests = testGroup "amend should"+  [ testCase "change error messages under it" do+      let p = char 'a' *> amend (char 'b' *> char 'c' *> char 'd')+      case testParse p "ab" of+        Failure (TestError pos _) -> pos @?= (1, 2)+        _ -> assertFailure "parser must fail"+      case testParse p "abc" of+        Failure (TestError pos _) -> pos @?= (1, 2)+        _ -> assertFailure "parser must fail"+  , testCase "not affect input consumption" do+      ensureFails (amend (char 'a' *> char 'b') <|> char 'a') "a"+  ]++entrenchTests :: TestTree+entrenchTests = testGroup "entrench should"+  [ testCase "prevent the change of error messages under it" do+      let p = char 'a' *> amend (char 'b' *> entrench (char 'c') *> char 'd')+      case testParse p "ab" of+        Failure (TestError pos _) -> pos @?= (1, 3)+        _ -> assertFailure "parser must fail"+      case testParse p "abc" of+        Failure (TestError pos _) -> pos @?= (1, 2)+        _ -> assertFailure "parser must fail"+      let q = char 'a' *> amend (char 'b' *> char 'c' *> entrench (char 'd'))+      case testParse q "ab" of+        Failure (TestError pos _) -> pos @?= (1, 2)+        _ -> assertFailure "parser must fail"+      case testParse q "abc" of+        Failure (TestError pos _) -> pos @?= (1, 4)+        _ -> assertFailure "parser must fail"+  , testCase "not prevent the action of amend inside it" do+      let p = char 'a' *> amend (char 'b' *> entrench (amend (char 'c' *> char 'd' *> entrench (char 'e'))) *> char 'f')+      case testParse p "ab" of+        Failure (TestError pos _) -> pos @?= (1, 3)+        _ -> assertFailure "parser must fail"+      case testParse p "abc" of+        Failure (TestError pos _) -> pos @?= (1, 3)+        _ -> assertFailure "parser must fail"+      case testParse p "abcd" of+        Failure (TestError pos _) -> pos @?= (1, 5)+        _ -> assertFailure "parser must fail"+      case testParse p "abcde" of+        Failure (TestError pos _) -> pos @?= (1, 2)+        _ -> assertFailure "parser must fail"+  ]++dislodgeTests :: TestTree+dislodgeTests = testGroup "dislodge should"+  [ testCase "undo an entrench so that amend works again" do+      let p = char 'a' *> amend (char 'b' *> dislodge (entrench (entrench (char 'c'))) *> char 'd')+      case testParse p "ab" of+        Failure (TestError pos _) -> pos @?= (1, 2)+        _ -> assertFailure "parser must fail"+      case testParse p "abc" of+        Failure (TestError pos _) -> pos @?= (1, 2)+        _ -> assertFailure "parser must fail"+  , testCase "not prevent another entrench from occurring" do+      let p = char 'a' *> amend (char 'b' *> entrench (dislodge (entrench (char 'c'))) *> char 'd')+      case testParse p "ab" of+        Failure (TestError pos _) -> pos @?= (1, 3)+        _ -> assertFailure "parser must fail"+      case testParse p "abc" of+        Failure (TestError pos _) -> pos @?= (1, 2)+        _ -> assertFailure "parser must fail"+  , testCase "only unwind as many as instructed if applicable" do+      let p = char 'a' *> amend (char 'b' *> dislodgeBy 1 (entrench (entrench (char 'c'))) *> char 'd')+      let q = char 'a' *> amend (char 'b' *> dislodgeBy 2 (entrench (entrench (char 'c'))) *> char 'd')+      case testParse p "ab" of+        Failure (TestError pos _) -> pos @?= (1, 3)+        _ -> assertFailure "parser must fail"+      case testParse p "abc" of+        Failure (TestError pos _) -> pos @?= (1, 2)+        _ -> assertFailure "parser must fail"+      case testParse q "ab" of+        Failure (TestError pos _) -> pos @?= (1, 2)+        _ -> assertFailure "parser must fail"+      case testParse q "abc" of+        Failure (TestError pos _) -> pos @?= (1, 2)+        _ -> assertFailure "parser must fail"+  ]++amendThenDislodgeTests :: TestTree+amendThenDislodgeTests = testGroup "amendThenDislodge should"+  [ testCase "amend only non-entrenched messages and dislodge those that are" do+      let p = char 'a' *> amendThenDislodge (char 'b' *> entrench (entrench (char 'c')) *> char 'd')+      let q = amend p+      case testParse p "ab" of+        Failure (TestError pos _) -> pos @?= (1, 3)+        _ -> assertFailure "parser must fail"+      case testParse p "abc" of+        Failure (TestError pos _) -> pos @?= (1, 2)+        _ -> assertFailure "parser must fail"+      case testParse q "ab" of+        Failure (TestError pos _) -> pos @?= (1, 1)+        _ -> assertFailure "parser must fail"+      case testParse q "abc" of+        Failure (TestError pos _) -> pos @?= (1, 1)+        _ -> assertFailure "parser must fail"+  , testCase "only unwind as many as instructed if applicable" do+      let p = char 'a' *> amendThenDislodgeBy 1 (char 'b' *> entrench (entrench (char 'c')) *> char 'd')+      let q = amend p+      let r = char 'a' *> amendThenDislodgeBy 2 (char 'b' *> entrench (entrench (char 'c')) *> char 'd')+      let s = amend r+      case testParse p "ab" of+        Failure (TestError pos _) -> pos @?= (1, 3)+        _ -> assertFailure "parser must fail"+      case testParse p "abc" of+        Failure (TestError pos _) -> pos @?= (1, 2)+        _ -> assertFailure "parser must fail"+      case testParse q "ab" of+        Failure (TestError pos _) -> pos @?= (1, 3)+        _ -> assertFailure "parser must fail"+      case testParse q "abc" of+        Failure (TestError pos _) -> pos @?= (1, 1)+        _ -> assertFailure "parser must fail"+      case testParse r "ab" of+        Failure (TestError pos _) -> pos @?= (1, 3)+        _ -> assertFailure "parser must fail"+      case testParse r "abc" of+        Failure (TestError pos _) -> pos @?= (1, 2)+        _ -> assertFailure "parser must fail"+      case testParse s "ab" of+        Failure (TestError pos _) -> pos @?= (1, 1)+        _ -> assertFailure "parser must fail"+      case testParse s "abc" of+        Failure (TestError pos _) -> pos @?= (1, 1)+        _ -> assertFailure "parser must fail"+  ]++partialAmendTests :: TestTree+partialAmendTests = testGroup "partialAmend should"+  [ testCaseSteps "perform visual amendment but allow for domination" \step -> do+      let errorMaker n msg = atomic (exactly n (char 'a') *> (char 'b' <|> fail [msg]))++      step "a regular amend should lose against an even shallower error"+      let p = errorMaker 2 "small" <|> amend (errorMaker 3 "big")+      testParse p (replicate 4 'a') @?= Failure (TestError (1, 3) (SpecialisedError ["small"] 1))++      step "a partial amend can win against an error at a lesser offset but greater presentation"+      let q = errorMaker 2 "small" <|> partialAmend (errorMaker 3 "big")+      testParse q (replicate 4 'a') @?= Failure (TestError (1, 1) (SpecialisedError ["big"] 1))++      step "however, they do not win at equal underlying offset"+      let r = errorMaker 3 "first" <|> partialAmend (errorMaker 3 "second")+      testParse r (replicate 4 'a') @?= Failure (TestError (1, 4) (SpecialisedError ["first"] 1))+  ]++--TODO: filter tests++oneOfTests :: TestTree+oneOfTests = testGroup "oneOf should"+  [ testCase "incorporate range notation into the error" do+      testParse (oneOf ['0' .. '9']) "a" @?=+        Failure (TestError (1, 1) (VanillaError (Just (Raw "a")) [Named "one of \"0\" to \"9\""] [] 1))+  , testCase "incorporate sets of characters into error" do+      testParse (oneOf ['0', '2' .. '9']) "a" @?=+        Failure (TestError (1, 1) (VanillaError (Just (Raw "a")) (Set.map (Named . show . (: [])) ['0', '2' .. '9']) [] 1))+  ]++noneOfTests :: TestTree+noneOfTests = testGroup "noneOf should"+  [ testCase "incorporate range notation into the error" do+      testParse (noneOf ['0' .. '9']) "8" @?=+        Failure (TestError (1, 1) (VanillaError (Just (Raw "8")) [Named "anything outside of \"0\" to \"9\""] [] 1))+  , expectFailBecause "no label applied yet" $ testCase "incorporate sets of characters into error" do+      testParse (noneOf ['0', '2' .. '9']) "8" @?=+        Failure (TestError (1, 1) (VanillaError (Just (Raw "8")) [Named "anything except \"0\", \"1\", \"2\", \"3\", \"4\", \"5\", \"6\", \"7\", \"8\", or \"9\""] [] 1))+  ]++--TODO: patterns tests++regressionTests :: TestTree+regressionTests = testGroup "thou shalt not regress"+  [ testGroup "hints should"+      [ testCase "incorporate only with errors at the same offset depth" do+          let p = atomic (char 'a' *> digit)+          let parser = optional (char 'b' <?> ["b"]) *> label ["foo"] p+          case testParse parser "aa" of+            Failure (TestError (1, 2) (VanillaError _ expecteds _ 1)) -> do+              expecteds @?= [Named "digit"]+            err -> assertFailure $ "error message " ++ show err ++ " did not match"+          let q = amend (char 'a' *> digit)+          let qarser = optional (char 'b' <?> ["b"]) *> label ["foo"] q+          case testParse qarser "aa" of+            Failure (TestError (1, 1) (VanillaError _ expecteds _ 1)) -> do+              expecteds @?= [Named "foo", Named "b"]+            err -> assertFailure $ "error message " ++ show err ++ " did not match"+      ]+  , testGroup "amend should"+      -- FIXME: unclear why this would be the case+      [ expectFail $ testCase "ensure that errors pick up a new unexpected token" do+          let greeting = string "hello world" <* char '!'+          testParse (amend greeting <?> ["greeting"]) "hello world." @?=+            Failure (TestError (1, 1) (VanillaError (Just (Raw "h")) [Named "greeting"] [] 1))+      ]+  ]

@@ -7,7 +7,7 @@ import Text.Gigaparsec.Char (digit) import Text.Gigaparsec.Expr.Chain -import Text.Gigaparsec.Internal.Test (parseAll, ensureFails)+import Text.Gigaparsec.Internal.Test (testParseAll, ensureFails, testParse) import Text.Gigaparsec.Internal.PlainString ()  import Data.Char (digitToInt)@@ -27,9 +27,9 @@ postfixTests :: TestTree postfixTests = testGroup "postfix should"   [ testCase "require an initial value" do-      parseAll (postfix ("1" $> 1) ("+" $> succ)) "1" @?= Success 1+      testParseAll (postfix ("1" $> 1) ("+" $> succ)) "1" @?= Success 1   , testCase "parse all operators that follow" do-      parseAll (postfix ("1" $> 1) ("+" $> succ)) "1++++++++++++++" @?= Success 15+      testParseAll (postfix ("1" $> 1) ("+" $> succ)) "1++++++++++++++" @?= Success 15   , testCase "fail if an operator fails after consuming input" do       ensureFails (postfix ("1" $> 1) ("++" $> succ)) "1+++++++++++++++"   ]@@ -38,9 +38,9 @@ postfix1Tests = testGroup "postfix1 should"   [ testCase "require an initial value" do       ensureFails (postfix1 id ("1" $> 1) ("+" $> succ)) "1"-      parseAll (postfix1 id ("1" $> 1) ("+" $> succ)) "1+" @?= Success 2+      testParseAll (postfix1 id ("1" $> 1) ("+" $> succ)) "1+" @?= Success 2   , testCase "parse all operators that follow" do-      parseAll (postfix1 id ("1" $> 1) ("+" $> succ)) "1++++++++++++++" @?= Success 15+      testParseAll (postfix1 id ("1" $> 1) ("+" $> succ)) "1++++++++++++++" @?= Success 15   , testCase "fail if an operator fails after consuming input" do       ensureFails (postfix1 id ("1" $> 1) ("++" $> succ)) "1+++++++++++++++"   ]@@ -48,9 +48,9 @@ prefixTests :: TestTree prefixTests = testGroup "prefix should"    [ testCase "require an initial value" do-      parseAll (prefix ("+" $> succ) ("1" $> 1)) "1" @?= Success 1+      testParseAll (prefix ("+" $> succ) ("1" $> 1)) "1" @?= Success 1   , testCase "parse all operators that follow" do-      parseAll (prefix ("+" $> succ) ("1" $> 1)) "++++++++++++++1" @?= Success 15+      testParseAll (prefix ("+" $> succ) ("1" $> 1)) "++++++++++++++1" @?= Success 15   , testCase "fail if an operator fails after consuming input" do       ensureFails (prefix ("++" $> succ) ("1" $> 1)) "+++++++++++++++1"   ]@@ -59,9 +59,9 @@ prefix1Tests = testGroup "prefix1 should"   [ testCase "require an initial value" do       ensureFails (prefix1 id ("+" $> succ) ("1" $> 1)) "1"-      parseAll (prefix1 id ("+" $> succ) ("1" $> 1)) "+1" @?= Success 2+      testParseAll (prefix1 id ("+" $> succ) ("1" $> 1)) "+1" @?= Success 2   , testCase "parse all operators that follow" do-      parseAll (prefix1 id ("+" $> succ) ("1" $> 1)) "++++++++++++++1" @?= Success 15+      testParseAll (prefix1 id ("+" $> succ) ("1" $> 1)) "++++++++++++++1" @?= Success 15   , testCase "fail if an operator fails after consuming input" do       ensureFails (prefix1 id ("++" $> succ) ("1" $> 1)) "+++++++++++++++1"   ]@@ -70,13 +70,13 @@ chainr1Tests = testGroup "chainr1 should"   [ testCase "require an initial value" do       let p = chainr1 ("11" $> 1) ("+" $> (+))-      parseAll p "11" @?= Success 1+      testParseAll p "11" @?= Success 1       ensureFails p "1"       ensureFails p "2"   , testCase "parse all operators and values that follow" do-      parseAll (chainr1 ("11" $> 1) ("+" $> (+))) "11+11+11+11+11" @?= Success 5+      testParseAll (chainr1 ("11" $> 1) ("+" $> (+))) "11+11+11+11+11" @?= Success 5   , testCase "apply the functions with the correct associativity" do-      parseAll (chainr1 (digitToInt <$> digit) ("%" $> mod)) "6%5%2%7" @?= Success 0+      testParseAll (chainr1 (digitToInt <$> digit) ("%" $> mod)) "6%5%2%7" @?= Success 0   , testCase "fail if an operator or p fails after consuming input" do       let p = chainr1 ("11" $> 1) ("++" $> (+))       ensureFails p "11+11+11+11+11"@@ -87,7 +87,7 @@ chainrTests = testGroup "chainr should"   [ testCase "allow for no initial value" do       let p = chainr ("11" $> 1) ("+" $> (+)) 0-      parseAll p "" @?= Success 0+      testParseAll p "" @?= Success 0       ensureFails p "1"   ] @@ -95,13 +95,13 @@ chainl1Tests = testGroup "chainl1 should"   [ testCase "require an initial value" do       let p = chainl1 ("11" $> 1) ("+" $> (+))-      parseAll p "11" @?= Success 1+      testParseAll p "11" @?= Success 1       ensureFails p "1"       ensureFails p "2"   , testCase "parse all operators and values that follow" do-      parseAll (chainl1 ("11" $> 1) ("+" $> (+))) "11+11+11+11+11" @?= Success 5+      testParseAll (chainl1 ("11" $> 1) ("+" $> (+))) "11+11+11+11+11" @?= Success 5   , testCase "apply the functions with the correct associativity" do-      parseAll (chainl1 (digitToInt <$> digit) ("%" $> mod)) "6%5%2%7" @?= Success 1+      testParseAll (chainl1 (digitToInt <$> digit) ("%" $> mod)) "6%5%2%7" @?= Success 1   , testCase "fail if an operator or p fails after consuming input" do       let p = chainl1 ("11" $> 1) ("++" $> (+))       ensureFails p "11+11+11+11+11"@@ -112,7 +112,7 @@ chainlTests = testGroup "chainl should"   [ testCase "allow for no initial value" do       let p = chainl ("11" $> 1) ("+" $> (+)) 0-      parseAll p "" @?= Success 0+      testParseAll p "" @?= Success 0       ensureFails p "1"-      parse p "2" @?= Success 0+      testParse p "2" @?= Success 0   ]

@@ -6,7 +6,7 @@ import Text.Gigaparsec import Text.Gigaparsec.Expr.Infix -import Text.Gigaparsec.Internal.Test (parseAll)+import Text.Gigaparsec.Internal.Test (testParseAll) import Text.Gigaparsec.Internal.PlainString ()  data Expr = Add Int Expr | Sub Expr Int | Num Int deriving stock (Eq, Show)@@ -21,14 +21,14 @@ infixr1Tests = testGroup "infixr1 should"   [ testCase "correctly accept the use of a wrapping function" do       let p = infixr1 Num ("1" $> 1) ("+" $> Add)-      parseAll p "1+1+1" @?= Success (Add 1 (Add 1 (Num 1)))-      parseAll p "1" @?= Success (Num 1)+      testParseAll p "1+1+1" @?= Success (Add 1 (Add 1 (Num 1)))+      testParseAll p "1" @?= Success (Num 1)   ]  infixl1Tests :: TestTree infixl1Tests = testGroup "infixl1 should"   [ testCase "correctly accept the use of a wrapping function" do       let p = infixl1 Num ("1" $> 1) ("-" $> Sub)-      parseAll p "1-1-1" @?= Success (Sub (Sub (Num 1) 1) 1)-      parseAll p "1" @?= Success (Num 1)+      testParseAll p "1-1-1" @?= Success (Sub (Sub (Num 1) 1) 1)+      testParseAll p "1" @?= Success (Num 1)   ]

@@ -9,7 +9,7 @@ import Text.Gigaparsec.Expr import Text.Gigaparsec.Expr.Subtype -import Text.Gigaparsec.Internal.Test (parseAll)+import Text.Gigaparsec.Internal.Test (testParseAll) import Text.Gigaparsec.Internal.PlainString ()  import Data.Char (digitToInt)@@ -46,47 +46,47 @@   [ testCase "result in correct precedence" do       let expr = precedence' (digitToInt <$> digit) [ ops InfixL ["*" $> (*)]                                                     , ops InfixL ["+" $> (+)]]-      parseAll expr "1+2*3+4" @?= Success 11-      parseAll expr "1*2+3*4" @?= Success 14+      testParseAll expr "1+2*3+4" @?= Success 11+      testParseAll expr "1*2+3*4" @?= Success 14   , testCase "work for multiple operators at the same level" do       let expr = precedence' (digitToInt <$> digit) [ops InfixL ["+" $> (+), "-" $> (-)]]-      parseAll expr "1+2-3+4" @?= Success 4-      parseAll expr "1-2+3-4" @?= Success (-2)+      testParseAll expr "1+2-3+4" @?= Success 4+      testParseAll expr "1-2+3-4" @?= Success (-2)   , testCase "work for mixed associativity operators" do       let expr = precedence' (digitToInt <$> digit) [ ops InfixL ["*" $> (*)]                                                     , ops InfixR ["+" $> (+)]]-      parseAll expr "1+2*3+4" @?= Success 11-      parseAll expr "1*2+3*4" @?= Success 14+      testParseAll expr "1+2*3+4" @?= Success 11+      testParseAll expr "1*2+3*4" @?= Success 14   , testCase "parse mathematical expressions" do       let expr = precedence' (digitToInt <$> digit <|> "(" *> expr <* ")")                              [ ops Prefix ["-" $> negate]                              , ops InfixL ["/" $> div]                              , ops InfixR ["*" $> (*)]                              , ops InfixL ["+" $> (+), "-" $> (-)]]-      parseAll expr "(2+3)*8" @?= Success 40-      parseAll expr "-3+4" @?= Success 1-      parseAll expr "-(3+4)" @?= Success (-7)-      parseAll expr "(3+-7)*(-2--4)/2" @?= Success (-4)+      testParseAll expr "(2+3)*8" @?= Success 40+      testParseAll expr "-3+4" @?= Success 1+      testParseAll expr "-(3+4)" @?= Success (-7)+      testParseAll expr "(3+-7)*(-2--4)/2" @?= Success (-4)   , testCase "parse prefix operators mixed with infix operators" do       let expr = precedence' (digitToInt <$> digit <|> "(" *> expr <* ")")                              [ ops Prefix ["-" $> negate]                              , ops InfixL ["-" $> (-)]]-      parseAll expr "-1" @?= Success (-1)-      parseAll expr "2-1" @?= Success 1-      parseAll expr "-2-1" @?= Success (-3)-      parseAll expr "-(2-1)" @?= Success (-1)-      parseAll expr "(-0)-1" @?= Success (-1)+      testParseAll expr "-1" @?= Success (-1)+      testParseAll expr "2-1" @?= Success 1+      testParseAll expr "-2-1" @?= Success (-3)+      testParseAll expr "-(2-1)" @?= Success (-1)+      testParseAll expr "(-0)-1" @?= Success (-1)   , testCase "be able to parse prefix operators weaker than an infix" do       let expr = precedence' ("." $> Unit) [ ops InfixL [";" $> Bin]                                            , ops Prefix ["~" $> Un]]-      parseAll expr "~.;." @?= Success (Un (Bin Unit Unit))+      testParseAll expr "~.;." @?= Success (Un (Bin Unit Unit))   , testCase "generalise to sub-typed structures" do       let expr = precedence $  sops InfixN ["<" $> Less]                             +< sops InfixL ["+" $> Add]                             +< sops InfixR ["*" $> Mul]                             +< sops Prefix ["-" $> Neg]                             +< Atom (Num . digitToInt <$> digit <|> "(" *> (Parens <$> expr) <* ")")-      parseAll expr "(7+8)*2+3+6*2" @?=+      testParseAll expr "(7+8)*2+3+6*2" @?=         Success (upcast (Add (Add (upcast (Mul (upcast (Parens (upcast (Add (upcast (Num 7))                                                                             (upcast (Num 8))))))                                                (upcast (Num 2))))@@ -98,7 +98,7 @@                             +< gops InfixR OfFactor ["*" $> Mul]                             +< gops Prefix OfAtom ["-" $> Neg]                             +< Atom (Num . digitToInt <$> digit <|> "(" *> (Parens <$> expr) <* ")")-      parseAll expr "(7+8)*2+3+6*2<4" @?=+      testParseAll expr "(7+8)*2+3+6*2<4" @?=         Success (Less (Add (Add (upcast (Mul (upcast (Parens (upcast (Add (upcast (Num 7))                                                                           (upcast (Num 8))))))                                                (upcast (Num 2))))@@ -111,7 +111,7 @@                             >+ gops InfixL OfFactor ["*" $> Mul']                             >+ gops InfixL OfTerm ["+" $> Add]                             >+ gops InfixN OfExpr ["<" $> Less]-      parseAll expr "1*(2+3)" @?=+      testParseAll expr "1*(2+3)" @?=         Success (upcast (Mul' (upcast (Num 1))                               (upcast (Parens (upcast (Add (upcast (Num 2))                                                            (upcast (Num 3))))))))

@@ -1,9 +1,13 @@ -- A collection of test helpers-{-# LANGUAGE StandaloneDeriving, AllowAmbiguousTypes #-}+{-# LANGUAGE AllowAmbiguousTypes, RecordWildCards #-}+{-# OPTIONS_GHC -Wno-unrecognised-pragmas #-}+{-# HLINT ignore "Use newtype instead of data" #-} module Text.Gigaparsec.Internal.Test where  import Test.Tasty.HUnit +import Text.Gigaparsec.Internal.TestError+ import Text.Gigaparsec import Text.Gigaparsec.Internal import Text.Gigaparsec.Internal.RT@@ -12,28 +16,29 @@ import Control.Monad (unless, forM_) import Type.Reflection (typeOf, typeRep) --- don't @ me-deriving stock instance Eq State-deriving stock instance Show State+data LiftedState = Lifted State -parseAll :: Parsec a -> String -> Result a-parseAll p inp = parse (p <* eof) inp+testParse :: Parsec a -> String -> Result TestError a+testParse = parse @TestError +testParseAll :: Parsec a -> String -> Result TestError a+testParseAll p = testParse (p <* eof)+ -- TODO: could we use quick-check to generate states? -- | Tests to ensure that running the parser on the given string does nothing to the state pureParseWith :: HasCallStack => Parsec a -> String -> Assertion pureParseWith (Parsec p) inp = do   run initSt-  run (initSt { consumed = True })+  run (initSt { consumed = 1 })   run (initSt { line = 10, col = 20 })-  run (initSt { consumed = True, line = 10, col = 20 })+  run (initSt { consumed = 200, line = 10, col = 20 })   where initSt = emptyState inp         run :: State -> Assertion         run st = do-          let st' = runRT (p st (\ !_ -> return) return)-          unless (st == st') $+          let st' = runRT (p st (\ !_ s -> return (Lifted s)) (\ _ s -> return (Lifted s)))+          unless (Lifted st == st') $             assertFailure ("expected no change to internal state\n"-                        ++ "initial state: " ++ show st ++ "\n       became: " ++ show st')+                        ++ "initial state: " ++ show (Lifted st) ++ "\n       became: " ++ show st')  -- TODO: could we use quick-check to generate inputs? -- | Tests to ensure that running the parser does nothing to the state@@ -55,7 +60,7 @@         run :: State -> Assertion         run st = do           let st' = parseState p st-          assertBool (show st ++ " should be altered") (st' /= st)+          assertBool (show (Lifted st) ++ " should be altered") (st' /= Lifted st)  -- TODO: could we use quick-check to generate inputs? -- | Tests to ensure that running the parser does something to the state@@ -66,10 +71,10 @@   impureParseWith p ":@279"  consume :: a -> Parsec a-consume x = Parsec $ \st good _ -> good x (st { consumed = True})+consume x = Parsec $ \st good _ -> good x (st { consumed = consumed st + 1})  ensureFails :: (Show a, HasCallStack) => Parsec a -> String -> Assertion-ensureFails p inp = case parse p inp of+ensureFails p inp = case testParse p inp of   Failure{} -> return ()   Success x -> assertFailure ("parser must fail, but produced: " ++ show x) @@ -91,9 +96,33 @@         qSt = parseState q st     unless (pSt == qSt) $       assertFailure ("expected both parsers have the same effect on the state"-                  ++ "\ninitial state: " ++ show st+                  ++ "\ninitial state: " ++ show (Lifted st)                   ++ "\n          got: " ++ show pSt                   ++ "\n     expected: " ++ show qSt) -parseState :: Parsec a -> State -> State-parseState (Parsec p) st = runRT (p st (\ !_ -> return) return)+parseState :: Parsec a -> State -> LiftedState+parseState (Parsec p) st = runRT (p st (\ !_ st' -> return (Lifted st')) (\ _ st' -> return (Lifted st')))++-- don't @ me+instance Eq LiftedState where+  (==) :: LiftedState -> LiftedState -> Bool+  Lifted (State input1 consumed1 line1 col1 _hintValidOffset1 _hints1) ==+    Lifted (State input2 consumed2 line2 col2 _hintValidOffset2 _hints2) =+       consumed1 == consumed2 && line1 == line2 && col1 == col2 && input1 == input2+    -- this throws off a whole bunch of tests, understandably+    -- && hintValidOffset1 == hintValidOffset2 && hints1 == hints2+instance Show LiftedState where+  showsPrec :: Int -> LiftedState -> ShowS+  showsPrec p (Lifted State{..}) = showParen (p > 10) $ showString "State { input = "+                                                      . shows input+                                                      . showString ", consumed = "+                                                      . shows consumed+                                                      . showString ", line = "+                                                      . shows line+                                                      . showString ", col = "+                                                      . shows col+                                                      . showString ", hintsValidOffset = "+                                                      . shows hintsValidOffset+                                                      . showString ", hints = "+                                                      . shows hints+                                                      . showChar '}'

@@ -0,0 +1,59 @@+{-# LANGUAGE TypeFamilies #-}+module Text.Gigaparsec.Internal.TestError (+    TestError(..), TestErrorLines(..), TestErrorItem(..)+  ) where++import Text.Gigaparsec.Errors.ErrorBuilder hiding (Token(..))+import Text.Gigaparsec.Errors.ErrorBuilder qualified as Token++import Data.Set (Set)+import Data.List.NonEmpty (NonEmpty)+import Data.Set qualified as Set (fromList)+import Data.List.NonEmpty qualified as NonEmpty (take)++data TestError = TestError !(Word, Word) !TestErrorLines deriving stock (Eq, Show, Ord)+data TestErrorLines = VanillaError !(Maybe TestErrorItem) !(Set TestErrorItem) !(Set String) !Word+                    | SpecialisedError !(Set String) !Word deriving stock (Eq, Show, Ord)+data TestErrorItem = Raw !String | Named !String | EndOfInput deriving stock (Eq, Show, Ord)++instance ErrorBuilder TestError where+  format p _ = TestError p++  type Position TestError = (Word, Word)+  pos = (,)++  type Source TestError = ()+  source = const ()++  type ErrorInfoLines TestError = TestErrorLines+  vanillaError = VanillaError+  specialisedError = SpecialisedError++  type ExpectedItems TestError = Set TestErrorItem+  combineExpectedItems = id++  type Messages TestError = Set String+  combineMessages = Set.fromList++  type UnexpectedLine TestError = Maybe TestErrorItem+  unexpected = id+  type ExpectedLine TestError = Set TestErrorItem+  expected = id++  type Message TestError = String+  reason = id+  message = id++  type LineInfo TestError = Word+  lineInfo _ _ _ _ width = width++  numLinesBefore = 2+  numLinesAfter = 2++  type Item TestError = TestErrorItem+  raw = Raw+  named = Named+  endOfInput = EndOfInput++  unexpectedToken :: NonEmpty Char -> Word -> Bool -> Token.Token+  unexpectedToken cs demanded _ = Token.Raw (NonEmpty.take (fromIntegral demanded) cs)

@@ -33,14 +33,14 @@ eofTests :: TestTree eofTests = testGroup "eof should"   [ testCase "fail if input available" do ensureFails eof "a"-  , testCase "succeed if input ended" do parse eof "" @?= Success ()+  , testCase "succeed if input ended" do testParse eof "" @?= Success ()   , testCase "be pure" do pureParse eof   ]  pureTests :: TestTree pureTests = testGroup "pure should"   [ testCase "be pure" do pureParse unit-  , testCase "produce the given result" do parse unit "" @?= Success ()+  , testCase "produce the given result" do testParse unit "" @?= Success ()   ]  emptyTests :: TestTree@@ -71,8 +71,8 @@     , testCase "be impure if the left-hand side is impure and succeeds" do         impureParse (consume () <|> empty)     , testCase "succeed if the left-hand side succeeds" do-        parse (unit <|> empty) "" @?= Success ()-        parse (consume () <|> empty) "" @?= Success ()+        testParse (unit <|> empty) "" @?= Success ()+        testParse (consume () <|> empty) "" @?= Success ()     , testCase "be pure if the right-hand side succeeds purely" do         pureParse (empty <|> unit)     , testCase "be impure if the right-hand side succeeds impurely" do@@ -95,8 +95,8 @@     , testCase "be pure if the argument fails, even if impure" do         pureParse (atomic (consume () <**> empty))     , testCase "not alter failure characteristics of argument" do-        parse (atomic (consume ())) "" @?= Success ()-        parse (atomic unit) "" @?= Success ()+        testParse (atomic (consume ())) "" @?= Success ()+        testParse (atomic unit) "" @?= Success ()         ensureFails @Void (atomic empty) ""         ensureFails (atomic (consume () <* empty)) ""     ]@@ -112,8 +112,8 @@     , testCase "be impure if the argument is impure and fails" do         impureParse (lookAhead (consume () <* empty))     , testCase "not alter failure characteristics of argument" do-        parse (lookAhead (pure 7)) "" @?= Success 7-        parse (lookAhead (consume 14)) "" @?= Success 14+        testParse (lookAhead (pure 7)) "" @?= Success 7+        testParse (lookAhead (consume 14)) "" @?= Success 14         ensureFails @Void (lookAhead empty) ""         ensureFails (lookAhead (consume () <* empty)) ""     ]@@ -127,8 +127,8 @@         pureParse (notFollowedBy (consume ()))         pureParse (notFollowedBy (consume () *> empty))     , testCase "should succeed if the argument fails" do-        parse (notFollowedBy empty) "" @?= Success ()-        parse (notFollowedBy (consume () *> empty)) "" @?= Success ()+        testParse (notFollowedBy empty) "" @?= Success ()+        testParse (notFollowedBy (consume () *> empty)) "" @?= Success ()     , testCase "should fail if the argument succeeds" do         ensureFails (notFollowedBy unit) ""         ensureFails (notFollowedBy (consume ())) ""