diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,7 +1,10 @@ # Revision history for gigaparsec +## 0.2.3.0 -- 2024-01-29 +* Added _Verified Errors_ and _Preventative Errors_ in `Text.Gigaparsec.Errors.Patterns`. + ## 0.2.2.3 -- 2024-01-29 -* Fixed bug where `markAsToken` doesn't apply at the correct offsets +* Fixed bug where `markAsToken` doesn't apply at the correct offsets. ## 0.2.2.2 -- 2024-01-29 * Optimised the error system using `DefuncError` and `DefuncHints`. 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.2.3 +version: 0.2.3.0 -- A short (one-line) description of the package. synopsis: @@ -88,6 +88,7 @@ Text.Gigaparsec.Errors.DefaultErrorBuilder, Text.Gigaparsec.Errors.ErrorBuilder, Text.Gigaparsec.Errors.ErrorGen, + Text.Gigaparsec.Errors.Patterns, Text.Gigaparsec.Expr, Text.Gigaparsec.Expr.Chain, Text.Gigaparsec.Expr.Infix, 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 @@ -369,18 +369,30 @@ filterSWith errGen f p = amendThenDislodgeBy 1 $ withWidth (entrench p) >>= \(x, w) -> if f x then pure x else ErrorGen.asErr errGen x w +{- +@since 0.2.2.0 +-} filterOut :: (a -> Maybe String) -> Parsec a -> Parsec a filterOut p = filterSWith (vanillaGen { ErrorGen.reason = p }) (isNothing . p) +{- +@since 0.2.2.0 +-} guardAgainst :: (a -> Maybe [String]) -> Parsec a -> Parsec a guardAgainst p = filterSWith (specializedGen { ErrorGen.messages = fromJust . p }) (isNothing . p) +{- +@since 0.2.2.0 +-} unexpectedWhen :: (a -> Maybe String) -> Parsec a -> Parsec a unexpectedWhen p = filterSWith (vanillaGen { ErrorGen.unexpected = ErrorGen.NamedItem . fromJust . p }) (isNothing . p) +{- +@since 0.2.2.0 +-} unexpectedWithReasonWhen :: (a -> Maybe (String, String)) -> Parsec a -> Parsec a unexpectedWithReasonWhen p = filterSWith (vanillaGen { ErrorGen.unexpected = ErrorGen.NamedItem . fst . fromJust . p diff --git a/src/Text/Gigaparsec/Errors/Patterns.hs b/src/Text/Gigaparsec/Errors/Patterns.hs new file mode 100644 --- /dev/null +++ b/src/Text/Gigaparsec/Errors/Patterns.hs @@ -0,0 +1,85 @@ +{-# LANGUAGE Safe #-} +{-# OPTIONS_GHC -Wno-incomplete-record-updates #-} +module Text.Gigaparsec.Errors.Patterns ( + verifiedWith, + verifiedFail, verifiedUnexpected, verifiedExplain, + preventWith, + preventativeFail, preventativeExplain + ) where + +import Text.Gigaparsec (Parsec, atomic, (<+>), unit) +import Text.Gigaparsec.Position (withWidth) +import Text.Gigaparsec.Errors.Combinator (amend, hide) +import Text.Gigaparsec.Errors.ErrorGen (ErrorGen) +import Text.Gigaparsec.Errors.ErrorGen qualified as ErrorGen ( + asFail, asSelect, UnexpectedItem(RawItem), + vanillaGen, specializedGen, unexpected, reason, messages + ) + +{- +@since 0.2.3.0 +-} +verifiedWith :: ErrorGen a -> Parsec a -> Parsec b +verifiedWith err p = amend (ErrorGen.asFail err (hide (withWidth (atomic p)))) + +verifiedWithVanilla :: (a -> ErrorGen.UnexpectedItem) -> (a -> Maybe String) -> Parsec a -> Parsec b +verifiedWithVanilla unexGen reasonGen = verifiedWith $ + ErrorGen.vanillaGen { + ErrorGen.unexpected = unexGen, + ErrorGen.reason = reasonGen + } + +verifiedWithVanillaRaw :: (a -> Maybe String) -> Parsec a -> Parsec b +verifiedWithVanillaRaw = verifiedWithVanilla (const ErrorGen.RawItem) + +{- +@since 0.2.3.0 +-} +verifiedFail :: (a -> [String]) -> Parsec a -> Parsec b +verifiedFail msggen = verifiedWith $ + ErrorGen.specializedGen { + ErrorGen.messages = msggen + } + +{- +@since 0.2.3.0 +-} +verifiedUnexpected :: Parsec a -> Parsec b +verifiedUnexpected = verifiedWithVanillaRaw (const Nothing) + +{- +@since 0.2.3.0 +-} +verifiedExplain :: (a -> String) -> Parsec a -> Parsec b +verifiedExplain reasongen = verifiedWithVanillaRaw (Just . reasongen) + +{- +@since 0.2.3.0 +-} +preventWith :: ErrorGen a -> Parsec a -> Parsec () +preventWith err p = amend (ErrorGen.asSelect err (withWidth (hide (atomic p)) <+> unit)) + +preventWithVanilla :: (a -> ErrorGen.UnexpectedItem) -> (a -> Maybe String) -> Parsec a -> Parsec () +preventWithVanilla unexGen reasonGen = preventWith $ + ErrorGen.vanillaGen { + ErrorGen.unexpected = unexGen, + ErrorGen.reason = reasonGen + } + +preventWithVanillaRaw :: (a -> Maybe String) -> Parsec a -> Parsec () +preventWithVanillaRaw = preventWithVanilla (const ErrorGen.RawItem) + +{- +@since 0.2.3.0 +-} +preventativeFail :: (a -> [String]) -> Parsec a -> Parsec () +preventativeFail msggen = preventWith $ + ErrorGen.specializedGen { + ErrorGen.messages = msggen + } + +{- +@since 0.2.3.0 +-} +preventativeExplain :: (a -> String) -> Parsec a -> Parsec () +preventativeExplain reasongen = preventWithVanillaRaw (Just . reasongen) diff --git a/src/Text/Gigaparsec/Patterns.hs b/src/Text/Gigaparsec/Patterns.hs --- a/src/Text/Gigaparsec/Patterns.hs +++ b/src/Text/Gigaparsec/Patterns.hs @@ -40,11 +40,31 @@ import Language.Haskell.TH (Type(MulArrowT)) #endif -posAp :: Bool -> Q Exp -> Q Exp -posAp True p = [e| pos <**> $p |] -posAp False p = p +{-| +This function is used to automatically generate /Lifted Constructors/, which are +one of the patterns in /"Design Patterns for Parser Combinators/". It is provided +with a prefix, which is used to denote an application of the constructor, and +then a list of "ticked" constructors to generate lifted constructors for. This +means adding a single @'@ in front of the constructor name. For example: -deriveLiftedConstructors :: String -> [Name] -> Q [Dec] +> {-# LANGUAGE TemplateHaskell #-} +> data Foo = Foo a | Bar Int String +> $(deriveLiftedConstructors "mk" ['Foo, 'Bar]) + +Will generate two lifted constructors of the shape: + +> mkFoo :: Parsec a -> Parsec (Foo a) +> mkBar :: Parsec Int -> Parsec String -> Parsec (Foo a) + +Furthermore, if one of the arguments to the constructor has type `Text.Gigaparsec.Position.Pos`, +the @pos@ combinator will be applied automatically, and this will not be apparent in the signature +of the generated constructor. + +@since 0.2.2.0 +-} +deriveLiftedConstructors :: String -- ^ The prefix to be added to generated names + -> [Name] -- ^ The list of "ticked" constructors to generate for + -> Q [Dec] deriveLiftedConstructors prefix = fmap concat . traverse deriveCon where deriveCon :: Name -> Q [Dec] @@ -59,7 +79,32 @@ applyArgs :: Q Exp -> [Name] -> Q Exp applyArgs = foldl' (\rest arg -> [e|$rest <*> $(varE arg)|]) -deriveDeferredConstructors :: String -> [Name] -> Q [Dec] + +{-| +This function is used to automatically generate /Deferred Constructors/, which are +one of the patterns in /"Design Patterns for Parser Combinators/". It is provided +with a prefix, which is used to denote an application of the constructor, and +then a list of "ticked" constructors to generate deferred constructors for. This +means adding a single @'@ in front of the constructor name. For example: + +> {-# LANGUAGE TemplateHaskell #-} +> data Foo = Foo a | Bar Int String +> $(deriveDeferredConstructors "mk" ['Foo, 'Bar]) + +Will generate two deferred constructors of the shape: + +> mkFoo :: Parsec (a -> Foo a) +> mkBar :: Parsec (Int -> String -> Foo a) + +Furthermore, if one of the arguments to the constructor has type `Text.Gigaparsec.Position.Pos`, +the @pos@ combinator will be applied automatically, and this will not be apparent in the signature +of the generated constructor. + +@since 0.2.2.0 +-} +deriveDeferredConstructors :: String -- ^ The prefix to be added to generated names + -> [Name] -- ^ The list of "ticked" constructors to generate for + -> Q [Dec] deriveDeferredConstructors prefix = fmap concat . traverse deriveCon where deriveCon :: Name -> Q [Dec] @@ -68,6 +113,10 @@ sequence [ sigD con' ty , funD con' [clause [] (normalB (posAp posFound [e|pure $func|])) []] ] + +posAp :: Bool -> Q Exp -> Q Exp +posAp True p = [e| pos <**> $p |] +posAp False p = p funcType :: [Q Type] -> Q Type funcType = foldr1 (\ty rest -> [t| $ty -> $rest |])