packages feed

aeson-match-qq 1.2.1 → 1.2.2

raw patch · 6 files changed

+149/−12 lines, 6 filesdep +containers

Dependencies added: containers

Files

CHANGELOG.markdown view
@@ -1,3 +1,8 @@+1.2.2+=====++  * Unordered arrays (https://github.com/supki/aeson-match-qq/pull/15)+ 1.2.1 =====
aeson-match-qq.cabal view
@@ -1,11 +1,11 @@ cabal-version: 1.12 --- This file has been generated from package.yaml by hpack version 0.34.4.+-- This file has been generated from package.yaml by hpack version 0.34.6. -- -- see: https://github.com/sol/hpack  name:           aeson-match-qq-version:        1.2.1+version:        1.2.2 synopsis:       Declarative JSON matchers. description:    See README.markdown category:       Web@@ -40,6 +40,7 @@     , attoparsec     , base >=4.11 && <5     , bytestring+    , containers     , either     , haskell-src-meta     , scientific
src/Aeson/Match/QQ/Internal/Match.hs view
@@ -10,11 +10,14 @@ 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 @@         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 @@       (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 @@     (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 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 view
@@ -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
src/Aeson/Match/QQ/Internal/Value.hs view
@@ -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 =@@ -147,6 +159,7 @@   | NumberT   | StringT   | ArrayT+  | ArrayUOT   | ObjectT     deriving (Show, Eq, Lift) @@ -157,6 +170,7 @@       NumberT {} -> "number"       StringT {} -> "string"       ArrayT {} -> "array"+      ArrayUOT {} -> "array-unordered"       ObjectT {} -> "object"  data Nullable
test/Aeson/Match/QQSpec.hs view
@@ -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} |]@@ -96,6 +115,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`@@ -118,6 +144,7 @@             , extendable = False             }) +    -- https://github.com/supki/aeson-match-qq/issues/13     it "#13" $       [qq| "Слава Україні" |] `shouldMatch` [aesonQQ| "Слава Україні" |]