aeson-match-qq 1.5.1 → 1.5.2

raw patch · 5 files changed

+221/−42 lines, 5 filesdep +prettyPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

Dependencies added: pretty

API changes (from Hackage documentation)

Files

• CHANGELOG.markdown +5/−0
• aeson-match-qq.cabal +2/−1
• src/Aeson/Match/QQ.hs +12/−2
• src/Aeson/Match/QQ/Internal/Match.hs +157/−39
• test/Aeson/Match/QQSpec.hs +45/−0

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

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

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

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

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