gigaparsec 0.2.3.0 → 0.2.4.0

raw patch · 17 files changed

+863/−350 lines, 17 filesPVP ok

version bump matches the API change (PVP)

API changes (from Hackage documentation)

Files

• CHANGELOG.md +4/−0
• gigaparsec.cabal +4/−1
• src/Text/Gigaparsec/Errors/Combinator.hs +11/−1
• src/Text/Gigaparsec/Errors/ErrorGen.hs +1/−1
• src/Text/Gigaparsec/Internal/Errors/DefuncError.hs +5/−3
• src/Text/Gigaparsec/Internal/Token/BitBounds.hs +123/−0
• src/Text/Gigaparsec/Internal/Token/Errors.hs +137/−0
• src/Text/Gigaparsec/Internal/Token/Generic.hs +48/−47
• src/Text/Gigaparsec/Internal/Token/Lexer.hs +34/−27
• src/Text/Gigaparsec/Internal/Token/Names.hs +10/−11
• src/Text/Gigaparsec/Internal/Token/Numeric.hs +83/−167
• src/Text/Gigaparsec/Internal/Token/Symbol.hs +22/−18
• src/Text/Gigaparsec/Internal/Token/Text.hs +81/−71
• src/Text/Gigaparsec/Token/Descriptions.hs +3/−0
• src/Text/Gigaparsec/Token/Errors.hs +292/−0
• src/Text/Gigaparsec/Token/Lexer.hs +3/−3
• test/Text/Gigaparsec/Token/NamesTests.hs +2/−0

@@ -1,5 +1,9 @@ # Revision history for gigaparsec +## 0.2.4.0 -- 2024-02-03+* Added `ErrorConfig` and related types, along with `mkLexerWithErrorConfig`, to now allow+  for custom lexing errors.+ ## 0.2.3.0 -- 2024-01-29 * Added _Verified Errors_ and _Preventative Errors_ in `Text.Gigaparsec.Errors.Patterns`. 

@@ -20,7 +20,7 @@ -- PVP summary:     +-+------- breaking API changes --                  | | +----- non-breaking API additions --                  | | | +--- code changes with no API change-version:            0.2.3.0+version:            0.2.4.0  -- A short (one-line) description of the package. synopsis:@@ -97,6 +97,7 @@                       Text.Gigaparsec.Position,                       Text.Gigaparsec.Registers,                       Text.Gigaparsec.Token.Descriptions,+                      Text.Gigaparsec.Token.Errors,                       Text.Gigaparsec.Token.Lexer,                       Text.Gigaparsec.Token.Patterns, @@ -112,6 +113,8 @@                       Text.Gigaparsec.Internal.Errors.ParseError,                       Text.Gigaparsec.Internal.RT,                       Text.Gigaparsec.Internal.Require,+                      Text.Gigaparsec.Internal.Token.BitBounds,+                      Text.Gigaparsec.Internal.Token.Errors,                       Text.Gigaparsec.Internal.Token.Generic,                       Text.Gigaparsec.Internal.Token.Lexer,                       Text.Gigaparsec.Internal.Token.Names,

@@ -45,7 +45,9 @@     amend, partialAmend, entrench, dislodge, dislodgeBy,     amendThenDislodge, amendThenDislodgeBy, partialAmendThenDislodge, partialAmendThenDislodgeBy,     markAsToken,-    filterSWith, mapMaybeSWith, filterOut, guardAgainst, unexpectedWhen, unexpectedWithReasonWhen+    filterSWith, mapMaybeSWith,+    filterOut, guardAgainst, unexpectedWhen, unexpectedWithReasonWhen,+    mapEitherS   ) where  {-@@ -379,6 +381,7 @@ {- @since 0.2.2.0 -}+-- FIXME: 0.3.0.0 change to NonEmptyList guardAgainst :: (a -> Maybe [String]) -> Parsec a -> Parsec a guardAgainst p =   filterSWith (specializedGen { ErrorGen.messages = fromJust . p }) (isNothing . p)@@ -406,3 +409,10 @@ mapMaybeSWith :: ErrorGen a -> (a -> Maybe b) -> Parsec a -> Parsec b mapMaybeSWith errGen f p = amendThenDislodgeBy 1 $ withWidth (entrench p) >>= \(x, w) ->   maybe (ErrorGen.asErr errGen x w) pure (f x)++{-+@since 0.2.4.0+-}+mapEitherS :: (a -> Either (NonEmpty String) b) -> Parsec a -> Parsec b+mapEitherS f p = amendThenDislodgeBy 1 $ withWidth (entrench p) >>= \(x, w) ->+  either (failWide w) pure (f x)

@@ -9,7 +9,7 @@ import Text.Gigaparsec.Internal.Errors qualified as Internal (Error, CaretWidth(RigidCaret), addReason)  type ErrorGen :: * -> *-data ErrorGen a = SpecializedGen { messages :: a -> [String]+data ErrorGen a = SpecializedGen { messages :: a -> [String] -- FIXME: 0.3.0.0 change to NonEmptyList                                  , adjustWidth :: a -> Word -> Word                                  }                 | VanillaGen { unexpected :: a -> UnexpectedItem

@@ -11,7 +11,7 @@   ) where  import Data.Word (Word32)-import Data.Bits ((.&.), testBit, clearBit, setBit, complement, bit)+import Data.Bits ((.&.), (.|.), testBit, clearBit, setBit, complement, bit) import Data.Set (Set) import Data.Set qualified as Set (null) @@ -91,16 +91,18 @@       EQ -> case k1 of         IsSpecialised -> case k2 of           IsSpecialised ->-            DefuncError IsSpecialised (flags1 .&. flags2) pOff1 uOff1 (Op (Merged errTy1 errTy2))+            DefuncError IsSpecialised (combineFlags 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))+            DefuncError IsVanilla (combineFlags flags1 flags2) pOff1 uOff1 (Op (Merged errTy1 errTy2))           IsSpecialised | isFlexibleCaret err2 ->             DefuncError IsSpecialised flags1 pOff1 uOff1 (Op (AdjustCaret errTy2 errTy1))           _ -> err2+  where combineFlags f1 f2 =+          (f1 .&. f2 .&. complement entrenchedMask) .|. max (f1 .&. entrenchedMask) (f2 .&. entrenchedMask)  withHints :: DefuncHints -> DefuncError -> DefuncError withHints Blank err = err

@@ -0,0 +1,123 @@+{-# LANGUAGE Safe #-}+{-# LANGUAGE DataKinds, ConstraintKinds, MultiParamTypeClasses, AllowAmbiguousTypes, FlexibleInstances, UndecidableInstances, TypeFamilies, TypeOperators, CPP #-}+{-# OPTIONS_GHC -Wno-incomplete-record-updates #-}+{-# OPTIONS_HADDOCK hide #-}+module Text.Gigaparsec.Internal.Token.BitBounds (+    module Text.Gigaparsec.Internal.Token.BitBounds+  ) where++import Data.Kind (Constraint)+import Data.Int (Int8, Int16, Int32, Int64)+import Data.Word (Word8, Word16, Word32, Word64)+import Numeric.Natural (Natural)++#if __GLASGOW_HASKELL__ >= 904++import GHC.TypeLits (type (<=?), Nat)+import GHC.TypeError (TypeError, ErrorMessage(Text, (:<>:), ShowType), Assert)++#else++import GHC.TypeLits (type (<=?), Nat, TypeError, ErrorMessage(Text, (:<>:), ShowType))++type Assert :: Bool -> Constraint -> Constraint+type family Assert b c where+  Assert 'True  _ = ()+  Assert 'False c = c++#endif++type Bits :: *+data Bits = B8 | B16 | B32 | B64++type BitWidth :: * -> Bits+type family BitWidth t where+  BitWidth Integer = 'B64+  BitWidth Int     = 'B64+  BitWidth Word    = 'B64+  BitWidth Word64  = 'B64+  BitWidth Natural = 'B64+  BitWidth Int32   = 'B32+  BitWidth Word32  = 'B32+  BitWidth Int16   = 'B16+  BitWidth Word16  = 'B16+  BitWidth Int8    = 'B8+  BitWidth Word8   = 'B8+  BitWidth t       = TypeError ('Text "The type '" ' :<>: 'ShowType t+                          ':<>: 'Text "' is not a numeric type supported by Gigaparsec")++type SignednessK :: *+data SignednessK = Signed | Unsigned++type Signedness :: * -> SignednessK -> Constraint+type family Signedness t s where+  Signedness Integer _         = () -- integers are allowed to serve as both unsigned and signed+  Signedness Int     'Signed   = ()+  Signedness Word    'Unsigned = ()+  Signedness Word64  'Unsigned = ()+  Signedness Natural 'Unsigned = ()+  Signedness Int32   'Signed   = ()+  Signedness Word32  'Unsigned = ()+  Signedness Int16   'Signed   = ()+  Signedness Word16  'Unsigned = ()+  Signedness Int8    'Signed   = ()+  Signedness Word8   'Unsigned = ()+  Signedness t       'Signed   = TypeError ('Text "The type '" ':<>: 'ShowType t+                                      ':<>: 'Text "' does not hold signed numbers")+  Signedness t       'Unsigned = TypeError ('Text "The type '" ' :<>: 'ShowType t+                                      ':<>: 'Text "' does not hold unsigned numbers")++type ShowBits :: Bits -> ErrorMessage+type ShowBits b = 'ShowType (BitsNat b)++-- This is intentionally not a type alias. On GHC versions < 9.4.1 it appears that TypeErrors are+-- reported slightly more eagerly and we get an error on this definition because+-- > BitsNat b <=? BitsNat (BitWidth t)+-- cannot be solved+type HasWidthFor :: Bits -> * -> Constraint+type family HasWidthFor bits t where+  HasWidthFor bits t = Assert (BitsNat bits <=? BitsNat (BitWidth t))+                              (TypeError ('Text "The type '"+                                    ':<>: 'ShowType t  ' :<>: 'Text "' cannot store a "+                                    ':<>: ShowBits bits ' :<>: 'Text " bit number (only supports up to "+                                    ':<>: ShowBits (BitWidth t) ' :<>: 'Text " bits)."))++type BitBounds :: Bits -> Constraint+class BitBounds b where+  upperSigned :: Integer+  lowerSigned :: Integer+  upperUnsigned :: Integer+  bits :: Bits+  type BitsNat b :: Nat+instance BitBounds 'B8 where+  upperSigned = fromIntegral (maxBound @Int8)+  lowerSigned = fromIntegral (minBound @Int8)+  upperUnsigned = fromIntegral (maxBound @Word8)+  bits = B8+  type BitsNat 'B8 = 8+instance BitBounds 'B16 where+  upperSigned = fromIntegral (maxBound @Int16)+  lowerSigned = fromIntegral (minBound @Int16)+  upperUnsigned = fromIntegral (maxBound @Word16)+  bits = B16+  type BitsNat 'B16 = 16+instance BitBounds 'B32 where+  upperSigned = fromIntegral (maxBound @Int32)+  lowerSigned = fromIntegral (minBound @Int32)+  upperUnsigned = fromIntegral (maxBound @Word32)+  bits = B32+  type BitsNat 'B32 = 32+instance BitBounds 'B64 where+  upperSigned = fromIntegral (maxBound @Int64)+  lowerSigned = fromIntegral (minBound @Int64)+  upperUnsigned = fromIntegral (maxBound @Word64)+  bits = B64+  type BitsNat 'B64 = 64++type CanHoldSigned :: Bits -> * -> Constraint+class (BitBounds bits, Num t) => CanHoldSigned bits t where+instance (BitBounds bits, Num t, Signedness t 'Signed, HasWidthFor bits t) => CanHoldSigned bits t++type CanHoldUnsigned :: Bits -> * -> Constraint+class (BitBounds bits, Num t) => CanHoldUnsigned bits t where+instance (BitBounds bits, Num t, Signedness t 'Unsigned, HasWidthFor bits t) => CanHoldUnsigned bits t

@@ -0,0 +1,137 @@+{-# LANGUAGE Safe #-}+{-# LANGUAGE BlockArguments #-}+{-# OPTIONS_HADDOCK hide #-}+module Text.Gigaparsec.Internal.Token.Errors (module Text.Gigaparsec.Internal.Token.Errors) where++import Text.Gigaparsec (Parsec, empty)+import Text.Gigaparsec qualified as Errors (filterS, mapMaybeS)+import Text.Gigaparsec.Char (satisfy)+import Text.Gigaparsec.Errors.Combinator qualified as Errors (+    label, explain, hide,+    filterOut, guardAgainst, mapEitherS, unexpectedWhen, unexpectedWithReasonWhen+  )+import Text.Gigaparsec.Errors.Patterns (verifiedFail, verifiedExplain)++import Data.Set (Set)+import Data.Map (Map)++import Data.Map qualified as Map (member, (!))+import Data.Kind (Constraint)+import Data.Maybe (isJust, fromJust)+import Data.List.NonEmpty (NonEmpty)+import Data.List.NonEmpty qualified as NonEmpty (toList)++type LabelWithExplainConfig :: *+data LabelWithExplainConfig = LENotConfigured+                            | LELabel !(Set String)+                            | LEReason !String+                            | LEHidden+                            | LELabelAndReason !(Set String) !String++type LabelConfig :: *+data LabelConfig = LNotConfigured+                 | LLabel !(Set String)+                 | LHidden++type ExplainConfig :: *+data ExplainConfig = ENotConfigured+                   | EReason !String++type Annotate :: * -> Constraint+class Annotate config where+  annotate :: config -> Parsec a -> Parsec a++instance Annotate LabelConfig where+  annotate LNotConfigured = id+  annotate (LLabel ls) = Errors.label ls+  annotate LHidden = Errors.hide++instance Annotate ExplainConfig where+  annotate ENotConfigured = id+  annotate (EReason r) = Errors.explain r++instance Annotate LabelWithExplainConfig where+  annotate LENotConfigured = id+  annotate (LELabel ls) = Errors.label ls+  annotate LEHidden = Errors.hide+  annotate (LEReason r) = Errors.explain r+  annotate (LELabelAndReason ls r) = Errors.label ls . Errors.explain r++type FilterConfig :: * -> *+data FilterConfig a = VSBasicFilter+                    | VSSpecializedFilter (a -> NonEmpty String)+                    | VSUnexpected (a -> String)+                    | VSBecause (a -> String)+                    | VSUnexpectedBecause (a -> String) (a -> String)++type VanillaFilterConfig :: * -> *+data VanillaFilterConfig a = VBasicFilter+                           | VUnexpected (a -> String)+                           | VBecause (a -> String)+                           | VUnexpectedBecause (a -> String) (a -> String)++type SpecializedFilterConfig :: * -> *+data SpecializedFilterConfig a = SBasicFilter+                               | SSpecializedFilter (a -> NonEmpty String)++type Filter :: (* -> *) -> Constraint+class Filter config where+  filterS :: config a -> (a -> Bool) -> Parsec a -> Parsec a+  filterS = filterS' id+  mapMaybeS :: config a -> (a -> Maybe b) -> Parsec a -> Parsec b+  mapMaybeS = mapMaybeS' id++  filterS' :: (a -> x) -> config x -> (a -> Bool) -> Parsec a -> Parsec a+  mapMaybeS' :: (a -> x) -> config x -> (a -> Maybe b) -> Parsec a -> Parsec b++instance Filter FilterConfig where+  filterS' _ VSBasicFilter g = Errors.filterS g+  filterS' f (VSSpecializedFilter msgs) g = Errors.guardAgainst (errWhen f (NonEmpty.toList . msgs) g)+  filterS' f (VSBecause reason) g = Errors.filterOut (errWhen f reason g)+  filterS' f (VSUnexpected unex) g = Errors.unexpectedWhen (errWhen f unex g)+  filterS' f (VSUnexpectedBecause unex reason) g =+    Errors.unexpectedWithReasonWhen (errWhen f (\x -> (unex x, reason x)) g)++  mapMaybeS' _ VSBasicFilter g = Errors.mapMaybeS g+  mapMaybeS' f (VSSpecializedFilter msgs) g = Errors.mapEitherS (errMap f msgs g)+  mapMaybeS' f config g = mapMaybeSDefault filterS' f config g++instance Filter VanillaFilterConfig where+  filterS' _ VBasicFilter g = Errors.filterS g+  filterS' f (VBecause reason) g = Errors.filterOut (errWhen f reason g)+  filterS' f (VUnexpected unex) g = Errors.unexpectedWhen (errWhen f unex g)+  filterS' f (VUnexpectedBecause unex reason) g =+    Errors.unexpectedWithReasonWhen (errWhen f (\x -> (unex x, reason x)) g)++  mapMaybeS' _ VBasicFilter g = Errors.mapMaybeS g+  mapMaybeS' f config g = mapMaybeSDefault filterS' f config g++instance Filter SpecializedFilterConfig where+  filterS' _ SBasicFilter g = Errors.filterS g+  filterS' f (SSpecializedFilter msgs) g = Errors.guardAgainst (errWhen f (NonEmpty.toList . msgs) g)++  mapMaybeS' _ SBasicFilter g = Errors.mapMaybeS g+  mapMaybeS' f (SSpecializedFilter msgs) g = Errors.mapEitherS (errMap f msgs g)++errWhen :: (a -> x) -> (x -> e) -> (a -> Bool) -> (a -> Maybe e)+errWhen f g p x+  | p x = Just (g (f x))+  | otherwise = Nothing++errMap :: (a -> x) -> (x -> e) -> (a -> Maybe b) -> (a -> Either e b)+errMap f g p x = maybe (Left (g (f x))) Right (p x)++mapMaybeSDefault :: ((a -> x) -> config x -> (a -> Bool) -> Parsec a -> Parsec a)+                 -> ((a -> x) -> config x -> (a -> Maybe b) -> Parsec a -> Parsec b)+mapMaybeSDefault filt f config g = fmap (fromJust . g) . filt f config (isJust . g)+++type VerifiedBadChars :: *+data VerifiedBadChars = BadCharsFail !(Map Char (NonEmpty String))+                      | BadCharsReason !(Map Char String)+                      | BadCharsUnverified++checkBadChar :: VerifiedBadChars -> Parsec a+checkBadChar (BadCharsFail cs) = verifiedFail (NonEmpty.toList . (cs Map.!)) (satisfy (`Map.member` cs))+checkBadChar (BadCharsReason cs) = verifiedExplain (cs Map.!) (satisfy (`Map.member` cs))+checkBadChar BadCharsUnverified = empty

@@ -14,36 +14,37 @@  import Data.Char (isDigit, isHexDigit, isOctDigit, digitToInt) import Data.List (foldl')+import Text.Gigaparsec.Token.Errors (ErrorConfig (labelNumericBreakChar))+import Text.Gigaparsec.Internal.Token.Errors (annotate, LabelConfig)  type GenericNumeric :: *-data GenericNumeric = Generic { zeroAllowedDecimal :: Parsec Integer-                              , zeroAllowedHexadecimal :: Parsec Integer-                              , zeroAllowedOctal :: Parsec Integer-                              , zeroAllowedBinary :: Parsec Integer-                              , zeroNotAllowedDecimal :: Parsec Integer-                              , zeroNotAllowedHexadecimal :: Parsec Integer-                              , zeroNotAllowedOctal :: Parsec Integer-                              , zeroNotAllowedBinary :: Parsec Integer-                              -- FIXME: labels are configurable here-                              , plainDecimal :: NumericDesc -> Parsec Integer-                              , plainHexadecimal :: NumericDesc -> Parsec Integer-                              , plainOctal :: NumericDesc -> Parsec Integer-                              , plainBinary :: NumericDesc -> Parsec Integer+data GenericNumeric = Generic { zeroAllowedDecimal :: LabelConfig -> Parsec Integer+                              , zeroAllowedHexadecimal :: LabelConfig -> Parsec Integer+                              , zeroAllowedOctal :: LabelConfig -> Parsec Integer+                              , zeroAllowedBinary :: LabelConfig -> Parsec Integer+                              , zeroNotAllowedDecimal :: LabelConfig -> Parsec Integer+                              , zeroNotAllowedHexadecimal :: LabelConfig -> Parsec Integer+                              , zeroNotAllowedOctal :: LabelConfig -> Parsec Integer+                              , zeroNotAllowedBinary :: LabelConfig -> Parsec Integer+                              , plainDecimal :: NumericDesc -> LabelConfig -> Parsec Integer+                              , plainHexadecimal :: NumericDesc -> LabelConfig -> Parsec Integer+                              , plainOctal :: NumericDesc -> LabelConfig -> Parsec Integer+                              , plainBinary :: NumericDesc -> LabelConfig -> Parsec Integer                               } -mkGeneric :: GenericNumeric-mkGeneric = Generic {..}-  where ofRadix1 :: Integer -> Parsec Char -> Parsec Integer+mkGeneric :: ErrorConfig -> GenericNumeric+mkGeneric !err = Generic {..}+  where ofRadix1 :: Integer -> Parsec Char -> LabelConfig -> Parsec Integer         ofRadix1 radix dig = ofRadix2 radix dig dig-        ofRadix2 :: Integer -> Parsec Char -> Parsec Char -> Parsec Integer-        ofRadix2 radix startDig dig =-          foldl' (withDigit radix) 0 <$> (startDig <:> many dig) --TODO: improve+        ofRadix2 :: Integer -> Parsec Char -> Parsec Char -> LabelConfig -> Parsec Integer+        ofRadix2 radix startDig dig label =+          foldl' (withDigit radix) 0 <$> (startDig <:> many (annotate label dig)) --TODO: improve -        ofRadixBreak1 :: Integer -> Parsec Char -> Char -> Parsec Integer+        ofRadixBreak1 :: Integer -> Parsec Char -> Char -> LabelConfig -> Parsec Integer         ofRadixBreak1 radix dig = ofRadixBreak2 radix dig dig-        ofRadixBreak2 :: Integer -> Parsec Char -> Parsec Char -> Char -> Parsec Integer-        ofRadixBreak2 radix startDig dig breakChar =-          foldl' (withDigit radix) 0 <$> (startDig <:> many (optional (char breakChar) *> dig)) --TODO: improve+        ofRadixBreak2 :: Integer -> Parsec Char -> Parsec Char -> Char -> LabelConfig -> Parsec Integer+        ofRadixBreak2 radix startDig dig breakChar label =+          foldl' (withDigit radix) 0 <$> (startDig <:> many (optional (annotate (labelNumericBreakChar err) (annotate label (char breakChar))) *> annotate label dig)) --TODO: improve          nonZeroDigit = satisfy (\c -> isDigit c && c /= '0') <?> ["digit"]         nonZeroHexDigit = satisfy (\c -> isHexDigit c && c /= '0') <?> ["hexadecimal digit"]@@ -58,34 +59,34 @@         zeroAllowedOctal = ofRadix1 8 octDigit         zeroAllowedBinary = ofRadix1 2 bit -        zeroNotAllowedDecimal = ofRadix2 10 nonZeroDigit digit <|> secretZero-        zeroNotAllowedHexadecimal = ofRadix2 16 nonZeroHexDigit hexDigit <|> secretZero-        zeroNotAllowedOctal = ofRadix2 8 nonZeroOctDigit octDigit <|> secretZero-        zeroNotAllowedBinary = ofRadix2 2 nonZeroBit bit <|> secretZero+        zeroNotAllowedDecimal label = ofRadix2 10 nonZeroDigit digit label <|> secretZero+        zeroNotAllowedHexadecimal label = ofRadix2 16 nonZeroHexDigit hexDigit label <|> secretZero+        zeroNotAllowedOctal label = ofRadix2 8 nonZeroOctDigit octDigit label <|> secretZero+        zeroNotAllowedBinary label = ofRadix2 2 nonZeroBit bit label <|> secretZero -        plainDecimal NumericDesc{leadingZerosAllowed, literalBreakChar} = case literalBreakChar of-          NoBreakChar | leadingZerosAllowed            -> zeroAllowedDecimal-          NoBreakChar                                  -> zeroNotAllowedDecimal-          BreakCharSupported c _ | leadingZerosAllowed -> ofRadixBreak1 10 digit c-          BreakCharSupported c _                       -> ofRadixBreak2 10 nonZeroDigit digit c <|> secretZero+        plainDecimal NumericDesc{leadingZerosAllowed, literalBreakChar} label = case literalBreakChar of+          NoBreakChar | leadingZerosAllowed            -> zeroAllowedDecimal label+          NoBreakChar                                  -> zeroNotAllowedDecimal label+          BreakCharSupported c _ | leadingZerosAllowed -> ofRadixBreak1 10 digit c label+          BreakCharSupported c _                       -> ofRadixBreak2 10 nonZeroDigit digit c label <|> secretZero -        plainHexadecimal NumericDesc{leadingZerosAllowed, literalBreakChar} = case literalBreakChar of-          NoBreakChar | leadingZerosAllowed            -> zeroAllowedDecimal-          NoBreakChar                                  -> zeroNotAllowedDecimal-          BreakCharSupported c _ | leadingZerosAllowed -> ofRadixBreak1 16 hexDigit c-          BreakCharSupported c _                       -> ofRadixBreak2 16 nonZeroHexDigit hexDigit c <|> secretZero+        plainHexadecimal NumericDesc{leadingZerosAllowed, literalBreakChar} label = case literalBreakChar of+          NoBreakChar | leadingZerosAllowed            -> zeroAllowedDecimal label+          NoBreakChar                                  -> zeroNotAllowedDecimal label+          BreakCharSupported c _ | leadingZerosAllowed -> ofRadixBreak1 16 hexDigit c label+          BreakCharSupported c _                       -> ofRadixBreak2 16 nonZeroHexDigit hexDigit c label <|> secretZero -        plainOctal NumericDesc{leadingZerosAllowed, literalBreakChar} = case literalBreakChar of-          NoBreakChar | leadingZerosAllowed            -> zeroAllowedDecimal-          NoBreakChar                                  -> zeroNotAllowedDecimal-          BreakCharSupported c _ | leadingZerosAllowed -> ofRadixBreak1 8 octDigit c-          BreakCharSupported c _                       -> ofRadixBreak2 8 nonZeroOctDigit octDigit c <|> secretZero+        plainOctal NumericDesc{leadingZerosAllowed, literalBreakChar} label = case literalBreakChar of+          NoBreakChar | leadingZerosAllowed            -> zeroAllowedDecimal label+          NoBreakChar                                  -> zeroNotAllowedDecimal label+          BreakCharSupported c _ | leadingZerosAllowed -> ofRadixBreak1 8 octDigit c label+          BreakCharSupported c _                       -> ofRadixBreak2 8 nonZeroOctDigit octDigit c label <|> secretZero -        plainBinary NumericDesc{leadingZerosAllowed, literalBreakChar} = case literalBreakChar of-          NoBreakChar | leadingZerosAllowed            -> zeroAllowedDecimal-          NoBreakChar                                  -> zeroNotAllowedDecimal-          BreakCharSupported c _ | leadingZerosAllowed -> ofRadixBreak1 2 bit c-          BreakCharSupported c _                       -> ofRadixBreak2 2 nonZeroBit bit c <|> secretZero+        plainBinary NumericDesc{leadingZerosAllowed, literalBreakChar} label = case literalBreakChar of+          NoBreakChar | leadingZerosAllowed            -> zeroAllowedDecimal label+          NoBreakChar                                  -> zeroNotAllowedDecimal label+          BreakCharSupported c _ | leadingZerosAllowed -> ofRadixBreak1 2 bit c label+          BreakCharSupported c _                       -> ofRadixBreak2 2 nonZeroBit bit c label <|> secretZero  withDigit :: Integer -> Integer -> Char -> Integer withDigit radix n d = n * radix + fromIntegral (digitToInt d)

@@ -1,9 +1,8 @@ {-# LANGUAGE Trustworthy #-}-{-# LANGUAGE OverloadedLists #-} {-# OPTIONS_GHC -Wno-partial-fields #-} {-# OPTIONS_HADDOCK hide #-} module Text.Gigaparsec.Internal.Token.Lexer (-    Lexer, mkLexer,+    Lexer, mkLexer, mkLexerWithErrorConfig,     Lexeme, lexeme, nonlexeme, fully, space,     apply, sym, symbol, names, -- more go here, no numeric and no text     -- Numeric@@ -19,9 +18,14 @@ import Text.Gigaparsec.Char (satisfy, string, item, endOfLine) import Text.Gigaparsec.Combinator (skipMany, skipManyTill) import Text.Gigaparsec.Registers (put, get, localWith, rollback)-import Text.Gigaparsec.Errors.Combinator (hide, (<?>))+import Text.Gigaparsec.Errors.Combinator (hide)  import Text.Gigaparsec.Token.Descriptions qualified as Desc+import Text.Gigaparsec.Token.Errors (+    ErrorConfig (labelSpaceEndOfLineComment, labelSpaceEndOfMultiComment),+    defaultErrorConfig+  )+import Text.Gigaparsec.Internal.Token.Errors (annotate) import Text.Gigaparsec.Internal.Token.Generic (mkGeneric) import Text.Gigaparsec.Internal.Token.Symbol (Symbol, mkSym, mkSymbol) import Text.Gigaparsec.Internal.Token.Symbol qualified as Symbol (lexeme)@@ -31,8 +35,8 @@     IntegerParsers, mkSigned, mkUnsigned,     --FloatingParsers, mkSignedFloating, mkUnsignedFloating,     --CombinedParsers, mkSignedCombined, mkUnsignedCombined,-    CanHoldSigned, CanHoldUnsigned   )+import Text.Gigaparsec.Internal.Token.BitBounds (CanHoldSigned, CanHoldUnsigned) import Text.Gigaparsec.Internal.Token.Numeric qualified as Numeric (lexemeInteger, {-lexemeFloating, lexemeCombined-}) import Text.Gigaparsec.Internal.Token.Text (     TextParsers,@@ -57,9 +61,12 @@                    }  mkLexer :: Desc.LexicalDesc -> Lexer-mkLexer Desc.LexicalDesc{..} = Lexer {..}+mkLexer !desc = mkLexerWithErrorConfig desc defaultErrorConfig++mkLexerWithErrorConfig :: Desc.LexicalDesc -> ErrorConfig -> Lexer+mkLexerWithErrorConfig Desc.LexicalDesc{..} !errConfig = Lexer {..}   where apply p = p <* whiteSpace space-        gen = mkGeneric+        gen = mkGeneric errConfig         lexeme = Lexeme { apply = apply                         , sym = apply . sym nonlexeme                         , symbol = Symbol.lexeme apply (symbol nonlexeme)@@ -77,32 +84,32 @@                         , rawMultiStringLiteral = Text.lexeme apply (rawMultiStringLiteral nonlexeme)                         , charLiteral = Text.lexeme apply (charLiteral nonlexeme)                         }-        nonlexeme = NonLexeme { sym = mkSym symbolDesc (symbol nonlexeme)-                              , symbol = mkSymbol symbolDesc nameDesc-                              , names = mkNames nameDesc symbolDesc-                              , natural = mkUnsigned numericDesc gen-                              , integer = mkSigned numericDesc (natural nonlexeme)+        nonlexeme = NonLexeme { sym = mkSym symbolDesc (symbol nonlexeme) errConfig+                              , symbol = mkSymbol symbolDesc nameDesc errConfig+                              , names = mkNames nameDesc symbolDesc errConfig+                              , natural = mkUnsigned numericDesc gen errConfig+                              , integer = mkSigned numericDesc (natural nonlexeme) errConfig                               {-, floating = mkSignedFloating numericDesc positiveFloating                               , unsignedCombined = mkUnsignedCombined numericDesc (natural nonlexeme) positiveFloating                               , signedCombined = mkSignedCombined numericDesc (unsignedCombined nonlexeme)-}-                              , stringLiteral = mkStringParsers stringEnds escapeChar graphicCharacter False-                              , rawStringLiteral = mkStringParsers stringEnds rawChar graphicCharacter False-                              , multiStringLiteral = mkStringParsers multiStringEnds escapeChar graphicCharacter True-                              , rawMultiStringLiteral = mkStringParsers multiStringEnds rawChar graphicCharacter True-                              , charLiteral = mkCharacterParsers textDesc escape+                              , stringLiteral = mkStringParsers stringEnds escapeChar graphicCharacter False errConfig+                              , rawStringLiteral = mkStringParsers stringEnds rawChar graphicCharacter False errConfig+                              , multiStringLiteral = mkStringParsers multiStringEnds escapeChar graphicCharacter True errConfig+                              , rawMultiStringLiteral = mkStringParsers multiStringEnds rawChar graphicCharacter True errConfig+                              , charLiteral = mkCharacterParsers textDesc escape errConfig                               }         --positiveFloating = mkUnsignedFloating numericDesc (natural nonlexeme) gen-        !escape = mkEscape (Desc.escapeSequences textDesc) mkGeneric -- this is mkGeneric because of errors+        !escape = mkEscape (Desc.escapeSequences textDesc) gen errConfig         graphicCharacter = Desc.graphicCharacter textDesc         stringEnds = Desc.stringEnds textDesc         multiStringEnds = Desc.multiStringEnds textDesc         rawChar = RawChar-        escapeChar = mkEscapeChar (Desc.escapeSequences textDesc) escape (whiteSpace space)+        escapeChar = mkEscapeChar (Desc.escapeSequences textDesc) escape (whiteSpace space) errConfig         fully' p = whiteSpace space *> p <* eof         fully p           | Desc.whitespaceIsContextDependent spaceDesc = initSpace space *> fully' p           | otherwise                                   = fully' p-        space = mkSpace spaceDesc+        space = mkSpace spaceDesc errConfig  --TODO: better name for this, I guess? type Lexeme :: *@@ -147,20 +154,20 @@                    , initSpace :: Parsec ()                    } -mkSpace :: Desc.SpaceDesc -> Space-mkSpace desc@Desc.SpaceDesc{..} = Space {..}+mkSpace :: Desc.SpaceDesc -> ErrorConfig -> Space+mkSpace desc@Desc.SpaceDesc{..} !errConfig = Space {..}   where -- don't think we can trust doing initialisation here, it'll happen in some random order         {-# NOINLINE wsImpl #-}         !wsImpl = fromIORef (unsafePerformIO (newIORef (error "uninitialised space")))         comment = commentParser desc -- do not make this strict         implOf-          | supportsComments desc = hide . maybe skipComments (skipMany . (<|> comment) . void . satisfy)+          | supportsComments desc = hide . maybe skipComments (skipMany . (<|> comment errConfig) . void . satisfy)           | otherwise             = hide . maybe empty (skipMany . satisfy)         !configuredWhitespace = implOf space         !whiteSpace           | whitespaceIsContextDependent = join (get wsImpl)           | otherwise                    = configuredWhitespace-        !skipComments = skipMany comment+        !skipComments = skipMany (comment errConfig)         alter p           | whitespaceIsContextDependent = rollback wsImpl . localWith wsImpl (implOf p)           | otherwise                    = throw (UnsupportedOperation badAlter)@@ -178,15 +185,15 @@ -- TODO: needs error messages put in (is the hide correct) -- TODO: remove guard, configure properly -}-commentParser :: Desc.SpaceDesc -> Parsec ()-commentParser Desc.SpaceDesc{..} =+commentParser :: Desc.SpaceDesc -> ErrorConfig -> Parsec ()+commentParser Desc.SpaceDesc{..} !errConfig =   require (multiEnabled || singleEnabled) "skipComments" noComments $     require (not (multiEnabled && isPrefixOf multiLineCommentStart lineCommentStart)) "skipComments" noOverlap $       hide (multiLine <|> singleLine)   where     -- can't make these strict until guard is gone     openComment = atomic (string multiLineCommentStart)-    closeComment = atomic (string multiLineCommentEnd) <?> ["end of comment"]+    closeComment = annotate (labelSpaceEndOfMultiComment errConfig) (atomic (string multiLineCommentEnd))     multiLine = guard multiEnabled *> openComment *> wellNested 1     wellNested :: Int -> Parsec ()     wellNested 0 = unit@@ -195,7 +202,7 @@                <|> item *> wellNested n     singleLine = guard singleEnabled               *> atomic (string lineCommentStart)-              *> skipManyTill item (endOfLineComment <?> ["end of comment"])+              *> skipManyTill item (annotate (labelSpaceEndOfLineComment errConfig) endOfLineComment)      endOfLineComment       | lineCommentAllowsEOF = void endOfLine <|> eof

@@ -21,6 +21,10 @@     CharPredicate   ) import Data.Char (toLower)+import Text.Gigaparsec.Token.Errors (+    ErrorConfig (labelNameIdentifier, unexpectedNameIllegalIdentifier, labelNameOperator, unexpectedNameIllegalOperator, filterNameIllFormedIdentifier, filterNameIllFormedOperator)+  )+import Text.Gigaparsec.Internal.Token.Errors (filterS)  -- TODO: primes are gross, better way? type Names :: *@@ -30,21 +34,16 @@                    , userDefinedOperator' :: !(CharPredicate -> Parsec String)                    } -mkNames :: NameDesc -> SymbolDesc -> Names-mkNames NameDesc{..} symbolDesc@SymbolDesc{..} = Names {..}+mkNames :: NameDesc -> SymbolDesc -> ErrorConfig -> Names+mkNames NameDesc{..} symbolDesc@SymbolDesc{..} err = Names {..}   where-    -- TODO: error transformers     !isReserved = isReservedName symbolDesc     !identifier =-      keyOrOp identifierStart identifierLetter isReserved "identifier" ("keyword " ++)-    identifier' start =-      unexpectedWhen (\v -> if startsWith start v then Nothing else Just ("identifier " ++ v))-                     identifier+      keyOrOp identifierStart identifierLetter isReserved (labelNameIdentifier err) (unexpectedNameIllegalIdentifier err)+    identifier' start = filterS (filterNameIllFormedIdentifier err) (startsWith start) identifier     !userDefinedOperator =-      keyOrOp operatorStart operatorLetter (flip Set.member hardOperators) "operator" ("reserved operator " ++)-    userDefinedOperator' start =-      unexpectedWhen (\v -> if startsWith start v then Nothing else Just ("operator " ++ v))-                     userDefinedOperator+      keyOrOp operatorStart operatorLetter (flip Set.member hardOperators) (labelNameOperator err) (unexpectedNameIllegalOperator err)+    userDefinedOperator' start = filterS (filterNameIllFormedOperator err) (startsWith start) userDefinedOperator      keyOrOp :: CharPredicate -> CharPredicate -> (String -> Bool) -> String -> (String -> String) -> Parsec String     keyOrOp start letter illegal name unexpectedIllegal =

@@ -1,5 +1,5 @@ {-# LANGUAGE Safe #-}-{-# LANGUAGE DataKinds, ConstraintKinds, MultiParamTypeClasses, AllowAmbiguousTypes, FlexibleInstances, FlexibleContexts, UndecidableInstances, ApplicativeDo, TypeFamilies, TypeOperators, CPP #-}+{-# LANGUAGE DataKinds, ConstraintKinds, AllowAmbiguousTypes, KindSignatures, MonoLocalBinds #-} {-# OPTIONS_GHC -Wno-incomplete-record-updates #-} {-# OPTIONS_HADDOCK hide #-} module Text.Gigaparsec.Internal.Token.Numeric (module Text.Gigaparsec.Internal.Token.Numeric) where@@ -7,8 +7,6 @@ import Text.Gigaparsec (Parsec, unit, void, atomic, (<|>), ($>)) import Text.Gigaparsec.Char (char, oneOf) import Text.Gigaparsec.Combinator (optional, optionalAs)-import Text.Gigaparsec.Errors.Combinator (mapMaybeSWith)-import Text.Gigaparsec.Errors.ErrorGen (specializedGen, messages) import Text.Gigaparsec.Token.Descriptions     ( BreakCharDesc(BreakCharSupported, NoBreakChar),       NumericDesc( NumericDesc, positiveSign, literalBreakChar@@ -17,150 +15,66 @@                  , hexadecimalLeads, octalLeads, binaryLeads                  ),       PlusSignPresence(PlusIllegal, PlusRequired, PlusOptional) )-import Text.Gigaparsec.Internal.Token.Generic (GenericNumeric(plainDecimal, plainHexadecimal, plainOctal, plainBinary))-import Data.Char (intToDigit)+import Text.Gigaparsec.Internal.Token.Generic (+    GenericNumeric(plainDecimal, plainHexadecimal, plainOctal, plainBinary)+  )+import Text.Gigaparsec.Internal.Token.BitBounds (+    CanHoldUnsigned, CanHoldSigned,+    BitBounds(upperSigned, upperUnsigned, lowerSigned),+    Bits(B8, B16, B32, B64), bits+  )+import Text.Gigaparsec.Token.Errors (+    ErrorConfig (filterIntegerOutOfBounds, labelIntegerSignedDecimal, labelIntegerUnsignedDecimal,+                 labelIntegerSignedHexadecimal, labelIntegerUnsignedHexadecimal,+                 labelIntegerSignedOctal, labelIntegerUnsignedOctal, labelIntegerSignedBinary,+                 labelIntegerUnsignedBinary, labelIntegerSignedNumber, labelIntegerUnsignedNumber,+                 labelIntegerDecimalEnd, labelIntegerHexadecimalEnd, labelIntegerOctalEnd,+                 labelIntegerBinaryEnd, labelIntegerNumberEnd)+  ) import Data.Kind (Constraint)-import Data.Int (Int8, Int16, Int32, Int64)-import Data.Word (Word8, Word16, Word32, Word64)-import Numeric.Natural (Natural) import Data.Proxy (Proxy(Proxy)) import Control.Monad (when, unless)-import Numeric (showIntAtBase)--#if __GLASGOW_HASKELL__ >= 904--import GHC.TypeLits (type (<=?), Nat)-import GHC.TypeError (TypeError, ErrorMessage(Text, (:<>:), ShowType), Assert)--#else--import GHC.TypeLits (type (<=?), Nat, TypeError, ErrorMessage(Text, (:<>:), ShowType))--type Assert :: Bool -> Constraint -> Constraint-type family Assert b c where-  Assert 'True  _ = ()-  Assert 'False c = c--#endif--type Bits :: *-data Bits = B8 | B16 | B32 | B64--type BitWidth :: * -> Bits-type family BitWidth t where-  BitWidth Integer = 'B64-  BitWidth Int     = 'B64-  BitWidth Word    = 'B64-  BitWidth Word64  = 'B64-  BitWidth Natural = 'B64-  BitWidth Int32   = 'B32-  BitWidth Word32  = 'B32-  BitWidth Int16   = 'B16-  BitWidth Word16  = 'B16-  BitWidth Int8    = 'B8-  BitWidth Word8   = 'B8-  BitWidth t       = TypeError ('Text "The type '" ' :<>: 'ShowType t-                          ':<>: 'Text "' is not a numeric type supported by Gigaparsec")--type SignednessK :: *-data SignednessK = Signed | Unsigned--type Signedness :: * -> SignednessK -> Constraint-type family Signedness t s where-  Signedness Integer _         = () -- integers are allowed to serve as both unsigned and signed-  Signedness Int     'Signed   = ()-  Signedness Word    'Unsigned = ()-  Signedness Word64  'Unsigned = ()-  Signedness Natural 'Unsigned = ()-  Signedness Int32   'Signed   = ()-  Signedness Word32  'Unsigned = ()-  Signedness Int16   'Signed   = ()-  Signedness Word16  'Unsigned = ()-  Signedness Int8    'Signed   = ()-  Signedness Word8   'Unsigned = ()-  Signedness t       'Signed   = TypeError ('Text "The type '" ':<>: 'ShowType t-                                      ':<>: 'Text "' does not hold signed numbers")-  Signedness t       'Unsigned = TypeError ('Text "The type '" ' :<>: 'ShowType t-                                      ':<>: 'Text "' does not hold unsigned numbers")--type ShowBits :: Bits -> ErrorMessage-type ShowBits b = 'ShowType (BitsNat b)---- This is intentionally not a type alias. On GHC versions < 9.4.1 it appears that TypeErrors are--- reported slightly more eagerly and we get an error on this definition because--- > BitsNat b <=? BitsNat (BitWidth t)--- cannot be solved-type HasWidthFor :: Bits -> * -> Constraint-type family HasWidthFor bits t where-  HasWidthFor bits t = Assert (BitsNat bits <=? BitsNat (BitWidth t))-                              (TypeError ('Text "The type '"-                                    ':<>: 'ShowType t  ' :<>: 'Text "' cannot store a "-                                    ':<>: ShowBits bits ' :<>: 'Text " bit number (only supports up to "-                                    ':<>: ShowBits (BitWidth t) ' :<>: 'Text " bits)."))--type BitBounds :: Bits -> Constraint-class BitBounds b where-  upperSigned :: Integer-  lowerSigned :: Integer-  upperUnsigned :: Integer-  bits :: Int-  type BitsNat b :: Nat-instance BitBounds 'B8 where-  upperSigned = fromIntegral (maxBound @Int8)-  lowerSigned = fromIntegral (minBound @Int8)-  upperUnsigned = fromIntegral (maxBound @Word8)-  bits = 8-  type BitsNat 'B8 = 8-instance BitBounds 'B16 where-  upperSigned = fromIntegral (maxBound @Int16)-  lowerSigned = fromIntegral (minBound @Int16)-  upperUnsigned = fromIntegral (maxBound @Word16)-  bits = 16-  type BitsNat 'B16 = 16-instance BitBounds 'B32 where-  upperSigned = fromIntegral (maxBound @Int32)-  lowerSigned = fromIntegral (minBound @Int32)-  upperUnsigned = fromIntegral (maxBound @Word32)-  bits = 32-  type BitsNat 'B32 = 32-instance BitBounds 'B64 where-  upperSigned = fromIntegral (maxBound @Int64)-  lowerSigned = fromIntegral (minBound @Int64)-  upperUnsigned = fromIntegral (maxBound @Word64)-  bits = 64-  type BitsNat 'B64 = 64--type CanHoldSigned :: Bits -> * -> Constraint-class (BitBounds bits, Num t) => CanHoldSigned bits t where-instance (BitBounds bits, Num t, Signedness t 'Signed, HasWidthFor bits t) => CanHoldSigned bits t--type CanHoldUnsigned :: Bits -> * -> Constraint-class (BitBounds bits, Num t) => CanHoldUnsigned bits t where-instance (BitBounds bits, Num t, Signedness t 'Unsigned, HasWidthFor bits t) => CanHoldUnsigned bits t+import Text.Gigaparsec.Internal.Token.Errors (mapMaybeS, LabelWithExplainConfig, annotate) +-- TODO: switch to private versions in future type IntegerParsers :: (Bits -> * -> Constraint) -> * data IntegerParsers canHold = IntegerParsers { decimal :: Parsec Integer                                              , hexadecimal :: Parsec Integer                                              , octal :: Parsec Integer                                              , binary :: Parsec Integer                                              , number :: Parsec Integer-                                             , _bounded :: forall (bits :: Bits) t. canHold bits t => Proxy bits -> Parsec Integer -> Int -> Parsec t+                                             , _bounded :: forall (bits :: Bits) t. canHold bits t+                                                        => Proxy bits+                                                        -> Parsec Integer+                                                        -> Int+                                                        -> (ErrorConfig -> Bool -> Maybe Bits -> LabelWithExplainConfig)+                                                        -> Parsec t                                              }  decimalBounded :: forall (bits :: Bits) canHold t. canHold bits t => IntegerParsers canHold -> Parsec t-decimalBounded IntegerParsers{..} = _bounded (Proxy @bits) decimal 10+decimalBounded IntegerParsers{..} = _bounded (Proxy @bits) decimal 10 label+  where label !err True = labelIntegerSignedDecimal err+        label err False = labelIntegerUnsignedDecimal err  hexadecimalBounded :: forall (bits :: Bits) canHold t. canHold bits t => IntegerParsers canHold -> Parsec t-hexadecimalBounded IntegerParsers{..} = _bounded (Proxy @bits) hexadecimal 16+hexadecimalBounded IntegerParsers{..} = _bounded (Proxy @bits) hexadecimal 16 label+  where label !err True = labelIntegerSignedHexadecimal err+        label err False = labelIntegerUnsignedHexadecimal err  octalBounded :: forall (bits :: Bits) canHold t. canHold bits t => IntegerParsers canHold -> Parsec t-octalBounded IntegerParsers{..} = _bounded (Proxy @bits) octal 8+octalBounded IntegerParsers{..} = _bounded (Proxy @bits) octal 8 label+  where label !err True  = labelIntegerSignedOctal err+        label err False = labelIntegerUnsignedOctal err  binaryBounded :: forall (bits :: Bits) canHold t. canHold bits t => IntegerParsers canHold -> Parsec t-binaryBounded IntegerParsers{..} = _bounded (Proxy @bits) binary 2+binaryBounded IntegerParsers{..} = _bounded (Proxy @bits) binary 2 label+  where label !err True = labelIntegerSignedBinary err+        label err False = labelIntegerUnsignedBinary err  numberBounded :: forall (bits :: Bits) canHold t. canHold bits t => IntegerParsers canHold -> Parsec t-numberBounded IntegerParsers{..} = _bounded (Proxy @bits) number 10+numberBounded IntegerParsers{..} = _bounded (Proxy @bits) number 10 label+  where label !err True = labelIntegerSignedNumber err+        label err False = labelIntegerUnsignedNumber err  decimal8 :: forall a canHold. canHold 'B8 a => IntegerParsers canHold -> Parsec a decimal8 = decimalBounded @'B8@@ -206,22 +120,16 @@ number64 :: forall a canHold. canHold 'B64 a => IntegerParsers canHold -> Parsec a number64 = numberBounded @'B64 -outOfBounds :: Integer -> Integer -> Int -> Integer -> [String]-outOfBounds small big radix _n = [-    "literal is not within the range " ++ resign small (" to " ++ resign big "")-  ]-  where resign n-          | n < 0 = ('-' :) . showIntAtBase (toInteger radix) intToDigit (abs n)-          | otherwise = showIntAtBase (toInteger radix) intToDigit n--mkUnsigned :: NumericDesc -> GenericNumeric -> IntegerParsers CanHoldUnsigned-mkUnsigned desc@NumericDesc{..} gen = IntegerParsers {..}-  where _bounded :: forall (bits :: Bits) t. CanHoldUnsigned bits t-                 => Proxy bits -> Parsec Integer -> Int -> Parsec t-        _bounded _ num radix = mapMaybeSWith-          (specializedGen { messages = outOfBounds 0 (upperUnsigned @bits) radix })-          (\n -> if n >= 0 && n <= upperUnsigned @bits then Just (fromInteger n) else Nothing)-          num+mkUnsigned :: NumericDesc -> GenericNumeric -> ErrorConfig -> IntegerParsers CanHoldUnsigned+mkUnsigned desc@NumericDesc{..} !gen !err = IntegerParsers {..}+  where _bounded :: forall (b :: Bits) t. CanHoldUnsigned b t+                 => Proxy b -> Parsec Integer -> Int+                 -> (ErrorConfig -> Bool -> Maybe Bits -> LabelWithExplainConfig)+                 -> Parsec t+        _bounded _ num radix label = annotate (label err False (Just (bits @b))) $+          mapMaybeS (filterIntegerOutOfBounds err 0 (upperUnsigned @b) radix)+                    (\n -> if n >= 0 && n <= upperUnsigned @b then Just (fromInteger n) else Nothing)+                    num          leadingBreakChar = case literalBreakChar of           NoBreakChar -> unit@@ -231,27 +139,28 @@         noZeroHexadecimal = do           unless (null hexadecimalLeads) (void (oneOf hexadecimalLeads))           leadingBreakChar-          plainHexadecimal gen desc+          annotate (labelIntegerHexadecimalEnd err) (plainHexadecimal gen desc (labelIntegerHexadecimalEnd err))          noZeroOctal = do           unless (null octalLeads) (void (oneOf octalLeads))           leadingBreakChar-          plainOctal gen desc+          annotate (labelIntegerOctalEnd err) (plainOctal gen desc (labelIntegerOctalEnd err))          noZeroBinary = do           unless (null binaryLeads) (void (oneOf binaryLeads))           leadingBreakChar-          plainBinary gen desc+          annotate (labelIntegerBinaryEnd err) (plainBinary gen desc (labelIntegerBinaryEnd err)) -        decimal = plainDecimal gen desc-        hexadecimal = atomic (char '0' *> noZeroHexadecimal)-        octal = atomic (char '0' *> noZeroOctal)-        binary = atomic (char '0' *> noZeroBinary)+        decimal = annotate (labelIntegerUnsignedDecimal err Nothing) $ plainDecimal gen desc (labelIntegerDecimalEnd err)+        hexadecimal = annotate (labelIntegerUnsignedHexadecimal err Nothing) $ atomic (char '0' *> noZeroHexadecimal)+        octal = annotate (labelIntegerUnsignedOctal err Nothing) $ atomic (char '0' *> noZeroOctal)+        binary = annotate (labelIntegerUnsignedBinary err Nothing) $ atomic (char '0' *> noZeroBinary)+        -- FIXME: numberEnd label is not applied here!         number           | not integerNumbersCanBeBinary           , not integerNumbersCanBeHexadecimal-          , not integerNumbersCanBeOctal = decimal-          | otherwise = atomic (zeroLead <|> decimal)+          , not integerNumbersCanBeOctal = annotate (labelIntegerUnsignedNumber err Nothing) decimal+          | otherwise = annotate (labelIntegerUnsignedNumber err Nothing) $ atomic (zeroLead <|> decimal)           where zeroLead = char '0' *> addHex (addOct (addBin (decimal <|> pure 0)))                 addHex                   | integerNumbersCanBeHexadecimal = (noZeroHexadecimal <|>)@@ -263,8 +172,8 @@                   | integerNumbersCanBeBinary = (noZeroBinary <|>)                   | otherwise = id -mkSigned :: NumericDesc -> IntegerParsers c -> IntegerParsers CanHoldSigned-mkSigned NumericDesc{..} unsigned = IntegerParsers {+mkSigned :: NumericDesc -> IntegerParsers c -> ErrorConfig -> IntegerParsers CanHoldSigned+mkSigned NumericDesc{..} !unsigned !err = IntegerParsers {     decimal = _decimal,     hexadecimal = _hexadecimal,     octal = _octal,@@ -272,25 +181,32 @@     number = _number,     ..   }-  where _bounded :: forall (bits :: Bits) t. CanHoldSigned bits t-                 => Proxy bits -> Parsec Integer -> Int -> Parsec t-        _bounded _ num radix = mapMaybeSWith-          (specializedGen { messages = outOfBounds (lowerSigned @bits) (upperSigned @bits) radix })-          (\n -> if n >= lowerSigned @bits && n <= upperSigned @bits-                 then Just (fromInteger n)-                 else Nothing)-          num+  where _bounded :: forall (b :: Bits) t. CanHoldSigned b t+                 => Proxy b -> Parsec Integer -> Int+                 -> (ErrorConfig -> Bool -> Maybe Bits -> LabelWithExplainConfig)+                 -> Parsec t+        _bounded _ num radix label = annotate (label err True (Just (bits @b))) $+          mapMaybeS (filterIntegerOutOfBounds err (lowerSigned @b) (upperSigned @b) radix)+                    (\n -> if n >= lowerSigned @b && n <= upperSigned @b+                           then Just (fromInteger n)+                           else Nothing)+                    num          sign :: Parsec (Integer -> Integer)         sign = case positiveSign of           PlusRequired -> char '+' $> id <|> char '-' $> negate           PlusOptional -> char '-' $> negate <|> optionalAs id (char '+')           PlusIllegal  -> pure id-        _decimal = atomic (sign <*> decimal unsigned)-        _hexadecimal = atomic (sign <*> hexadecimal unsigned)-        _octal = atomic (sign <*> octal unsigned)-        _binary = atomic (sign <*> binary unsigned)-        _number = atomic (sign <*> number unsigned)+        _decimal = annotate (labelIntegerSignedDecimal err Nothing) $+          atomic (sign <*> annotate (labelIntegerDecimalEnd err) (decimal unsigned))+        _hexadecimal = annotate (labelIntegerSignedHexadecimal err Nothing) $+          atomic (sign <*> annotate (labelIntegerHexadecimalEnd err) (hexadecimal unsigned))+        _octal = annotate (labelIntegerSignedOctal err Nothing) $+          atomic (sign <*> annotate (labelIntegerOctalEnd err) (octal unsigned))+        _binary = annotate (labelIntegerSignedBinary err Nothing) $+          atomic (sign <*> annotate (labelIntegerBinaryEnd err) (binary unsigned))+        _number = annotate (labelIntegerSignedNumber err Nothing) $+          atomic (sign <*> annotate (labelIntegerNumberEnd err) (number unsigned))  {-type FloatingParsers :: * data FloatingParsers = FloatingParsers {}@@ -317,7 +233,7 @@     octal = lexe octal,     binary = lexe binary,     number = lexe number,-    _bounded = \n b radix -> lexe (_bounded n b radix)+    _bounded = \n b radix label -> lexe (_bounded n b radix label)   }  {-lexemeFloating :: (forall a. Parsec a -> Parsec a) -> FloatingParsers -> FloatingParsers

@@ -14,40 +14,44 @@  import Data.Set qualified as Set (member, toList, fromList, null) import Data.Char (toUpper, toLower, isLetter)-import Text.Gigaparsec.Errors.Combinator (amend, emptyWide, (<?>))+import Text.Gigaparsec.Errors.Combinator (amend, emptyWide, (<?>), label) import Data.Set (Set)+import Data.Map qualified as Map (findWithDefault) import Data.Maybe (mapMaybe) import Text.Gigaparsec.Internal.Require (require)+import Text.Gigaparsec.Token.Errors (ErrorConfig (labelSymbolEndOfKeyword, labelSymbolEndOfOperator, labelSymbol), notConfigured)+import Text.Gigaparsec.Internal.Token.Errors (annotate)  type Symbol :: * data Symbol = Symbol { softKeyword :: !(String -> Parsec ())                      , softOperator :: !(String -> Parsec ())                      } -mkSymbol :: SymbolDesc -> NameDesc -> Symbol-mkSymbol SymbolDesc{..} NameDesc{..} = Symbol {..}+mkSymbol :: SymbolDesc -> NameDesc -> ErrorConfig -> Symbol+mkSymbol SymbolDesc{..} NameDesc{..} err = Symbol {..}   where softKeyword name = require (not (null name)) "softKeyword" "keywords may not be empty"-          (_softKeyword caseSensitive identifierLetter name <?> [name])+          (_softKeyword caseSensitive identifierLetter name err <?> [name])         softOperator name = require (not (null name)) "softOperator" "operators may not be empty"-          (_softOperator hardOperators operatorLetter name <?> [name])+          (_softOperator hardOperators operatorLetter name err <?> [name]) -mkSym :: SymbolDesc -> Symbol -> (String -> Parsec ())-mkSym SymbolDesc{..} Symbol{..} str-  | Set.member str hardKeywords  = softKeyword str-  | Set.member str hardOperators = softOperator str-  | otherwise                    = void (atomic (string str))+mkSym :: SymbolDesc -> Symbol -> ErrorConfig -> (String -> Parsec ())+mkSym SymbolDesc{..} Symbol{..} err str =+  annotate (Map.findWithDefault notConfigured str (labelSymbol err)) $+    if | Set.member str hardKeywords  -> softKeyword str+       | Set.member str hardOperators -> softOperator str+       | otherwise                    -> void (atomic (string str))  lexeme :: (forall a. Parsec a -> Parsec a) -> Symbol -> Symbol lexeme lexe Symbol{..} = Symbol { softKeyword = lexe . softKeyword                                 , softOperator = lexe . softOperator                                 } -_softKeyword :: Bool -> CharPredicate -> String -> Parsec ()-_softKeyword caseSensitive letter kw-  | not caseSensitive = atomic (nfb letter caseString)-  | otherwise         = atomic (nfb letter (string kw))+_softKeyword :: Bool -> CharPredicate -> String -> ErrorConfig -> Parsec ()+_softKeyword caseSensitive letter kw err+  | not caseSensitive = atomic (nfb letter caseString) <?> [kw]+  | otherwise         = atomic (nfb letter (string kw)) <?> [kw]   where nfb Nothing p = void p-        nfb (Just c) p = p *> (notFollowedBy (satisfy c) <?> ["end of " ++ kw])+        nfb (Just c) p = p *> (notFollowedBy (satisfy c) <?> [labelSymbolEndOfKeyword err kw])         n = length kw         caseChar c           | isLetter c = char (toUpper c) <|> char (toLower c)@@ -56,10 +60,10 @@                  <|> emptyWide (fromIntegral n)  -- TODO: trie-based implementation-_softOperator :: Set String -> CharPredicate -> String -> Parsec ()-_softOperator hardOperators letter op =+_softOperator :: Set String -> CharPredicate -> String -> ErrorConfig -> Parsec ()+_softOperator hardOperators letter op err = label [op] $   if Set.null ends then atomic (string op *> notFollowedBy letter')-  else atomic (string op *> (notFollowedBy (void letter' <|> void (strings ends)) <?> ["end of " ++ op]))+  else atomic (string op *> (notFollowedBy (void letter' <|> void (strings ends)) <?> [labelSymbolEndOfOperator err op]))   where ends = Set.fromList (mapMaybe (flip strip op) (Set.toList hardOperators))         letter' = maybe empty satisfy letter         strip []      str@(:){}          = Just str

@@ -14,21 +14,36 @@     CharPredicate,     NumberOfDigits(Exactly, AtMost, Unbounded)   )-import Text.Gigaparsec.Internal.Token.Generic (GenericNumeric(zeroAllowedDecimal, zeroAllowedHexadecimal, zeroAllowedOctal, zeroAllowedBinary))-import Data.Char (isSpace, chr, ord, digitToInt, isAscii, isLatin1, intToDigit)+import Text.Gigaparsec.Token.Errors (+    ErrorConfig(verifiedCharBadCharsUsedInLiteral, verifiedStringBadCharsUsedInLiteral,+                filterCharNonAscii, filterCharNonLatin1,+                labelCharAscii, labelCharAsciiEnd, labelCharLatin1, labelCharLatin1End,+                labelCharUnicodeEnd, labelCharUnicode,+                labelGraphicCharacter, labelStringCharacter,+                filterStringNonAscii, filterStringNonLatin1,+                labelEscapeEnd, labelEscapeSequence, filterEscapeCharNumericSequenceIllegal,+                filterEscapeCharRequiresExactDigits, labelEscapeNumericEnd, labelEscapeNumeric,+                labelStringEscapeGap, labelStringEscapeGapEnd, labelStringEscapeEmpty,+                labelStringAscii, labelStringAsciiEnd, labelStringLatin1, labelStringLatin1End,+                labelStringUnicode, labelStringUnicodeEnd),+    NotConfigurable (notConfigured)+  )+import Text.Gigaparsec.Internal.Token.Errors (+    checkBadChar, filterS, annotate, mapMaybeS, mapMaybeS',+    LabelWithExplainConfig, LabelConfig+  )+import Text.Gigaparsec.Internal.Token.Generic (+    GenericNumeric(zeroAllowedDecimal, zeroAllowedHexadecimal, zeroAllowedOctal, zeroAllowedBinary)+  )+import Data.Char (isSpace, chr, ord, digitToInt, isAscii, isLatin1) import Data.Map qualified as Map (insert, map) import Data.Set (Set) import Data.Set qualified as Set (toList) import Data.List.NonEmpty (NonEmpty((:|)), sort)-import Data.List.NonEmpty qualified as NonEmpty (toList) import Text.Gigaparsec.Registers (Reg, make, unsafeMake, gets, modify, put, get) import Text.Gigaparsec.Combinator (guardS, choice, manyTill)-import Text.Gigaparsec.Errors.Combinator (filterOut, (<?>), label, explain, mapMaybeSWith) import Control.Applicative (liftA3) import Data.Maybe (catMaybes)-import Text.Gigaparsec.Errors.ErrorGen (specializedGen, messages)-import Text.Gigaparsec.Errors.DefaultErrorBuilder (disjunct, toString, from)-import Numeric (showIntAtBase)  -- TODO: is it possible to /actually/ support Text/Bytestring in future? -- Perhaps something like the Numeric stuff?@@ -45,67 +60,72 @@ type CharacterParsers :: * type CharacterParsers = TextParsers Char -mkCharacterParsers :: TextDesc -> Escape -> CharacterParsers-mkCharacterParsers TextDesc{..} escape = TextParsers {..}-  where unicode = lit uncheckedUniLetter-        ascii = lit (filterOut (\c -> if c > '\x7f' then Just "non-ascii character" else Nothing) uncheckedUniLetter)-        latin1 = lit (filterOut (\c -> if c > '\xff' then Just "non-latin1 character" else Nothing) uncheckedUniLetter)+mkCharacterParsers :: TextDesc -> Escape -> ErrorConfig -> CharacterParsers+mkCharacterParsers TextDesc{..} escape !err = TextParsers {..}+  where unicode = lit (labelCharUnicode err) (labelCharUnicodeEnd err) uncheckedUniLetter+        ascii = lit (labelCharAscii err) (labelCharAsciiEnd err) (filterS (filterCharNonAscii err) (> '\x7f') uncheckedUniLetter)+        latin1 = lit (labelCharLatin1 err) (labelCharLatin1End err) (filterS (filterCharNonLatin1 err) (> '\xff') uncheckedUniLetter)          quote = char characterLiteralEnd-        lit c = quote *> c <* quote-        uncheckedUniLetter = escapeChar escape <|> graphic+        lit label endLabel c = annotate label quote *> c <* annotate endLabel quote+        uncheckedUniLetter = escapeChar escape <|> graphic <|> checkBadChar (verifiedCharBadCharsUsedInLiteral err) -        graphic = maybe empty satisfy (letter characterLiteralEnd False graphicCharacter) <?> ["graphic character"]+        graphic = annotate (labelGraphicCharacter err) $ maybe empty satisfy (letter characterLiteralEnd False graphicCharacter)  type StringChar :: * data StringChar = RawChar                 | EscapeChar {-# UNPACK #-} !Char (Parsec (Maybe Char)) -mkEscapeChar :: EscapeDesc -> Escape -> Parsec () -> StringChar-mkEscapeChar !desc !esc !space = EscapeChar (escBegin desc) stringEsc+mkEscapeChar :: EscapeDesc -> Escape -> Parsec () -> ErrorConfig -> StringChar+mkEscapeChar !desc !esc !space !err = EscapeChar (escBegin desc) stringEsc   where stringEsc = escapeBegin esc *> (escapeGap $> Nothing <|>                                         escapeEmpty $> Nothing <|>                                         Just <$> escapeCode esc)-        escapeEmpty = maybe empty char (emptyEscape desc)+        escapeEmpty = maybe empty (annotate (labelStringEscapeEmpty err) . char) (emptyEscape desc)         escapeGap-          | gapsSupported desc = some (space <?> ["string gap"]) *> (escapeBegin esc <?> ["end of string gap"])+          | gapsSupported desc = some (annotate (labelStringEscapeGap err) space)+                              *> annotate (labelStringEscapeGapEnd err) (escapeBegin esc)           | otherwise = empty -mkChar :: StringChar -> CharPredicate -> Parsec (Maybe Char)-mkChar RawChar = maybe empty (fmap Just . label ["string character"] . satisfy)-mkChar (EscapeChar escBegin stringEsc) =-  foldr (\p -> label ["string character"] . (<|> fmap Just (satisfy (\c -> p c && c /= escBegin) <?> ["graphic character"])))+mkChar :: StringChar -> ErrorConfig -> CharPredicate -> Parsec (Maybe Char)+mkChar RawChar !err = maybe empty ((<|> checkBadChar (verifiedStringBadCharsUsedInLiteral err)) . fmap Just . annotate (labelStringCharacter err) . satisfy)+mkChar (EscapeChar escBegin stringEsc) err =+  foldr (\p -> annotate (labelStringCharacter err) . (<|> checkBadChar (verifiedStringBadCharsUsedInLiteral err)) . (<|> fmap Just (annotate (labelGraphicCharacter err) (satisfy (\c -> p c && c /= escBegin)))))         stringEsc  isRawChar :: StringChar -> Bool isRawChar RawChar = True isRawChar EscapeChar{} = False -ensureAscii :: Parsec String -> Parsec String-ensureAscii = filterOut $ \s ->-  if not (all isAscii s) then Just "non-ascii characters in string literal, this is not allowed"-  else Nothing+ensureAscii :: ErrorConfig -> Parsec String -> Parsec String+ensureAscii !err = filterS (filterStringNonAscii err) (not . all isAscii) -ensureLatin1 :: Parsec String -> Parsec String-ensureLatin1 = filterOut $ \s ->-  if not (all isLatin1 s) then Just "non-latin1 characters in string literal, this is not allowed"-  else Nothing+ensureLatin1 :: ErrorConfig -> Parsec String -> Parsec String+ensureLatin1 !err = filterS (filterStringNonLatin1 err) (not . all isLatin1) -mkStringParsers :: Set (String, String) -> StringChar -> CharPredicate -> Bool -> StringParsers-mkStringParsers !ends !stringChar !isGraphic !allowsAllSpace = TextParsers {..}-  where ascii = stringLiteral ensureAscii-        latin1 = stringLiteral ensureLatin1-        unicode = stringLiteral id+mkStringParsers :: Set (String, String) -> StringChar -> CharPredicate -> Bool -> ErrorConfig -> StringParsers+mkStringParsers !ends !stringChar !isGraphic !allowsAllSpace !err = TextParsers {..}+  where ascii = stringLiteral (ensureAscii err) (labelStringAscii err) (labelStringAsciiEnd err)+        latin1 = stringLiteral (ensureLatin1 err) (labelStringLatin1 err) (labelStringLatin1End err)+        unicode = stringLiteral id (labelStringUnicode err) (labelStringUnicodeEnd err) -        stringLiteral :: (Parsec String -> Parsec String) -> Parsec String-        stringLiteral valid = choice (map (uncurry (makeStringParser valid)) (Set.toList ends))+        stringLiteral :: (Parsec String -> Parsec String)+                      -> (Bool -> Bool -> LabelWithExplainConfig)+                      -> (Bool -> Bool -> LabelConfig)+                      -> Parsec String+        stringLiteral valid openLabel closeLabel =+          choice (map (uncurry (makeStringParser valid openLabel closeLabel)) (Set.toList ends)) -        makeStringParser :: (Parsec String -> Parsec String) -> String -> String -> Parsec String-        makeStringParser valid begin end@(terminalInit : _) =-          let strChar = mkChar stringChar (letter terminalInit allowsAllSpace isGraphic)-          in (string begin *>) . valid $-               catMaybes <$> manyTill (Just <$> char terminalInit <|> strChar) (atomic (string end))-        makeStringParser _ _ [] = error "string terminals cannot be empty"+        makeStringParser :: (Parsec String -> Parsec String)+                         -> (Bool -> Bool -> LabelWithExplainConfig)+                         -> (Bool -> Bool -> LabelConfig)+                         -> String -> String -> Parsec String+        makeStringParser valid openLabel closeLabel begin end@(terminalInit : _) =+          let strChar = mkChar stringChar err (letter terminalInit allowsAllSpace isGraphic)+          in (annotate (openLabel allowsAllSpace (isRawChar stringChar)) (string begin) *>) . valid $+               catMaybes <$> manyTill (Just <$> char terminalInit <|> strChar)+                                      (annotate (closeLabel allowsAllSpace (isRawChar stringChar)) (atomic (string end)))+        makeStringParser _ _ _ _ [] = error "string terminals cannot be empty"  letter :: Char -> Bool -> CharPredicate -> CharPredicate letter !terminalLead !allowsAllSpace (Just g)@@ -119,11 +139,11 @@                      , escapeChar :: !(Parsec Char)                      } -mkEscape :: EscapeDesc -> GenericNumeric -> Escape-mkEscape EscapeDesc{..} gen = Escape {..}+mkEscape :: EscapeDesc -> GenericNumeric -> ErrorConfig -> Escape+mkEscape EscapeDesc{..} gen !err = Escape {..}   where-    escapeBegin = void (char escBegin) <?> ["escape sequence"]-    escapeCode = explain "invalid escape sequence" $ label ["end of escape sequence"] $+    escapeBegin = annotate (labelEscapeSequence err) $ void (char escBegin)+    escapeCode = annotate (labelEscapeEnd err) $       escMapped <|> numericEscape     escapeChar = escapeBegin *> escapeCode @@ -132,27 +152,21 @@      numericEscape = decimalEsc <|> hexadecimalEsc <|> octalEsc <|> binaryEsc -    decimalEsc = fromDesc 10 decimalEscape (zeroAllowedDecimal gen) digit-    hexadecimalEsc = fromDesc 16 hexadecimalEscape (zeroAllowedHexadecimal gen) hexDigit-    octalEsc = fromDesc 8 octalEscape (zeroAllowedOctal gen) octDigit-    binaryEsc = fromDesc 2 binaryEscape (zeroAllowedBinary gen) bit+    decimalEsc = fromDesc 10 decimalEscape (zeroAllowedDecimal gen notConfigured) digit+    hexadecimalEsc = fromDesc 16 hexadecimalEscape (zeroAllowedHexadecimal gen notConfigured) hexDigit+    octalEsc = fromDesc 8 octalEscape (zeroAllowedOctal gen notConfigured) octDigit+    binaryEsc = fromDesc 2 binaryEscape (zeroAllowedBinary gen notConfigured) bit      boundedChar :: Parsec Integer -> Char -> Maybe Char -> Int -> Parsec Char-    boundedChar p maxValue prefix radix = foldr (\c t -> char c *> t) (mapMaybeSWith err f p) prefix-      where f c+    boundedChar p maxValue prefix radix = annotate (labelEscapeNumeric err radix) $+      foldr (\c t -> char c *> annotate (labelEscapeNumericEnd err c radix) t)+            (mapMaybeS config f p)+            prefix+      where config = filterEscapeCharNumericSequenceIllegal err maxValue radix+            f c              | c < toInteger (ord maxValue) = Just (chr (fromInteger c))              | otherwise = Nothing-            err = specializedGen { messages = messages }-            messages :: Integer -> [String]-            messages c-              | c > toInteger (ord maxValue) =-                  [showIntAtBase (toInteger radix) intToDigit c-                    (" is greater than the maximum character value of "-                    ++ showIntAtBase (toInteger radix) intToDigit (toInteger (ord maxValue)) "")]-              | otherwise = ["illegal unicode character: "-                          ++ showIntAtBase (toInteger radix) intToDigit c ""] -     atMost' :: Int -> Parsec Char -> Reg r Word -> Parsec Integer     atMost' radix dig atMostR =       -- FIXME: surely this is an inefficient mess with the translations?@@ -164,13 +178,9 @@      exactly :: Word -> Word -> Int -> Parsec Char -> NonEmpty Word -> Parsec Integer     exactly n full radix dig reqDigits = make n $ \atMostR ->-      mapMaybeSWith (specializedGen {messages = messages})-                    (\(num, m) -> if m == full then Just num else Nothing)-                    (atMost' radix dig atMostR <~> gets atMostR (full -))-      where messages :: (Integer, Word) -> [String]-            messages (_, got) =-              [toString ("numeric escape requires " <> formatted <> "digits, but only got" <> from got)]-            ~(Just formatted) = disjunct True (map show (NonEmpty.toList reqDigits))+      mapMaybeS' snd (filterEscapeCharRequiresExactDigits err radix reqDigits)+                 (\(num, m) -> if m == full then Just num else Nothing)+                 (atMost' radix dig atMostR <~> gets atMostR (full -))      oneOfExactly' :: NonEmpty Word -> Word -> Word -> [Word] -> Int -> Parsec Char -> Reg r Word -> Parsec Integer     oneOfExactly' reqDigits digits m [] radix dig digitsParsed =

@@ -1,6 +1,9 @@ {-# LANGUAGE Safe #-} {-# LANGUAGE OverloadedLists #-} {-# OPTIONS_GHC -Wno-partial-fields #-}+-- TODO: In next major, don't expose the constructors of the descriptions,+-- we want them built up by record copy for forwards compatible evolution+-- We can move this into an internal module to accommodate that if we want module Text.Gigaparsec.Token.Descriptions (module Text.Gigaparsec.Token.Descriptions) where  import Data.Char (isSpace)

@@ -0,0 +1,292 @@+{-# LANGUAGE Safe #-}+{-# LANGUAGE NoMonomorphismRestriction, BlockArguments, OverloadedLists, OverloadedStrings #-}+{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}+module Text.Gigaparsec.Token.Errors (+    ErrorConfig(+      labelNumericBreakChar, labelIntegerUnsignedDecimal,+      labelIntegerUnsignedHexadecimal, labelIntegerUnsignedOctal,+      labelIntegerUnsignedBinary, labelIntegerUnsignedNumber,+      labelIntegerSignedDecimal,+      labelIntegerSignedHexadecimal, labelIntegerSignedOctal,+      labelIntegerSignedBinary, labelIntegerSignedNumber,+      labelIntegerDecimalEnd,+      labelIntegerHexadecimalEnd, labelIntegerOctalEnd,+      labelIntegerBinaryEnd, labelIntegerNumberEnd,+      filterIntegerOutOfBounds,+      labelNameIdentifier, labelNameOperator,+      unexpectedNameIllegalIdentifier, unexpectedNameIllegalOperator,+      filterNameIllFormedIdentifier, filterNameIllFormedOperator,+      labelCharAscii, labelCharLatin1, labelCharUnicode,+      labelCharAsciiEnd, labelCharLatin1End, labelCharUnicodeEnd,+      labelStringAscii, labelStringLatin1, labelStringUnicode,+      labelStringAsciiEnd, labelStringLatin1End, labelStringUnicodeEnd,+      labelStringCharacter, labelGraphicCharacter, labelEscapeSequence,+      labelEscapeNumeric, labelEscapeNumericEnd, labelEscapeEnd,+      labelStringEscapeEmpty, labelStringEscapeGap, labelStringEscapeGapEnd,+      filterCharNonAscii, filterCharNonLatin1, filterStringNonAscii, filterStringNonLatin1,+      filterEscapeCharRequiresExactDigits, filterEscapeCharNumericSequenceIllegal,+      verifiedCharBadCharsUsedInLiteral, verifiedStringBadCharsUsedInLiteral,+      labelSymbol, labelSymbolEndOfKeyword, labelSymbolEndOfOperator,+      labelSpaceEndOfLineComment, labelSpaceEndOfMultiComment+    ),+    defaultErrorConfig,+    LabelWithExplainConfig, LabelWithExplainConfigurable(..),+    LabelConfig, LabelConfigurable(..),+    ExplainConfig, ExplainConfigurable(..),+    NotConfigurable(..),+    FilterConfig,+    VanillaFilterConfig, VanillaFilterConfigurable(..),+    SpecializedFilterConfig, SpecializedFilterConfigurable(..),+    BasicFilterConfigurable(..),+    VerifiedBadChars, badCharsFail, badCharsReason,+    Unverified(..),+    Bits(B8, B16, B32, B64)+  ) where++import Data.Set (Set)+import Data.Map (Map)+import Data.Map qualified as Map (empty)+import Data.List.NonEmpty (NonEmpty((:|)))+import Data.List.NonEmpty qualified as NonEmpty (toList)+import Data.Kind (Constraint)+import Text.Gigaparsec.Internal.Token.BitBounds (Bits(B8, B16, B32, B64))+import Numeric (showIntAtBase)+import Data.Char (intToDigit, ord)+import Text.Gigaparsec.Errors.DefaultErrorBuilder (from, disjunct, toString)+import Text.Gigaparsec.Internal.Token.Errors (+    LabelWithExplainConfig(LELabelAndReason, LELabel, LEHidden, LEReason, LENotConfigured),+    LabelConfig(LLabel, LHidden, LNotConfigured), ExplainConfig(EReason, ENotConfigured),+    FilterConfig(VSBecause, VSUnexpected, VSUnexpectedBecause, VSBasicFilter, VSSpecializedFilter),+    SpecializedFilterConfig(SSpecializedFilter, SBasicFilter),+    VanillaFilterConfig(VBecause, VUnexpected, VUnexpectedBecause, VBasicFilter),+    VerifiedBadChars(BadCharsUnverified, BadCharsFail, BadCharsReason)+  )++type ErrorConfig :: *+data ErrorConfig =+  ErrorConfig { labelNumericBreakChar :: !LabelWithExplainConfig+              , labelIntegerUnsignedDecimal :: Maybe Bits -> LabelWithExplainConfig+              , labelIntegerUnsignedHexadecimal :: Maybe Bits -> LabelWithExplainConfig+              , labelIntegerUnsignedOctal :: Maybe Bits -> LabelWithExplainConfig+              , labelIntegerUnsignedBinary :: Maybe Bits -> LabelWithExplainConfig+              , labelIntegerUnsignedNumber :: Maybe Bits -> LabelWithExplainConfig+              , labelIntegerSignedDecimal :: Maybe Bits -> LabelWithExplainConfig+              , labelIntegerSignedHexadecimal :: Maybe Bits -> LabelWithExplainConfig+              , labelIntegerSignedOctal :: Maybe Bits -> LabelWithExplainConfig+              , labelIntegerSignedBinary :: Maybe Bits -> LabelWithExplainConfig+              , labelIntegerSignedNumber :: Maybe Bits -> LabelWithExplainConfig+              , labelIntegerDecimalEnd :: LabelConfig+              , labelIntegerHexadecimalEnd :: LabelConfig+              , labelIntegerOctalEnd :: LabelConfig+              , labelIntegerBinaryEnd :: LabelConfig+              , labelIntegerNumberEnd :: LabelConfig+              , filterIntegerOutOfBounds :: Integer -> Integer -> Int -> FilterConfig Integer+              , labelNameIdentifier :: String+              , labelNameOperator :: String+              , unexpectedNameIllegalIdentifier :: String -> String+              , unexpectedNameIllegalOperator :: String -> String+              , filterNameIllFormedIdentifier :: FilterConfig String+              , filterNameIllFormedOperator :: FilterConfig String+              , labelCharAscii :: LabelWithExplainConfig+              , labelCharLatin1 :: LabelWithExplainConfig+              , labelCharUnicode :: LabelWithExplainConfig+              , labelCharAsciiEnd :: LabelConfig+              , labelCharLatin1End :: LabelConfig+              , labelCharUnicodeEnd :: LabelConfig+              , labelStringAscii :: Bool -> Bool -> LabelWithExplainConfig+              , labelStringLatin1 :: Bool -> Bool -> LabelWithExplainConfig+              , labelStringUnicode :: Bool -> Bool -> LabelWithExplainConfig+              , labelStringAsciiEnd :: Bool -> Bool -> LabelConfig+              , labelStringLatin1End :: Bool -> Bool -> LabelConfig+              , labelStringUnicodeEnd :: Bool -> Bool -> LabelConfig+              , labelStringCharacter :: LabelConfig+              , labelGraphicCharacter :: LabelWithExplainConfig+              , labelEscapeSequence :: LabelWithExplainConfig+              , labelEscapeNumeric :: Int -> LabelWithExplainConfig+              , labelEscapeNumericEnd :: Char -> Int -> LabelWithExplainConfig+              , labelEscapeEnd :: LabelWithExplainConfig+              , labelStringEscapeEmpty :: LabelConfig+              , labelStringEscapeGap :: LabelConfig+              , labelStringEscapeGapEnd :: LabelConfig+              , filterCharNonAscii :: VanillaFilterConfig Char+              , filterCharNonLatin1 :: VanillaFilterConfig Char+              , filterStringNonAscii :: SpecializedFilterConfig String+              , filterStringNonLatin1 :: SpecializedFilterConfig String+              , filterEscapeCharRequiresExactDigits :: Int -> NonEmpty Word -> SpecializedFilterConfig Word+              , filterEscapeCharNumericSequenceIllegal :: Char -> Int -> SpecializedFilterConfig Integer+              , verifiedCharBadCharsUsedInLiteral :: VerifiedBadChars+              , verifiedStringBadCharsUsedInLiteral :: VerifiedBadChars+              , labelSymbol :: Map String LabelWithExplainConfig+              -- don't bother with these until parsley standardises+              --, defaultSymbolKeyword :: Labeller+              --, defaultSymbolOperator :: Labeller+              --, defaultSymbolPunctuaton :: Labeller+              , labelSymbolEndOfKeyword :: String -> String+              , labelSymbolEndOfOperator :: String -> String+              , labelSpaceEndOfLineComment :: LabelWithExplainConfig+              , labelSpaceEndOfMultiComment :: LabelWithExplainConfig+              }++defaultErrorConfig :: ErrorConfig+defaultErrorConfig = ErrorConfig {..}+  where labelNumericBreakChar = notConfigured+        labelIntegerUnsignedDecimal = const notConfigured+        labelIntegerUnsignedHexadecimal = const notConfigured+        labelIntegerUnsignedOctal = const notConfigured+        labelIntegerUnsignedBinary = const notConfigured+        labelIntegerUnsignedNumber = const notConfigured+        labelIntegerSignedDecimal = const notConfigured+        labelIntegerSignedHexadecimal = const notConfigured+        labelIntegerSignedOctal = const notConfigured+        labelIntegerSignedBinary = const notConfigured+        labelIntegerSignedNumber = const notConfigured+        labelIntegerDecimalEnd = notConfigured+        labelIntegerHexadecimalEnd = notConfigured+        labelIntegerOctalEnd = notConfigured+        labelIntegerBinaryEnd = notConfigured+        labelIntegerNumberEnd = notConfigured+        filterIntegerOutOfBounds small big nativeRadix = specializedFilter+          (outOfBounds small big nativeRadix)+        labelNameIdentifier = "identifier"+        labelNameOperator = "operator"+        unexpectedNameIllegalIdentifier = ("keyword " ++)+        unexpectedNameIllegalOperator = ("reserved operator " ++)+        filterNameIllFormedIdentifier = unexpected ("identifier " ++)+        filterNameIllFormedOperator = unexpected ("operator " ++)+        labelCharAscii = notConfigured+        labelCharLatin1 = notConfigured+        labelCharUnicode = notConfigured+        labelCharAsciiEnd = notConfigured+        labelCharLatin1End = notConfigured+        labelCharUnicodeEnd = notConfigured+        labelStringAscii _ _ = notConfigured+        labelStringLatin1 _ _ = notConfigured+        labelStringUnicode _ _ = notConfigured+        labelStringAsciiEnd _ _ = notConfigured+        labelStringLatin1End _ _ = notConfigured+        labelStringUnicodeEnd _ _ = notConfigured+        labelStringCharacter = label ["string character"]+        labelGraphicCharacter = label ["graphic character"]+        labelEscapeSequence = label ["escape sequence"]+        labelEscapeNumeric _ = notConfigured+        labelEscapeNumericEnd _ _ = notConfigured+        labelEscapeEnd = labelAndReason ["end of escape sequence"] "invalid escape sequence"+        labelStringEscapeEmpty = notConfigured+        labelStringEscapeGap = label ["string gap"]+        labelStringEscapeGapEnd = label ["end of string gap"]+        filterCharNonAscii = because (const "non-ascii character")+        filterCharNonLatin1 = because (const "non-latin1 character")+        filterStringNonAscii =+          specializedFilter (const ["non-ascii characters in string literal, this is not allowed"])+        filterStringNonLatin1 =+          specializedFilter (const ["non-latin1 characters in string literal, this is not allowed"])+        filterEscapeCharRequiresExactDigits _ needed = specializedFilter \got ->+          let ~(Just formatted) = disjunct True (map show (NonEmpty.toList needed))+          in [toString ("numeric escape requires " <> formatted <> "digits, but only got" <> from got)]+        filterEscapeCharNumericSequenceIllegal maxEscape radix =+          let messages :: Integer -> NonEmpty String+              messages c+                | c > toInteger (ord maxEscape) = singleton $+                    showIntAtBase (toInteger radix) intToDigit c+                      (" is greater than the maximum character value of "+                      ++ showIntAtBase (toInteger radix) intToDigit (toInteger (ord maxEscape)) "")+                | otherwise = singleton $ "illegal unicode character: "+                                        ++ showIntAtBase (toInteger radix) intToDigit c ""+          in specializedFilter messages+        verifiedCharBadCharsUsedInLiteral = unverified+        verifiedStringBadCharsUsedInLiteral = unverified+        labelSymbol = Map.empty+        -- defaultSymbolKeyword = Label+        -- defaultSymbolOperator = Label+        -- defaultSymbolOperator = NotConfigured+        labelSymbolEndOfKeyword = ("end of " ++)+        labelSymbolEndOfOperator = ("end of " ++)+        labelSpaceEndOfLineComment = label ["end of comment"]+        labelSpaceEndOfMultiComment = label ["end of comment"]++outOfBounds :: Integer -> Integer -> Int -> Integer -> NonEmpty String+outOfBounds small big radix _n = singleton $+    "literal is not within the range " ++ resign small (" to " ++ resign big "")+  where resign n+          | n < 0 = ('-' :) . showIntAtBase (toInteger radix) intToDigit (abs n)+          | otherwise = showIntAtBase (toInteger radix) intToDigit n++type LabelConfigurable :: * -> Constraint+class LabelConfigurable config where+  label :: Set String -> config+  hidden :: config++instance LabelConfigurable LabelConfig where+  label = LLabel+  hidden = LHidden+instance LabelConfigurable LabelWithExplainConfig where+  label = LELabel+  hidden = LEHidden++type ExplainConfigurable :: * -> Constraint+class ExplainConfigurable config where+  reason :: String -> config++instance ExplainConfigurable ExplainConfig where reason = EReason+instance ExplainConfigurable LabelWithExplainConfig where reason = LEReason++type LabelWithExplainConfigurable :: * -> Constraint+class LabelWithExplainConfigurable config where+  labelAndReason :: Set String -> String -> config++instance LabelWithExplainConfigurable LabelWithExplainConfig where labelAndReason = LELabelAndReason++type NotConfigurable :: * -> Constraint+class NotConfigurable config where+  notConfigured :: config++instance NotConfigurable LabelWithExplainConfig where notConfigured = LENotConfigured+instance NotConfigurable LabelConfig where notConfigured = LNotConfigured+instance NotConfigurable ExplainConfig where notConfigured = ENotConfigured++type VanillaFilterConfigurable :: (* -> *) -> Constraint+class VanillaFilterConfigurable config where+  unexpected :: (a -> String) -> config a+  because :: (a -> String) -> config a+  unexpectedBecause :: (a -> String) -> (a -> String) -> config a++instance VanillaFilterConfigurable FilterConfig where+  unexpected = VSUnexpected+  because = VSBecause+  unexpectedBecause = VSUnexpectedBecause++instance VanillaFilterConfigurable VanillaFilterConfig where+  unexpected = VUnexpected+  because = VBecause+  unexpectedBecause = VUnexpectedBecause++type SpecializedFilterConfigurable :: (* -> *) -> Constraint+class SpecializedFilterConfigurable config where+  specializedFilter :: (a -> NonEmpty String) -> config a++instance SpecializedFilterConfigurable FilterConfig where+  specializedFilter = VSSpecializedFilter+instance SpecializedFilterConfigurable SpecializedFilterConfig where+  specializedFilter = SSpecializedFilter++type BasicFilterConfigurable :: (* -> *) -> Constraint+class BasicFilterConfigurable config where+  basicFilter :: config a++instance BasicFilterConfigurable FilterConfig where basicFilter = VSBasicFilter+instance BasicFilterConfigurable VanillaFilterConfig where basicFilter = VBasicFilter+instance BasicFilterConfigurable SpecializedFilterConfig where basicFilter = SBasicFilter++badCharsFail :: Map Char (NonEmpty String) -> VerifiedBadChars+badCharsFail = BadCharsFail+badCharsReason :: Map Char String -> VerifiedBadChars+badCharsReason = BadCharsReason++type Unverified :: * -> Constraint+class Unverified config where+  unverified :: config++instance Unverified VerifiedBadChars where unverified = BadCharsUnverified++singleton :: a -> NonEmpty a+singleton x = x :| []

@@ -3,7 +3,7 @@ -- Ideally, we should probably expose all the functionally via this one file -- for ergonomics module Text.Gigaparsec.Token.Lexer (-    Lexer, mkLexer,+    Lexer, mkLexer, mkLexerWithErrorConfig,     Lexeme, lexeme, nonlexeme, fully, space,     apply, sym, symbol, names,     -- Symbol@@ -27,7 +27,7 @@   ) where  import Text.Gigaparsec.Internal.Token.Lexer (-    Lexer, mkLexer,+    Lexer, mkLexer, mkLexerWithErrorConfig,     Lexeme (rawMultiStringLiteral), lexeme, nonlexeme, fully, space,     apply, sym, symbol, names,     integer, natural,@@ -46,7 +46,7 @@     octal8, octal16, octal32, octal64,     binary8, binary16, binary32, binary64   )-import Text.Gigaparsec.Internal.Token.Numeric qualified as Internal+import Text.Gigaparsec.Internal.Token.BitBounds qualified as Internal import Text.Gigaparsec.Internal.Token.Text (     TextParsers, ascii, unicode, latin1   )

@@ -14,6 +14,7 @@ import Control.Monad (forM_) import Data.Char (isLetter, isAlphaNum) import Text.Gigaparsec.Internal.TestError+import Text.Gigaparsec.Token.Errors (defaultErrorConfig)  tests :: TestTree tests = testGroup "Names"@@ -96,6 +97,7 @@                        , hardKeywords = ["keyword", "HARD"]                        , hardOperators = ["+", "<", "<="]                        })+          defaultErrorConfig  basicNames :: Names basicNames = namesFor (Just isLetter) (Just isAlphaNum) True