fix #30: Try to match every matcher for a duplicated key

CHANGELOG.markdown

@@ -3,6 +3,8 @@ next
 
   * Added `any` type for consistency.
 
+  * Duplicate keys in objects are handled ~~properly~~ better (https://github.com/supki/aeson-match-qq/pull/40)
+
 1.7.0
 ====
 

src/Aeson/Match/QQ.hs

@@ -14,7 +14,6 @@ module Aeson.Match.QQ
   , Array
   , Object
   , Box(..)
-  , HoleSig(..)
   , Type(..)
   , Path(..)
   , PathElem(..)
@@ -45,7 +44,6 @@ import           Aeson.Match.QQ.Internal.Value
   , Box(..)
   , Array
   , Object
-  , HoleSig(..)
   , Type(..)
   , quote
   )

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

@@ -63,7 +63,6 @@ import qualified Aeson.Match.QQ.Internal.PrettyPrint as Matcher (pp)
 import           Aeson.Match.QQ.Internal.Value
   ( Matcher(..)
   , Box(..)
-  , HoleSig(..)
   , Type(..)
   , embed
   )
@@ -86,10 +85,6 @@ match matcher0 given0 =
       mistyped expected =
         mistype path expected matcher given
     case (matcher, given) of
-      (Hole holeType nameO, val) -> do
-        unless (holeTypeMatch holeType val) $
-          mistyped (type_ holeType)
-        pure (maybe mempty (\name -> HashMap.singleton name val) nameO)
       (Null, Aeson.Null) ->
         pure mempty
       (Null, _) -> do
@@ -157,27 +152,38 @@ match matcher0 given0 =
             (extra || HashMap.null extraValues)
             (extraObjectValues path extraValues) *>
           fold
-            (\k v -> maybe (missingPathElem path (Key k)) (go (Key k : path) v) (HashMap.lookup k o))
+            (\k vs ->
+              maybe
+                (missingPathElem path (Key k))
+                (\ov -> foldr1 (liftA2 (<>)) (fmap (\v -> go (Key k : path) v ov) vs))
+                (HashMap.lookup k o))
             values
       (Object _, _) -> do
         mistyped ObjectT
         pure mempty
+      (Sig type_ nullable x, val) -> -- do -- ApplicativeDo shits the bed here for some reason
+        unless (sigTypeMatch type_ nullable val) (mistyped type_) *>
+        go path x val
+      (Var "", _) ->
+        pure mempty
+      (Var name, val) ->
+        pure (HashMap.singleton name val)
       (Ext val, val') ->
         go path (embed val) val'
 
-holeTypeMatch :: HoleSig -> Aeson.Value -> Bool
-holeTypeMatch type_ val =
-  case (type_, val) of
-    (HoleSig {type_ = AnyT}, _) -> True
-    (HoleSig {nullable = True}, Aeson.Null) -> True
-    (HoleSig {type_ = BoolT}, Aeson.Bool {}) -> True
-    (HoleSig {type_ = NumberT}, Aeson.Number {}) -> True
-    (HoleSig {type_ = StringT}, Aeson.String {}) -> True
-    (HoleSig {type_ = StringCIT}, Aeson.String {}) -> True
-    (HoleSig {type_ = ArrayT}, Aeson.Array {}) -> True
-    (HoleSig {type_ = ArrayUOT}, Aeson.Array {}) -> True
-    (HoleSig {type_ = ObjectT}, Aeson.Object {}) -> True
-    (_, _) -> False
+sigTypeMatch :: Type -> Bool -> Aeson.Value -> Bool
+sigTypeMatch type_ nullable val =
+  case (type_, nullable, val) of
+    (AnyT,      _,    _) -> True
+    (_,         True, Aeson.Null) -> True
+    (BoolT,     _,    Aeson.Bool {}) -> True
+    (NumberT,   _,    Aeson.Number {}) -> True
+    (StringT,   _,    Aeson.String {}) -> True
+    (StringCIT, _,    Aeson.String {}) -> True
+    (ArrayT,    _,    Aeson.Array {}) -> True
+    (ArrayUOT,  _,    Aeson.Array {}) -> True
+    (ObjectT,   _,    Aeson.Object {}) -> True
+    (_,         _,    _) -> False
 
 matchArrayUO
   :: Validation (NonEmpty Error) (HashMap Text Aeson.Value)

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

@@ -30,7 +30,6 @@ import           Prelude hiding (any, null)
 import           Aeson.Match.QQ.Internal.Value
   ( Matcher(..)
   , Box(..)
-  , HoleSig(..)
   , Type(..)
   )
 
@@ -80,30 +79,30 @@ optimize :: Matcher Exp -> Matcher Exp
 optimize = \case
   -- [...] -> _ : array
   Array Box {extra = True, values = (Vector.null -> True)} ->
-    Hole (HoleSig ArrayT False) Nothing
+    Sig ArrayT False (Var "")
   -- this optimization is probably never going to be used,
   -- but I'll include it for completeness:
   -- (unordered) [...] -> _ : unordered-array
   ArrayUO Box {extra = True, values = (Vector.null -> True)} ->
-    Hole (HoleSig ArrayUOT False) Nothing
+    Sig ArrayUOT False (Var "")
   -- {...} -> _ : object
   Object Box {extra = True, values = (HashMap.null -> True)} ->
-    Hole (HoleSig ObjectT False) Nothing
+    Sig ObjectT False (Var "")
   val ->
     val
 
 any :: Atto.Parser (Matcher Exp)
 any = do
   _ <- Atto.word8 HoleP
-  name <- fmap Just key <|> pure Nothing
+  name <- key <|> pure ""
   spaces
   b <- optional Atto.peekWord8'
-  expectedType <- case b of
+  (type_, nullable) <- case b of
     Just ColonP ->
-      holeSig
+      sig
     _ ->
-      pure (HoleSig AnyT False)
-  pure (Hole expectedType name)
+      pure (AnyT, False)
+  pure (Sig type_ nullable (Var name))
 
 null :: Atto.Parser (Matcher Exp)
 null =
@@ -208,10 +207,10 @@ object = do
         sep <- Atto.satisfy (\w -> w == CommaP || w == CloseCurlyBracketP) Atto.<?> "',' or '}'"
         case sep of
           CommaP ->
-            loop ((k, val) : acc)
+            loop ((k, pure val) : acc)
           CloseCurlyBracketP ->
             pure $ Object Box
-              { values = HashMap.fromList ((k, val) : acc)
+              { values = HashMap.fromListWith (<>) ((k, pure val) : acc)
               , extra = False
               }
           _ ->
@@ -244,8 +243,8 @@ haskellExp =
     str <- Atto.takeWhile1 (/= CloseCurlyBracketP) <* Atto.word8 CloseCurlyBracketP
     either fail pure (parseExp (Text.unpack (Text.decodeUtf8 str)))
 
-holeSig :: Atto.Parser HoleSig
-holeSig = do
+sig :: Atto.Parser (Type, Bool)
+sig = do
   _ <- Atto.word8 ColonP
   spaces
   asum
@@ -262,7 +261,7 @@ holeSig = do
   p name typeName = do
     _ <- Atto.string name
     q <- optional (Atto.word8 QuestionMarkP)
-    pure (HoleSig typeName (isJust q))
+    pure (typeName, isJust q)
 
 eof :: Atto.Parser ()
 eof =

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

@@ -6,6 +6,7 @@ module Aeson.Match.QQ.Internal.PrettyPrint
   ( pp
   ) where
 
+import           Control.Monad ((<=<))
 import qualified Data.Aeson as Aeson
 import           Data.Bool (bool)
 import qualified Data.ByteString.Lazy as ByteString.Lazy
@@ -17,6 +18,7 @@ import           Data.HashMap.Strict (HashMap)
 import qualified Data.HashMap.Strict as HashMap
 import           Data.Int (Int64)
 import qualified Data.List as List
+import           Data.List.NonEmpty (NonEmpty)
 import           Data.Scientific (Scientific, floatingOrInteger)
 import           Data.String (fromString)
 import qualified Data.Text as Text
@@ -28,7 +30,6 @@ import qualified Text.PrettyPrint as PP
 
 import           Aeson.Match.QQ.Internal.Value
   ( Matcher(..)
-  , HoleSig(..)
   , Type(..)
   , Box(..)
   )
@@ -44,8 +45,6 @@ pp value =
 
 rValue :: Matcher Aeson.Value -> PP.Doc
 rValue = \case
-  Hole sig name ->
-    rHole sig name
   Null ->
     rNull
   Bool b ->
@@ -62,34 +61,13 @@ rValue = \case
     rArrayUO xs
   Object o ->
     rObject o
+  Sig type_ nullable v ->
+    rSig type_ nullable v
+  Var name ->
+    rVar name
   Ext ext ->
     rExt ext
 
-rHole :: HoleSig -> Maybe Text -> PP.Doc
-rHole sig name =
-  ("_" <> maybe PP.empty rName name) <+> rSig sig
-
-rName :: Text -> PP.Doc
-rName name =
-  PP.text (bool (Text.unpack name) (show name) (hasSpaces name))
- where
-  hasSpaces =
-    Text.any Char.isSpace
-
-rSig :: HoleSig -> PP.Doc
-rSig HoleSig {type_, nullable} =
-  (":" <+> rType type_) <> bool PP.empty "?" nullable
- where
-  rType = \case
-    AnyT -> "any"
-    BoolT -> "bool"
-    NumberT -> "number"
-    StringT -> "string"
-    StringCIT -> "ci-string"
-    ArrayT -> "array"
-    ArrayUOT -> "unordered-array"
-    ObjectT -> "object"
-
 rNull :: PP.Doc
 rNull =
   "null"
@@ -131,13 +109,9 @@ rArrayUO box =
     , rArray box
     ]
 
-rExt :: Aeson.Value -> PP.Doc
-rExt =
-  fromString . Text.unpack . Text.decodeUtf8 . ByteString.Lazy.toStrict . Aeson.encode
-
-rObject :: Box (HashMap Text (Matcher Aeson.Value)) -> PP.Doc
+rObject :: Box (HashMap Text (NonEmpty (Matcher Aeson.Value))) -> PP.Doc
 rObject Box {values, extra} =
-  case List.sortOn fst (HashMap.toList values) of
+  case toKeyValues values of
     [] ->
       "{}"
     kv : kvs ->
@@ -155,10 +129,41 @@ rObject Box {values, extra} =
         , rValue value
         ]
 
+toKeyValues :: (Ord k, Foldable t) => HashMap k (t v) -> [(k, v)]
+toKeyValues =
+  traverse toList <=< List.sortOn fst . HashMap.toList
+
+rSig :: Type -> Bool -> Matcher Aeson.Value -> PP.Doc
+rSig type_ nullable val =
+  rValue val <+> ((":" <+> rType type_) <> bool PP.empty "?" nullable)
+ where
+  rType = \case
+    AnyT -> "any"
+    BoolT -> "bool"
+    NumberT -> "number"
+    StringT -> "string"
+    StringCIT -> "ci-string"
+    ArrayT -> "array"
+    ArrayUOT -> "unordered-array"
+    ObjectT -> "object"
+
+rVar :: Text -> PP.Doc
+rVar name =
+  "_" <> rName name
+
+rName :: Text -> PP.Doc
+rName name =
+  PP.text (bool (Text.unpack name) (show name) (hasSpaces name))
+ where
+  hasSpaces =
+    Text.any Char.isSpace
+
+rExt :: Aeson.Value -> PP.Doc
+rExt =
+  fromString . Text.unpack . Text.decodeUtf8 . ByteString.Lazy.toStrict . Aeson.encode
+
 simpleValue :: Matcher Aeson.Value -> Bool
 simpleValue = \case
-  Hole {} ->
-    True
   Null {} ->
     True
   Bool {} ->
@@ -175,5 +180,9 @@ simpleValue = \case
     False
   Object {} ->
     False
+  Sig {} ->
+    True
+  Var {} ->
+    True
   Ext {} ->
     True