diff --git a/CHANGELOG.markdown b/CHANGELOG.markdown --- a/CHANGELOG.markdown +++ b/CHANGELOG.markdown @@ -1,3 +1,12 @@ +1.3.2 +===== + + * Improved matching errors for embedded Haskell values (https://github.com/supki/aeson-match-qq/pull/18) + + * Separate error types for type- and value- level mismatches (https://github.com/supki/aeson-match-qq/pull/18) + + * Case insensitive strings (https://github.com/supki/aeson-match-qq/pull/17) + 1.3.1 ===== diff --git a/aeson-match-qq.cabal b/aeson-match-qq.cabal --- a/aeson-match-qq.cabal +++ b/aeson-match-qq.cabal @@ -1,11 +1,11 @@ cabal-version: 1.12 --- This file has been generated from package.yaml by hpack version 0.34.6. +-- This file has been generated from package.yaml by hpack version 0.34.7. -- -- see: https://github.com/sol/hpack name: aeson-match-qq -version: 1.3.1 +version: 1.3.2 synopsis: Declarative JSON matchers. description: See README.markdown category: Web @@ -40,6 +40,7 @@ , attoparsec , base >=4.14 && <5 , bytestring + , case-insensitive , containers , either , haskell-src-meta 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 @@ -12,6 +12,7 @@ , qq , match , mismatch + , mistype , missingPathElem , extraArrayValues , extraObjectValues @@ -22,9 +23,26 @@ import Language.Haskell.TH.Quote (QuasiQuoter(..)) import Language.Haskell.TH.Syntax (Lift(..)) -import Aeson.Match.QQ.Internal.Match (Path, PathElem(..), match, mismatch, missingPathElem, extraArrayValues, extraObjectValues) +import Aeson.Match.QQ.Internal.Match + ( Path + , PathElem(..) + , match + , mismatch + , mistype + , missingPathElem + , extraArrayValues + , extraObjectValues + ) import Aeson.Match.QQ.Internal.Parse (parse) -import Aeson.Match.QQ.Internal.Value (Value(..), Box(..), Array, Object, TypeSig(..), Type(..), Nullable(..)) +import Aeson.Match.QQ.Internal.Value + ( Value(..) + , Box(..) + , Array + , Object + , TypeSig(..) + , Type(..) + , Nullable(..) + ) qq :: QuasiQuoter 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 @@ -10,9 +10,10 @@ import Control.Monad (unless) import Data.Aeson ((.=)) import qualified Data.Aeson as Aeson +import Data.Bool (bool) +import qualified Data.CaseInsensitive as CI import Data.Either.Validation (Validation(..), eitherToValidation) import Data.Foldable (for_, toList) -import Data.Bool (bool) import Data.HashMap.Strict (HashMap) import qualified Data.HashMap.Strict as HashMap import Data.List.NonEmpty (NonEmpty) @@ -24,7 +25,14 @@ import qualified Data.Vector as Vector import Prelude hiding (any, null) -import Aeson.Match.QQ.Internal.Value (Value(..), Box(..), TypeSig(..), Type(..), Nullable(..)) +import Aeson.Match.QQ.Internal.Value + ( Value(..) + , Box(..) + , TypeSig(..) + , Type(..) + , Nullable(..) + , embed + ) match @@ -36,35 +44,42 @@ where go path matcher given = do let mismatched = mismatch (reverse path) matcher given + mistyped = mistype (reverse path) matcher given case (matcher, given) of (Any holeTypeO nameO, val) -> do for_ holeTypeO $ \holeType -> unless (holeTypeMatch holeType val) - mismatched + mistyped pure (maybe mempty (\name -> HashMap.singleton name val) nameO) (Null, Aeson.Null) -> pure mempty (Null, _) -> do - mismatched + mistyped pure mempty (Bool b, Aeson.Bool b') -> do unless (b == b') mismatched pure mempty (Bool _, _) -> do - mismatched + mistyped pure mempty (Number n, Aeson.Number n') -> do unless (n == n') mismatched pure mempty (Number _, _) -> do - mismatched + mistyped pure mempty (String str, Aeson.String str') -> do unless (str == str') mismatched pure mempty (String _, _) -> do - mismatched + mistyped pure mempty + (StringCI str, Aeson.String str') -> do + unless (str == CI.mk str') mismatched + pure mempty + (StringCI _, _) -> do + mistyped + pure mempty (Array Box {knownValues, extendable}, Aeson.Array arr) -> let fold f = @@ -79,12 +94,12 @@ (\i v -> maybe (missingPathElem (reverse path) (Idx i)) (go (Idx i : path) v) (arr Vector.!? i)) knownValues (Array _, _) -> do - mismatched + mistyped pure mempty (ArrayUO box, Aeson.Array arr) -> matchArrayUO mismatched path box arr (ArrayUO _, _) -> do - mismatched + mistyped pure mempty (Object Box {knownValues, extendable}, Aeson.Object o) -> let fold f = @@ -99,11 +114,10 @@ (\k v -> maybe (missingPathElem (reverse path) (Key k)) (go (Key k : path) v) (HashMap.lookup k o)) knownValues (Object _, _) -> do - mismatched - pure mempty - (Ext val, val') -> do - unless (val == val') mismatched + mistyped pure mempty + (Ext val, val') -> + go path (embed val) val' holeTypeMatch :: TypeSig -> Aeson.Value -> Bool holeTypeMatch type_ val = @@ -112,7 +126,9 @@ (TypeSig {type_ = BoolT} , Aeson.Bool {}) -> True (TypeSig {type_ = NumberT} , Aeson.Number {}) -> True (TypeSig {type_ = StringT} , Aeson.String {}) -> True + (TypeSig {type_ = StringCIT} , Aeson.String {}) -> True (TypeSig {type_ = ArrayT} , Aeson.Array {}) -> True + (TypeSig {type_ = ArrayUOT} , Aeson.Array {}) -> True (TypeSig {type_ = ObjectT} , Aeson.Object {}) -> True (_, _) -> False @@ -178,6 +194,10 @@ mismatch path matcher given = throwE (Mismatch MkMismatch {..}) +mistype :: Path -> Value Aeson.Value -> Aeson.Value -> Validation (NonEmpty VE) a +mistype path matcher given = + throwE (Mistype MkMismatch {..}) + missingPathElem :: Path -> PathElem -> Validation (NonEmpty VE) a missingPathElem path missing = throwE (MissingPathElem MkMissingPathElem {..}) @@ -196,6 +216,7 @@ data VE = Mismatch Mismatch + | Mistype Mismatch | MissingPathElem MissingPathElem | ExtraArrayValues ExtraArrayValues | ExtraObjectValues ExtraObjectValues @@ -206,6 +227,10 @@ Aeson.object . \case Mismatch v -> [ "type" .= ("mismatch" :: Text) + , "value" .= v + ] + Mistype v -> + [ "type" .= ("mistype" :: Text) , "value" .= v ] MissingPathElem v -> diff --git a/src/Aeson/Match/QQ/Internal/Parse.hs b/src/Aeson/Match/QQ/Internal/Parse.hs --- a/src/Aeson/Match/QQ/Internal/Parse.hs +++ b/src/Aeson/Match/QQ/Internal/Parse.hs @@ -7,11 +7,12 @@ import Control.Applicative ((<|>), optional) import qualified Data.Aeson.Parser as Aeson +import qualified Data.Attoparsec.ByteString as Atto import qualified Data.ByteString as ByteString -- cannot use .Text here due to .Aeson parsers being tied to .ByteString -import qualified Data.Attoparsec.ByteString as Atto import Data.Bool (bool) import Data.ByteString (ByteString) +import qualified Data.CaseInsensitive as CI import qualified Data.Char as Char import Data.Foldable (asum) import qualified Data.HashMap.Strict as HashMap @@ -50,7 +51,7 @@ OpenSquareBracketP -> array OpenParenP -> - arrayUO + arrayUO <|> stringCI OpenCurlyBracketP -> object HashP -> @@ -91,6 +92,12 @@ string = fmap String Aeson.jstring +stringCI :: Atto.Parser (Value Exp) +stringCI = do + _ <- Atto.string "(ci)" + spaces + fmap (StringCI . CI.mk) Aeson.jstring + array :: Atto.Parser (Value Exp) array = do _ <- Atto.word8 OpenSquareBracketP @@ -132,11 +139,7 @@ arrayUO :: Atto.Parser (Value Exp) arrayUO = do - _ <- Atto.word8 OpenParenP - spaces - _ <- Atto.string "unordered" - spaces - _ <- Atto.word8 CloseParenP + _ <- Atto.string "(unordered)" spaces Array box <- array pure (ArrayUO box) @@ -209,7 +212,9 @@ [ p "bool" BoolT , p "number" NumberT , p "string" StringT + , p "ci-string" StringCIT , p "array" ArrayT + , p "unordered-array" ArrayUOT , p "object" ObjectT ] where @@ -239,9 +244,10 @@ pattern OpenSquareBracketP = 91 -- '[' pattern CloseSquareBracketP = 93 -- ']' -pattern OpenParenP, CloseParenP :: Word8 +pattern OpenParenP :: Word8 pattern OpenParenP = 40 -- '(' -pattern CloseParenP = 41 -- ')' +-- pattern CloseParenP :: Word8 +-- pattern CloseParenP = 41 -- ')' pattern OpenCurlyBracketP, CloseCurlyBracketP, ColonP :: Word8 pattern OpenCurlyBracketP = 123 -- '{' diff --git a/src/Aeson/Match/QQ/Internal/Value.hs b/src/Aeson/Match/QQ/Internal/Value.hs --- a/src/Aeson/Match/QQ/Internal/Value.hs +++ b/src/Aeson/Match/QQ/Internal/Value.hs @@ -6,6 +6,7 @@ {-# LANGUAGE StrictData #-} {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE ViewPatterns #-} module Aeson.Match.QQ.Internal.Value ( Value(..) , Box(..) @@ -14,11 +15,14 @@ , TypeSig(..) , Type(..) , Nullable(..) + , embed ) where import Data.Aeson ((.=)) import qualified Data.Aeson as Aeson import qualified Data.Aeson.Encoding.Internal as Aeson (encodingToLazyByteString) +import Data.CaseInsensitive (CI) +import qualified Data.CaseInsensitive as CI import Data.HashMap.Strict (HashMap) import qualified Data.HashMap.Strict as HashMap import Data.Scientific (Scientific) @@ -38,6 +42,7 @@ | Bool Bool | Number Scientific | String Text + | StringCI (CI Text) | Array (Array ext) | ArrayUO (Array ext) | Object (Object ext) @@ -67,6 +72,10 @@ [ "type" .= ("string" :: Text) , "value" .= v ] + StringCI v -> + [ "type" .= ("string-ci" :: Text) + , "value" .= CI.original v + ] Array v -> [ "type" .= ("array" :: Text) , "value" .= v @@ -115,6 +124,8 @@ [| Number (fromRational $(pure (LitE (RationalL (toRational n))))) :: Value Aeson.Value |] String str -> [| String (fromString $(pure (LitE (textL str)))) :: Value Aeson.Value |] + StringCI str -> + [| StringCI (fromString $(pure (LitE (textL (CI.original str))))) :: Value Aeson.Value |] Array Box {knownValues, extendable} -> [| Array Box { knownValues = @@ -158,6 +169,7 @@ = BoolT | NumberT | StringT + | StringCIT | ArrayT | ArrayUOT | ObjectT @@ -169,6 +181,7 @@ BoolT {} -> "bool" :: Text NumberT {} -> "number" StringT {} -> "string" + StringCIT {} -> "string-ci" ArrayT {} -> "array" ArrayUOT {} -> "array-unordered" ObjectT {} -> "object" @@ -183,3 +196,18 @@ Aeson.toJSON . \case Nullable -> True NonNullable -> False + +embed :: Aeson.Value -> Value ext +embed = \case + Aeson.Null -> + Null + Aeson.Bool b -> + Bool b + Aeson.Number n -> + Number n + Aeson.String n -> + String n + Aeson.Array xs -> + Array Box {knownValues = fmap embed xs, extendable = False} + Aeson.Object o -> + Object Box {knownValues = fmap embed o, extendable = False} 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 @@ -72,9 +72,12 @@ [qq| false |] `shouldMatch` [aesonQQ| false |] [qq| 4 |] `shouldMatch` [aesonQQ| 4 |] [qq| "foo" |] `shouldMatch` [aesonQQ| "foo" |] + [qq| (ci) "foo" |] `shouldMatch` [aesonQQ| "Foo" |] [qq| [1, 2, 3] |] `shouldMatch` [aesonQQ| [1, 2, 3] |] [qq| [1, _ : number, 3, ...] |] `shouldMatch` [aesonQQ| [1, 2, 3, 4] |] [qq| [1, _ : string] |] `shouldMatch` [aesonQQ| [1, "foo"] |] + [qq| [1, _ : ci-string] |] `shouldMatch` [aesonQQ| [1, "foo"] |] + [qq| [1, _ : unordered-array] |] `shouldMatch` [aesonQQ| [1, ["foo"]] |] [qq| (unordered) [] |] `shouldMatch` [aesonQQ| [] |] [qq| (unordered) [1, 2, 3] |] `shouldMatch` [aesonQQ| [1, 2, 3] |] [qq| (unordered) [1, 2, 3] |] `shouldMatch` [aesonQQ| [2, 3, 1] |] @@ -93,6 +96,7 @@ [qq| false |] `shouldNotMatch` [aesonQQ| true |] [qq| 4 |] `shouldNotMatch` [aesonQQ| 7 |] [qq| "foo" |] `shouldNotMatch` [aesonQQ| "bar" |] + [qq| (ci) "foo" |] `shouldNotMatch` [aesonQQ| "Bar" |] [qq| [1, 2, 3] |] `shouldNotMatch` [aesonQQ| [1, 2, 3, 4] |] [qq| [1, 2, 3, ...] |] `shouldNotMatch` [aesonQQ| [1, 2] |] [qq| [1, _ : string] |] `shouldNotMatch` [aesonQQ| [1, 2] |] @@ -147,6 +151,21 @@ -- https://github.com/supki/aeson-match-qq/issues/13 it "#13" $ [qq| "Слава Україні" |] `shouldMatch` [aesonQQ| "Слава Україні" |] + + -- https://github.com/supki/aeson-match-qq/issues/18 + it "#18" $ do + -- string ~ string + match [qq| "foo" |] [aesonQQ| "bar" |] `shouldBe` + mismatch [] (String "foo") (Aeson.String "bar") + -- string !~ number + match [qq| "foo" |] [aesonQQ| 4 |] `shouldBe` + mistype [] (String "foo") (Aeson.Number 4) + -- string !~ null + match [qq| "foo" |] [aesonQQ| null |] `shouldBe` + mistype [] (String "foo") Aeson.Null + -- null !~ number + match [qq| null |] [aesonQQ| 4 |] `shouldBe` + mistype [] Null (Aeson.Number 4) newtype ToEncoding a = ToEncoding { unToEncoding :: a } deriving (Show, Eq, Num)