diff --git a/CHANGELOG.markdown b/CHANGELOG.markdown --- a/CHANGELOG.markdown +++ b/CHANGELOG.markdown @@ -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 ===== diff --git a/aeson-match-qq.cabal b/aeson-match-qq.cabal --- a/aeson-match-qq.cabal +++ b/aeson-match-qq.cabal @@ -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 diff --git a/src/Aeson/Match/QQ.hs b/src/Aeson/Match/QQ.hs --- a/src/Aeson/Match/QQ.hs +++ b/src/Aeson/Match/QQ.hs @@ -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 -> 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 @@ -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..] 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,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 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,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 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,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)