From 24771852bd1ca1de85a2875794dda97db29cc854 Mon Sep 17 00:00:00 2001 From: Matvey Aksenov Date: Wed, 6 Apr 2022 08:43:54 +0000 Subject: [PATCH] fix #6: Unordered arrays --- aeson-match-qq.cabal | 5 +- package.yaml | 1 + shell.nix | 13 ++++ src/Aeson/Match/QQ/Internal/Match.hs | 92 +++++++++++++++++++++++++--- src/Aeson/Match/QQ/Internal/Parse.hs | 18 ++++++ src/Aeson/Match/QQ/Internal/Value.hs | 14 +++++ stack.yaml | 2 +- stack.yaml.lock | 8 +-- test/Aeson/Match/QQSpec.hs | 27 ++++++++ 9 files changed, 162 insertions(+), 18 deletions(-) create mode 100644 shell.nix diff --git a/aeson-match-qq.cabal b/aeson-match-qq.cabal index 5d65b4e..96a213e 100644 --- a/aeson-match-qq.cabal +++ b/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 diff --git a/package.yaml b/package.yaml index 14ff409..baae9e3 100644 --- a/package.yaml +++ b/package.yaml @@ -19,6 +19,7 @@ library: - aeson - attoparsec - bytestring + - containers - either - haskell-src-meta - scientific diff --git a/shell.nix b/shell.nix new file mode 100644 index 0000000..ff5755e --- /dev/null +++ b/shell.nix @@ -0,0 +1,13 @@ +{ pkgs ? import {} +, ghc ? pkgs.haskell.compiler.ghc884 +, stack ? pkgs.stack +}: +pkgs.mkShell { + buildInputs = with pkgs; [ + ghc + stack + ]; + + shellHook = '' + ''; +} diff --git a/src/Aeson/Match/QQ/Internal/Match.hs b/src/Aeson/Match/QQ/Internal/Match.hs index ec35284..7c53fdf 100644 --- a/src/Aeson/Match/QQ/Internal/Match.hs +++ b/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..] diff --git a/src/Aeson/Match/QQ/Internal/Parse.hs b/src/Aeson/Match/QQ/Internal/Parse.hs index 5c24895..79524b7 100644 --- a/src/Aeson/Match/QQ/Internal/Parse.hs +++ b/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 diff --git a/src/Aeson/Match/QQ/Internal/Value.hs b/src/Aeson/Match/QQ/Internal/Value.hs index d9414c2..9a6bcc8 100644 --- a/src/Aeson/Match/QQ/Internal/Value.hs +++ b/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 diff --git a/stack.yaml b/stack.yaml index 77b672f..b3b92e0 100644 --- a/stack.yaml +++ b/stack.yaml @@ -1,4 +1,4 @@ -resolver: lts-14.7 +resolver: lts-16.31 packages: - '.' allow-newer: true diff --git a/stack.yaml.lock b/stack.yaml.lock index 8d62222..c222190 100644 --- a/stack.yaml.lock +++ b/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 diff --git a/test/Aeson/Match/QQSpec.hs b/test/Aeson/Match/QQSpec.hs index 7b0d72f..ff10d7a 100644 --- a/test/Aeson/Match/QQSpec.hs +++ b/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| "Слава Україні" |]