aeson-match-qq 1.0.0 → 1.1.0

raw patch · 7 files changed

+149/−34 lines, 7 filesdep ~basePVP ok

version bump matches the API change (PVP)

Dependency ranges changed: base

API changes (from Hackage documentation)

Files

• CHANGELOG.markdown +11/−0
• aeson-match-qq.cabal +6/−5
• src/Aeson/Match/QQ.hs +4/−1
• src/Aeson/Match/QQ/Internal/Match.hs +28/−15
• src/Aeson/Match/QQ/Internal/Parse.hs +29/−3
• src/Aeson/Match/QQ/Internal/Value.hs +50/−4
• test/Aeson/Match/QQSpec.hs +21/−6

@@ -0,0 +1,11 @@+1.1.0+=====++  * Optionally typed holes (https://github.com/supki/aeson-match-qq/pull/9)++  * Fixed spurious validation errors (https://github.com/supki/aeson-match-qq/issues/7)++1.0.0+=====++  * Initial release.

@@ -4,11 +4,11 @@ -- -- see: https://github.com/sol/hpack ----- hash: 57b8bf8d01a999a9e081c25a75f1254dbf1f7d23805594b588bed35eb03b9a7a+-- hash: b37b8f340b6ce5d17c4938172bdd5e7805347f8290f68163f3215e5b7cfd8a14  name:           aeson-match-qq-version:        1.0.0-synopsis:       Matching Aeson values with a quasiquoter+version:        1.1.0+synopsis:       Declarative JSON matchers. description:    See README.markdown category:       Web maintainer:     matvey.aksenov@gmail.com@@ -18,6 +18,7 @@ build-type:     Simple extra-source-files:     README.markdown+    CHANGELOG.markdown  library   exposed-modules:@@ -33,7 +34,7 @@   build-depends:       aeson     , attoparsec-    , base >=4.7 && <5+    , base >=4.11 && <5     , bytestring     , either     , haskell-src-meta@@ -57,7 +58,7 @@       aeson     , aeson-match-qq     , aeson-qq-    , base >=4.7 && <5+    , base >=4.11 && <5     , hspec     , unordered-containers   default-language: Haskell2010

@@ -3,6 +3,9 @@   , Array   , Object   , Box(..)+  , TypeSig(..)+  , Type(..)+  , Nullable(..)   , Path   , PathElem(..)   , parse@@ -20,7 +23,7 @@  import           Aeson.Match.QQ.Internal.Match (Path, PathElem(..), match, mismatch, missingPathElem, extraArrayValues, extraObjectValues) import           Aeson.Match.QQ.Internal.Parse (parse)-import           Aeson.Match.QQ.Internal.Value (Value(..), Box(..), Array, Object)+import           Aeson.Match.QQ.Internal.Value (Value(..), Box(..), Array, Object, TypeSig(..), Type(..), Nullable(..))   qq :: QuasiQuoter

@@ -11,6 +11,7 @@ import           Data.Aeson ((.=)) import qualified Data.Aeson as Aeson import           Data.Either.Validation (Validation, eitherToValidation)+import           Data.Foldable (for_) import           Data.HashMap.Strict (HashMap) import qualified Data.HashMap.Strict as HashMap import           Data.List.NonEmpty (NonEmpty)@@ -20,7 +21,7 @@ import qualified Data.Vector as Vector import           Prelude hiding (any, null) -import           Aeson.Match.QQ.Internal.Value (Value(..), Box(..))+import           Aeson.Match.QQ.Internal.Value (Value(..), Box(..), TypeSig(..), Type(..), Nullable(..))   match :: Value Aeson.Value -> Aeson.Value -> Validation (NonEmpty VE) (HashMap Text Aeson.Value)@@ -30,10 +31,11 @@   go path matcher given = do     let mismatched = mismatch (reverse path) matcher given     case (matcher, given) of-      (Any Nothing, _) ->-        pure mempty-      (Any (Just name), val) ->-        pure (HashMap.singleton name val)+      (Any holeTypeO nameO, val) -> do+        for_ holeTypeO $ \holeType ->+          unless (holeTypeMatch holeType val)+            mismatched+        pure (maybe mempty (\name -> HashMap.singleton name val) nameO)       (Null, Aeson.Null) ->         pure mempty       (Null, _) -> do@@ -58,14 +60,14 @@         mismatched         pure mempty       (Array Box {knownValues, extendable}, Aeson.Array arr) ->-        let knownValuesL = Vector.length knownValues-            arrL = Vector.length arr-            fold f =+        let fold f =               Vector.ifoldr (\i v a -> liftA2 HashMap.union a (f i v)) (pure mempty)+            extraValues =+              Vector.drop (Vector.length knownValues) arr         in           unless-            (extendable || knownValuesL == arrL)-            (extraArrayValues (reverse path) (Vector.drop knownValuesL arr)) *>+            (extendable || Vector.null extraValues)+            (extraArrayValues (reverse path) extraValues) *>           fold             (\i v -> maybe (missingPathElem (reverse path) (Idx i)) (go (Idx i : path) v) (arr Vector.!? i))             knownValues@@ -73,14 +75,14 @@         mismatched         pure mempty       (Object Box {knownValues, extendable}, Aeson.Object o) ->-        let knownValuesL = HashMap.size knownValues-            oL = HashMap.size o-            fold f =+        let fold f =               HashMap.foldrWithKey (\k v a -> liftA2 HashMap.union a (f k v)) (pure mempty)+            extraValues =+              HashMap.difference o knownValues         in           unless-            (extendable || knownValuesL == oL)-            (extraObjectValues (reverse path) (HashMap.difference o knownValues)) *>+            (extendable || HashMap.null extraValues)+            (extraObjectValues (reverse path) extraValues) *>           fold             (\k v -> maybe (missingPathElem (reverse path) (Key k)) (go (Key k : path) v) (HashMap.lookup k o))             knownValues@@ -90,6 +92,17 @@       (Ext val, val') -> do         unless (val == val') mismatched         pure mempty++holeTypeMatch :: TypeSig -> Aeson.Value -> Bool+holeTypeMatch type_ val =+  case (type_, val) of+    (TypeSig {nullable = Nullable}, Aeson.Null) -> True+    (TypeSig {type_ = BoolT} , Aeson.Bool {}) -> True+    (TypeSig {type_ = NumberT} , Aeson.Number {}) -> True+    (TypeSig {type_ = StringT} , Aeson.String {}) -> True+    (TypeSig {type_ = ArrayT} , Aeson.Array {}) -> True+    (TypeSig {type_ = ObjectT} , Aeson.Object {}) -> True+    (_, _) -> False  mismatch :: Path -> Value Aeson.Value -> Aeson.Value -> Validation (NonEmpty VE) a mismatch path matcher given =

@@ -5,14 +5,17 @@   ( parse   ) where -import           Control.Applicative ((<|>))+import           Control.Applicative ((<|>), optional) import qualified Data.Aeson.Parser as Aeson 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.Char as Char+import           Data.Foldable (asum) import qualified Data.HashMap.Strict as HashMap+import           Data.Maybe (isJust) import           Data.Text (Text) import qualified Data.Text as Text import qualified Data.Text.Encoding as Text@@ -22,7 +25,7 @@ import           Language.Haskell.TH (Exp(..)) import           Prelude hiding (any, null) -import           Aeson.Match.QQ.Internal.Value (Value(..), Box(..))+import           Aeson.Match.QQ.Internal.Value (Value(..), Box(..), TypeSig(..), Type(..), Nullable(..))   parse :: ByteString -> Either String (Value Exp)@@ -61,7 +64,10 @@ any :: Atto.Parser (Value Exp) any = do   _ <- Atto.word8 AnyP-  fmap (Any . Just) key <|> pure (Any Nothing)+  name <- fmap Just key <|> pure Nothing+  spaces+  expectedType <- optional typeSig+  pure (Any expectedType name)  null :: Atto.Parser (Value Exp) null =@@ -180,6 +186,23 @@     str <- Atto.takeWhile1 (/= CloseCurlyBracketP) <* Atto.word8 CloseCurlyBracketP     either fail pure (parseExp (Text.unpack (Text.decodeUtf8 str))) +typeSig :: Atto.Parser TypeSig+typeSig = do+  _ <- Atto.word8 ColonP+  spaces+  asum+    [ p "bool" BoolT+    , p "number" NumberT+    , p "string" StringT+    , p "array" ArrayT+    , p "object" ObjectT+    ]+ where+  p name typeName = do+    _ <- Atto.string name+    q <- optional (Atto.word8 QuestionMarkP)+    pure (TypeSig typeName (bool NonNullable Nullable (isJust q)))+ -- This function has been stolen from aeson. -- ref: https://hackage.haskell.org/package/aeson-1.4.6.0/docs/src/Data.Aeson.Parser.Internal.html#skipSpace spaces :: Atto.Parser ()@@ -216,3 +239,6 @@ pattern NewLineP = 0x0a pattern CRP = 0x0d pattern TabP = 0x09++pattern QuestionMarkP :: Word8+pattern QuestionMarkP = 63 -- '?'

@@ -1,7 +1,9 @@+{-# LANGUAGE DeriveLift #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE StrictData #-} {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TypeFamilies #-} module Aeson.Match.QQ.Internal.Value@@ -9,6 +11,9 @@   , Box(..)   , Array   , Object+  , TypeSig(..)+  , Type(..)+  , Nullable(..)   ) where  import           Data.Aeson ((.=))@@ -28,7 +33,7 @@   data Value ext-  = Any (Maybe Text)+  = Any (Maybe TypeSig) (Maybe Text)   | Null   | Bool Bool   | Number Scientific@@ -41,8 +46,9 @@ instance Aeson.ToJSON ext => Aeson.ToJSON (Value ext) where   toJSON =     Aeson.object . \case-      Any name ->+      Any type_ name ->         [ "type" .= ("any" :: Text)+        , "expected-type" .= type_         , "name" .= name         ]       Null ->@@ -94,8 +100,8 @@ -- undefined for some datatypes. instance ext ~ Exp => Lift (Value ext) where   lift = \case-    Any name ->-      [| Any $(pure (maybe (ConE 'Nothing) (AppE (ConE 'Just) . AppE (VarE 'fromString) . LitE . textL) name)) :: Value Aeson.Value |]+    Any type_ name ->+      [| Any type_ $(pure (maybe (ConE 'Nothing) (AppE (ConE 'Just) . AppE (VarE 'fromString) . LitE . textL) name)) :: Value Aeson.Value |]     Null ->       [| Null :: Value Aeson.Value |]     Bool b ->@@ -123,3 +129,43 @@    where     textL =       StringL . Text.unpack++data TypeSig = TypeSig+  { type_    :: Type+  , nullable :: Nullable+  } deriving (Show, Eq, Lift)++instance Aeson.ToJSON TypeSig where+  toJSON TypeSig {..} =+    Aeson.object+      [ "type" .= type_+      , "nullable" .= nullable+      ]++data Type+  = BoolT+  | NumberT+  | StringT+  | ArrayT+  | ObjectT+    deriving (Show, Eq, Lift)++instance Aeson.ToJSON Type where+  toJSON =+    Aeson.toJSON . \case+      BoolT {} -> "bool" :: Text+      NumberT {} -> "number"+      StringT {} -> "string"+      ArrayT {} -> "array"+      ObjectT {} -> "object"++data Nullable+  = Nullable+  | NonNullable+    deriving (Show, Eq, Lift)++instance Aeson.ToJSON Nullable where+  toJSON =+    Aeson.toJSON . \case+      Nullable -> True+      NonNullable -> False

@@ -16,9 +16,11 @@ spec = do   describe "parse" $     it "specs" $ do-      [qq| _ |] `shouldBe` Any Nothing-      [qq| _hole |] `shouldBe` Any (pure "hole")-      [qq| _"fancy hole" |] `shouldBe` Any (pure "fancy hole")+      [qq| _ |] `shouldBe` Any Nothing Nothing+      [qq| _hole |] `shouldBe` Any Nothing (pure "hole")+      [qq| _"fancy hole" |] `shouldBe` Any Nothing (pure "fancy hole")+      [qq| _typed-hole : number |] `shouldBe` Any (pure (TypeSig NumberT NonNullable)) (pure "typed-hole")+      [qq| _typed-nullable-hole : number? |] `shouldBe` Any (pure (TypeSig NumberT Nullable)) (pure "typed-nullable-hole")        [qq| null |] `shouldBe` Null @@ -35,9 +37,9 @@       [qq| [1, 2, 3] |] `shouldBe`         Array Box {knownValues = [Number 1, Number 2, Number 3], extendable = False}       [qq| [1, _, 3] |] `shouldBe`-        Array Box {knownValues = [Number 1, Any Nothing, Number 3], extendable = False}+        Array Box {knownValues = [Number 1, Any Nothing Nothing, Number 3], extendable = False}       [qq| [1, _, 3, ...] |] `shouldBe`-        Array Box {knownValues = [Number 1, Any Nothing, Number 3], extendable = True}+        Array Box {knownValues = [Number 1, Any Nothing Nothing, Number 3], extendable = True}        [qq| {} |] `shouldBe`         Object Box {knownValues = [], extendable = False}@@ -62,10 +64,13 @@       [qq| 4 |] `shouldMatch` [aesonQQ| 4 |]       [qq| "foo" |] `shouldMatch` [aesonQQ| "foo" |]       [qq| [1, 2, 3] |] `shouldMatch` [aesonQQ| [1, 2, 3] |]-      [qq| [1, 2, 3, ...] |] `shouldMatch` [aesonQQ| [1, 2, 3, 4] |]+      [qq| [1, _ : number, 3, ...] |] `shouldMatch` [aesonQQ| [1, 2, 3, 4] |]+      [qq| [1, _ : string] |] `shouldMatch` [aesonQQ| [1, "foo"] |]       [qq| {foo: 4, bar: 7} |] `shouldMatch` [aesonQQ| {foo: 4, bar: 7} |]       [qq| {foo: 4, bar: 7, ...} |] `shouldMatch` [aesonQQ| {foo: 4, bar: 7, baz: 11} |]       [qq| #{1 + 2 :: Int} |] `shouldMatch` [aesonQQ| 3 |]+      [qq| {foo: _ : number, bar: 7} |] `shouldMatch` [aesonQQ| {foo: 4, bar: 7} |]+      [qq| {foo: _ : number?, bar: 7} |] `shouldMatch` [aesonQQ| {foo: null, bar: 7} |]        [qq| null |] `shouldNotMatch` [aesonQQ| 4 |]       [qq| true |] `shouldNotMatch` [aesonQQ| false |]@@ -74,11 +79,14 @@       [qq| "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] |]       [qq| [1, 2, 3, ...] |] `shouldNotMatch` [aesonQQ| [1, 2, 4] |]       [qq| {foo: 4, bar: 7} |] `shouldNotMatch` [aesonQQ| {foo: 7, bar: 4} |]       [qq| {foo: 4, bar: 7} |] `shouldNotMatch` [aesonQQ| {foo: 4, baz: 7} |]       [qq| {foo: 4, bar: 7, ...} |] `shouldNotMatch` [aesonQQ| {foo: 4, baz: 11} |]       [qq| #{1 + 2 :: Int} |] `shouldNotMatch` [aesonQQ| 4 |]+      [qq| {foo: _ : number, bar: 7} |] `shouldNotMatch` [aesonQQ| {foo: "foo", bar: 7} |]+      [qq| {foo: _ : number, bar: 7} |] `shouldNotMatch` [aesonQQ| {foo: null, bar: 7} |]      it "paths" $ do       match [qq| {foo: {bar: {baz: [1, 4]}}} |] [aesonQQ| {foo: {bar: {baz: [1, 7]}}} |] `shouldBe`@@ -87,6 +95,13 @@     it "named holes" $ do       match [qq| {foo: _hole} |] [aesonQQ| {foo: {bar: {baz: [1, 4]}}} |] `shouldBe`         pure (HashMap.singleton "hole" [aesonQQ| {bar: {baz: [1, 4]}} |])++    -- https://github.com/supki/aeson-match-qq/issues/7+    it "#7" $ do+      match [qq| {foo: _} |] [aesonQQ| {} |] `shouldBe`+        missingPathElem [] "foo"+      match [qq| [_] |] [aesonQQ| [] |] `shouldBe`+        missingPathElem [] (Idx 0)  newtype ToEncoding a = ToEncoding { unToEncoding :: a }     deriving (Show, Eq, Num)