diff --git a/CHANGELOG.markdown b/CHANGELOG.markdown --- a/CHANGELOG.markdown +++ b/CHANGELOG.markdown @@ -1,3 +1,8 @@ +1.5.2 +===== + + * Add `prettyError`, a pretty printer for `Error`s (https://github.com/supki/aeson-match-qq/pull/23) + 1.5.1 ===== diff --git a/aeson-match-qq.cabal b/aeson-match-qq.cabal --- a/aeson-match-qq.cabal +++ b/aeson-match-qq.cabal @@ -5,7 +5,7 @@ -- see: https://github.com/sol/hpack name: aeson-match-qq -version: 1.5.1 +version: 1.5.2 synopsis: Declarative JSON matchers. description: See README.markdown category: Web @@ -44,6 +44,7 @@ , containers , either , haskell-src-meta + , pretty , scientific , template-haskell , text diff --git a/src/Aeson/Match/QQ.hs b/src/Aeson/Match/QQ.hs --- a/src/Aeson/Match/QQ.hs +++ b/src/Aeson/Match/QQ.hs @@ -15,14 +15,18 @@ , TypeSig(..) , Type(..) , Nullable(..) - , Path + , Path(..) , PathElem(..) + + , prettyError ) where import Data.String (IsString(..)) import qualified Data.Text.Encoding as Text import Language.Haskell.TH.Quote (QuasiQuoter(..)) import Language.Haskell.TH.Syntax (Lift(..)) +import qualified Text.PrettyPrint as PP (render) +import qualified Text.PrettyPrint.HughesPJClass as PP (Pretty(..)) import Aeson.Match.QQ.Internal.Match ( match @@ -31,7 +35,7 @@ , MissingPathElem(..) , ExtraArrayValues(..) , ExtraObjectValues(..) - , Path + , Path(..) , PathElem(..) ) import Aeson.Match.QQ.Internal.Parse (parse) @@ -46,6 +50,7 @@ ) +-- | Construct a matcher 'Value'. qq :: QuasiQuoter qq = QuasiQuoter { quoteExp = \str -> @@ -61,3 +66,8 @@ , quoteDec = \_ -> error "Aeson.Match.QQ.qq: no quoteDec" } + +-- | Pretty print an 'Error'. +prettyError :: Error -> String +prettyError = + PP.render . PP.pPrint diff --git a/src/Aeson/Match/QQ/Internal/Match.hs b/src/Aeson/Match/QQ/Internal/Match.hs --- a/src/Aeson/Match/QQ/Internal/Match.hs +++ b/src/Aeson/Match/QQ/Internal/Match.hs @@ -1,10 +1,12 @@ {-# LANGUAGE CPP #-} {-# LANGUAGE ApplicativeDo #-} {-# LANGUAGE DuplicateRecordFields #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE UndecidableInstances #-} {-# LANGUAGE ViewPatterns #-} module Aeson.Match.QQ.Internal.Match ( match @@ -13,7 +15,7 @@ , MissingPathElem(..) , ExtraArrayValues(..) , ExtraObjectValues(..) - , Path + , Path(..) , PathElem(..) ) where @@ -25,6 +27,7 @@ import qualified Data.Aeson.KeyMap as Aeson (toHashMapText) #endif import Data.Bool (bool) +import qualified Data.ByteString.Lazy.Char8 as ByteString.Lazy import qualified Data.CaseInsensitive as CI import Data.Either.Validation ( Validation(..) @@ -34,14 +37,27 @@ import Data.Foldable (for_, toList) import Data.HashMap.Strict (HashMap) import qualified Data.HashMap.Strict as HashMap +import qualified Data.List as List import Data.List.NonEmpty (NonEmpty) import Data.Maybe (mapMaybe) import qualified Data.Set as Set import Data.String (IsString(..)) import Data.Text (Text) +import qualified Data.Text as Text import Data.Vector (Vector) import qualified Data.Vector as Vector +import GHC.Exts (IsList) import Prelude hiding (any, null) +import qualified Text.PrettyPrint as PP + ( Doc + , vcat + , hsep + , brackets + , text + , char + , int + ) +import qualified Text.PrettyPrint.HughesPJClass as PP (Pretty(..)) import Aeson.Match.QQ.Internal.Value ( Value(..) @@ -56,7 +72,7 @@ -- | Test if a matcher matches a 'Aeson.Value'. match :: Value Aeson.Value - -- ^ A 'qq`-created 'Value' + -- ^ A matcher -> Aeson.Value -- ^ A 'Value' from aeson -> Either (NonEmpty Error) (HashMap Text Aeson.Value) @@ -66,8 +82,8 @@ validationToEither (go [] matcher0 given0) where go path matcher given = do - let mismatched = mismatch (reverse path) matcher given - mistyped = mistype (reverse path) matcher given + let mismatched = mismatch path matcher given + mistyped = mistype path matcher given case (matcher, given) of (Any holeTypeO nameO, val) -> do for_ holeTypeO $ \holeType -> @@ -112,9 +128,9 @@ in unless (extendable || Vector.null extraValues) - (extraArrayValues (reverse path) extraValues) *> + (extraArrayValues path extraValues) *> fold - (\i v -> maybe (missingPathElem (reverse path) (Idx i)) (go (Idx i : path) v) (arr Vector.!? i)) + (\i v -> maybe (missingPathElem path (Idx i)) (go (Idx i : path) v) (arr Vector.!? i)) knownValues (Array _, _) -> do mistyped @@ -139,9 +155,9 @@ in unless (extendable || HashMap.null extraValues) - (extraObjectValues (reverse path) extraValues) *> + (extraObjectValues path extraValues) *> fold - (\k v -> maybe (missingPathElem (reverse path) (Key k)) (go (Key k : path) v) (HashMap.lookup k o)) + (\k v -> maybe (missingPathElem path (Key k)) (go (Key k : path) v) (HashMap.lookup k o)) knownValues (Object _, _) -> do mistyped @@ -164,7 +180,7 @@ matchArrayUO :: Validation (NonEmpty Error) (HashMap Text Aeson.Value) - -> Path + -> [PathElem] -> Box (Vector (Value Aeson.Value)) -> Vector Aeson.Value -> Validation (NonEmpty Error) (HashMap Text Aeson.Value) @@ -188,7 +204,7 @@ | length ivs < length xs && not extendable -> do let is = Set.fromList (map fst ivs) extraValues = Vector.ifilter (\i _ -> not (i `Set.member` is)) xs - extraArrayValues (reverse path) extraValues + extraArrayValues path extraValues | otherwise -> pure (foldMap snd ivs) where @@ -220,24 +236,41 @@ I (a, _) `compare` I (b, _) = a `compare` b -mismatch :: Path -> Value Aeson.Value -> Aeson.Value -> Validation (NonEmpty Error) a -mismatch path matcher given = +mismatch + :: [PathElem] + -> Value Aeson.Value + -> Aeson.Value + -> Validation (NonEmpty Error) a +mismatch (Path . reverse -> path) matcher given = throwE (Mismatch MkMismatch {..}) -mistype :: Path -> Value Aeson.Value -> Aeson.Value -> Validation (NonEmpty Error) a -mistype path matcher given = +mistype + :: [PathElem] + -> Value Aeson.Value + -> Aeson.Value + -> Validation (NonEmpty Error) a +mistype (Path . reverse -> path) matcher given = throwE (Mistype MkMismatch {..}) -missingPathElem :: Path -> PathElem -> Validation (NonEmpty Error) a -missingPathElem path missing = +missingPathElem + :: [PathElem] + -> PathElem + -> Validation (NonEmpty Error) a +missingPathElem (Path . reverse -> path) missing = throwE (MissingPathElem MkMissingPathElem {..}) -extraArrayValues :: Path -> Vector Aeson.Value -> Validation (NonEmpty Error) a -extraArrayValues path values = +extraArrayValues + :: [PathElem] + -> Vector Aeson.Value + -> Validation (NonEmpty Error) a +extraArrayValues (Path . reverse -> path) values = throwE (ExtraArrayValues MkExtraArrayValues {..}) -extraObjectValues :: Path -> HashMap Text Aeson.Value -> Validation (NonEmpty Error) a -extraObjectValues path values = +extraObjectValues + :: [PathElem] + -> HashMap Text Aeson.Value + -> Validation (NonEmpty Error) a +extraObjectValues (Path . reverse -> path) values = throwE (ExtraObjectValues MkExtraObjectValues {..}) throwE :: e -> Validation (NonEmpty e) a @@ -252,6 +285,34 @@ | ExtraObjectValues ExtraObjectValues deriving (Show, Eq) +instance PP.Pretty Error where + pPrint = \case + Mismatch err -> + PP.vcat + [ " error: value does not match" + , PP.pPrint err + ] + Mistype err -> + PP.vcat + [ " error: type of value does not match" + , PP.pPrint err + ] + MissingPathElem err -> + PP.vcat + [ " error: missing key or index" + , PP.pPrint err + ] + ExtraArrayValues err -> + PP.vcat + [ " error: extra array values" + , PP.pPrint err + ] + ExtraObjectValues err -> + PP.vcat + [ " error: extra object values" + , PP.pPrint err + ] + instance Aeson.ToJSON Error where toJSON = Aeson.object . \case @@ -276,8 +337,30 @@ , "value" .= v ] +data Mismatch = MkMismatch + { path :: Path + , matcher :: Value Aeson.Value + , given :: Aeson.Value + } deriving (Show, Eq) + +instance Aeson.ToJSON Mismatch where + toJSON MkMismatch {..} = + Aeson.object + [ "path" .= path + , "matcher" .= matcher + , "given" .= given + ] + +instance PP.Pretty Mismatch where + pPrint MkMismatch {..} = + PP.vcat + [ PP.hsep [" path:", PP.pPrint path] + , PP.hsep ["matcher:", ppJson matcher] + , PP.hsep [" given:", ppJson given] + ] + data MissingPathElem = MkMissingPathElem - { path :: Path + { path :: Path , missing :: PathElem } deriving (Show, Eq) @@ -288,22 +371,15 @@ , "missing" .= missing ] -data Mismatch = MkMismatch - { path :: Path - , matcher :: Value Aeson.Value - , given :: Aeson.Value - } deriving (Show, Eq) - -instance Aeson.ToJSON Mismatch where - toJSON MkMismatch {..} = - Aeson.object - [ "path" .= path - , "matcher" .= matcher - , "given" .= given +instance PP.Pretty MissingPathElem where + pPrint (MkMissingPathElem {..}) = + PP.vcat + [ PP.hsep [" path:", PP.pPrint path] + , PP.hsep ["missing:", PP.pPrint missing] ] data ExtraArrayValues = MkExtraArrayValues - { path :: Path + { path :: Path , values :: Vector Aeson.Value } deriving (Show, Eq) @@ -314,8 +390,18 @@ , "values" .= values ] +instance PP.Pretty ExtraArrayValues where + pPrint MkExtraArrayValues {..} = + PP.vcat + [ PP.hsep [" path:", PP.pPrint path] + , PP.hsep + [ " values:" + , PP.vcat (map ppJson (toList values)) + ] + ] + data ExtraObjectValues = MkExtraObjectValues - { path :: Path + { path :: Path , values :: HashMap Text Aeson.Value } deriving (Show, Eq) @@ -326,13 +412,38 @@ , "values" .= values ] -type Path = [PathElem] +instance PP.Pretty ExtraObjectValues where + pPrint MkExtraObjectValues {..} = + PP.vcat + [ PP.hsep [" path:", PP.pPrint path] + , PP.hsep + [ " values:" + , PP.vcat ((map prettyKV . List.sortOn fst . HashMap.toList) values) + ] + ] + where + prettyKV (k, v) = + PP.vcat + [ PP.hsep [" key:", PP.pPrint (Key k)] + , PP.hsep ["value:", ppJson v] + ] +newtype Path = Path { unPath :: [PathElem] } + deriving (Show, Eq, IsList, Aeson.ToJSON) + +instance PP.Pretty Path where + pPrint = + foldMap PP.pPrint . unPath + data PathElem = Key Text | Idx Int deriving (Show, Eq) +instance IsString PathElem where + fromString = + Key . fromString + instance Aeson.ToJSON PathElem where toJSON = \case Key k -> @@ -340,9 +451,16 @@ Idx i -> Aeson.Number (fromIntegral i) -instance IsString PathElem where - fromString = - Key . fromString +instance PP.Pretty PathElem where + pPrint = \case + Key k -> + PP.char '.' <> PP.text (Text.unpack k) + Idx i -> + PP.brackets (PP.int i) + +ppJson :: Aeson.ToJSON a => a -> PP.Doc +ppJson = + PP.text . ByteString.Lazy.unpack . Aeson.encode imapMaybe :: (Int -> a -> Maybe b) -> [a] -> [b] imapMaybe f = diff --git a/test/Aeson/Match/QQSpec.hs b/test/Aeson/Match/QQSpec.hs --- a/test/Aeson/Match/QQSpec.hs +++ b/test/Aeson/Match/QQSpec.hs @@ -199,6 +199,51 @@ , given = Aeson.Number 4 }) + it "pretty" $ do + prettyError (Mismatch MkMismatch + { path = [Key "foo", Idx 0, Key "bar"] + , matcher = String "foo" + , given = Aeson.String "bar" + }) `shouldBe` + " error: value does not match\n\ + \ path: .foo[0].bar\n\ + \matcher: {\"value\":\"foo\",\"type\":\"string\"}\n\ + \ given: \"bar\"" + prettyError (Mistype MkMismatch + { path = [Key "foo", Idx 0, Key "bar"] + , matcher = String "foo" + , given = Aeson.Number 4 + }) `shouldBe` + " error: type of value does not match\n\ + \ path: .foo[0].bar\n\ + \matcher: {\"value\":\"foo\",\"type\":\"string\"}\n\ + \ given: 4" + prettyError (MissingPathElem MkMissingPathElem + { path = [Key "foo", Idx 0, Key "bar"] + , missing = Idx 1 + }) `shouldBe` + " error: missing key or index\n\ + \ path: .foo[0].bar\n\ + \missing: [1]" + prettyError (ExtraArrayValues MkExtraArrayValues + { path = [Key "foo", Idx 0, Key "bar"] + , values = [Aeson.String "foo", Aeson.Number 4] + }) `shouldBe` + " error: extra array values\n\ + \ path: .foo[0].bar\n\ + \ values: \"foo\"\n\ + \ 4" + prettyError (ExtraObjectValues MkExtraObjectValues + { path = [Key "foo", Idx 0, Key "bar"] + , values = HashMap.fromList [("k0", Aeson.String "foo"), ("k1", Aeson.Number 4)] + }) `shouldBe` + " error: extra object values\n\ + \ path: .foo[0].bar\n\ + \ values: key: .k0\n\ + \ value: \"foo\"\n\ + \ key: .k1\n\ + \ value: 4" + newtype ToEncoding a = ToEncoding { unToEncoding :: a } deriving (Show, Eq, Num)