fix #6: Unordered arrays

aeson-match-qq.cabal

@@ -1,10 +1,8 @@
 cabal-version: 1.12
 
--- This file has been generated from package.yaml by hpack version 0.31.2.
+-- This file has been generated from package.yaml by hpack version 0.34.6.
 --
 -- see: https://github.com/sol/hpack
---
--- hash: 2cf49c3c176aae86e39190d8aeb04288afe12de46702d55f3587e474ea2b368a
 
 name:           aeson-match-qq
 version:        1.2.1
@@ -42,6 +40,7 @@ library
     , attoparsec
     , base >=4.11 && <5
     , bytestring
+    , containers
     , either
     , haskell-src-meta
     , scientific

package.yaml

@@ -19,6 +19,7 @@ library:
     - aeson
     - attoparsec
     - bytestring
+    - containers
     - either
     - haskell-src-meta
     - scientific

shell.nix

@@ -0,0 +1,13 @@
+{ pkgs ? import <nixpkgs> {}
+, ghc ? pkgs.haskell.compiler.ghc884
+, stack ? pkgs.stack
+}:
+pkgs.mkShell {
+  buildInputs = with pkgs; [
+    ghc
+    stack
+  ];
+
+  shellHook = ''
+  '';
+}

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

@@ -10,11 +10,14 @@ import           Control.Applicative (liftA2)
 import           Control.Monad (unless)
 import           Data.Aeson ((.=))
 import qualified Data.Aeson as Aeson
-import           Data.Either.Validation (Validation, eitherToValidation)
-import           Data.Foldable (for_)
+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)
+import           Data.Maybe (mapMaybe)
+import qualified Data.Set as Set
 import           Data.String (IsString(..))
 import           Data.Text (Text)
 import           Data.Vector (Vector)
@@ -63,10 +66,11 @@ match =
         mismatched
         pure mempty
       (Array Box {knownValues, extendable}, Aeson.Array arr) ->
-        let fold f =
-              Vector.ifoldr (\i v a -> liftA2 HashMap.union a (f i v)) (pure mempty)
-            extraValues =
-              Vector.drop (Vector.length knownValues) arr
+        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 || Vector.null extraValues)
@@ -77,11 +81,17 @@ match =
       (Array _, _) -> do
         mismatched
         pure mempty
+      (ArrayUO box, Aeson.Array arr) ->
+        matchArrayUO mismatched path box arr
+      (ArrayUO _, _) -> do
+        mismatched
+        pure mempty
       (Object Box {knownValues, extendable}, Aeson.Object o) ->
-        let fold f =
-              HashMap.foldrWithKey (\k v a -> liftA2 HashMap.union a (f k v)) (pure mempty)
-            extraValues =
-              HashMap.difference o knownValues
+        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 || HashMap.null extraValues)
@@ -107,6 +117,64 @@ holeTypeMatch type_ val =
     (TypeSig {type_ = ObjectT} , Aeson.Object {}) -> True
     (_, _) -> False
 
+matchArrayUO
+  :: Validation (NonEmpty VE) (HashMap Text Aeson.Value)
+  -> Path
+  -> Box (Vector (Value Aeson.Value))
+  -> Vector Aeson.Value
+  -> Validation (NonEmpty VE) (HashMap Text Aeson.Value)
+matchArrayUO mismatched path Box {knownValues, extendable} xs = do
+  -- Collect possible indices in `xs` for each position in `knownValues`.
+  let indices = map (collectMatchingIndices (toList xs)) (toList knownValues)
+  -- Find all unique valid ways to map each position in `knownValues` to
+  -- a member of `xs`.
+  case allIndicesAssignments indices of
+    -- If no assignment has been found, we give up.
+    [] ->
+      mismatched
+    ivs : _
+      -- If some positions in `knownValues` cannot be mapped to
+      -- anything in `xs`, we give up.
+      | length ivs < length knownValues ->
+        mismatched
+      -- If there are some members of `xs` that aren't matched by
+      -- anything in `knownValues`, we check if the pattern is
+      -- extendable.
+      | 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
+      | otherwise ->
+        pure (foldMap snd ivs)
+ where
+  collectMatchingIndices is knownValue =
+    imapMaybe matchingIndex is
+   where
+    matchingIndex i x =
+      case match knownValue x of
+        Success vs ->
+          Just (i, vs)
+        Failure _ ->
+          Nothing
+  allIndicesAssignments = map (map unI) . cleanUp . go Set.empty
+   where
+    go _ [] = [[]]
+    go known (is : iss) = do
+      (i, vs) <- is
+      bool (map (I (i, vs) :) (go (Set.insert i known) iss)) [] (i `Set.member` known)
+    cleanUp =
+      toList . Set.fromList . map (Set.toAscList . Set.fromList)
+
+newtype I = I { unI :: (Int, HashMap Text Aeson.Value) }
+
+instance Eq I where
+  I (a, _) == I (b, _) =
+    a == b
+
+instance Ord I where
+  I (a, _) `compare` I (b, _) =
+    a `compare` b
+
 mismatch :: Path -> Value Aeson.Value -> Aeson.Value -> Validation (NonEmpty VE) a
 mismatch path matcher given =
   throwE (Mismatch MkMismatch {..})
@@ -221,3 +289,7 @@ instance Aeson.ToJSON PathElem where
 instance IsString PathElem where
   fromString =
     Key . fromString
+
+imapMaybe :: (Int -> a -> Maybe b) -> [a] -> [b]
+imapMaybe f =
+  mapMaybe (uncurry f) . zip [0..]

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

@@ -49,6 +49,8 @@ value = do
       string
     OpenSquareBracketP ->
       array
+    OpenParenP ->
+      arrayUO
     OpenCurlyBracketP ->
       object
     HashP ->
@@ -128,6 +130,17 @@ array = do
       _ ->
         error "impossible"
 
+arrayUO :: Atto.Parser (Value Exp)
+arrayUO = do
+  _ <- Atto.word8 OpenParenP
+  spaces
+  _ <- Atto.string "unordered"
+  spaces
+  _ <- Atto.word8 CloseParenP
+  spaces
+  Array box <- array
+  pure (ArrayUO box)
+
 object :: Atto.Parser (Value Exp)
 object = do
   _ <- Atto.word8 OpenCurlyBracketP
@@ -226,9 +239,14 @@ pattern OpenSquareBracketP, CloseSquareBracketP :: Word8
 pattern OpenSquareBracketP = 91 -- '['
 pattern CloseSquareBracketP = 93 -- ']'
 
+pattern OpenParenP, CloseParenP :: Word8
+pattern OpenParenP = 40 -- '('
+pattern CloseParenP = 41 -- ')'
+
 pattern OpenCurlyBracketP, CloseCurlyBracketP, ColonP :: Word8
 pattern OpenCurlyBracketP = 123 -- '{'
 pattern CloseCurlyBracketP = 125 -- '}'
+
 pattern ColonP = 58 -- ':'
 
 pattern ZeroP, NineP, MinusP :: Word8

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

@@ -39,6 +39,7 @@ data Value ext
   | Number Scientific
   | String Text
   | Array (Array ext)
+  | ArrayUO (Array ext)
   | Object (Object ext)
   | Ext ext
     deriving (Show, Eq)
@@ -70,6 +71,10 @@ instance Aeson.ToJSON ext => Aeson.ToJSON (Value ext) where
         [ "type" .= ("array" :: Text)
         , "value" .= v
         ]
+      ArrayUO v ->
+        [ "type" .= ("array-unordered" :: Text)
+        , "value" .= v
+        ]
       Object v ->
         [ "type" .= ("object" :: Text)
         , "value" .= v
@@ -117,6 +122,13 @@ instance ext ~ Exp => Lift (Value ext) where
           , extendable
           } :: Value Aeson.Value
       |]
+    ArrayUO Box {knownValues, extendable} -> [|
+        ArrayUO Box
+          { knownValues =
+              Vector.fromList $(fmap (ListE . Vector.toList) (traverse lift knownValues))
+          , extendable
+          } :: Value Aeson.Value
+      |]
     Object Box {knownValues, extendable} -> [|
         Object Box
           { knownValues =
@@ -147,6 +159,7 @@ data Type
   | NumberT
   | StringT
   | ArrayT
+  | ArrayUOT
   | ObjectT
     deriving (Show, Eq, Lift)
 
@@ -157,6 +170,7 @@ instance Aeson.ToJSON Type where
       NumberT {} -> "number"
       StringT {} -> "string"
       ArrayT {} -> "array"
+      ArrayUOT {} -> "array-unordered"
       ObjectT {} -> "object"
 
 data Nullable

stack.yaml

@@ -1,4 +1,4 @@
-resolver: lts-14.7
+resolver: lts-16.31
 packages:
   - '.'
 allow-newer: true

stack.yaml.lock

@@ -6,7 +6,7 @@
 packages: []
 snapshots:
 - completed:
-    size: 523700
-    url: https://raw.githubusercontent.com/commercialhaskell/stackage-snapshots/master/lts/14/7.yaml
-    sha256: 8e3f3c894be74d71fa4bf085e0a8baae7e4d7622d07ea31a52736b80f8b9bb1a
-  original: lts-14.7
+    size: 534126
+    url: https://raw.githubusercontent.com/commercialhaskell/stackage-snapshots/master/lts/16/31.yaml
+    sha256: 637fb77049b25560622a224845b7acfe81a09fdb6a96a3c75997a10b651667f6
+  original: lts-16.31

test/Aeson/Match/QQSpec.hs

@@ -41,6 +41,15 @@ spec = do
       [qq| [1, _, 3, ...] |] `shouldBe`
         Array Box {knownValues = [Number 1, Any Nothing Nothing, Number 3], extendable = True}
 
+      [qq| (unordered) [] |] `shouldBe`
+        ArrayUO Box {knownValues = [], extendable = False}
+      [qq| (unordered) [1, 2, 3] |] `shouldBe`
+        ArrayUO Box {knownValues = [Number 1, Number 2, Number 3], extendable = False}
+      [qq| (unordered) [1, _, 3] |] `shouldBe`
+        ArrayUO Box {knownValues = [Number 1, Any Nothing Nothing, Number 3], extendable = False}
+      [qq| (unordered) [1, _, 3, ...] |] `shouldBe`
+        ArrayUO Box {knownValues = [Number 1, Any Nothing Nothing, Number 3], extendable = True}
+
       [qq| {} |] `shouldBe`
         Object Box {knownValues = [], extendable = False}
       [qq| {foo: 4} |] `shouldBe`
@@ -66,6 +75,13 @@ spec = do
       [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| (unordered) [] |] `shouldMatch` [aesonQQ| [] |]
+      [qq| (unordered) [1, 2, 3] |] `shouldMatch` [aesonQQ| [1, 2, 3] |]
+      [qq| (unordered) [1, 2, 3] |] `shouldMatch` [aesonQQ| [2, 3, 1] |]
+      [qq| (unordered) [1, 2, 2] |] `shouldMatch` [aesonQQ| [2, 2, 1] |]
+      [qq| (unordered) [1, _, 2] |] `shouldMatch` [aesonQQ| [2, 2, 1] |]
+      [qq| (unordered) [1, 2, ...] |] `shouldMatch` [aesonQQ| [2, 3, 1] |]
+      [qq| (unordered) [1, 2, ...] |] `shouldMatch` [aesonQQ| [2, 2, 1] |]
       [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 |]
@@ -81,6 +97,9 @@ spec = do
       [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| (unordered) [1, 2, 3] |] `shouldNotMatch` [aesonQQ| [1, 2, 4] |]
+      [qq| (unordered) [1, 2, 3, 4] |] `shouldNotMatch` [aesonQQ| [1, 2, 3] |]
+      [qq| (unordered) [1, 2] |] `shouldNotMatch` [aesonQQ| [1, 2, 2] |]
       [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} |]
@@ -96,6 +115,13 @@ spec = do
       match [qq| {foo: _hole} |] [aesonQQ| {foo: {bar: {baz: [1, 4]}}} |] `shouldBe`
         pure (HashMap.singleton "hole" [aesonQQ| {bar: {baz: [1, 4]}} |])
 
+    context "unordered array" $
+      it "named holes" $ do
+        match [qq| (unordered) [1, _hole] |] [aesonQQ| [2, 1] |] `shouldBe`
+          pure (HashMap.singleton "hole" [aesonQQ| 2 |])
+        match [qq| (unordered) [{foo: _hole}, ...] |] [aesonQQ| [{foo: 2}, 1] |] `shouldBe`
+          pure (HashMap.singleton "hole" [aesonQQ| 2 |])
+
     -- https://github.com/supki/aeson-match-qq/issues/7
     it "#7" $ do
       match [qq| {foo: _} |] [aesonQQ| {} |] `shouldBe`
@@ -118,6 +144,7 @@ spec = do
             , extendable = False
             })
 
+    -- https://github.com/supki/aeson-match-qq/issues/13
     it "#13" $
       [qq| "Слава Україні" |] `shouldMatch` [aesonQQ| "Слава Україні" |]