Optimise Error System

.github/workflows/ci.yaml

@@ -16,11 +16,13 @@ jobs:
         #   26% 9.4
         #   10% 9.6
         # As such, we'll keep supporting 8.10 as an LTS of sorts for now.
-        ghc: ['8.10', '9.2', '9.4', latest]
+        ghc: ['8.10', '9.2', '9.4', '9.6', latest]
         cabal: ['3.6', latest]
         exclude:
             - ghc: '9.4'
               cabal: '3.6'
+            - ghc: '9.6'
+              cabal: '3.6'
             - ghc: 'latest'
               cabal: '3.6'
     env:
@@ -30,15 +32,15 @@ jobs:
         uses: actions/checkout@v4
 
       - name: Setup Haskell
-        uses: haskell/actions/setup@v2
+        uses: haskell-actions/setup@v2
         with:
           ghc-version: ${{ matrix.ghc }}
           cabal-version: ${{ matrix.cabal }}
 
       - name: Determine Dependencies
         run: |
           cabal update
-          cabal freeze
+          cabal freeze $CONFIG
 
       - name: Check Cache
         uses: actions/cache@v2
@@ -82,7 +84,7 @@ jobs:
       - name: Determine Dependencies
         run: |
           cabal update
-          cabal freeze
+          cabal freeze $CONFIG
 
       - name: Check Cache
         uses: actions/cache@v2

CHANGELOG.md

@@ -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
 

benchmarks/Main.hs

@@ -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 ()

gigaparsec.cabal

@@ -20,7 +20,7 @@ name:               gigaparsec
 -- 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 @@ library
                       -- 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 @@ test-suite gigaparsec-test
         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,

src/Text/Gigaparsec.hs

@@ -86,14 +86,14 @@
 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)
 import Text.Gigaparsec.Errors.ErrorGen (vanillaGen)
 
 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)
@@ -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.

src/Text/Gigaparsec/Char.hs

@@ -50,7 +50,7 @@ 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, 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 :: String        -- ^ the string, @s@, to be parsed from the input
 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'

src/Text/Gigaparsec/Errors/Combinator.hs

@@ -78,13 +78,13 @@ import Text.Gigaparsec.Errors.ErrorGen qualified as ErrorGen
 -- 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 @@ label ls (Internal.Parsec p) =
       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 :: Parsec a -> Parsec a
 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 @@ should be used to prevent @Lexer@-based token extraction from being performed on
 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.

src/Text/Gigaparsec/Errors/ErrorGen.hs

@@ -6,10 +6,10 @@
   ) 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]
                                  , adjustWidth :: a -> Word -> Word
                                  }
                 | VanillaGen { unexpected :: a -> UnexpectedItem
@@ -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

src/Text/Gigaparsec/Internal.hs

@@ -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
 
@@ -55,10 +54,10 @@
 libraries like @parsec@ and @gigaparsec@.
 -}
 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)