diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -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`. diff --git a/gigaparsec.cabal b/gigaparsec.cabal --- a/gigaparsec.cabal +++ b/gigaparsec.cabal @@ -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, diff --git a/src/Text/Gigaparsec/Errors/Combinator.hs b/src/Text/Gigaparsec/Errors/Combinator.hs --- a/src/Text/Gigaparsec/Errors/Combinator.hs +++ b/src/Text/Gigaparsec/Errors/Combinator.hs @@ -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) diff --git a/src/Text/Gigaparsec/Errors/ErrorGen.hs b/src/Text/Gigaparsec/Errors/ErrorGen.hs --- a/src/Text/Gigaparsec/Errors/ErrorGen.hs +++ b/src/Text/Gigaparsec/Errors/ErrorGen.hs @@ -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 diff --git a/src/Text/Gigaparsec/Internal/Errors/DefuncError.hs b/src/Text/Gigaparsec/Internal/Errors/DefuncError.hs --- a/src/Text/Gigaparsec/Internal/Errors/DefuncError.hs +++ b/src/Text/Gigaparsec/Internal/Errors/DefuncError.hs @@ -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 diff --git a/src/Text/Gigaparsec/Internal/Token/BitBounds.hs b/src/Text/Gigaparsec/Internal/Token/BitBounds.hs new file mode 100644 --- /dev/null +++ b/src/Text/Gigaparsec/Internal/Token/BitBounds.hs @@ -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 diff --git a/src/Text/Gigaparsec/Internal/Token/Errors.hs b/src/Text/Gigaparsec/Internal/Token/Errors.hs new file mode 100644 --- /dev/null +++ b/src/Text/Gigaparsec/Internal/Token/Errors.hs @@ -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 diff --git a/src/Text/Gigaparsec/Internal/Token/Generic.hs b/src/Text/Gigaparsec/Internal/Token/Generic.hs --- a/src/Text/Gigaparsec/Internal/Token/Generic.hs +++ b/src/Text/Gigaparsec/Internal/Token/Generic.hs @@ -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) diff --git a/src/Text/Gigaparsec/Internal/Token/Lexer.hs b/src/Text/Gigaparsec/Internal/Token/Lexer.hs --- a/src/Text/Gigaparsec/Internal/Token/Lexer.hs +++ b/src/Text/Gigaparsec/Internal/Token/Lexer.hs @@ -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 diff --git a/src/Text/Gigaparsec/Internal/Token/Names.hs b/src/Text/Gigaparsec/Internal/Token/Names.hs --- a/src/Text/Gigaparsec/Internal/Token/Names.hs +++ b/src/Text/Gigaparsec/Internal/Token/Names.hs @@ -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 = diff --git a/src/Text/Gigaparsec/Internal/Token/Numeric.hs b/src/Text/Gigaparsec/Internal/Token/Numeric.hs --- a/src/Text/Gigaparsec/Internal/Token/Numeric.hs +++ b/src/Text/Gigaparsec/Internal/Token/Numeric.hs @@ -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 diff --git a/src/Text/Gigaparsec/Internal/Token/Symbol.hs b/src/Text/Gigaparsec/Internal/Token/Symbol.hs --- a/src/Text/Gigaparsec/Internal/Token/Symbol.hs +++ b/src/Text/Gigaparsec/Internal/Token/Symbol.hs @@ -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 diff --git a/src/Text/Gigaparsec/Internal/Token/Text.hs b/src/Text/Gigaparsec/Internal/Token/Text.hs --- a/src/Text/Gigaparsec/Internal/Token/Text.hs +++ b/src/Text/Gigaparsec/Internal/Token/Text.hs @@ -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 = diff --git a/src/Text/Gigaparsec/Token/Descriptions.hs b/src/Text/Gigaparsec/Token/Descriptions.hs --- a/src/Text/Gigaparsec/Token/Descriptions.hs +++ b/src/Text/Gigaparsec/Token/Descriptions.hs @@ -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) diff --git a/src/Text/Gigaparsec/Token/Errors.hs b/src/Text/Gigaparsec/Token/Errors.hs new file mode 100644 --- /dev/null +++ b/src/Text/Gigaparsec/Token/Errors.hs @@ -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 :| [] diff --git a/src/Text/Gigaparsec/Token/Lexer.hs b/src/Text/Gigaparsec/Token/Lexer.hs --- a/src/Text/Gigaparsec/Token/Lexer.hs +++ b/src/Text/Gigaparsec/Token/Lexer.hs @@ -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 ) diff --git a/test/Text/Gigaparsec/Token/NamesTests.hs b/test/Text/Gigaparsec/Token/NamesTests.hs --- a/test/Text/Gigaparsec/Token/NamesTests.hs +++ b/test/Text/Gigaparsec/Token/NamesTests.hs @@ -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