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