fix #7: Spurious extra-{object,array}-values validation failures

CHANGELOG.markdown

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

aeson-match-qq.cabal

@@ -4,7 +4,7 @@ cabal-version: 1.12
 --
 -- see: https://github.com/sol/hpack
 --
--- hash: e7acbabc06f912fe2b0617d8c1c1491874eb81a49df7c6df3d294a69ea828906
+-- hash: f80fad124596de7e4e4a91aba4f6534488acc68087f9b8ceb7e5cafef313d1ff
 
 name:           aeson-match-qq
 version:        1.0.0
@@ -18,6 +18,7 @@ license-file:   LICENSE
 build-type:     Simple
 extra-source-files:
     README.markdown
+    CHANGELOG.markdown
 
 library
   exposed-modules:

package.yaml

@@ -8,6 +8,7 @@ copyright: Matvey Aksenov 2020
 license: BSD2
 extra-source-files:
   - README.markdown
+  - CHANGELOG.markdown
 
 dependencies:
   - base >= 4.11 && < 5

src/Aeson/Match/QQ/Internal/Match.hs

@@ -58,29 +58,29 @@ match =
         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
       (Array _, _) -> do
         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

test/Aeson/Match/QQSpec.hs

@@ -88,6 +88,13 @@ spec = 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)