kdl-hs 1.1.1 → 1.2.0

raw patch · 10 files changed

+273/−78 lines, 10 filesPVP ok

version bump matches the API change (PVP)

API changes (from Hackage documentation)

Files

• CHANGELOG.md +8/−0
• kdl-hs.cabal +5/−2
• src/KDL/Decoder/Arrow.hs +65/−28
• src/KDL/Decoder/Internal/DecodeM.hs +33/−31
• src/KDL/Decoder/Internal/Error.hs +34/−5
• src/KDL/Decoder/Schema.hs +25/−1
• test/KDL/ApplicativeSpec.hs +3/−3
• test/KDL/Decoder/ArrowSpec.hs +3/−3
• test/KDL/Decoder/SharedSpec/Template.hs +65/−4
• test/KDL/DecoderSpec.hs +32/−1

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

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

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

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

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

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

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

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

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

@@ -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"+          ]