diff --git a/CHANGELOG.markdown b/CHANGELOG.markdown --- a/CHANGELOG.markdown +++ b/CHANGELOG.markdown @@ -1,3 +1,8 @@ +1.4.2 +===== + + * Unordered arrays (https://github.com/supki/aeson-match-qq/pull/15) + 1.4.1 ===== diff --git a/aeson-match-qq.cabal b/aeson-match-qq.cabal --- a/aeson-match-qq.cabal +++ b/aeson-match-qq.cabal @@ -7,7 +7,7 @@ -- hash: 5d1f836e56344a26982a1f67c2ccb2010e6ac6be94d88f239c4b15c9fe108df6 name: aeson-match-qq -version: 1.4.1 +version: 1.4.2 synopsis: Declarative JSON matchers. description: See README.markdown category: Web @@ -42,6 +42,7 @@ , attoparsec , base >=4.14 && <5 , bytestring + , containers , either , haskell-src-meta , scientific 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 @@ -12,11 +12,14 @@ import Data.Aeson ((.=)) import qualified Data.Aeson as Aeson import qualified Data.Aeson.KeyMap as Aeson (toHashMapText) -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) @@ -65,10 +68,11 @@ 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) @@ -79,6 +83,11 @@ (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 (Aeson.toHashMapText -> o)) -> let fold f = HashMap.foldrWithKey (\k v a -> liftA2 HashMap.union a (f k v)) (pure mempty) @@ -109,6 +118,64 @@ (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 {..}) @@ -223,3 +290,7 @@ instance IsString PathElem where fromString = Key . fromString + +imapMaybe :: (Int -> a -> Maybe b) -> [a] -> [b] +imapMaybe f = + mapMaybe (uncurry f) . zip [0..] 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 @@ -49,6 +49,8 @@ string OpenSquareBracketP -> array + OpenParenP -> + arrayUO OpenCurlyBracketP -> object HashP -> @@ -128,6 +130,17 @@ _ -> 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 = 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 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 @@ -39,6 +39,7 @@ | Number Scientific | String Text | Array (Array ext) + | ArrayUO (Array ext) | Object (Object ext) | Ext ext deriving (Show, Eq) @@ -70,6 +71,10 @@ [ "type" .= ("array" :: Text) , "value" .= v ] + ArrayUO v -> + [ "type" .= ("array-unordered" :: Text) + , "value" .= v + ] Object v -> [ "type" .= ("object" :: Text) , "value" .= v @@ -117,6 +122,13 @@ , 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 = @@ -149,6 +161,7 @@ | NumberT | StringT | ArrayT + | ArrayUOT | ObjectT deriving (Show, Eq, Lift) @@ -159,6 +172,7 @@ NumberT {} -> "number" StringT {} -> "string" ArrayT {} -> "array" + ArrayUOT {} -> "array-unordered" ObjectT {} -> "object" data Nullable 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 @@ -41,6 +41,15 @@ [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 @@ [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 @@ [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} |] @@ -100,6 +119,13 @@ 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` @@ -122,6 +148,7 @@ , extendable = False }) + -- https://github.com/supki/aeson-match-qq/issues/13 it "#13" $ [qq| "Слава Україні" |] `shouldMatch` [aesonQQ| "Слава Україні" |]