aeson-match-qq 1.2.2 → 1.3.0
raw patch · 7 files changed
+26/−164 lines, 7 filesdep −containersdep ~base
Dependencies removed: containers
Dependency ranges changed: base
Files
- CHANGELOG.markdown +2/−7
- aeson-match-qq.cabal +7/−6
- src/Aeson/Match/QQ.hs +1/−2
- src/Aeson/Match/QQ/Internal/Match.hs +11/−86
- src/Aeson/Match/QQ/Internal/Parse.hs +0/−18
- src/Aeson/Match/QQ/Internal/Value.hs +1/−15
- test/Aeson/Match/QQSpec.hs +4/−30
CHANGELOG.markdown view
@@ -1,12 +1,7 @@-1.2.2-=====-- * Unordered arrays (https://github.com/supki/aeson-match-qq/pull/15)--1.2.1+1.3.0 ===== - * Proper Unicode support (https://github.com/supki/aeson-match-qq/pull/14)+ * GHC 9.0 compatibility 1.2.0 =====
aeson-match-qq.cabal view
@@ -1,18 +1,20 @@ cabal-version: 1.12 --- This file has been generated from package.yaml by hpack version 0.34.6.+-- This file has been generated from package.yaml by hpack version 0.34.4. -- -- see: https://github.com/sol/hpack+--+-- hash: 861c01fee7e78bcb5bbb679c51d856ac4cdd2c82b61d209a00d4ed0b58709e57 name: aeson-match-qq-version: 1.2.2+version: 1.3.0 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 2022+copyright: Matvey Aksenov 2021 license: BSD2 license-file: LICENSE build-type: Simple@@ -38,9 +40,8 @@ build-depends: aeson , attoparsec- , base >=4.11 && <5+ , base >=4.14 && <5 , bytestring- , containers , either , haskell-src-meta , scientific@@ -63,7 +64,7 @@ aeson , aeson-match-qq , aeson-qq- , base >=4.11 && <5+ , base >=4.14 && <5 , hspec , unordered-containers default-language: Haskell2010
src/Aeson/Match/QQ.hs view
@@ -18,7 +18,6 @@ ) where import Data.String (IsString(..))-import qualified Data.Text.Encoding as Text import Language.Haskell.TH.Quote (QuasiQuoter(..)) import Language.Haskell.TH.Syntax (Lift(..)) @@ -30,7 +29,7 @@ qq :: QuasiQuoter qq = QuasiQuoter { quoteExp = \str ->- case parse (Text.encodeUtf8 (fromString str)) of+ case parse (fromString str) of Left err -> error ("Aeson.Match.QQ.qq: " ++ err) Right val ->
src/Aeson/Match/QQ/Internal/Match.hs view
@@ -10,14 +10,11 @@ import Control.Monad (unless) import Data.Aeson ((.=)) import qualified Data.Aeson as Aeson-import Data.Either.Validation (Validation(..), eitherToValidation)-import Data.Foldable (for_, toList)-import Data.Bool (bool)+import Data.Either.Validation (Validation, eitherToValidation)+import Data.Foldable (for_) 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)@@ -27,10 +24,7 @@ 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@@ -66,11 +60,10 @@ 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)@@ -81,17 +74,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)- 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)@@ -117,64 +104,6 @@ (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 {..})@@ -289,7 +218,3 @@ 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,8 +49,6 @@ string OpenSquareBracketP -> array- OpenParenP ->- arrayUO OpenCurlyBracketP -> object HashP ->@@ -130,17 +128,6 @@ _ -> 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@@ -239,14 +226,9 @@ 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,7 +39,6 @@ | Number Scientific | String Text | Array (Array ext)- | ArrayUO (Array ext) | Object (Object ext) | Ext ext deriving (Show, Eq)@@ -71,10 +70,6 @@ [ "type" .= ("array" :: Text) , "value" .= v ]- ArrayUO v ->- [ "type" .= ("array-unordered" :: Text)- , "value" .= v- ] Object v -> [ "type" .= ("object" :: Text) , "value" .= v@@ -122,17 +117,10 @@ , 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 =- HashMap.fromList $(fmap (ListE . map (\(k, v) -> TupE [LitE (textL k), v]) . HashMap.toList) (traverse lift knownValues))+ HashMap.fromList $(fmap (ListE . map (\(k, v) -> TupE [Just (LitE (textL k)), Just v]) . HashMap.toList) (traverse lift knownValues)) , extendable } :: Value Aeson.Value |]@@ -159,7 +147,6 @@ | NumberT | StringT | ArrayT- | ArrayUOT | ObjectT deriving (Show, Eq, Lift) @@ -170,7 +157,6 @@ NumberT {} -> "number" StringT {} -> "string" ArrayT {} -> "array"- ArrayUOT {} -> "array-unordered" ObjectT {} -> "object" data Nullable
test/Aeson/Match/QQSpec.hs view
@@ -41,15 +41,6 @@ [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`@@ -75,13 +66,6 @@ [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 |]@@ -97,15 +81,16 @@ [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`@@ -115,13 +100,6 @@ 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`@@ -143,10 +121,6 @@ { 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)