diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,3 +1,11 @@ +## v1.2.0 + +* Add `Exception` instance to `DecodeError` +* Fix error messages after decoder succeeds after backtracking +* Add `KDL.label` +* Include type information to errors about expected argument/prop +* Rename `TextSchema` to `StringSchema` + ## v1.1.1 * Fix running tests with sdist bundle diff --git a/kdl-hs.cabal b/kdl-hs.cabal --- a/kdl-hs.cabal +++ b/kdl-hs.cabal @@ -1,7 +1,7 @@ cabal-version: 3.0 name: kdl-hs -version: 1.1.1 +version: 1.2.0 synopsis: KDL language parser and API description: KDL language parser and API. homepage: https://github.com/brandonchinn178/kdl-hs#readme @@ -68,7 +68,10 @@ test-suite kdl-tests type: exitcode-stdio-1.0 - ghc-options: -F -pgmF=skeletest-preprocessor + ghc-options: + -F -pgmF=skeletest-preprocessor + -- skeletest animations during callProcess + -threaded build-tool-depends: , skeletest:skeletest-preprocessor , kdl-hs:kdl-hs-test-decoder diff --git a/src/KDL/Decoder/Arrow.hs b/src/KDL/Decoder/Arrow.hs --- a/src/KDL/Decoder/Arrow.hs +++ b/src/KDL/Decoder/Arrow.hs @@ -3,6 +3,7 @@ {-# LANGUAGE LambdaCase #-} {-# LANGUAGE OverloadedRecordDot #-} {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} {-# LANGUAGE TypeFamilies #-} module KDL.Decoder.Arrow ( @@ -85,6 +86,9 @@ bool, null, + -- * Modifiers + label, + -- * Combinators oneOf, many, @@ -127,6 +131,7 @@ SchemaOf, TypedNodeSchema (..), TypedValueSchema (..), + getValueSchemaNames, ) import KDL.Parser (parse, parseFile) import KDL.Types ( @@ -183,10 +188,7 @@ document decoder = UnsafeDocumentDecoder decoder - { run = \() -> do - a <- decoder.run () - validateNodeList - pure a + { run = \() -> decoder.run () <* validateNodeList } -- | Get the schema of a 'DocumentDecoder'. @@ -211,11 +213,7 @@ node_ : _ -> do let identifier = node_.name index <- StateT.gets (getNodeIndex identifier.value) - Trans.lift . decodeThrow $ - DecodeError_UnexpectedNode - { identifier = identifier - , index = index - } + Trans.lift . decodeThrow $ DecodeError_UnexpectedNode{identifier, index} -- | Decode a node with the given name using a 'DecodeNode' instance. -- @@ -277,7 +275,7 @@ Just (_, b) -> pure b Nothing -> do index <- StateT.gets (getNodeIndex name) - Trans.lift $ decodeThrow DecodeError_ExpectedNode{name = name, index = index} + Trans.lift $ decodeThrow DecodeError_ExpectedNode{name, index} decodeFirstNodeWhere :: (Node -> Bool) -> @@ -293,7 +291,7 @@ index <- StateT.gets (getNodeIndex name.value) StateT.modify $ \s -> s{object = s.object{nodes = nodes'}} b <- - Trans.lift . addContext ContextNode{name = name, index = index} $ + Trans.lift . addContext ContextNode{name, index} $ decodeNode node_ StateT.modify $ \s -> s{history = s.history{nodesSeen = inc name.value s.history.nodesSeen}} pure $ Just (node_, b) @@ -569,7 +567,7 @@ , validTypeAnns = typeAnns , nodeSchema = decoder.schema } - decodeNode a node_ = do + decodeNode a node_ = discardHints $ do validateAnn typeAnns node_.ann runDecodeStateM node_ emptyDecodeHistory $ do -- TODO: add typeHint to Context @@ -582,17 +580,9 @@ [] -> pure () Entry{name = Nothing, value} : _ -> do index <- StateT.gets getArgIndex - Trans.lift . decodeThrow $ - DecodeError_UnexpectedArg - { index = index - , value = value - } + Trans.lift . decodeThrow $ DecodeError_UnexpectedArg{index, value} Entry{name = Just identifier, value} : _ -> do - Trans.lift . decodeThrow $ - DecodeError_UnexpectedProp - { identifier = identifier - , value = value - } + Trans.lift . decodeThrow $ DecodeError_UnexpectedProp{identifier, value} case node_.children of Nothing -> pure () Just children_ -> do @@ -635,7 +625,7 @@ emptyNode name = Node { ann = Nothing - , name = name + , name , entries = [] , children = Nothing , ext = def @@ -689,15 +679,23 @@ withTypedValueDecoder $ \schema decodeValue -> DecodeArrow (SchemaOne $ NodeArg schema) $ \a -> do index <- StateT.gets getArgIndex + let + expectedArgError = + DecodeError_ExpectedArg + { index + , label = Nothing + , expectedTypes = getValueSchemaNames schema.dataSchema + } + argContext = ContextArg{index, label = Nothing} entries <- StateT.gets (.object.entries) (entry, entries') <- - maybe (Trans.lift $ decodeThrow DecodeError_ExpectedArg{index = index}) pure $ + maybe (Trans.lift $ decodeThrow expectedArgError) pure $ extractFirst (isNothing . (.name)) entries StateT.modify $ \s -> s{object = s.object{entries = entries'}} b <- - Trans.lift . addContext ContextArg{index = index} $ + Trans.lift . addContext argContext $ decodeValue a entry.value StateT.modify $ \s -> s{history = s.history{argsSeen = s.history.argsSeen + 1}} pure b @@ -744,8 +742,14 @@ propWith' name = withTypedValueDecoder $ \schema decodeValue -> DecodeArrow (SchemaOne $ NodeProp name schema) $ \a -> do + let expectedPropError = + DecodeError_ExpectedProp + { name + , expectedTypes = getValueSchemaNames schema.dataSchema + } + decodeOnePropWhere (== name) (decodeValue a) - >>= maybe (Trans.lift $ decodeThrow DecodeError_ExpectedProp{name = name}) (pure . snd) + >>= maybe (Trans.lift $ decodeThrow expectedPropError) (pure . snd) decodeOnePropWhere :: (Text -> Bool) -> @@ -758,7 +762,7 @@ Just (name, prop_, entries') -> do StateT.modify $ \s -> s{object = s.object{entries = entries'}} b <- - Trans.lift . addContext ContextProp{name = name} $ + Trans.lift . addContext ContextProp{name} $ decodeValue prop_.value StateT.modify $ \s -> s{history = s.history{propsSeen = Set.insert name s.history.propsSeen}} pure $ Just (name, b) @@ -1030,7 +1034,7 @@ -- | Decode a KDL string value. string :: DecodeArrow Value a Text -string = valueDataDecoderPrim (SchemaOne TextSchema) $ \case +string = valueDataDecoderPrim (SchemaOne StringSchema) $ \case Value{data_ = String s} -> pure s v -> decodeThrow DecodeError_ValueDecodeFail{expectedType = "string", value = v} @@ -1051,6 +1055,39 @@ null = valueDataDecoderPrim (SchemaOne NullSchema) $ \case Value{data_ = Null} -> pure () v -> decodeThrow DecodeError_ValueDecodeFail{expectedType = "null", value = v} + +{----- Modifiers -----} + +-- | Add a label to any errors that occur in the given decoder. +-- +-- Currently only labels arguments. +-- +-- Behavior is undefined if multiple labellable things are being decoded. +-- +-- === __Example__ +-- +-- @ +-- KDL.label "name" KDL.arg +-- KDL.label "name" $ KDL.argAt "foo" +-- @ +label :: Text -> DecodeArrow o a b -> DecodeArrow o a b +label name decoder = + decoder + { run = \a -> + StateT.mapStateT (mapErrors addLabel) $ + decoder.run a + } + where + addLabel (ctx, kind) = + let ctx' = + flip map ctx $ \case + ContextArg{label = _, ..} -> ContextArg{label = Just name, ..} + item -> item + kind' = + case kind of + DecodeError_ExpectedArg{label = _, ..} -> DecodeError_ExpectedArg{label = Just name, ..} + _ -> kind + in (ctx', kind') {----- Utilities -----} diff --git a/src/KDL/Decoder/Internal/DecodeM.hs b/src/KDL/Decoder/Internal/DecodeM.hs --- a/src/KDL/Decoder/Internal/DecodeM.hs +++ b/src/KDL/Decoder/Internal/DecodeM.hs @@ -11,10 +11,13 @@ -- * DecodeM monad DecodeM (..), + DecodeHints, runDecodeM, decodeThrow, failM, + mapErrors, addContext, + discardHints, ) where import Control.Applicative (Alternative (..)) @@ -25,32 +28,31 @@ import KDL.Decoder.Internal.Error -- | The monad that returns either a 'DecodeError' or a result of type @a@. --- --- The odd structure here is because of our backtracking semantics. We want to --- collect all errors that may appear (even if a value is successfully parsed) --- so that if we get a failure later on, we can return the deepest error, even --- if it was in a successful branch. +data DecodeM a + = DecodeM_Found a DecodeHints + | DecodeM_Fail (NonEmpty BaseDecodeError) + +-- | Hints to provide additional context in a future error after a successful +-- branch. -- -- Take this motivating example: a node takes an arbitrary number of string -- args. If you pass some strings then a number, it'll successfully parse up to -- the number and return success, only for the node to fail later with -- "unexpected argument: 123". But the true error was -- "unexpected number, expected string". -data DecodeM a - = DecodeM_Found a [BaseDecodeError] - | DecodeM_Fail (NonEmpty BaseDecodeError) +type DecodeHints = [BaseDecodeError] instance Functor DecodeM where fmap f = \case DecodeM_Found a es -> DecodeM_Found (f a) es DecodeM_Fail es -> DecodeM_Fail es instance Applicative DecodeM where - pure x = DecodeM_Found x [] + pure x = DecodeM_Found x mempty l <*> r = case (l, r) of - (DecodeM_Found f es1, DecodeM_Found a es2) -> DecodeM_Found (f a) (mergeErrorsLR es1 es2) - (DecodeM_Found _ es1, DecodeM_Fail es2) -> DecodeM_Fail (mergeErrorsL es1 es2) - (DecodeM_Fail es1, DecodeM_Found _ es2) -> DecodeM_Fail (mergeErrorsR es1 es2) + (DecodeM_Found f es1, DecodeM_Found a es2) -> DecodeM_Found (f a) (es1 <> es2) + (DecodeM_Found _ es1, DecodeM_Fail es2) -> DecodeM_Fail (mergeHintsL es1 es2) + (DecodeM_Fail es1, DecodeM_Found _ es2) -> DecodeM_Fail (mergeHintsR es1 es2) (DecodeM_Fail es1, DecodeM_Fail es2) -> DecodeM_Fail (mergeErrors es1 es2) instance Monad DecodeM where (>>) = (*>) @@ -59,8 +61,8 @@ DecodeM_Fail es1 -> DecodeM_Fail es1 DecodeM_Found a es1 -> case k a of - DecodeM_Found b es2 -> DecodeM_Found b (mergeErrorsLR es1 es2) - DecodeM_Fail es2 -> DecodeM_Fail (mergeErrorsL es1 es2) + DecodeM_Found b es2 -> DecodeM_Found b (es1 <> es2) + DecodeM_Fail es2 -> DecodeM_Fail (mergeHintsL es1 es2) instance Alternative DecodeM where empty = failM "" l <|> r = @@ -68,7 +70,7 @@ DecodeM_Found a es1 -> DecodeM_Found a es1 DecodeM_Fail es1 -> case r of - DecodeM_Found a es2 -> DecodeM_Found a (NonEmpty.toList $ mergeErrorsR es1 es2) + DecodeM_Found a es2 -> DecodeM_Found a (NonEmpty.toList es1 <> es2) DecodeM_Fail es2 -> DecodeM_Fail (mergeErrors es1 es2) -- | Run a 'DecodeM' action and return the result or the deepest error found. @@ -77,6 +79,8 @@ DecodeM_Found a _ -> Right a DecodeM_Fail errors -> Left DecodeError{filepath = Nothing, errors} +{----- mergeErrors -----} + mergeErrors :: NonEmpty BaseDecodeError -> NonEmpty BaseDecodeError -> @@ -89,31 +93,23 @@ where key = length . fst . NonEmpty.head -mergeErrorsL :: - [BaseDecodeError] -> +mergeHintsL :: + DecodeHints -> NonEmpty BaseDecodeError -> NonEmpty BaseDecodeError -mergeErrorsL l r = maybe r (\l' -> mergeErrors l' r) (NonEmpty.nonEmpty l) +mergeHintsL l r = maybe r (\l' -> mergeErrors l' r) (NonEmpty.nonEmpty l) -mergeErrorsR :: +mergeHintsR :: NonEmpty BaseDecodeError -> - [BaseDecodeError] -> + DecodeHints -> NonEmpty BaseDecodeError -mergeErrorsR l r = maybe l (\r' -> mergeErrors l r') (NonEmpty.nonEmpty r) +mergeHintsR l r = maybe l (\r' -> mergeErrors l r') (NonEmpty.nonEmpty r) -mergeErrorsLR :: - [BaseDecodeError] -> - [BaseDecodeError] -> - [BaseDecodeError] -mergeErrorsLR l r = - case (l, r) of - ([], _) -> r - (_, []) -> l - (x : xs, y : ys) -> NonEmpty.toList $ mergeErrors (x :| xs) (y :| ys) +{----- DecodeM operations -----} mapErrors :: (BaseDecodeError -> BaseDecodeError) -> DecodeM a -> DecodeM a mapErrors f = \case - DecodeM_Found a es -> DecodeM_Found a (fmap f es) + DecodeM_Found a es -> DecodeM_Found a (map f es) DecodeM_Fail es -> DecodeM_Fail (fmap f es) -- | Throw an error. @@ -127,3 +123,9 @@ -- | Add context to all errors that occur in the given action. addContext :: ContextItem -> DecodeM a -> DecodeM a addContext ctxItem = mapErrors (first (ctxItem :)) + +-- | Discard hints after validating that an error context is successful. +discardHints :: DecodeM a -> DecodeM a +discardHints = \case + DecodeM_Found a _ -> DecodeM_Found a mempty + DecodeM_Fail es -> DecodeM_Fail es diff --git a/src/KDL/Decoder/Internal/Error.hs b/src/KDL/Decoder/Internal/Error.hs --- a/src/KDL/Decoder/Internal/Error.hs +++ b/src/KDL/Decoder/Internal/Error.hs @@ -14,6 +14,7 @@ renderDecodeError, ) where +import Control.Exception (Exception (..)) import Data.List.NonEmpty (NonEmpty) import Data.List.NonEmpty qualified as NonEmpty import Data.Map qualified as Map @@ -34,6 +35,9 @@ } deriving (Show, Eq) +instance Exception DecodeError where + displayException = Text.unpack . renderDecodeError + type BaseDecodeError = (Context, DecodeErrorKind) type Context = [ContextItem] @@ -44,6 +48,7 @@ } | ContextArg { index :: Int + , label :: Maybe Text } | ContextProp { name :: Identifier @@ -54,8 +59,8 @@ = DecodeError_Custom Text | DecodeError_ParseError Text | DecodeError_ExpectedNode {name :: Text, index :: Int} - | DecodeError_ExpectedArg {index :: Int} - | DecodeError_ExpectedProp {name :: Text} + | DecodeError_ExpectedArg {index :: Int, label :: Maybe Text, expectedTypes :: [Text]} + | DecodeError_ExpectedProp {name :: Text, expectedTypes :: [Text]} | DecodeError_MismatchedAnn {givenAnn :: Identifier, validAnns :: [Text]} | DecodeError_ValueDecodeFail {expectedType :: Text, value :: Value} | DecodeError_UnexpectedNode {identifier :: Identifier, index :: Int} @@ -92,7 +97,7 @@ | otherwise = Text.intercalate " > " . map renderCtxItem $ items renderCtxItem = \case ContextNode{..} -> renderIdentifier name <> " #" <> showT index - ContextArg{..} -> "arg #" <> showT index + ContextArg{..} -> renderArg index label ContextProp{..} -> "prop " <> renderIdentifier name renderErrors = map (" " <>) . concatMap (Text.lines . renderError) @@ -102,13 +107,37 @@ DecodeError_ExpectedNode{..} | index == 0 -> "Expected node: " <> name | otherwise -> "Expected another node: " <> name - DecodeError_ExpectedArg{..} -> "Expected arg #" <> showT index - DecodeError_ExpectedProp{..} -> "Expected prop: " <> name + DecodeError_ExpectedArg{..} -> + Text.concat + [ "Expected " + , renderArg index label + , if null expectedTypes + then "" + else " with type: " <> oxfordList "or" expectedTypes + ] + DecodeError_ExpectedProp{..} -> + Text.concat + [ "Expected prop '" <> name <> "'" + , if null expectedTypes + then "" + else " with type: " <> oxfordList "or" expectedTypes + ] DecodeError_MismatchedAnn{..} -> "Expected annotation to be one of " <> showT validAnns <> ", got: " <> renderIdentifier givenAnn DecodeError_ValueDecodeFail{..} -> "Expected " <> expectedType <> ", got: " <> renderValue value DecodeError_UnexpectedNode{..} -> "Unexpected node: " <> renderIdentifier identifier <> " #" <> showT index DecodeError_UnexpectedArg{..} -> "Unexpected arg #" <> showT index <> ": " <> renderValue value DecodeError_UnexpectedProp{..} -> "Unexpected prop: " <> renderIdentifier identifier <> "=" <> renderValue value + + renderArg index label = "arg " <> maybe ("#" <> showT index) (\s -> "'" <> s <> "'") label + + oxfordList conj = \case + [x] -> x + [x, y] -> Text.unwords [x, conj, y] + xs -> Text.intercalate ", " $ mapLast ((conj <> " ") <>) xs + mapLast f = \case + [] -> [] + [x] -> [f x] + x : xs -> x : mapLast f xs -- Replace with Text.show after requiring at least text-2.1.2 showT :: (Show a) => a -> Text diff --git a/src/KDL/Decoder/Schema.hs b/src/KDL/Decoder/Schema.hs --- a/src/KDL/Decoder/Schema.hs +++ b/src/KDL/Decoder/Schema.hs @@ -1,5 +1,6 @@ {-# LANGUAGE DuplicateRecordFields #-} {-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE TypeFamilies #-} module KDL.Decoder.Schema ( @@ -10,6 +11,10 @@ TypedValueSchema (..), schemaJoin, schemaAlt, + + -- * Fold over schema items + foldSchema, + getValueSchemaNames, ) where import Data.Text (Text) @@ -59,7 +64,7 @@ deriving (Show, Eq) data instance SchemaItem Value - = TextSchema + = StringSchema | NumberSchema | BoolSchema | NullSchema @@ -82,3 +87,22 @@ (SchemaOr [], r) -> r (SchemaOr l, r) -> SchemaOr (l <> [r]) (l, r) -> SchemaOr [l, r] + +{------ Fold over schema items -----} + +foldSchema :: (SchemaItem a -> b) -> SchemaOf a -> [b] +foldSchema f = go + where + go = \case + SchemaOne valSchema -> [f valSchema] + SchemaSome s -> go s + SchemaAnd ss -> concatMap go ss + SchemaOr ss -> concatMap go ss + SchemaUnknown -> [] + +getValueSchemaNames :: SchemaOf Value -> [Text] +getValueSchemaNames = foldSchema $ \case + StringSchema -> "string" + NumberSchema -> "number" + BoolSchema -> "bool" + NullSchema -> "null" diff --git a/test/KDL/ApplicativeSpec.hs b/test/KDL/ApplicativeSpec.hs --- a/test/KDL/ApplicativeSpec.hs +++ b/test/KDL/ApplicativeSpec.hs @@ -58,7 +58,7 @@ , dataSchema = KDL.SchemaOr [ KDL.SchemaOne KDL.BoolSchema - , KDL.SchemaOne KDL.TextSchema + , KDL.SchemaOne KDL.StringSchema ] } } @@ -72,7 +72,7 @@ KDL.TypedValueSchema { typeHint = typeRep $ Proxy @String , validTypeAnns = ["string"] - , dataSchema = KDL.SchemaOne KDL.TextSchema + , dataSchema = KDL.SchemaOne KDL.StringSchema } } , KDL.SchemaAnd [] @@ -86,7 +86,7 @@ KDL.TypedValueSchema { typeHint = typeRep $ Proxy @Text , validTypeAnns = ["string"] - , dataSchema = KDL.SchemaOne KDL.TextSchema + , dataSchema = KDL.SchemaOne KDL.StringSchema } } , KDL.SchemaOne . KDL.NodeNamed "baz" $ diff --git a/test/KDL/Decoder/ArrowSpec.hs b/test/KDL/Decoder/ArrowSpec.hs --- a/test/KDL/Decoder/ArrowSpec.hs +++ b/test/KDL/Decoder/ArrowSpec.hs @@ -56,7 +56,7 @@ , dataSchema = KDL.SchemaOr [ KDL.SchemaOne KDL.BoolSchema - , KDL.SchemaOne KDL.TextSchema + , KDL.SchemaOne KDL.StringSchema ] } } @@ -70,7 +70,7 @@ KDL.TypedValueSchema { typeHint = typeRep $ Proxy @String , validTypeAnns = ["string"] - , dataSchema = KDL.SchemaOne KDL.TextSchema + , dataSchema = KDL.SchemaOne KDL.StringSchema } } , KDL.SchemaAnd [] @@ -84,7 +84,7 @@ KDL.TypedValueSchema { typeHint = typeRep $ Proxy @Text , validTypeAnns = ["string"] - , dataSchema = KDL.SchemaOne KDL.TextSchema + , dataSchema = KDL.SchemaOne KDL.StringSchema } } , KDL.SchemaOne . KDL.NodeNamed "baz" $ diff --git a/test/KDL/Decoder/SharedSpec/Template.hs b/test/KDL/Decoder/SharedSpec/Template.hs --- a/test/KDL/Decoder/SharedSpec/Template.hs +++ b/test/KDL/Decoder/SharedSpec/Template.hs @@ -27,7 +27,8 @@ decodeValueSpec, ) where -import Control.Monad (forM_, unless) +import Control.Applicative ((<|>)) +import Control.Monad (forM_, unless, void) import Data.Map qualified as Map import Data.Text (Text) import Data.Text qualified as Text @@ -307,7 +308,7 @@ KDL.decodeWith decoder config `shouldSatisfy` decodeErrorMsg [ "At: foo #0" - , " Expected arg #0" + , " Expected arg #0 with type: number" ] it "fails if arg fails to parse" $ do @@ -320,6 +321,26 @@ , " Expected string, got: 1" ] + it "shows label on missing arg" $ do + let config = "foo" + decoder = KDL.document $ _DO_ + _STMT_(KDL.label "value" $ KDL.argAt @Int "foo") + KDL.decodeWith decoder config + `shouldSatisfy` decodeErrorMsg + [ "At: foo #0" + , " Expected arg 'value' with type: number" + ] + + it "shows label on invalid arg" $ do + let config = "foo 1" + decoder = KDL.document $ _DO_ + _STMT_(KDL.label "value" $ KDL.argAt @Text "foo") + KDL.decodeWith decoder config + `shouldSatisfy` decodeErrorMsg + [ "At: foo #0 > arg 'value'" + , " Expected string, got: 1" + ] + -- Most behaviors tested with `argAt` describe "argAtWith" $ do it "gets argument at a node" $ do @@ -625,7 +646,7 @@ decodeNode "foo" decoder config `shouldSatisfy` decodeErrorMsg [ "At: foo #0" - , " Expected arg #0" + , " Expected arg #0 with type: number" ] it "fails if argument fails to parse" $ do @@ -648,6 +669,36 @@ , " Unexpected arg #1: 2" ] + it "shows label on missing arg" $ do + let config = "foo" + decoder = _DO_ + _STMT_(KDL.label "value" $ KDL.arg @Int) + decodeNode "foo" decoder config + `shouldSatisfy` decodeErrorMsg + [ "At: foo #0" + , " Expected arg 'value' with type: number" + ] + + it "shows expected types on missing arg" $ do + let config = "foo" + decoder = _DO_ + _STMT_(KDL.label "value" $ KDL.argWith $ void KDL.number <|> void KDL.string) + decodeNode "foo" decoder config + `shouldSatisfy` decodeErrorMsg + [ "At: foo #0" + , " Expected arg 'value' with type: number or string" + ] + + it "shows label on invalid arg" $ do + let config = "foo test" + decoder = _DO_ + _STMT_(KDL.label "value" $ KDL.arg @Int) + decodeNode "foo" decoder config + `shouldSatisfy` decodeErrorMsg + [ "At: foo #0 > arg 'value'" + , " Expected number, got: test" + ] + -- Most behaviors tested with `arg` describe "argWith" $ do it "decodes an argument" $ do @@ -733,7 +784,7 @@ decodeNode "foo" decoder config `shouldSatisfy` decodeErrorMsg [ "At: foo #0" - , " Expected prop: test" + , " Expected prop 'test' with type: number" ] it "fails if prop fails to parse" $ do @@ -754,6 +805,16 @@ `shouldSatisfy` decodeErrorMsg [ "At: foo #0" , " Unexpected prop: b=2" + ] + + it "shows expected types on missing prop" $ do + let config = "foo 123" + decoder = _DO_ + _STMT_(KDL.propWith "test" $ void KDL.number <|> void KDL.string) + decodeNode "foo" decoder config + `shouldSatisfy` decodeErrorMsg + [ "At: foo #0" + , " Expected prop 'test' with type: number or string" ] -- Most behaviors tested with `prop` diff --git a/test/KDL/DecoderSpec.hs b/test/KDL/DecoderSpec.hs --- a/test/KDL/DecoderSpec.hs +++ b/test/KDL/DecoderSpec.hs @@ -2,10 +2,12 @@ module KDL.DecoderSpec (spec) where -import Control.Monad (when) +import Control.Monad (unless, when) +import Data.Char (isAlpha) import Data.Text (Text) import Data.Text qualified as Text import KDL qualified +import KDL.TestUtils.Error (decodeErrorMsg) import KDL.Types (Node) import Skeletest import Skeletest.Predicate qualified as P @@ -76,9 +78,38 @@ $ KDL.optional (KDL.prop @Text "a") KDL.decodeFileWith decoder file `shouldSatisfy` P.returns (decodeErrorMsgSnapshot (Just file)) + spec_regressionTests + newtype FixtureKdlFile = FixtureKdlFile FilePath instance Fixture FixtureKdlFile where fixtureAction = do FixtureTmpDir tmpdir <- getFixture pure . noCleanup $ FixtureKdlFile (tmpdir "kdl-hs-test.kdl") + +{----- Regression tests -----} + +spec_regressionTests :: Spec +spec_regressionTests = do + describe "Regression tests" $ do + it "fails with correct error when error occurs in another node after backtracking in a previous node" $ do + let config = "user a { foo { bar } }; user a1" + decoder = + KDL.document . KDL.many . KDL.nodeWith "user" $ do + _ <- + KDL.children . KDL.many . KDL.nodeWith "foo" $ do + KDL.children . KDL.nodeWith "bar" $ do + KDL.children $ + sequence + [ KDL.optional $ KDL.node @KDL.Node "opt1" + , KDL.optional $ KDL.node @KDL.Node "opt2" + ] + KDL.argWith $ do + s <- KDL.string + unless (Text.all isAlpha s) $ do + KDL.fail "Invalid username" + KDL.decodeWith decoder config + `shouldSatisfy` decodeErrorMsg + [ "At: user #1 > arg #0" + , " Invalid username" + ]