Show filepath in error message in decodeFileWith

Author: brandonchinn178

kdl-hs.cabal

@@ -69,6 +69,7 @@ test-suite kdl-tests
   build-depends:
       base
     , containers
+    , filepath
     , kdl-hs
     , skeletest
     , temporary

src/KDL/Decoder/Arrow.hs

@@ -92,6 +92,7 @@ import Control.Monad (unless, when)
 import Control.Monad.Trans.Class qualified as Trans
 import Control.Monad.Trans.State.Strict (StateT)
 import Control.Monad.Trans.State.Strict qualified as StateT
+import Data.Bifunctor (first)
 import Data.Bits (finiteBitSize)
 import Data.Int (Int64)
 import Data.List (partition)
@@ -134,22 +135,27 @@ import Prelude qualified
 
 -- | Decode the given KDL configuration with the given decoder.
 decodeWith :: DocumentDecoder a -> Text -> Either DecodeError a
-decodeWith decoder = decodeFromParseResult decoder . parse
+decodeWith decoder = decodeFromParseResult decoder Nothing . parse
 
 -- | Read KDL configuration from the given file path and decode it with the given decoder.
 decodeFileWith :: DocumentDecoder a -> FilePath -> IO (Either DecodeError a)
-decodeFileWith decoder = fmap (decodeFromParseResult decoder) . parseFile
+decodeFileWith decoder fp = decodeFromParseResult decoder (Just fp) <$> parseFile fp
 
 -- | Decode an already-parsed 'Document' with the given decoder.
 decodeDocWith :: DocumentDecoder a -> Document -> Either DecodeError a
 decodeDocWith (UnsafeDocumentDecoder decoder) doc =
   runDecodeM . runDecodeStateM doc emptyDecodeHistory $
     decoder.run ()
 
-decodeFromParseResult :: DocumentDecoder a -> Either Text Document -> Either DecodeError a
-decodeFromParseResult decoder = \case
-  Left e -> runDecodeM . decodeThrow $ DecodeError_ParseError e
-  Right doc -> decodeDocWith decoder doc
+decodeFromParseResult ::
+  DocumentDecoder a ->
+  Maybe FilePath ->
+  Either Text Document ->
+  Either DecodeError a
+decodeFromParseResult decoder mPath =
+  first (\e -> e{filepath = mPath}) . \case
+    Left e -> runDecodeM . decodeThrow $ DecodeError_ParseError e
+    Right doc -> decodeDocWith decoder doc
 
 {----- Decoder -----}
 

src/KDL/Decoder/Internal/DecodeM.hs

@@ -1,5 +1,6 @@
 {-# LANGUAGE DuplicateRecordFields #-}
 {-# LANGUAGE LambdaCase #-}
+{-# LANGUAGE OverloadedRecordDot #-}
 {-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE RecordWildCards #-}
 {-# LANGUAGE NoFieldSelectors #-}
@@ -70,7 +71,7 @@ runDecodeM (DecodeM f) = f Left Left Right
 -- This error is non-fatal and can be handled by '<|>'. See 'makeFatal'
 -- for more information.
 decodeThrow :: BaseDecodeError -> DecodeM a
-decodeThrow e = DecodeM $ \_ onFail _ -> onFail $ DecodeError [([], e)]
+decodeThrow e = DecodeM $ \_ onFail _ -> onFail $ DecodeError Nothing [([], e)]
 
 -- | Throw a 'DecodeError_Custom' error.
 failM :: Text -> DecodeM a
@@ -91,4 +92,4 @@ makeNonFatal (DecodeM f) = DecodeM $ \_ onFail onSuccess -> f onFail onFail onSu
 addContext :: ContextItem -> DecodeM a -> DecodeM a
 addContext ctxItem (DecodeM f) = DecodeM $ \onFatal onFail onSuccess -> f (onFatal . addCtx) (onFail . addCtx) onSuccess
  where
-  addCtx (DecodeError es) = DecodeError [(ctxItem : ctx, msg) | (ctx, msg) <- es]
+  addCtx e = e{errors = [(ctxItem : ctx, msg) | (ctx, msg) <- e.errors]}

src/KDL/Decoder/Internal/Error.hs

@@ -1,5 +1,6 @@
 {-# LANGUAGE DuplicateRecordFields #-}
 {-# LANGUAGE LambdaCase #-}
+{-# LANGUAGE OverloadedRecordDot #-}
 {-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE RecordWildCards #-}
 {-# LANGUAGE NoFieldSelectors #-}
@@ -12,6 +13,7 @@ module KDL.Decoder.Internal.Error (
   renderDecodeError,
 ) where
 
+import Control.Applicative ((<|>))
 import Data.Map qualified as Map
 import Data.Text (Text)
 import Data.Text qualified as Text
@@ -24,12 +26,15 @@ import KDL.Types (
   Value,
  )
 
-data DecodeError = DecodeError [(Context, BaseDecodeError)]
+data DecodeError = DecodeError
+  { filepath :: Maybe FilePath
+  , errors :: [(Context, BaseDecodeError)]
+  }
   deriving (Show, Eq)
 instance Semigroup DecodeError where
-  DecodeError e1 <> DecodeError e2 = DecodeError (e1 <> e2)
+  DecodeError fp1 e1 <> DecodeError fp2 e2 = DecodeError (fp1 <|> fp2) (e1 <> e2)
 instance Monoid DecodeError where
-  mempty = DecodeError []
+  mempty = DecodeError Nothing []
 
 type Context = [ContextItem]
 
@@ -60,10 +65,19 @@ data BaseDecodeError
   deriving (Show, Eq)
 
 renderDecodeError :: DecodeError -> Text
-renderDecodeError = Text.intercalate "\n" . map renderCtxErrors . groupCtxErrors
+renderDecodeError decodeError =
+  Text.intercalate "\n"
+    . addPath decodeError.filepath
+    . map renderCtxErrors
+    . groupCtxErrors
+    $ decodeError.errors
  where
   -- Group errors with the same contexts together
-  groupCtxErrors (DecodeError es) = Map.toAscList $ Map.fromListWith (<>) [(ctx, [e]) | (ctx, e) <- es]
+  groupCtxErrors es = Map.toAscList $ Map.fromListWith (<>) [(ctx, [e]) | (ctx, e) <- es]
+
+  addPath = \case
+    Nothing -> id
+    Just fp -> let msg = "Failed to decode " <> Text.pack fp <> ":" in (msg :)
 
   renderCtxErrors = \case
     -- Special case parse errors, which shouldn't have a context

test/KDL/DecoderSpec.hs

@@ -9,6 +9,8 @@ import KDL qualified
 import KDL.TestUtils.Error (decodeErrorMsg)
 import KDL.Types (Node)
 import Skeletest
+import Skeletest.Predicate qualified as P
+import System.FilePath ((</>))
 
 spec :: Spec
 spec = do
@@ -53,3 +55,58 @@ spec = do
           [ "At: foo #1 > bar #0 > baz #3 > prop a"
           , "  Expected text, got: 1"
           ]
+
+  describe "decodeFileWith" $ do
+    it "fails with helpful error if parsing fails" $ do
+      FixtureKdlFile file <- getFixture
+      writeFile file "foo hello= 123"
+      let decoder = KDL.document $ KDL.node @Node "foo"
+      KDL.decodeFileWith decoder file
+        `shouldSatisfy` (P.returns . decodeErrorMsg)
+          [ "Failed to decode " <> Text.pack file <> ":"
+          , "1:10:"
+          , "  |"
+          , "1 | foo hello= 123"
+          , "  |          ^^"
+          , "unexpected \"= \""
+          , "expecting Node Child, Node Space, or Node Terminator"
+          ]
+
+    it "fails with user-defined error" $ do
+      FixtureKdlFile file <- getFixture
+      writeFile file "foo -1"
+      let decoder =
+            KDL.document . KDL.argAtWith "foo" $
+              KDL.withDecoder KDL.number $ \x -> do
+                when (x < 0) $ do
+                  KDL.failM $ "Got negative number: " <> (Text.pack . show) x
+                pure x
+      KDL.decodeFileWith decoder file
+        `shouldSatisfy` (P.returns . decodeErrorMsg)
+          [ "Failed to decode " <> Text.pack file <> ":"
+          , "At: foo #0 > arg #0"
+          , "  Got negative number: -1.0"
+          ]
+
+    it "shows context in deeply nested error" $ do
+      FixtureKdlFile file <- getFixture
+      writeFile file "foo; foo { bar { baz; baz; baz; baz a=1; }; }"
+      let decoder =
+            KDL.document
+              . (KDL.many . KDL.nodeWith "foo" . KDL.children)
+              . (KDL.many . KDL.nodeWith "bar" . KDL.children)
+              . (KDL.many . KDL.nodeWith "baz")
+              $ KDL.optional (KDL.prop @Text "a")
+      KDL.decodeFileWith decoder file
+        `shouldSatisfy` (P.returns . decodeErrorMsg)
+          [ "Failed to decode " <> Text.pack file <> ":"
+          , "At: foo #1 > bar #0 > baz #3 > prop a"
+          , "  Expected text, got: 1"
+          ]
+
+newtype FixtureKdlFile = FixtureKdlFile FilePath
+
+instance Fixture FixtureKdlFile where
+  fixtureAction = do
+    FixtureTmpDir tmpdir <- getFixture
+    pure . noCleanup $ FixtureKdlFile (tmpdir </> "kdl-hs-test.kdl")