diff --git a/CHANGELOG.markdown b/CHANGELOG.markdown new file mode 100644 --- /dev/null +++ b/CHANGELOG.markdown @@ -0,0 +1,11 @@ +1.1.0 +===== + + * Optionally typed holes (https://github.com/supki/aeson-match-qq/pull/9) + + * Fixed spurious validation errors (https://github.com/supki/aeson-match-qq/issues/7) + +1.0.0 +===== + + * Initial release. diff --git a/aeson-match-qq.cabal b/aeson-match-qq.cabal --- a/aeson-match-qq.cabal +++ b/aeson-match-qq.cabal @@ -4,11 +4,11 @@ -- -- see: https://github.com/sol/hpack -- --- hash: 57b8bf8d01a999a9e081c25a75f1254dbf1f7d23805594b588bed35eb03b9a7a +-- hash: b37b8f340b6ce5d17c4938172bdd5e7805347f8290f68163f3215e5b7cfd8a14 name: aeson-match-qq -version: 1.0.0 -synopsis: Matching Aeson values with a quasiquoter +version: 1.1.0 +synopsis: Declarative JSON matchers. description: See README.markdown category: Web maintainer: matvey.aksenov@gmail.com @@ -18,6 +18,7 @@ build-type: Simple extra-source-files: README.markdown + CHANGELOG.markdown library exposed-modules: @@ -33,7 +34,7 @@ build-depends: aeson , attoparsec - , base >=4.7 && <5 + , base >=4.11 && <5 , bytestring , either , haskell-src-meta @@ -57,7 +58,7 @@ aeson , aeson-match-qq , aeson-qq - , base >=4.7 && <5 + , base >=4.11 && <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 @@ -3,6 +3,9 @@ , Array , Object , Box(..) + , TypeSig(..) + , Type(..) + , Nullable(..) , Path , PathElem(..) , parse @@ -20,7 +23,7 @@ import Aeson.Match.QQ.Internal.Match (Path, PathElem(..), match, mismatch, missingPathElem, extraArrayValues, extraObjectValues) import Aeson.Match.QQ.Internal.Parse (parse) -import Aeson.Match.QQ.Internal.Value (Value(..), Box(..), Array, Object) +import Aeson.Match.QQ.Internal.Value (Value(..), Box(..), Array, Object, TypeSig(..), Type(..), Nullable(..)) qq :: QuasiQuoter 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 @@ -11,6 +11,7 @@ import Data.Aeson ((.=)) import qualified Data.Aeson as Aeson 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) @@ -20,7 +21,7 @@ import qualified Data.Vector as Vector import Prelude hiding (any, null) -import Aeson.Match.QQ.Internal.Value (Value(..), Box(..)) +import Aeson.Match.QQ.Internal.Value (Value(..), Box(..), TypeSig(..), Type(..), Nullable(..)) match :: Value Aeson.Value -> Aeson.Value -> Validation (NonEmpty VE) (HashMap Text Aeson.Value) @@ -30,10 +31,11 @@ go path matcher given = do let mismatched = mismatch (reverse path) matcher given case (matcher, given) of - (Any Nothing, _) -> - pure mempty - (Any (Just name), val) -> - pure (HashMap.singleton name val) + (Any holeTypeO nameO, val) -> do + for_ holeTypeO $ \holeType -> + unless (holeTypeMatch holeType val) + mismatched + pure (maybe mempty (\name -> HashMap.singleton name val) nameO) (Null, Aeson.Null) -> pure mempty (Null, _) -> do @@ -58,14 +60,14 @@ mismatched pure mempty (Array Box {knownValues, extendable}, Aeson.Array arr) -> - let knownValuesL = Vector.length knownValues - arrL = Vector.length arr - fold f = + 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 || knownValuesL == arrL) - (extraArrayValues (reverse path) (Vector.drop knownValuesL arr)) *> + (extendable || Vector.null extraValues) + (extraArrayValues (reverse path) extraValues) *> fold (\i v -> maybe (missingPathElem (reverse path) (Idx i)) (go (Idx i : path) v) (arr Vector.!? i)) knownValues @@ -73,14 +75,14 @@ mismatched pure mempty (Object Box {knownValues, extendable}, Aeson.Object o) -> - let knownValuesL = HashMap.size knownValues - oL = HashMap.size o - fold f = + 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 || knownValuesL == oL) - (extraObjectValues (reverse path) (HashMap.difference o knownValues)) *> + (extendable || HashMap.null extraValues) + (extraObjectValues (reverse path) extraValues) *> fold (\k v -> maybe (missingPathElem (reverse path) (Key k)) (go (Key k : path) v) (HashMap.lookup k o)) knownValues @@ -90,6 +92,17 @@ (Ext val, val') -> do unless (val == val') mismatched pure mempty + +holeTypeMatch :: TypeSig -> Aeson.Value -> Bool +holeTypeMatch type_ val = + case (type_, val) of + (TypeSig {nullable = Nullable}, Aeson.Null) -> True + (TypeSig {type_ = BoolT} , Aeson.Bool {}) -> True + (TypeSig {type_ = NumberT} , Aeson.Number {}) -> True + (TypeSig {type_ = StringT} , Aeson.String {}) -> True + (TypeSig {type_ = ArrayT} , Aeson.Array {}) -> True + (TypeSig {type_ = ObjectT} , Aeson.Object {}) -> True + (_, _) -> False mismatch :: Path -> Value Aeson.Value -> Aeson.Value -> Validation (NonEmpty VE) a mismatch path matcher given = 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 @@ -5,14 +5,17 @@ ( parse ) where -import Control.Applicative ((<|>)) +import Control.Applicative ((<|>), optional) import qualified Data.Aeson.Parser as Aeson import qualified Data.ByteString as ByteString -- cannot use .Text here due to .Aeson parsers being tied to .ByteString import qualified Data.Attoparsec.ByteString as Atto +import Data.Bool (bool) import Data.ByteString (ByteString) import qualified Data.Char as Char +import Data.Foldable (asum) import qualified Data.HashMap.Strict as HashMap +import Data.Maybe (isJust) import Data.Text (Text) import qualified Data.Text as Text import qualified Data.Text.Encoding as Text @@ -22,7 +25,7 @@ import Language.Haskell.TH (Exp(..)) import Prelude hiding (any, null) -import Aeson.Match.QQ.Internal.Value (Value(..), Box(..)) +import Aeson.Match.QQ.Internal.Value (Value(..), Box(..), TypeSig(..), Type(..), Nullable(..)) parse :: ByteString -> Either String (Value Exp) @@ -61,7 +64,10 @@ any :: Atto.Parser (Value Exp) any = do _ <- Atto.word8 AnyP - fmap (Any . Just) key <|> pure (Any Nothing) + name <- fmap Just key <|> pure Nothing + spaces + expectedType <- optional typeSig + pure (Any expectedType name) null :: Atto.Parser (Value Exp) null = @@ -180,6 +186,23 @@ str <- Atto.takeWhile1 (/= CloseCurlyBracketP) <* Atto.word8 CloseCurlyBracketP either fail pure (parseExp (Text.unpack (Text.decodeUtf8 str))) +typeSig :: Atto.Parser TypeSig +typeSig = do + _ <- Atto.word8 ColonP + spaces + asum + [ p "bool" BoolT + , p "number" NumberT + , p "string" StringT + , p "array" ArrayT + , p "object" ObjectT + ] + where + p name typeName = do + _ <- Atto.string name + q <- optional (Atto.word8 QuestionMarkP) + pure (TypeSig typeName (bool NonNullable Nullable (isJust q))) + -- This function has been stolen from aeson. -- ref: https://hackage.haskell.org/package/aeson-1.4.6.0/docs/src/Data.Aeson.Parser.Internal.html#skipSpace spaces :: Atto.Parser () @@ -216,3 +239,6 @@ pattern NewLineP = 0x0a pattern CRP = 0x0d pattern TabP = 0x09 + +pattern QuestionMarkP :: Word8 +pattern QuestionMarkP = 63 -- '?' 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 @@ -1,7 +1,9 @@ +{-# LANGUAGE DeriveLift #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE StrictData #-} {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TypeFamilies #-} module Aeson.Match.QQ.Internal.Value @@ -9,6 +11,9 @@ , Box(..) , Array , Object + , TypeSig(..) + , Type(..) + , Nullable(..) ) where import Data.Aeson ((.=)) @@ -28,7 +33,7 @@ data Value ext - = Any (Maybe Text) + = Any (Maybe TypeSig) (Maybe Text) | Null | Bool Bool | Number Scientific @@ -41,8 +46,9 @@ instance Aeson.ToJSON ext => Aeson.ToJSON (Value ext) where toJSON = Aeson.object . \case - Any name -> + Any type_ name -> [ "type" .= ("any" :: Text) + , "expected-type" .= type_ , "name" .= name ] Null -> @@ -94,8 +100,8 @@ -- undefined for some datatypes. instance ext ~ Exp => Lift (Value ext) where lift = \case - Any name -> - [| Any $(pure (maybe (ConE 'Nothing) (AppE (ConE 'Just) . AppE (VarE 'fromString) . LitE . textL) name)) :: Value Aeson.Value |] + Any type_ name -> + [| Any type_ $(pure (maybe (ConE 'Nothing) (AppE (ConE 'Just) . AppE (VarE 'fromString) . LitE . textL) name)) :: Value Aeson.Value |] Null -> [| Null :: Value Aeson.Value |] Bool b -> @@ -123,3 +129,43 @@ where textL = StringL . Text.unpack + +data TypeSig = TypeSig + { type_ :: Type + , nullable :: Nullable + } deriving (Show, Eq, Lift) + +instance Aeson.ToJSON TypeSig where + toJSON TypeSig {..} = + Aeson.object + [ "type" .= type_ + , "nullable" .= nullable + ] + +data Type + = BoolT + | NumberT + | StringT + | ArrayT + | ObjectT + deriving (Show, Eq, Lift) + +instance Aeson.ToJSON Type where + toJSON = + Aeson.toJSON . \case + BoolT {} -> "bool" :: Text + NumberT {} -> "number" + StringT {} -> "string" + ArrayT {} -> "array" + ObjectT {} -> "object" + +data Nullable + = Nullable + | NonNullable + deriving (Show, Eq, Lift) + +instance Aeson.ToJSON Nullable where + toJSON = + Aeson.toJSON . \case + Nullable -> True + NonNullable -> False 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 @@ -16,9 +16,11 @@ spec = do describe "parse" $ it "specs" $ do - [qq| _ |] `shouldBe` Any Nothing - [qq| _hole |] `shouldBe` Any (pure "hole") - [qq| _"fancy hole" |] `shouldBe` Any (pure "fancy hole") + [qq| _ |] `shouldBe` Any Nothing Nothing + [qq| _hole |] `shouldBe` Any Nothing (pure "hole") + [qq| _"fancy hole" |] `shouldBe` Any Nothing (pure "fancy hole") + [qq| _typed-hole : number |] `shouldBe` Any (pure (TypeSig NumberT NonNullable)) (pure "typed-hole") + [qq| _typed-nullable-hole : number? |] `shouldBe` Any (pure (TypeSig NumberT Nullable)) (pure "typed-nullable-hole") [qq| null |] `shouldBe` Null @@ -35,9 +37,9 @@ [qq| [1, 2, 3] |] `shouldBe` Array Box {knownValues = [Number 1, Number 2, Number 3], extendable = False} [qq| [1, _, 3] |] `shouldBe` - Array Box {knownValues = [Number 1, Any Nothing, Number 3], extendable = False} + Array Box {knownValues = [Number 1, Any Nothing Nothing, Number 3], extendable = False} [qq| [1, _, 3, ...] |] `shouldBe` - Array Box {knownValues = [Number 1, Any Nothing, Number 3], extendable = True} + Array Box {knownValues = [Number 1, Any Nothing Nothing, Number 3], extendable = True} [qq| {} |] `shouldBe` Object Box {knownValues = [], extendable = False} @@ -62,10 +64,13 @@ [qq| 4 |] `shouldMatch` [aesonQQ| 4 |] [qq| "foo" |] `shouldMatch` [aesonQQ| "foo" |] [qq| [1, 2, 3] |] `shouldMatch` [aesonQQ| [1, 2, 3] |] - [qq| [1, 2, 3, ...] |] `shouldMatch` [aesonQQ| [1, 2, 3, 4] |] + [qq| [1, _ : number, 3, ...] |] `shouldMatch` [aesonQQ| [1, 2, 3, 4] |] + [qq| [1, _ : string] |] `shouldMatch` [aesonQQ| [1, "foo"] |] [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 |] + [qq| {foo: _ : number, bar: 7} |] `shouldMatch` [aesonQQ| {foo: 4, bar: 7} |] + [qq| {foo: _ : number?, bar: 7} |] `shouldMatch` [aesonQQ| {foo: null, bar: 7} |] [qq| null |] `shouldNotMatch` [aesonQQ| 4 |] [qq| true |] `shouldNotMatch` [aesonQQ| false |] @@ -74,11 +79,14 @@ [qq| "foo" |] `shouldNotMatch` [aesonQQ| "bar" |] [qq| [1, 2, 3] |] `shouldNotMatch` [aesonQQ| [1, 2, 3, 4] |] [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| {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} |] it "paths" $ do match [qq| {foo: {bar: {baz: [1, 4]}}} |] [aesonQQ| {foo: {bar: {baz: [1, 7]}}} |] `shouldBe` @@ -87,6 +95,13 @@ it "named holes" $ do match [qq| {foo: _hole} |] [aesonQQ| {foo: {bar: {baz: [1, 4]}}} |] `shouldBe` pure (HashMap.singleton "hole" [aesonQQ| {bar: {baz: [1, 4]}} |]) + + -- https://github.com/supki/aeson-match-qq/issues/7 + it "#7" $ do + match [qq| {foo: _} |] [aesonQQ| {} |] `shouldBe` + missingPathElem [] "foo" + match [qq| [_] |] [aesonQQ| [] |] `shouldBe` + missingPathElem [] (Idx 0) newtype ToEncoding a = ToEncoding { unToEncoding :: a } deriving (Show, Eq, Num)