aeson-match-qq 1.3.0 → 1.3.1
raw patch · 7 files changed
+155/−17 lines, 7 filesdep +containers
Dependencies added: containers
Files
- CHANGELOG.markdown +6/−0
- aeson-match-qq.cabal +4/−5
- src/Aeson/Match/QQ.hs +2/−1
- src/Aeson/Match/QQ/Internal/Match.hs +81/−7
- src/Aeson/Match/QQ/Internal/Parse.hs +18/−0
- src/Aeson/Match/QQ/Internal/Value.hs +14/−0
- test/Aeson/Match/QQSpec.hs +30/−4
CHANGELOG.markdown view
@@ -1,3 +1,9 @@+1.3.1+=====++ * Unordered arrays (https://github.com/supki/aeson-match-qq/pull/15) + * Proper Unicode support (https://github.com/supki/aeson-match-qq/pull/14)+ 1.3.0 =====
aeson-match-qq.cabal view
@@ -1,20 +1,18 @@ 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------ hash: 861c01fee7e78bcb5bbb679c51d856ac4cdd2c82b61d209a00d4ed0b58709e57 name: aeson-match-qq-version: 1.3.0+version: 1.3.1 synopsis: Declarative JSON matchers. description: See README.markdown category: Web homepage: https://github.com/supki/aeson-match-qq#readme bug-reports: https://github.com/supki/aeson-match-qq/issues maintainer: matvey.aksenov@gmail.com-copyright: Matvey Aksenov 2021+copyright: Matvey Aksenov 2022 license: BSD2 license-file: LICENSE build-type: Simple@@ -42,6 +40,7 @@ , attoparsec , base >=4.14 && <5 , bytestring+ , containers , either , haskell-src-meta , scientific
src/Aeson/Match/QQ.hs view
@@ -18,6 +18,7 @@ ) where import Data.String (IsString(..))+import qualified Data.Text.Encoding as Text import Language.Haskell.TH.Quote (QuasiQuoter(..)) import Language.Haskell.TH.Syntax (Lift(..)) @@ -29,7 +30,7 @@ qq :: QuasiQuoter qq = QuasiQuoter { quoteExp = \str ->- case parse (fromString str) of+ case parse (Text.encodeUtf8 (fromString str)) of Left err -> error ("Aeson.Match.QQ.qq: " ++ err) Right val ->
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)@@ -24,7 +27,10 @@ import Aeson.Match.QQ.Internal.Value (Value(..), Box(..), TypeSig(..), Type(..), Nullable(..)) -match :: Value Aeson.Value -> Aeson.Value -> Validation (NonEmpty VE) (HashMap Text Aeson.Value)+match+ :: Value Aeson.Value+ -> Aeson.Value+ -> Validation (NonEmpty VE) (HashMap Text Aeson.Value) match = go [] where@@ -60,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)@@ -74,6 +81,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 o) -> let fold f = HashMap.foldrWithKey (\k v a -> liftA2 HashMap.union a (f k v)) (pure mempty)@@ -104,6 +116,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 {..})@@ -218,3 +288,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,16 +97,15 @@ [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} |] [qq| #{1 + 2 :: Int} |] `shouldNotMatch` [aesonQQ| 4 |] [qq| {foo: _ : number, bar: 7} |] `shouldNotMatch` [aesonQQ| {foo: "foo", bar: 7} |] [qq| {foo: _ : number, bar: 7} |] `shouldNotMatch` [aesonQQ| {foo: null, bar: 7} |]- [qq|- { foo: _ : string- , bar: 7- } |] `shouldNotMatch` [aesonQQ| {foo: null, bar: 7} |] it "paths" $ do match [qq| {foo: {bar: {baz: [1, 4]}}} |] [aesonQQ| {foo: {bar: {baz: [1, 7]}}} |] `shouldBe`@@ -100,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`@@ -121,6 +143,10 @@ { knownValues = [Object (Box {knownValues = [], extendable = False})] , extendable = False })++ -- https://github.com/supki/aeson-match-qq/issues/13+ it "#13" $+ [qq| "Слава Україні" |] `shouldMatch` [aesonQQ| "Слава Україні" |] newtype ToEncoding a = ToEncoding { unToEncoding :: a } deriving (Show, Eq, Num)