gigaparsec 0.2.2.1 → 0.2.2.2

raw patch · 20 files changed

+752/−295 lines, 20 filesdep ~basedep ~bytestringPVP ok

version bump matches the API change (PVP)

Dependency ranges changed: base, bytestring

API changes (from Hackage documentation)

Files

• CHANGELOG.md +6/−2
• benchmarks/Main.hs +1/−3
• gigaparsec.cabal +9/−2
• src/Text/Gigaparsec.hs +3/−3
• src/Text/Gigaparsec/Char.hs +2/−2
• src/Text/Gigaparsec/Errors/Combinator.hs +7/−6
• src/Text/Gigaparsec/Errors/ErrorGen.hs +4/−4
• src/Text/Gigaparsec/Internal.hs +17/−18
• src/Text/Gigaparsec/Internal/Errors.hs +74/−246
• src/Text/Gigaparsec/Internal/Errors/CaretControl.hs +21/−0
• src/Text/Gigaparsec/Internal/Errors/DefuncBuilders.hs +213/−0
• src/Text/Gigaparsec/Internal/Errors/DefuncError.hs +161/−0
• src/Text/Gigaparsec/Internal/Errors/DefuncHints.hs +25/−0
• src/Text/Gigaparsec/Internal/Errors/DefuncTypes.hs +85/−0
• src/Text/Gigaparsec/Internal/Errors/ErrorItem.hs +23/−0
• src/Text/Gigaparsec/Internal/Errors/ParseError.hs +93/−0
• src/Text/Gigaparsec/Patterns.hs +1/−1
• test/Text/Gigaparsec/DebugTests.hs +1/−1
• test/Text/Gigaparsec/ErrorsTests.hs +4/−5
• test/Text/Gigaparsec/Internal/Test.hs +2/−2

@@ -1,7 +1,11 @@ # Revision history for gigaparsec -## 0.2.2.1 -- 2014-01-29-* Fixed bug where case sensitive keywords where parsed insensitively and vice-versa+## 0.2.2.2 -- 2024-01-29+* Optimised the error system using `DefuncError` and `DefuncHints`.+* Fixed bugs with amending and token merging.++## 0.2.2.1 -- 2024-01-29+* Fixed bug where case sensitive keywords where parsed insensitively and vice-versa.  ## 0.2.2.0 -- 2024-01-21 

@@ -4,15 +4,13 @@ module Main (main) where  import Gauge (defaultMain, bench, nf)-import Text.Gigaparsec (Parsec, Result(Success, Failure), parse, atomic, (<|>))+import Text.Gigaparsec (Parsec, Result, 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 ()

@@ -20,7 +20,7 @@ -- PVP summary:     +-+------- breaking API changes --                  | | +----- non-breaking API additions --                  | | | +--- code changes with no API change-version:            0.2.2.1+version:            0.2.2.2  -- A short (one-line) description of the package. synopsis:@@ -102,6 +102,13 @@                       -- Internals                       Text.Gigaparsec.Internal,                       Text.Gigaparsec.Internal.Errors,+                      Text.Gigaparsec.Internal.Errors.CaretControl,+                      Text.Gigaparsec.Internal.Errors.DefuncBuilders,+                      Text.Gigaparsec.Internal.Errors.DefuncError,+                      Text.Gigaparsec.Internal.Errors.DefuncHints,+                      Text.Gigaparsec.Internal.Errors.DefuncTypes,+                      Text.Gigaparsec.Internal.Errors.ErrorItem,+                      Text.Gigaparsec.Internal.Errors.ParseError,                       Text.Gigaparsec.Internal.RT,                       Text.Gigaparsec.Internal.Require,                       Text.Gigaparsec.Internal.Token.Generic,@@ -173,7 +180,7 @@         gigaparsec,         containers >= 0.6 && < 0.7,         deepseq >= 1.4 && < 1.6,-        bytestring >= 0.10 && < 0.12,+        bytestring >= 0.9 && < 0.13,         --deriving-compat >= 0.6 && < 0.7,         tasty >=1.1 && <1.6,         tasty-expected-failure >=0.11 && <0.13,

@@ -86,7 +86,7 @@ import Text.Gigaparsec.Internal (Parsec(Parsec), emptyState, manyr, somer) import Text.Gigaparsec.Internal qualified as Internal (State(..), useHints, expectedErr) import Text.Gigaparsec.Internal.RT qualified as Internal (RT, runRT, rtToIO)-import Text.Gigaparsec.Internal.Errors qualified as Internal (ParseError, ExpectItem(ExpectEndOfInput), fromParseError)+import Text.Gigaparsec.Internal.Errors qualified as Internal (Error, ExpectItem(ExpectEndOfInput), fromError)  import Text.Gigaparsec.Errors.ErrorBuilder (ErrorBuilder) import Text.Gigaparsec.Errors.Combinator (filterSWith, mapMaybeSWith)@@ -191,8 +191,8 @@ _parse file (Parsec p) inp = 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 file inp err))+        bad :: Internal.Error -> Internal.State -> Internal.RT (Result err a)+        bad err _ = return (Failure (Internal.fromError file inp err))  {-| This combinator parses its argument @p@, but rolls back any consumed input on failure.

@@ -50,7 +50,7 @@ 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, unParsec), State(..), expectedErr, useHints)-import Text.Gigaparsec.Internal.Errors qualified as Internal (ExpectItem(ExpectRaw), ParseError)+import Text.Gigaparsec.Internal.Errors qualified as Internal (ExpectItem(ExpectRaw), Error) import Text.Gigaparsec.Internal.Require (require)  import Data.Bits (Bits((.&.), (.|.)))@@ -168,7 +168,7 @@ string s = require (not (null s)) "Text.Gigaparsec.Char.string" "cannot pass empty string" $   --TODO: this could be much improved   Internal.Parsec $ \st ok bad ->-    let bad' (_ :: Internal.ParseError) =+    let bad' (_ :: Internal.Error) =           Internal.useHints bad (Internal.expectedErr st [Internal.ExpectRaw s]                                                          (fromIntegral (length s)))     in Internal.unParsec (traverse char s) st ok bad'

@@ -78,13 +78,13 @@ -- We want to use this to make the docs point to the right definition for users. import Text.Gigaparsec.Internal (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.Errors (Error, CaretWidth(FlexibleCaret, RigidCaret))+import Text.Gigaparsec.Internal.Errors qualified as Internal (setLexical, amendErr, entrenchErr, dislodgeErr, partialAmendErr, labelErr, explainErr, replaceHints) import Text.Gigaparsec.Internal.Require (require) import Text.Gigaparsec.Position (withWidth)  import Data.Set (Set)-import Data.Set qualified as Set (empty, map)+import Data.Set qualified as Set (empty) import Data.List.NonEmpty (NonEmpty) import Data.List.NonEmpty qualified as NonEmpty (toList) import Data.Maybe (isNothing, fromJust)@@ -105,7 +105,7 @@       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 }+            | otherwise = good x st' { Internal.hints = Internal.replaceHints ls (Internal.hints st') }           bad' err = Internal.useHints bad (Internal.labelErr origConsumed ls err)       in p st good' bad' @@ -264,7 +264,7 @@ partialAmend = _amend Internal.partialAmendErr  {-# INLINE _amend #-}-_amend :: (Word -> Word -> Word -> ParseError -> ParseError) -> Parsec a -> Parsec a+_amend :: (Word -> Word -> Word -> Error -> Error) -> Parsec a -> Parsec a _amend f (Internal.Parsec p) =   Internal.Parsec $ \st good bad ->     let !origConsumed = Internal.consumed st@@ -348,7 +348,8 @@ since lexing errors cannot be the result of unexpected tokens. -} markAsToken :: Parsec a -> Parsec a-markAsToken = Internal.adjustErr Internal.setLexical+markAsToken (Internal.Parsec p) = Internal.Parsec $ \st good bad ->+  p st good $ \err -> bad (Internal.setLexical (Internal.consumed st) err)  {-| This combinator changes the expected component of any errors generated by this parser.

@@ -6,7 +6,7 @@   ) where import Text.Gigaparsec.Internal (Parsec) import Text.Gigaparsec.Internal qualified as Internal (Parsec(Parsec), State, specialisedErr, emptyErr, expectedErr, unexpectedErr, raise)-import Text.Gigaparsec.Internal.Errors qualified as Internal (ParseError, CaretWidth(RigidCaret), addReason)+import Text.Gigaparsec.Internal.Errors qualified as Internal (Error, CaretWidth(RigidCaret), addReason)  type ErrorGen :: * -> * data ErrorGen a = SpecializedGen { messages :: a -> [String]@@ -45,18 +45,18 @@       good' (Left (x, w)) st' = bad (genErr errGen st' x w) st'   in p st good' bad -genErr :: ErrorGen a -> Internal.State -> a -> Word -> Internal.ParseError+genErr :: ErrorGen a -> Internal.State -> a -> Word -> Internal.Error genErr SpecializedGen{..} st x w =   Internal.specialisedErr st (messages x) (Internal.RigidCaret (adjustWidth x w)) genErr VanillaGen{..} st x w =   addReason (reason x) (makeError (unexpected x) st (adjustWidth x w)) -makeError :: UnexpectedItem -> Internal.State -> Word -> Internal.ParseError+makeError :: UnexpectedItem -> Internal.State -> Word -> Internal.Error makeError RawItem st cw = Internal.expectedErr st [] cw makeError EmptyItem st cw = Internal.emptyErr st cw makeError (NamedItem name) st cw = Internal.unexpectedErr st [] name (Internal.RigidCaret cw)  -- no fold, unlifed type-addReason :: Maybe String -> Internal.ParseError -> Internal.ParseError+addReason :: Maybe String -> Internal.Error -> Internal.Error addReason Nothing err = err addReason (Just reason) err = Internal.addReason reason err

@@ -18,17 +18,16 @@ 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 (Error, Hints, ExpectItem, CaretWidth) import Text.Gigaparsec.Internal.Errors qualified as Errors (     emptyErr, expectedErr, specialisedErr, mergeErr, unexpectedErr,-    expecteds, isExpectedEmpty, presentationOffset, useHints+    isExpectedEmpty, presentationOffset, useHints, DefuncHints(Blank), addError   )  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 @@ -57,8 +56,8 @@ type Parsec :: * -> * newtype Parsec a = Parsec {     unParsec :: forall r. State-             -> (a -> State -> RT r) -- the good continuation-             -> (ParseError -> State -> RT r)      -- the bad continuation+             -> (a -> State -> RT r)     -- the good continuation+             -> (Error -> State -> RT r) -- the bad continuation              -> RT r   } @@ -126,7 +125,7 @@   {-# INLINE return #-}   {-# INLINE (>>=) #-} -raise :: (State -> ParseError) -> Parsec a+raise :: (State -> Error) -> Parsec a raise mkErr = Parsec $ \st _ bad -> useHints bad (mkErr st) st  instance Alternative Parsec where@@ -188,7 +187,7 @@     -- | the valid for which hints can be used     hintsValidOffset :: {-# UNPACK #-} !Word,     -- | the hints at this point in time-    hints :: !(Set ExpectItem),+    hints :: Hints,     -- | Debug nesting     debugLevel :: {-# UNPACK #-} !Int   }@@ -199,35 +198,35 @@                         , line = 1                         , col = 1                         , hintsValidOffset = 0-                        , hints = Set.empty+                        , hints = Errors.Blank                         , debugLevel = 0                         } -emptyErr :: State -> Word -> ParseError+emptyErr :: State -> Word -> Error emptyErr State{..} = Errors.emptyErr consumed line col -expectedErr :: State -> Set ExpectItem -> Word -> ParseError+expectedErr :: State -> Set ExpectItem -> Word -> Error expectedErr State{..} = Errors.expectedErr input consumed line col -specialisedErr :: State -> [String] -> CaretWidth -> ParseError+specialisedErr :: State -> [String] -> CaretWidth -> Error specialisedErr State{..} = Errors.specialisedErr consumed line col -unexpectedErr :: State -> Set ExpectItem -> String -> CaretWidth -> ParseError+unexpectedErr :: State -> Set ExpectItem -> String -> CaretWidth -> Error unexpectedErr State{..} = Errors.unexpectedErr consumed line col -errorToHints :: State -> ParseError -> State+errorToHints :: State -> Error -> 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) }+    if hintsValidOffset < consumed then st { hints = Errors.addError (Errors.Blank) err, hintsValidOffset = consumed }+    else                                st { hints = Errors.addError hints err } errorToHints st _ = st -useHints :: (ParseError -> State -> RT r) -> (ParseError -> State -> RT r)+useHints :: (Error -> State -> RT r) -> (Error -> 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 }+  | otherwise                              = bad err st{ hintsValidOffset = presentationOffset, hints = Errors.Blank }   where !presentationOffset = Errors.presentationOffset err -adjustErr :: (ParseError -> ParseError) -> Parsec a -> Parsec a+adjustErr :: (Error -> Error) -> Parsec a -> Parsec a adjustErr f (Parsec p) = Parsec $ \st good bad -> p st good $ \err -> bad (f err)

@@ -1,274 +1,102 @@ {-# LANGUAGE Trustworthy #-} {-# LANGUAGE RecordWildCards, BangPatterns, NamedFieldPuns, CPP #-}-#include "portable-unlifted.h"-{-# OPTIONS_GHC -Wno-partial-fields -Wno-all-missed-specialisations -Wno-missing-import-lists #-}+{-# OPTIONS_GHC -Wno-all-missed-specialisations #-} {-# OPTIONS_HADDOCK hide #-}-module Text.Gigaparsec.Internal.Errors (module Text.Gigaparsec.Internal.Errors) where--import Prelude hiding (lines)+#include "portable-unlifted.h"+module Text.Gigaparsec.Internal.Errors (+    module Text.Gigaparsec.Internal.Errors,+    CaretWidth(..), ExpectItem(..),+    Error.presentationOffset, Error.isExpectedEmpty, DefuncHints(Blank)+  ) where -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(..))+import Text.Gigaparsec.Errors.ErrorBuilder (ErrorBuilder) -CPP_import_PortableUnlifted+import Text.Gigaparsec.Internal.Errors.DefuncError (DefuncError)+import Text.Gigaparsec.Internal.Errors.DefuncError qualified as Error+import Text.Gigaparsec.Internal.Errors.DefuncHints (DefuncHints(Blank))+import Text.Gigaparsec.Internal.Errors.DefuncHints qualified as Hints -type Span :: *-type Span = Word+import Text.Gigaparsec.Internal.Errors.CaretControl (CaretWidth(FlexibleCaret, RigidCaret))+import Text.Gigaparsec.Internal.Errors.ErrorItem (ExpectItem(ExpectNamed, ExpectEndOfInput, ExpectRaw))+import Text.Gigaparsec.Internal.Errors.ParseError (fromParseError)+import Text.Gigaparsec.Internal.Errors.DefuncBuilders (asParseError) -type CaretWidth :: UnliftedDatatype-data CaretWidth = FlexibleCaret { width :: {-# UNPACK #-} !Span }-                | RigidCaret { width :: {-# UNPACK #-} !Span }+CPP_import_PortableUnlifted -isFlexible :: CaretWidth -> Bool-isFlexible FlexibleCaret{} = True-isFlexible _               = False+type Error :: UnliftedDatatype+type Error = DefuncError+type Hints :: UnliftedDatatype+type Hints = DefuncHints -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-                                   }+{-# INLINE addError #-}+addError :: Hints -> Error -> Hints+addError = Hints.addError -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)+{-# INLINE replaceHints #-}+replaceHints :: Set String -> Hints -> Hints+replaceHints = Hints.replace -entrenched :: ParseError -> Bool-entrenched err = entrenchment err /= 0+{-# INLINABLE fromError #-}+fromError :: forall err. ErrorBuilder err => Maybe FilePath -> String -> Error -> err+fromError fp inp err = fromParseError fp inp (asParseError inp err) -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-  }+{-# INLINE emptyErr #-}+emptyErr :: Word -> Word -> Word -> Word -> Error+emptyErr = Error.emptyError -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-}+{-# INLINE expectedErr #-}+expectedErr :: String -> Word -> Word -> Word -> Set ExpectItem -> Word -> Error+expectedErr _ = Error.expectedError -specialisedErr :: Word -> Word -> Word -> [String] -> CaretWidth -> ParseError-specialisedErr !presentationOffset !line !col !msgs caretWidth = SpecialisedError {..}-  where !underlyingOffset = presentationOffset-        !entrenchment = 0 :: Word+{-# INLINE specialisedErr #-}+specialisedErr :: Word -> Word -> Word -> [String] -> CaretWidth -> Error+specialisedErr = Error.specialisedError -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-  }+{-# INLINE unexpectedErr #-}+unexpectedErr :: Word -> Word -> Word -> Set ExpectItem -> String -> CaretWidth -> Error+unexpectedErr = Error.unexpectedError -labelErr :: Word -> Set String -> ParseError -> ParseError-labelErr !offset expecteds err@VanillaError{}-  | offset == presentationOffset err = err { expecteds = Set.map ExpectNamed expecteds }-labelErr _ _ err = err+{-# INLINE labelErr #-}+labelErr :: Word -> Set String -> Error -> Error+labelErr = Error.label -explainErr :: Word -> String -> ParseError -> ParseError-explainErr !offset reason err@VanillaError{}-  | offset == presentationOffset err = addReason reason err+--TODO: remove?+{-# INLINABLE explainErr #-}+explainErr :: Word -> String -> Error -> Error+explainErr !offset reason err+  | offset == Error.presentationOffset err = addReason reason err explainErr _ _ err = err -addReason :: String -> ParseError -> ParseError-addReason reason err@VanillaError{} = err { reasons = Set.insert reason (reasons err) }-addReason _ 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)))+{-# INLINE addReason #-}+addReason :: String -> Error -> Error+addReason = Error.withReason -        expectItem :: ExpectItem -> Builder.Item err-        expectItem (ExpectRaw t) = Builder.raw @err t-        expectItem (ExpectNamed n) = Builder.named @err n-        expectItem ExpectEndOfInput = Builder.endOfInput @err+{-# INLINE amendErr #-}+amendErr :: Word -> Word -> Word -> Error -> Error+amendErr = Error.amend False -        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)+{-# INLINE partialAmendErr #-}+partialAmendErr :: Word -> Word -> Word -> Error -> Error+partialAmendErr = Error.amend True -        -- 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+{-# INLINE entrenchErr #-}+entrenchErr :: Error -> Error+entrenchErr = Error.entrench -        caret = col err - 1-        trimToLine width = min width (fromIntegral (length curLine) - caret + 1)+{-# INLINE dislodgeErr #-}+dislodgeErr :: Word -> Error -> Error+dislodgeErr !w = Error.dislodge (fromIntegral w) --FIXME: -        lines :: String -> NonEmpty String-        lines [] = "" :| []-        lines ('\n':cs) = "" <| lines cs-        lines (c:cs) = let l :| ls = lines cs in (c:l) :| ls+{-# INLINE setLexical #-}+setLexical :: Word -> Error -> Error+setLexical = Error.markAsLexical -        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)+{-# INLINE useHints #-}+useHints :: Hints -> Error -> Error+useHints = Error.withHints -        tokenSpan :: Token -> Word-        tokenSpan (Token.Raw cs) = fromIntegral (length cs)-        tokenSpan (Token.Named _ w) = w+{-# INLINE mergeErr #-}+mergeErr :: Error -> Error -> Error+mergeErr = Error.merge

@@ -0,0 +1,21 @@+{-# LANGUAGE Trustworthy #-}+{-# LANGUAGE CPP #-}+{-# OPTIONS_HADDOCK hide #-}+#include "portable-unlifted.h"+module Text.Gigaparsec.Internal.Errors.CaretControl (+    module Text.Gigaparsec.Internal.Errors.CaretControl+  ) where++CPP_import_PortableUnlifted++type Span :: *+type Span = Word++type CaretWidth :: UnliftedDatatype+data CaretWidth = FlexibleCaret { width :: {-# UNPACK #-} !Span }+                | RigidCaret { width :: {-# UNPACK #-} !Span }++{-# INLINE isFlexible #-}+isFlexible :: CaretWidth -> Bool+isFlexible FlexibleCaret{} = True+isFlexible _               = False

@@ -0,0 +1,213 @@+{-# LANGUAGE Trustworthy #-}+{-# LANGUAGE GADTs, DataKinds, UnboxedTuples, PatternSynonyms, CPP #-}+{-# OPTIONS_HADDOCK hide #-}+{-# OPTIONS_GHC -Wno-unused-imports #-}+-- Yes, this is redundant, however, it is necessary to get the UNPACK to fire+{-# OPTIONS_GHC -Wno-redundant-strictness-flags -Wno-missing-kind-signatures #-}+#include "portable-unlifted.h"+module Text.Gigaparsec.Internal.Errors.DefuncBuilders (+    asParseError+  ) where++import Text.Gigaparsec.Internal.Errors.DefuncTypes (+    DefuncHints(Blank, AddErr, Replace),+    ErrorOp(Amended, WithLabel, WithHints, Merged, WithReason, AdjustCaret),+    BaseError(Unexpected, Empty, Expected, ClassicSpecialised),+    DefuncError_(Op, Base),+    DefuncError(DefuncError, presentationOffset, errKind, errTy),+    ErrKindSingleton(IsSpecialised, IsVanilla),+    ErrKind(Vanilla, Specialised),+    expecteds, unexpectedWidth+  )+import Text.Gigaparsec.Internal.Errors.ParseError (ParseError(VanillaError, SpecialisedError))+import Text.Gigaparsec.Internal.Errors.CaretControl (CaretWidth(FlexibleCaret, width), isFlexible)+import Text.Gigaparsec.Internal.Errors.DefuncError (isLexical)+import Text.Gigaparsec.Internal.Errors.ErrorItem (+    ExpectItem(ExpectNamed),+    UnexpectItem(UnexpectEndOfInput, UnexpectNamed, UnexpectRaw)+  )++import Data.Set (Set)+import Data.Set qualified as Set (empty, insert, union, member, map)+import Data.List.NonEmpty (nonEmpty)++CPP_import_PortableUnlifted++asParseError :: String -> DefuncError -> ParseError+asParseError !input e@DefuncError{..} = case errKind of+  IsVanilla -> case makeVanilla 0 0 Set.empty (NoItem 0) Set.empty True errTy of+    (# line, col, exs, unex, reasons #) ->+      VanillaError presentationOffset line col (toErrorItem input presentationOffset unex) exs reasons (isLexical e)+  IsSpecialised -> case makeSpec 0 0 0 True id errTy of+    (# line, col, width, _, dmsgs #) ->+      SpecialisedError presentationOffset line col (distinct (dmsgs [])) width+  where+    !outOfRange = presentationOffset >= fromIntegral (length input)++    makeVanilla :: Word -> Word -> Set ExpectItem -> BuilderUnexpectItem -> Set String -> Bool+                -> DefuncError_ 'Vanilla+                -> (# Word, Word, Set ExpectItem, BuilderUnexpectItem, Set String #)+    makeVanilla !_ !_ !exs unex !reasons !acceptingExpected (Base line col err) =+      case err of+        Empty unexWidth ->+          (# line, col, exs, updateEmptyUnexpected unexWidth unex, reasons #)+        Expected exs' unexWidth ->+          (# line, col, addLabels acceptingExpected exs exs', updateUnexpected outOfRange unexWidth unex, reasons #)+        Unexpected exs' unex' caretWidth ->+          (# line, col, addLabels acceptingExpected exs exs', updateUnexpected' unex' caretWidth unex, reasons #)+    makeVanilla line col exs unex reasons acceptingExpected (Op op) =+      case op of+        Merged err1 err2 ->+          case makeVanilla line col exs unex reasons acceptingExpected err1 of+            (# line', col', exs', unex', reasons' #) ->+              makeVanilla line' col' exs' unex' reasons' acceptingExpected err2+        WithHints err hints ->+          case makeVanilla line col exs unex reasons acceptingExpected err of+            (# line', col', exs', unex', reasons' #) ->+              if acceptingExpected then+                case collectHints exs' UNothing hints of+                  (# exs'', UJust width #) ->+                    (# line', col', exs'', updateUnexpected outOfRange width unex', reasons' #)+                  (# exs'', UNothing #) -> (# line', col', exs'', unex', reasons' #)+              else (# line', col', exs', unex', reasons' #)+        WithLabel err ls ->+          case makeVanilla line col exs unex reasons False err of+            (# line', col', exs', unex', reasons' #) ->+              (# line', col', addLabels acceptingExpected exs' (Set.map ExpectNamed ls), unex', reasons' #)+        WithReason err reason ->+          makeVanilla line col exs unex (Set.insert reason reasons) acceptingExpected err+        Amended line' col' err ->+          case makeVanilla line col exs unex reasons acceptingExpected err of+            (# _, _, exs', unex', reasons' #) ->+              (# line', col', exs', unex', reasons' #)++    makeSpec :: Word -> Word -> Word -> Bool -> ([String] -> [String])+             -> DefuncError_ 'Specialised+             -> (# Word, Word, Word, Bool, [String] -> [String] #)+    makeSpec !_ !_ !w !flexible !dmsgs (Base line col (ClassicSpecialised msgs cw)) =+      let (# w', flexible' #) = updateCaretWidth flexible cw w+      in (# line, col, w', flexible', dmsgs . (msgs ++) #)+    makeSpec line col w flexible dmsgs (Op op) = case op of+      Merged err1 err2->+        case makeSpec line col w flexible dmsgs err1 of+          (# line', col', w', flexible', dmsgs' #) ->+            makeSpec line' col' w' flexible' dmsgs' err2+      AdjustCaret err1 err2 ->+        case makeSpec line col w flexible dmsgs err1 of+          (# line', col', w', flexible', dmsgs' #) ->+              -- assuming flexible == True+              (# line', col', adjustCaret w' err2, flexible', dmsgs' #)+      Amended line' col' err -> case makeSpec line col w flexible dmsgs err of+        (# _, _, w', flexible', dmsgs' #) -> (# line', col', w', flexible', dmsgs' #)++type BuilderUnexpectItem :: UnliftedDatatype+data BuilderUnexpectItem = NoItem {-# UNPACK #-} !Word+                         | RawItem {-# UNPACK #-} !Word+                         | NamedItem !String {-# UNPACK #-} !CaretWidth+                         | EndOfInput++updateEmptyUnexpected :: Word -> BuilderUnexpectItem -> BuilderUnexpectItem+updateEmptyUnexpected !w = pickHigher (NoItem w)++updateUnexpected :: Bool -> Word -> BuilderUnexpectItem -> BuilderUnexpectItem+updateUnexpected !outOfRange !w+ | outOfRange = pickHigher EndOfInput+ | otherwise  = pickHigher (RawItem w)++updateUnexpected' :: String -> CaretWidth -> BuilderUnexpectItem -> BuilderUnexpectItem+updateUnexpected' item cw = pickHigher (NamedItem item cw)++pickHigher :: BuilderUnexpectItem -> BuilderUnexpectItem -> BuilderUnexpectItem+pickHigher EndOfInput _ = EndOfInput+pickHigher _ EndOfInput = EndOfInput+pickHigher x@(RawItem w1) y@(RawItem w2)+  | w1 > w2   = x+  | otherwise = y+pickHigher x@(NoItem w1) y@(NoItem w2)+  | w1 > w2   = x+  | otherwise = y+pickHigher x@(NamedItem _ cw1) y@(NamedItem _ cw2)+  | isFlexible cw1 /= isFlexible cw2 = if isFlexible cw1 then x else y+  | width cw1 > width cw2            = x+  | otherwise                        = y+pickHigher x@(RawItem w1) (NoItem w2)+  | w1 > w2   = x+  | otherwise = RawItem w2+pickHigher x@(NamedItem name (FlexibleCaret w1)) (RawItem w2)+  | w1 > w2   = x+  | otherwise = NamedItem name (FlexibleCaret w2)+pickHigher x@(NamedItem name (FlexibleCaret w1)) (NoItem w2)+  | w1 > w2   = x+  | otherwise = NamedItem name (FlexibleCaret w2)+pickHigher x@NamedItem{} _ = x+pickHigher x y = pickHigher y x++addLabels :: Bool -> Set ExpectItem -> Set ExpectItem -> Set ExpectItem+addLabels True !exs !exs' = Set.union exs exs'+addLabels False exs _     = exs++toErrorItem :: String -> Word -> BuilderUnexpectItem -> Either Word UnexpectItem+toErrorItem !_ !_ (NoItem w) = Left w+toErrorItem _ _ (NamedItem item cw) = Right (UnexpectNamed item cw)+toErrorItem _ _ EndOfInput = Right UnexpectEndOfInput+toErrorItem input off (RawItem w) =+  case nonEmpty (drop (fromIntegral off) input) of+    Nothing -> Right UnexpectEndOfInput+    Just cs -> Right (UnexpectRaw cs w)++type UMaybe a = (# (# #) | a #)+{-# COMPLETE UJust, UNothing #-}+pattern UJust :: a -> UMaybe a+pattern UJust x = (# | x #)+pattern UNothing :: UMaybe a+pattern UNothing = (# (# #) | #)++collectHints :: Set ExpectItem -> UMaybe Word -> DefuncHints -> (# Set ExpectItem, UMaybe Word #)+collectHints !exs width Blank = (# exs, width #)+collectHints exs width (Replace ls) = (# Set.union exs (Set.map ExpectNamed ls), width #)+collectHints exs width (AddErr hints err) =+  let !(# exs', width' #) = collectHintsErr exs width err+  in collectHints exs' width' hints++collectHintsErr :: Set ExpectItem -> UMaybe Word -> DefuncError_ 'Vanilla -> (# Set ExpectItem, UMaybe Word #)+collectHintsErr !exs width (Base _ _ err) =+  (# Set.union exs (expecteds err), updateWidth width (unexpectedWidth err) #)+collectHintsErr exs width (Op op) = case op of+  -- FIXME: Why doesn't this traverse deeper to collect the width?+  WithLabel _ ls -> (# Set.union exs (Set.map ExpectNamed ls), width #)+  WithHints err hints ->+    let !(# exs', width' #) = collectHints exs width hints+    in collectHintsErr exs' width' err+  Merged err1 err2 ->+    let !(# exs', width' #) = collectHintsErr exs width err1+    in collectHintsErr exs' width' err2+  WithReason err _ -> collectHintsErr exs width err+  Amended _ _ err -> collectHintsErr exs width err++updateWidth :: UMaybe Word -> Word -> UMaybe Word+updateWidth UNothing !w = UJust w+updateWidth (UJust w) w' = UJust (max w w')++distinct :: forall a. Ord a => [a] -> [a]+distinct = go Set.empty+  where+    go :: Set a -> [a] -> [a]+    go _ [] = []+    go seen (x:xs)+      | Set.member x seen = go seen xs+      | otherwise         = x : go (Set.insert x seen) xs++updateCaretWidth :: Bool -> CaretWidth -> Word -> (# Word, Bool #)+updateCaretWidth flexible cw !w+  | isFlexible cw == flexible = (# max (width cw) w, flexible #)+  | isFlexible cw             = (# w, flexible #)+  | otherwise                 = (# width cw, False #)++adjustCaret :: Word -> DefuncError_ 'Vanilla -> Word+adjustCaret w (Base _ _ err) = max (unexpectedWidth err) w+adjustCaret w (Op op) = case op of+  WithLabel err _  -> adjustCaret w err+  WithHints err _  -> adjustCaret w err+  WithReason err _ -> adjustCaret w err+  Amended _ _ err  -> adjustCaret w err+  Merged err1 err2 -> adjustCaret (adjustCaret w err1) err2

@@ -0,0 +1,161 @@+{-# LANGUAGE Safe #-}+{-# LANGUAGE GADTs, NamedFieldPuns, BinaryLiterals, NumericUnderscores, DataKinds, BangPatterns #-}+{-# OPTIONS_HADDOCK hide #-}+{-# OPTIONS_GHC -Wno-missing-import-lists #-}+module Text.Gigaparsec.Internal.Errors.DefuncError (+    DefuncError(presentationOffset),+    specialisedError, expectedError, unexpectedError, emptyError,+    merge, withHints, withReason, withReasonAndOffset, label,+    amend, entrench, dislodge, markAsLexical,+    isVanilla, isExpectedEmpty, isLexical+  ) where++import Data.Word (Word32)+import Data.Bits ((.&.), testBit, clearBit, setBit, complement, bit)+import Data.Set (Set)+import Data.Set qualified as Set (null)++import Text.Gigaparsec.Internal.Errors.CaretControl (CaretWidth, Span, isFlexible)+import Text.Gigaparsec.Internal.Errors.DefuncTypes (+    DefuncError(..), DefuncError_(..), ErrKindSingleton(..),+    ErrorOp(..), BaseError(..),+    DefuncHints(..)+  )+import Text.Gigaparsec.Internal.Errors.ErrorItem (ExpectItem)++{-# INLINABLE isVanilla #-}+isVanilla :: DefuncError -> Bool+isVanilla DefuncError{flags} = testBit flags vanillaBit++{-# INLINABLE isExpectedEmpty #-}+isExpectedEmpty :: DefuncError -> Bool+isExpectedEmpty DefuncError{flags} = testBit flags expectedEmptyBit++{-# INLINABLE entrenchedBy #-}+entrenchedBy :: DefuncError -> Word32+entrenchedBy DefuncError{flags} = flags .&. entrenchedMask++{-# INLINABLE entrenched #-}+entrenched :: DefuncError -> Bool+entrenched err = entrenchedBy err > 0++{-# INLINABLE isFlexibleCaret #-}+isFlexibleCaret :: DefuncError -> Bool+isFlexibleCaret DefuncError{flags} = testBit flags flexibleCaretBit++{-# INLINABLE isLexical #-}+isLexical :: DefuncError -> Bool+isLexical DefuncError{flags} = testBit flags lexicalBit++-- Base Errors+specialisedError :: Word -> Word -> Word -> [String] -> CaretWidth -> DefuncError+specialisedError !pOff !line !col !msgs caret =+  DefuncError IsSpecialised flags pOff pOff (Base line col (ClassicSpecialised msgs caret))+  where flags :: Word32+        !flags+          | isFlexible caret = setBit (bit expectedEmptyBit) flexibleCaretBit+          | otherwise        = bit expectedEmptyBit++emptyError :: Word -> Word -> Word -> Span -> DefuncError+emptyError !pOff !line !col !unexWidth =+  DefuncError IsVanilla flags pOff pOff (Base line col (Empty unexWidth))+  where flags :: Word32+        !flags = setBit (bit vanillaBit) expectedEmptyBit++expectedError :: Word -> Word -> Word -> Set ExpectItem -> Span -> DefuncError+expectedError !pOff !line !col !exs !unexWidth =+  DefuncError IsVanilla flags pOff pOff (Base line col (Expected exs unexWidth))+  where flags :: Word32+        !flags+          | Set.null exs = setBit (bit vanillaBit) expectedEmptyBit+          | otherwise    = bit vanillaBit++unexpectedError :: Word -> Word -> Word -> Set ExpectItem -> String -> CaretWidth -> DefuncError+unexpectedError !pOff !line !col !exs !unex caretWidth =+  DefuncError IsVanilla flags pOff pOff (Base line col (Unexpected exs unex caretWidth))+  where flags :: Word32+        !flags+          | Set.null exs = setBit (bit vanillaBit) expectedEmptyBit+          | otherwise    = bit vanillaBit++-- Operations+merge :: DefuncError -> DefuncError -> DefuncError+merge err1@(DefuncError k1 flags1 pOff1 uOff1 errTy1)+      err2@(DefuncError k2 flags2 pOff2 uOff2 errTy2) =+  case compare uOff1 uOff2 of+    GT -> err1+    LT -> err2+    EQ -> case compare pOff1 pOff2 of+      GT -> err1+      LT -> err2+      EQ -> case k1 of+        IsSpecialised -> case k2 of+          IsSpecialised ->+            DefuncError IsSpecialised (flags1 .&. flags2) pOff1 uOff1 (Op (Merged errTy1 errTy2))+          IsVanilla | isFlexibleCaret err1 ->+            DefuncError IsSpecialised flags1 pOff1 uOff1 (Op (AdjustCaret errTy1 errTy2))+          _ -> err1+        IsVanilla -> case k2 of+          IsVanilla ->+            DefuncError IsVanilla (flags1 .&. flags2) pOff1 uOff1 (Op (Merged errTy1 errTy2))+          IsSpecialised | isFlexibleCaret err2 ->+            DefuncError IsSpecialised flags1 pOff1 uOff1 (Op (AdjustCaret errTy2 errTy1))+          _ -> err2++withHints :: DefuncHints -> DefuncError -> DefuncError+withHints Blank err = err+withHints hints (DefuncError IsVanilla flags pOff uOff errTy) =+  DefuncError IsVanilla (clearBit flags expectedEmptyBit) pOff uOff (Op (WithHints errTy hints))+withHints _ err = err++withReasonAndOffset :: String -> Word -> DefuncError -> DefuncError+withReasonAndOffset !reason !off (DefuncError IsVanilla flags pOff uOff errTy) | pOff == off =+  DefuncError IsVanilla flags pOff uOff (Op (WithReason errTy reason))+withReasonAndOffset _ _ err = err++withReason :: String -> DefuncError -> DefuncError+withReason !reason err = withReasonAndOffset reason (presentationOffset err) err++label :: Word -> Set String -> DefuncError -> DefuncError+label !off !labels (DefuncError IsVanilla flags pOff uOff errTy) | pOff == off =+  DefuncError IsVanilla flags' pOff uOff (Op (WithLabel errTy labels))+  where !flags'+          | Set.null labels = setBit flags expectedEmptyBit+          | otherwise       = clearBit flags expectedEmptyBit+label _ _ err = err++amend :: Bool -> Word -> Word -> Word -> DefuncError -> DefuncError+amend !partial !pOff !line !col err@(DefuncError k flags _ uOff errTy)+  | entrenched err = err+  | otherwise = DefuncError k flags pOff uOff' (Op (Amended line col errTy))+  where+    !uOff' = if partial then uOff else pOff++entrench :: DefuncError -> DefuncError+entrench (DefuncError k flags pOff uOff errTy) = DefuncError k (flags + 1) pOff uOff errTy++dislodge :: Word32 -> DefuncError -> DefuncError+dislodge by err@(DefuncError k flags pOff uOff errTy)+  | eBy == 0  = err+  | eBy > by  = DefuncError k (flags - by) pOff uOff errTy+  | otherwise = DefuncError k (flags .&. complement entrenchedMask) pOff uOff errTy+  where !eBy = entrenchedBy err++markAsLexical :: Word -> DefuncError -> DefuncError+markAsLexical !off (DefuncError IsVanilla flags pOff uOff errTy) | off == pOff =+  DefuncError IsVanilla (setBit flags lexicalBit) pOff uOff errTy+markAsLexical _ err = err++-- FLAG MASKS+{-# INLINE vanillaBit #-}+{-# INLINE expectedEmptyBit #-}+{-# INLINE lexicalBit #-}+{-# INLINE flexibleCaretBit #-}+{-# INLINE entrenchedMask #-}+vanillaBit, expectedEmptyBit, lexicalBit, flexibleCaretBit :: Int+vanillaBit       = 31+expectedEmptyBit = 30+lexicalBit       = 29+flexibleCaretBit = 28+entrenchedMask :: Word32+entrenchedMask    = 0b00001111_11111111_11111111_11111111

@@ -0,0 +1,25 @@+{-# LANGUAGE Safe #-}+{-# LANGUAGE GADTs, NamedFieldPuns, BinaryLiterals, NumericUnderscores, DataKinds, BangPatterns #-}+{-# OPTIONS_HADDOCK hide #-}+{-# OPTIONS_GHC -Wno-missing-import-lists #-}+module Text.Gigaparsec.Internal.Errors.DefuncHints (+    DefuncHints(Blank),+    replace, addError+  ) where++import Text.Gigaparsec.Internal.Errors.DefuncTypes (+    DefuncHints(Blank, Replace, AddErr),+    DefuncError(DefuncError), ErrKindSingleton(IsVanilla)+  )++import Data.Set (Set)++{-# INLINABLE replace #-}+replace :: Set String -> DefuncHints -> DefuncHints+replace !_ Blank = Blank+replace ls _      = Replace ls++{-# INLINABLE addError #-}+addError :: DefuncHints -> DefuncError -> DefuncHints+addError hints (DefuncError IsVanilla _ _ _ err) = AddErr hints err+addError _ _ = error "invariance broken: a specialised error is never added to hints"

@@ -0,0 +1,85 @@+{-# LANGUAGE Trustworthy #-}+{-# LANGUAGE BangPatterns, CPP, DataKinds, GADTs #-}+{-# OPTIONS_HADDOCK hide #-}+-- Yes, this is redundant, however, it is necessary to get the UNPACK to fire+{-# OPTIONS_GHC -Wno-redundant-strictness-flags #-}+#include "portable-unlifted.h"+module Text.Gigaparsec.Internal.Errors.DefuncTypes (+    module Text.Gigaparsec.Internal.Errors.DefuncTypes+  ) where++import Text.Gigaparsec.Internal.Errors.CaretControl (CaretWidth (width), Span)+import Text.Gigaparsec.Internal.Errors.ErrorItem (ExpectItem)++import Data.Word (Word32)+import Data.Set (Set)+import Data.Set qualified as Set (empty)++CPP_import_PortableUnlifted++type ErrKind :: *+data ErrKind = Vanilla | Specialised++-- Don't make this unlifted, it breaks GHC, unsure why+type ErrKindSingleton :: ErrKind -> *+data ErrKindSingleton k where+  IsVanilla :: ErrKindSingleton 'Vanilla+  IsSpecialised :: ErrKindSingleton 'Specialised++type DefuncError :: UnliftedDatatype+data DefuncError = forall k. DefuncError {+    errKind :: !(ErrKindSingleton k),+    flags :: {-# UNPACK #-} !Word32,+    presentationOffset :: {-# UNPACK #-} !Word,+    underlyingOffset :: {-# UNPACK #-} !Word,+    errTy :: !(DefuncError_ k)+  }++-- We don't UNPACK this, reduces the allocations in other parts+type DefuncError_ :: ErrKind -> UnliftedDatatype+data DefuncError_ k where+  Base :: {-# UNPACK #-} !Word -- ^ line+       -> {-# UNPACK #-} !Word -- ^ col+       -> {-# UNPACK #-} !(BaseError k)+       -> DefuncError_ k+  Op :: {-# UNPACK #-} !(ErrorOp k) -> DefuncError_ k+++type BaseError :: ErrKind -> UnliftedDatatype+data BaseError k where+  ClassicSpecialised :: ![String] -> {-# UNPACK #-} !CaretWidth -> BaseError 'Specialised+  Expected :: !(Set ExpectItem) -> {-# UNPACK #-} !Span -> BaseError 'Vanilla+  Unexpected :: !(Set ExpectItem) -> !String -> {-# UNPACK #-} !CaretWidth -> BaseError 'Vanilla+  Empty :: {-# UNPACK #-} !Span -> BaseError 'Vanilla++{-# INLINABLE expecteds #-}+expecteds :: BaseError 'Vanilla -> Set ExpectItem+expecteds (Expected exs _) = exs+expecteds (Unexpected exs _ _) = exs+expecteds Empty{} = Set.empty++{-# INLINEABLE unexpectedWidth #-}+unexpectedWidth :: BaseError 'Vanilla -> Word+unexpectedWidth (Expected _ w) = w+unexpectedWidth (Unexpected _ _ cw) = width cw+unexpectedWidth (Empty w) = w+++type ErrorOp :: ErrKind -> UnliftedDatatype+data ErrorOp k where+  Merged      :: !(DefuncError_ k) -> !(DefuncError_ k) -> ErrorOp k+  AdjustCaret :: !(DefuncError_ 'Specialised)+              -> !(DefuncError_ 'Vanilla) -- ^ caretAdjuster+              -> ErrorOp 'Specialised+  WithHints   :: !(DefuncError_ 'Vanilla) -> !DefuncHints -> ErrorOp 'Vanilla+  WithReason  :: !(DefuncError_ 'Vanilla) -> !String -> ErrorOp 'Vanilla+  WithLabel   :: !(DefuncError_ 'Vanilla) -> !(Set String) -> ErrorOp 'Vanilla+  Amended     :: {-# UNPACK #-} !Word -- ^ line+              -> {-# UNPACK #-} !Word -- ^ col+              -> !(DefuncError_ k) -> ErrorOp k++type DefuncHints :: UnliftedDatatype+data DefuncHints where+  Blank :: DefuncHints+  Replace :: !(Set String) -> DefuncHints+  AddErr :: !DefuncHints -> !(DefuncError_ 'Vanilla) -> DefuncHints

@@ -0,0 +1,23 @@+{-# LANGUAGE Safe #-}+{-# OPTIONS_HADDOCK hide #-}+-- Yes, this is redundant, however, it is necessary to get the UNPACK to fire on CaretWidth+{-# OPTIONS_GHC -Wno-redundant-strictness-flags #-}+module Text.Gigaparsec.Internal.Errors.ErrorItem (+    module Text.Gigaparsec.Internal.Errors.ErrorItem+  ) where++import Data.List.NonEmpty (NonEmpty)++import Text.Gigaparsec.Internal.Errors.CaretControl (CaretWidth)++type Input :: *+type Input = NonEmpty Char+type UnexpectItem :: *+data UnexpectItem = UnexpectRaw !Input {-# UNPACK #-} !Word+                  | UnexpectNamed !String {-# UNPACK #-} !CaretWidth+                  | UnexpectEndOfInput+type ExpectItem :: *+data ExpectItem = ExpectRaw !String+                | ExpectNamed !String+                | ExpectEndOfInput+                deriving stock (Eq, Ord, Show)

@@ -0,0 +1,93 @@+{-# LANGUAGE Safe #-}+{-# OPTIONS_HADDOCK hide #-}+{-# OPTIONS_GHC -Wno-partial-fields -Wno-missing-import-lists #-}+module Text.Gigaparsec.Internal.Errors.ParseError (+    module Text.Gigaparsec.Internal.Errors.ParseError+  ) where++import Prelude hiding (lines)++import Data.List.NonEmpty (NonEmpty((:|)), nonEmpty, (<|))+import Data.Set qualified as Set (map, foldr)++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(..))++import Text.Gigaparsec.Internal.Errors.CaretControl+import Text.Gigaparsec.Internal.Errors.ErrorItem++import Data.Set (Set)++type ParseError :: *+data ParseError = VanillaError { presentationOffset :: {-# UNPACK #-} !Word+                               , line :: {-# UNPACK #-} !Word+                               , col :: {-# UNPACK #-} !Word+                               , unexpected :: !(Either Word UnexpectItem)+                               , expecteds :: !(Set ExpectItem)+                               , reasons :: !(Set String)+                               , lexicalError :: !Bool+                               }+                | SpecialisedError { presentationOffset :: {-# UNPACK #-} !Word+                                   , line :: {-# UNPACK #-} !Word+                                   , col :: {-# UNPACK #-} !Word+                                   , msgs :: ![String]+                                   , caretWidth :: {-# UNPACK #-} !Span+                                   }++{-# 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 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

@@ -102,7 +102,7 @@ splitFun' ty                                   = [ty]  -- When KindSignatures is off, the default (a :: *) that TH generates is broken!-#if __GLASGOW_HASKELL__ >= 902+#if __GLASGOW_HASKELL__ >= 900 sanitiseStarT :: TyVarBndr flag -> TyVarBndr flag sanitiseStarT (KindedTV ty flag StarT) = PlainTV ty flag sanitiseStarT ty = ty

@@ -57,7 +57,7 @@ ioParse (Internal.Parsec p) inp = Internal.rtToIO $ p (Internal.emptyState inp) good bad   where good :: a -> Internal.State -> Internal.RT ()         good _ _  = return ()-        bad :: Internal.ParseError -> Internal.State -> Internal.RT ()+        bad :: Internal.Error -> Internal.State -> Internal.RT ()         bad _ _ = return ()  mockDebug :: String -> (DebugConfig -> Parsec a) -> IO String

@@ -101,7 +101,7 @@   , 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+  , 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))   ]@@ -127,7 +127,7 @@   [ 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+  , 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@@ -143,7 +143,7 @@   , 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+  , 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@@ -389,8 +389,7 @@             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+      [ 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))

@@ -130,6 +130,6 @@                                                       . shows col                                                       . showString ", hintsValidOffset = "                                                       . shows hintsValidOffset-                                                      . showString ", hints = "-                                                      . shows hints+                                                      -- . showString ", hints = "+                                                      -- . shows hints                                                       . showChar '}'