diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,5 +1,10 @@ ## [_Unreleased_](https://github.com/pbrisbin/yaml-marked/compare/v0.1.0.0...main) +## [v0.2.0.0](https://github.com/pbrisbin/yaml-marked/compare/v0.1.0.0...v0.2.0.0) + +- Prepend errors with JSON path information +- Add `markedJSONPath` + ## [v0.1.0.0](https://github.com/pbrisbin/yaml-marked/tree/v0.1.0.0) First tagged release. diff --git a/src/Data/Aeson/Compat.hs b/src/Data/Aeson/Compat.hs --- a/src/Data/Aeson/Compat.hs +++ b/src/Data/Aeson/Compat.hs @@ -3,16 +3,32 @@ module Data.Aeson.Compat #if MIN_VERSION_aeson(2, 0, 0) ( module Data.Aeson + , parseEither ) where import Data.Aeson + +#if MIN_VERSION_aeson(2, 1, 0) +import Prelude +import Data.Aeson.Types (Parser, IResult(..), iparse) + +parseEither :: (a -> Parser b) -> a -> Either String b +parseEither f a = case iparse f a of + IError _ x -> Left x + ISuccess b -> Right b #else +import Data.Aeson.Types (parseEither) +#endif + +#else ( Key , module Data.Aeson + , parseEither ) where import Data.Aeson import Data.Text (Text) +import Data.Aeson.Types (parseEither) type Key = Text #endif diff --git a/src/Data/Aeson/Compat/Key.hs b/src/Data/Aeson/Compat/Key.hs --- a/src/Data/Aeson/Compat/Key.hs +++ b/src/Data/Aeson/Compat/Key.hs @@ -4,13 +4,14 @@ ( Key , fromText , toText + , toString ) where #if MIN_VERSION_aeson(2, 0, 0) import Data.Aeson.Key #else -import Prelude (id) -import Data.Text (Text) +import Prelude +import Data.Text (Text, unpack) type Key = Text @@ -19,4 +20,7 @@ toText :: Key -> Text toText = id + +toString :: Key -> String +toString = unpack . toText #endif diff --git a/src/Data/Yaml/Marked.hs b/src/Data/Yaml/Marked.hs --- a/src/Data/Yaml/Marked.hs +++ b/src/Data/Yaml/Marked.hs @@ -9,12 +9,14 @@ import Prelude +import Data.Aeson (JSONPath) import Numeric.Natural import Text.Libyaml (Event, MarkedEvent (..), YamlMark (..)) data Marked a = Marked { markedItem :: a , markedPath :: FilePath + , markedJSONPath :: Maybe JSONPath , markedLocationStart :: Location -- ^ Location of the first character of the item -- @@ -59,6 +61,7 @@ Marked { markedItem = yamlEvent , markedPath = fp + , markedJSONPath = Nothing , markedLocationStart = locationFromYamlMark yamlStartMark , markedLocationEnd = locationFromYamlMark yamlEndMark } diff --git a/src/Data/Yaml/Marked/Internal.hs b/src/Data/Yaml/Marked/Internal.hs --- a/src/Data/Yaml/Marked/Internal.hs +++ b/src/Data/Yaml/Marked/Internal.hs @@ -121,6 +121,7 @@ Marked { markedItem = Null , markedPath = fp + , markedJSONPath = Nothing , markedLocationStart = Location 0 0 0 , markedLocationEnd = Location 0 0 0 } @@ -213,10 +214,12 @@ peekC >>= \case Just me | EventSequenceEnd <- markedItem me -> do dropC 1 + path <- asks reverse let res = Marked { markedItem = Array $ V.fromList $ front [] , markedPath = markedPath me + , markedJSONPath = Just path , markedLocationStart = startLocation , markedLocationEnd = fromMaybe startLocation mEndLocation } @@ -238,10 +241,12 @@ parseMapping startLocation mEndLocation mergedKeys a front = headC >>= \case Just me | EventMappingEnd <- markedItem me -> do + path <- asks reverse let res = Marked { markedItem = Object front , markedPath = markedPath me + , markedJSONPath = Just path , markedLocationStart = startLocation , markedLocationEnd = fromMaybe startLocation mEndLocation } @@ -255,7 +260,7 @@ | EventAlias an <- markedItem me' -> lookupAliasKey an _ -> do - path <- ask + path <- asks reverse throwIO $ NonStringKey path ((mergedKeys', al'), endLocation) <- local (Key s :) $ do @@ -303,7 +308,9 @@ -> ConduitT (Marked Event) o Parse (Marked Value) parseScalar me v tag style a = do s <- parseScalarText me v tag style a - pure $ textToValue style tag s <$ me + let mv = textToValue style tag s <$ me + path <- lift $ asks reverse + pure $ mv {markedJSONPath = Just path} parseScalarKey :: Marked Event diff --git a/src/Data/Yaml/Marked/Parse.hs b/src/Data/Yaml/Marked/Parse.hs --- a/src/Data/Yaml/Marked/Parse.hs +++ b/src/Data/Yaml/Marked/Parse.hs @@ -13,13 +13,18 @@ , double , int , bool + + -- * Lower-level + , withPrependedPath ) where import Prelude import Data.Aeson.Compat (FromJSON, Key) import qualified Data.Aeson.Compat as Aeson +import qualified Data.Aeson.Compat.Key as Key import qualified Data.Aeson.Compat.KeyMap as KeyMap +import Data.Aeson.Types (formatRelativePath) import Data.Bifunctor (first) import Data.Foldable (toList) import Data.Scientific (Scientific) @@ -32,7 +37,7 @@ -> (MarkedObject -> Either String a) -> Marked Value -> Either String (Marked a) -withObject label f = traverse $ \case +withObject label f = withPrependedPath $ \case Object hm -> f hm v -> prependContext label $ typeMismatch "Object" v @@ -41,7 +46,7 @@ -> (MarkedArray -> Either String a) -> Marked Value -> Either String (Marked a) -withArray label f = traverse $ \case +withArray label f = withPrependedPath $ \case Array v -> f v v -> prependContext label $ typeMismatch "Array" v @@ -50,7 +55,7 @@ -> (Text -> Either String a) -> Marked Value -> Either String (Marked a) -withText label f = traverse $ \case +withText label f = withPrependedPath $ \case String t -> f t v -> prependContext label $ typeMismatch "String" v @@ -59,7 +64,7 @@ -> (Scientific -> Either String a) -> Marked Value -> Either String (Marked a) -withScientific label f = traverse $ \case +withScientific label f = withPrependedPath $ \case Number s -> f s v -> prependContext label $ typeMismatch "Number" v @@ -68,7 +73,7 @@ -> (Bool -> Either String a) -> Marked Value -> Either String (Marked a) -withBool label f = traverse $ \case +withBool label f = withPrependedPath $ \case Bool b -> f b v -> prependContext label $ typeMismatch "Bool" v @@ -90,7 +95,7 @@ prefix = "expected " <> expected <> ", but encountered " (.:) :: MarkedObject -> Key -> Either String (Marked Value) -(.:) km k = maybe (Left "Key not found") Right $ KeyMap.lookup k km +(.:) km k = maybe (Left $ "Key not found: " <> Key.toString k) Right $ KeyMap.lookup k km (.:?) :: MarkedObject -> Key -> Either String (Maybe (Marked Value)) (.:?) km k = Right $ KeyMap.lookup k km @@ -103,7 +108,7 @@ -- | Parse the value using its 'FromJSON' instance, passing along the marks json :: FromJSON a => Marked Value -> Either String (Marked a) -json = traverse valueAsJSON +json = withPrependedPath valueAsJSON value :: Marked Value -> Either String (Marked Aeson.Value) value = json @@ -119,3 +124,24 @@ bool :: Marked Value -> Either String (Marked Bool) bool = json + +-- | Prepend an error with an item's 'markedJSONPath', when present +-- +-- All of the functions above do this already. You would only need this if +-- you're writing something that doesn't us them. +withPrependedPath + :: (val -> Either String a) + -> Marked val + -> Either String (Marked a) +withPrependedPath f mv = first format $ traverse f mv + where + format :: String -> String + format = case markedJSONPath mv of + Nothing -> id + Just [] -> prependPathElem "Error in $" + Just xs -> prependPathElem $ formatRelativePath [last xs] + +prependPathElem :: String -> String -> String +prependPathElem prefix = \case + ys@('[' : _) -> prefix <> ys -- ys is "[k]", make it (e.g.) "$[k]" + ys -> prefix <> ": " <> ys -- ys is "{...}", make it (e.g.) "$: {...}" diff --git a/src/Data/Yaml/Marked/Value.hs b/src/Data/Yaml/Marked/Value.hs --- a/src/Data/Yaml/Marked/Value.hs +++ b/src/Data/Yaml/Marked/Value.hs @@ -10,8 +10,8 @@ import Data.Aeson (FromJSON (..)) import qualified Data.Aeson as Aeson +import Data.Aeson.Compat (parseEither) import Data.Aeson.Compat.KeyMap (KeyMap) -import Data.Aeson.Types (parseEither) import Data.Scientific (Scientific) import Data.Text (Text) import Data.Vector (Vector) diff --git a/test/Data/Yaml/Marked/DecodeSpec.hs b/test/Data/Yaml/Marked/DecodeSpec.hs --- a/test/Data/Yaml/Marked/DecodeSpec.hs +++ b/test/Data/Yaml/Marked/DecodeSpec.hs @@ -4,7 +4,9 @@ import Prelude +import Data.Aeson.Types (JSONPathElement (..)) import Data.Functor.Alt (()) +import Data.List (isPrefixOf) import Data.Text (Text) import Data.Yaml.Marked import Data.Yaml.Marked.Decode @@ -32,7 +34,7 @@ deriving stock (Eq, Show) decodeExtraDep :: Marked Value -> Either String (Marked ExtraDep) -decodeExtraDep x = (fmap Git <$> decodeGitCommit x) (fmap Plain <$> text x) +decodeExtraDep x = (fmap Plain <$> text x) (fmap Git <$> decodeGitCommit x) data GitCommit = GitCommit { git :: Marked Text @@ -80,6 +82,7 @@ Marked { markedItem = "lts-20.11" , markedPath = "" + , markedJSONPath = Just [Key "resolver"] , markedLocationStart = Location 10 0 10 , markedLocationEnd = Location 19 0 19 } @@ -89,12 +92,14 @@ [ Marked { markedItem = Plain "../local-package" , markedPath = "" + , markedJSONPath = Just [Key "extra-deps", Index 0] , markedLocationStart = Location 45 3 3 , markedLocationEnd = Location 61 3 19 } , Marked { markedItem = Plain "hackage-dep-1.0" , markedPath = "" + , markedJSONPath = Just [Key "extra-deps", Index 1] , markedLocationStart = Location 87 6 3 , markedLocationEnd = Location 102 6 18 } @@ -106,6 +111,7 @@ Marked { markedItem = "foo" , markedPath = "" + , markedJSONPath = Just [Key "extra-deps", Index 2, Key "git"] , markedLocationStart = Location 125 9 8 , markedLocationEnd = Location 128 9 11 } @@ -113,22 +119,26 @@ Marked { markedItem = "abc" , markedPath = "" + , markedJSONPath = Just [Key "extra-deps", Index 2, Key "commit"] , markedLocationStart = Location 140 10 11 , markedLocationEnd = Location 143 10 14 } } , markedPath = "" + , markedJSONPath = Just [Key "extra-deps", Index 2] , markedLocationStart = Location 120 9 3 , markedLocationEnd = Location 143 10 14 } , Marked { markedItem = Plain "foo-0.0.0" , markedPath = "" + , markedJSONPath = Just [Key "extra-deps", Index 3] , markedLocationStart = Location 159 13 3 , markedLocationEnd = Location 168 13 12 } ] , markedPath = "" + , markedJSONPath = Just [Key "extra-deps"] , markedLocationStart = Location 43 3 1 , markedLocationEnd = Location 168 13 12 } @@ -136,11 +146,52 @@ Marked { markedItem = True , markedPath = "" + , markedJSONPath = Just [Key "some-setting"] , markedLocationStart = Location 184 15 14 , markedLocationEnd = Location 187 15 17 } } , markedPath = "" + , markedJSONPath = Just [] , markedLocationStart = Location 0 0 0 , markedLocationEnd = Location 187 15 17 } + + context "errors" $ do + it "incorrect type" $ do + let exampleYaml = + mconcat + [ "resolver: lts-20.11\n" + , "extra-deps:\n" + , " - Yes\n" -- expected String, encountered Boolean + ] + + decodeThrow decodeStackYaml "" exampleYaml + `shouldThrow` aesonExceptionPrefixed "Error in $['extra-deps'][0]: " + + it "missing key" $ do + let exampleYaml = + mconcat + [ "extra-deps:\n" + , " - foo-1.0.1\n" + ] + + decodeThrow decodeStackYaml "" exampleYaml + `shouldThrow` aesonExceptionPrefixed "Error in $: Key not found" + + it "missing nested key" $ do + let exampleYaml = + mconcat + [ "resolver: lts-20.11\n" + , "extra-deps:\n" + , " - foo-1.0.1\n" + , " - git: abc\n" -- no commit + ] + + decodeThrow decodeStackYaml "" exampleYaml + `shouldThrow` aesonExceptionPrefixed "Error in $['extra-deps'][1]: Key not found: commit" + +aesonExceptionPrefixed :: String -> ParseException -> Bool +aesonExceptionPrefixed x = \case + AesonException msg -> x `isPrefixOf` msg + _ -> False diff --git a/yaml-marked.cabal b/yaml-marked.cabal --- a/yaml-marked.cabal +++ b/yaml-marked.cabal @@ -1,6 +1,6 @@ cabal-version: 1.18 name: yaml-marked -version: 0.1.0.0 +version: 0.2.0.0 license: MIT license-file: LICENSE maintainer: Pat Brisbin