aeson-match-qq 1.5.3 → 1.6.0
raw patch · 7 files changed
+187/−172 lines, 7 filesPVP ok
version bump matches the API change (PVP)
API changes (from Hackage documentation)
- Aeson.Match.QQ: Any :: Maybe TypeSig -> Maybe Text -> Value ext
- Aeson.Match.QQ: NonNullable :: Nullable
- Aeson.Match.QQ: Nullable :: Nullable
- Aeson.Match.QQ: TypeSig :: Type -> Nullable -> TypeSig
- Aeson.Match.QQ: [extendable] :: Box a -> Bool
- Aeson.Match.QQ: [knownValues] :: Box a -> a
- Aeson.Match.QQ: data Nullable
- Aeson.Match.QQ: data TypeSig
- Aeson.Match.QQ: data Value ext
- Aeson.Match.QQ.Internal.Value: Any :: Maybe TypeSig -> Maybe Text -> Value ext
- Aeson.Match.QQ.Internal.Value: NonNullable :: Nullable
- Aeson.Match.QQ.Internal.Value: Nullable :: Nullable
- Aeson.Match.QQ.Internal.Value: TypeSig :: Type -> Nullable -> TypeSig
- Aeson.Match.QQ.Internal.Value: [extendable] :: Box a -> Bool
- Aeson.Match.QQ.Internal.Value: [knownValues] :: Box a -> a
- Aeson.Match.QQ.Internal.Value: data Nullable
- Aeson.Match.QQ.Internal.Value: data TypeSig
- Aeson.Match.QQ.Internal.Value: data Value ext
- Aeson.Match.QQ.Internal.Value: instance (ext GHC.Types.~ Language.Haskell.TH.Syntax.Exp) => Language.Haskell.TH.Syntax.Lift (Aeson.Match.QQ.Internal.Value.Value ext)
- Aeson.Match.QQ.Internal.Value: instance Data.Aeson.Types.ToJSON.ToJSON Aeson.Match.QQ.Internal.Value.Nullable
- Aeson.Match.QQ.Internal.Value: instance Data.Aeson.Types.ToJSON.ToJSON Aeson.Match.QQ.Internal.Value.TypeSig
- Aeson.Match.QQ.Internal.Value: instance Data.Aeson.Types.ToJSON.ToJSON ext => Data.Aeson.Types.ToJSON.ToJSON (Aeson.Match.QQ.Internal.Value.Value ext)
- Aeson.Match.QQ.Internal.Value: instance GHC.Classes.Eq Aeson.Match.QQ.Internal.Value.Nullable
- Aeson.Match.QQ.Internal.Value: instance GHC.Classes.Eq Aeson.Match.QQ.Internal.Value.TypeSig
- Aeson.Match.QQ.Internal.Value: instance GHC.Classes.Eq ext => GHC.Classes.Eq (Aeson.Match.QQ.Internal.Value.Value ext)
- Aeson.Match.QQ.Internal.Value: instance GHC.Show.Show Aeson.Match.QQ.Internal.Value.Nullable
- Aeson.Match.QQ.Internal.Value: instance GHC.Show.Show Aeson.Match.QQ.Internal.Value.TypeSig
- Aeson.Match.QQ.Internal.Value: instance GHC.Show.Show ext => GHC.Show.Show (Aeson.Match.QQ.Internal.Value.Value ext)
- Aeson.Match.QQ.Internal.Value: instance Language.Haskell.TH.Syntax.Lift Aeson.Match.QQ.Internal.Value.Nullable
- Aeson.Match.QQ.Internal.Value: instance Language.Haskell.TH.Syntax.Lift Aeson.Match.QQ.Internal.Value.TypeSig
+ Aeson.Match.QQ: Hole :: Maybe HoleSig -> Maybe Text -> Matcher ext
+ Aeson.Match.QQ: HoleSig :: Type -> Bool -> HoleSig
+ Aeson.Match.QQ: [extra] :: Box a -> Bool
+ Aeson.Match.QQ: [values] :: Box a -> a
+ Aeson.Match.QQ: data HoleSig
+ Aeson.Match.QQ: data Matcher ext
+ Aeson.Match.QQ.Internal.Value: Hole :: Maybe HoleSig -> Maybe Text -> Matcher ext
+ Aeson.Match.QQ.Internal.Value: HoleSig :: Type -> Bool -> HoleSig
+ Aeson.Match.QQ.Internal.Value: [extra] :: Box a -> Bool
+ Aeson.Match.QQ.Internal.Value: [values] :: Box a -> a
+ Aeson.Match.QQ.Internal.Value: data HoleSig
+ Aeson.Match.QQ.Internal.Value: data Matcher ext
+ Aeson.Match.QQ.Internal.Value: instance (ext GHC.Types.~ Language.Haskell.TH.Syntax.Exp) => Language.Haskell.TH.Syntax.Lift (Aeson.Match.QQ.Internal.Value.Matcher ext)
+ Aeson.Match.QQ.Internal.Value: instance Data.Aeson.Types.ToJSON.ToJSON Aeson.Match.QQ.Internal.Value.HoleSig
+ Aeson.Match.QQ.Internal.Value: instance Data.Aeson.Types.ToJSON.ToJSON ext => Data.Aeson.Types.ToJSON.ToJSON (Aeson.Match.QQ.Internal.Value.Matcher ext)
+ Aeson.Match.QQ.Internal.Value: instance GHC.Base.Functor Aeson.Match.QQ.Internal.Value.Box
+ Aeson.Match.QQ.Internal.Value: instance GHC.Base.Functor Aeson.Match.QQ.Internal.Value.Matcher
+ Aeson.Match.QQ.Internal.Value: instance GHC.Classes.Eq Aeson.Match.QQ.Internal.Value.HoleSig
+ Aeson.Match.QQ.Internal.Value: instance GHC.Classes.Eq ext => GHC.Classes.Eq (Aeson.Match.QQ.Internal.Value.Matcher ext)
+ Aeson.Match.QQ.Internal.Value: instance GHC.Show.Show Aeson.Match.QQ.Internal.Value.HoleSig
+ Aeson.Match.QQ.Internal.Value: instance GHC.Show.Show ext => GHC.Show.Show (Aeson.Match.QQ.Internal.Value.Matcher ext)
+ Aeson.Match.QQ.Internal.Value: instance Language.Haskell.TH.Syntax.Lift Aeson.Match.QQ.Internal.Value.HoleSig
- Aeson.Match.QQ: Array :: Array ext -> Value ext
+ Aeson.Match.QQ: Array :: Array ext -> Matcher ext
- Aeson.Match.QQ: ArrayUO :: Array ext -> Value ext
+ Aeson.Match.QQ: ArrayUO :: Array ext -> Matcher ext
- Aeson.Match.QQ: Bool :: Bool -> Value ext
+ Aeson.Match.QQ: Bool :: Bool -> Matcher ext
- Aeson.Match.QQ: Ext :: ext -> Value ext
+ Aeson.Match.QQ: Ext :: ext -> Matcher ext
- Aeson.Match.QQ: MkMismatch :: Path -> Value Value -> Value -> Mismatch
+ Aeson.Match.QQ: MkMismatch :: Path -> Matcher Value -> Value -> Mismatch
- Aeson.Match.QQ: Null :: Value ext
+ Aeson.Match.QQ: Null :: Matcher ext
- Aeson.Match.QQ: Number :: Scientific -> Value ext
+ Aeson.Match.QQ: Number :: Scientific -> Matcher ext
- Aeson.Match.QQ: Object :: Object ext -> Value ext
+ Aeson.Match.QQ: Object :: Object ext -> Matcher ext
- Aeson.Match.QQ: String :: Text -> Value ext
+ Aeson.Match.QQ: String :: Text -> Matcher ext
- Aeson.Match.QQ: StringCI :: CI Text -> Value ext
+ Aeson.Match.QQ: StringCI :: CI Text -> Matcher ext
- Aeson.Match.QQ: [$sel:matcher:MkMismatch] :: Mismatch -> Value Value
+ Aeson.Match.QQ: [$sel:matcher:MkMismatch] :: Mismatch -> Matcher Value
- Aeson.Match.QQ: [nullable] :: TypeSig -> Nullable
+ Aeson.Match.QQ: [nullable] :: HoleSig -> Bool
- Aeson.Match.QQ: [type_] :: TypeSig -> Type
+ Aeson.Match.QQ: [type_] :: HoleSig -> Type
- Aeson.Match.QQ: match :: Value Value -> Value -> Either (NonEmpty Error) (HashMap Text Value)
+ Aeson.Match.QQ: match :: Matcher Value -> Value -> Either (NonEmpty Error) (HashMap Text Value)
- Aeson.Match.QQ: type Array ext = Box (Vector (Value ext))
+ Aeson.Match.QQ: type Array ext = Box (Vector (Matcher ext))
- Aeson.Match.QQ: type Object ext = Box (HashMap Text (Value ext))
+ Aeson.Match.QQ: type Object ext = Box (HashMap Text (Matcher ext))
- Aeson.Match.QQ.Internal.Match: MkMismatch :: Path -> Value Value -> Value -> Mismatch
+ Aeson.Match.QQ.Internal.Match: MkMismatch :: Path -> Matcher Value -> Value -> Mismatch
- Aeson.Match.QQ.Internal.Match: [$sel:matcher:MkMismatch] :: Mismatch -> Value Value
+ Aeson.Match.QQ.Internal.Match: [$sel:matcher:MkMismatch] :: Mismatch -> Matcher Value
- Aeson.Match.QQ.Internal.Match: match :: Value Value -> Value -> Either (NonEmpty Error) (HashMap Text Value)
+ Aeson.Match.QQ.Internal.Match: match :: Matcher Value -> Value -> Either (NonEmpty Error) (HashMap Text Value)
- Aeson.Match.QQ.Internal.Parse: parse :: ByteString -> Either String (Value Exp)
+ Aeson.Match.QQ.Internal.Parse: parse :: ByteString -> Either String (Matcher Exp)
- Aeson.Match.QQ.Internal.Value: Array :: Array ext -> Value ext
+ Aeson.Match.QQ.Internal.Value: Array :: Array ext -> Matcher ext
- Aeson.Match.QQ.Internal.Value: ArrayUO :: Array ext -> Value ext
+ Aeson.Match.QQ.Internal.Value: ArrayUO :: Array ext -> Matcher ext
- Aeson.Match.QQ.Internal.Value: Bool :: Bool -> Value ext
+ Aeson.Match.QQ.Internal.Value: Bool :: Bool -> Matcher ext
- Aeson.Match.QQ.Internal.Value: Ext :: ext -> Value ext
+ Aeson.Match.QQ.Internal.Value: Ext :: ext -> Matcher ext
- Aeson.Match.QQ.Internal.Value: Null :: Value ext
+ Aeson.Match.QQ.Internal.Value: Null :: Matcher ext
- Aeson.Match.QQ.Internal.Value: Number :: Scientific -> Value ext
+ Aeson.Match.QQ.Internal.Value: Number :: Scientific -> Matcher ext
- Aeson.Match.QQ.Internal.Value: Object :: Object ext -> Value ext
+ Aeson.Match.QQ.Internal.Value: Object :: Object ext -> Matcher ext
- Aeson.Match.QQ.Internal.Value: String :: Text -> Value ext
+ Aeson.Match.QQ.Internal.Value: String :: Text -> Matcher ext
- Aeson.Match.QQ.Internal.Value: StringCI :: CI Text -> Value ext
+ Aeson.Match.QQ.Internal.Value: StringCI :: CI Text -> Matcher ext
- Aeson.Match.QQ.Internal.Value: [nullable] :: TypeSig -> Nullable
+ Aeson.Match.QQ.Internal.Value: [nullable] :: HoleSig -> Bool
- Aeson.Match.QQ.Internal.Value: [type_] :: TypeSig -> Type
+ Aeson.Match.QQ.Internal.Value: [type_] :: HoleSig -> Type
- Aeson.Match.QQ.Internal.Value: embed :: Value -> Value ext
+ Aeson.Match.QQ.Internal.Value: embed :: Value -> Matcher ext
- Aeson.Match.QQ.Internal.Value: type Array ext = Box (Vector (Value ext))
+ Aeson.Match.QQ.Internal.Value: type Array ext = Box (Vector (Matcher ext))
- Aeson.Match.QQ.Internal.Value: type Object ext = Box (HashMap Text (Value ext))
+ Aeson.Match.QQ.Internal.Value: type Object ext = Box (HashMap Text (Matcher ext))
Files
- CHANGELOG.markdown +5/−0
- aeson-match-qq.cabal +1/−1
- src/Aeson/Match/QQ.hs +5/−7
- src/Aeson/Match/QQ/Internal/Match.hs +38/−41
- src/Aeson/Match/QQ/Internal/Parse.hs +42/−38
- src/Aeson/Match/QQ/Internal/Value.hs +71/−60
- test/Aeson/Match/QQSpec.hs +25/−25
CHANGELOG.markdown view
@@ -1,3 +1,8 @@+1.6.0+=====++ * Clarified ans simplified API some more.+ 1.5.3 =====
aeson-match-qq.cabal view
@@ -5,7 +5,7 @@ -- see: https://github.com/sol/hpack name: aeson-match-qq-version: 1.5.3+version: 1.6.0 synopsis: Declarative JSON matchers. description: See README.markdown category: Web
src/Aeson/Match/QQ.hs view
@@ -9,13 +9,12 @@ , ExtraObjectValues(..) , prettyError - , Value(..)+ , Matcher(..) , Array , Object , Box(..)- , TypeSig(..)+ , HoleSig(..) , Type(..)- , Nullable(..) , Path(..) , PathElem(..) ) where@@ -39,17 +38,16 @@ ) import Aeson.Match.QQ.Internal.Parse (parse) import Aeson.Match.QQ.Internal.Value- ( Value(..)+ ( Matcher(..) , Box(..) , Array , Object- , TypeSig(..)+ , HoleSig(..) , Type(..)- , Nullable(..) ) --- | Construct a matcher 'Value'.+-- | Construct a 'Matcher'. qq :: QuasiQuoter qq = QuasiQuoter { quoteExp = \str ->
src/Aeson/Match/QQ/Internal/Match.hs view
@@ -60,24 +60,21 @@ import qualified Text.PrettyPrint.HughesPJClass as PP (Pretty(..)) import Aeson.Match.QQ.Internal.Value- ( Value(..)+ ( Matcher(..) , Box(..)- , TypeSig(..)+ , HoleSig(..) , Type(..)- , Nullable(..) , embed ) --- | Test if a matcher matches a 'Aeson.Value'.+-- | Test if a 'Matcher' matches a 'Aeson.Value'. match- :: Value Aeson.Value- -- ^ A matcher, constructed with 'qq'+ :: Matcher Aeson.Value -> Aeson.Value- -- ^ A 'Value' from aeson -> Either (NonEmpty Error) (HashMap Text Aeson.Value) -- ^ Either a non-empty list of errors, or a mapping- -- from _holes to their values.+ -- from named _holes to their values. match matcher0 given0 = validationToEither (go [] matcher0 given0) where@@ -85,7 +82,7 @@ let mismatched = mismatch path matcher given mistyped = mistype path matcher given case (matcher, given) of- (Any holeTypeO nameO, val) -> do+ (Hole holeTypeO nameO, val) -> do for_ holeTypeO $ \holeType -> unless (holeTypeMatch holeType val) mistyped@@ -119,19 +116,19 @@ (StringCI _, _) -> do mistyped pure mempty- (Array Box {knownValues, extendable}, Aeson.Array arr) ->+ (Array Box {values, extra}, 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+ Vector.drop (Vector.length values) arr in unless- (extendable || Vector.null extraValues)+ (extra || Vector.null extraValues) (extraArrayValues path extraValues) *> fold (\i v -> maybe (missingPathElem path (Idx i)) (go (Idx i : path) v) (arr Vector.!? i))- knownValues+ values (Array _, _) -> do mistyped pure mempty@@ -140,7 +137,7 @@ (ArrayUO _, _) -> do mistyped pure mempty- ( Object Box {knownValues, extendable}+ ( Object Box {values, extra} #if MIN_VERSION_aeson(2,0,0) , Aeson.Object (Aeson.toHashMapText -> o) #else@@ -151,57 +148,57 @@ let fold f = HashMap.foldrWithKey (\k v a -> liftA2 HashMap.union a (f k v)) (pure mempty) extraValues =- HashMap.difference o knownValues+ HashMap.difference o values in unless- (extendable || HashMap.null extraValues)+ (extra || HashMap.null extraValues) (extraObjectValues path extraValues) *> fold (\k v -> maybe (missingPathElem path (Key k)) (go (Key k : path) v) (HashMap.lookup k o))- knownValues+ values (Object _, _) -> do mistyped pure mempty (Ext val, val') -> go path (embed val) val' -holeTypeMatch :: TypeSig -> Aeson.Value -> Bool+holeTypeMatch :: HoleSig -> 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_ = StringCIT} , Aeson.String {}) -> True- (TypeSig {type_ = ArrayT} , Aeson.Array {}) -> True- (TypeSig {type_ = ArrayUOT} , Aeson.Array {}) -> True- (TypeSig {type_ = ObjectT} , Aeson.Object {}) -> True+ (HoleSig {nullable = True}, Aeson.Null) -> True+ (HoleSig {type_ = BoolT} , Aeson.Bool {}) -> True+ (HoleSig {type_ = NumberT} , Aeson.Number {}) -> True+ (HoleSig {type_ = StringT} , Aeson.String {}) -> True+ (HoleSig {type_ = StringCIT} , Aeson.String {}) -> True+ (HoleSig {type_ = ArrayT} , Aeson.Array {}) -> True+ (HoleSig {type_ = ArrayUOT} , Aeson.Array {}) -> True+ (HoleSig {type_ = ObjectT} , Aeson.Object {}) -> True (_, _) -> False matchArrayUO :: Validation (NonEmpty Error) (HashMap Text Aeson.Value) -> [PathElem]- -> Box (Vector (Value Aeson.Value))+ -> Box (Vector (Matcher Aeson.Value)) -> Vector Aeson.Value -> Validation (NonEmpty Error) (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+matchArrayUO mismatched path Box {values, extra} xs = do+ -- Collect possible indices in `xs` for each position in `values`.+ let indices = map (collectMatchingIndices (toList xs)) (toList values)+ -- Find all unique valid ways to map each position in `values` 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+ -- If some positions in `values` cannot be mapped to -- anything in `xs`, we give up.- | length ivs < length knownValues ->+ | length ivs < length values -> 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+ -- anything in `values`, we check if the 'Matcher' allows for+ -- extra values.+ | length ivs < length xs && not extra -> do let is = Set.fromList (map fst ivs) extraValues = Vector.ifilter (\i _ -> not (i `Set.member` is)) xs extraArrayValues path extraValues@@ -238,7 +235,7 @@ mismatch :: [PathElem]- -> Value Aeson.Value+ -> Matcher Aeson.Value -> Aeson.Value -> Validation (NonEmpty Error) a mismatch (Path . reverse -> path) matcher given =@@ -246,7 +243,7 @@ mistype :: [PathElem]- -> Value Aeson.Value+ -> Matcher Aeson.Value -> Aeson.Value -> Validation (NonEmpty Error) a mistype (Path . reverse -> path) matcher given =@@ -347,7 +344,7 @@ -- is wrong, or the value itself does not match. data Mismatch = MkMismatch { path :: Path- , matcher :: Value Aeson.Value+ , matcher :: Matcher Aeson.Value , given :: Aeson.Value } deriving (Show, Eq) @@ -388,7 +385,7 @@ , PP.hsep ["missing:", PP.pPrint missing] ] --- | Unless an extendable matcher is used, any extra values in an array+-- | Unless an permissive matcher is used, any extra values in an array -- missing in the matcher will trigger this error. data ExtraArrayValues = MkExtraArrayValues { path :: Path@@ -412,7 +409,7 @@ ] ] --- | Unless an extendable matcher is used, any extra key-value pairs in+-- | Unless an permissive matcher is used, any extra key-value pairs in -- an object missing in the matcher will trigger this error. data ExtraObjectValues = MkExtraObjectValues { path :: Path
src/Aeson/Match/QQ/Internal/Parse.hs view
@@ -10,7 +10,6 @@ import qualified Data.Attoparsec.ByteString as Atto import qualified Data.ByteString as ByteString -- cannot use .Text here due to .Aeson parsers being tied to .ByteString-import Data.Bool (bool) import Data.ByteString (ByteString) import qualified Data.CaseInsensitive as CI import qualified Data.Char as Char@@ -26,19 +25,24 @@ import Language.Haskell.TH (Exp(..)) import Prelude hiding (any, null) -import Aeson.Match.QQ.Internal.Value (Value(..), Box(..), TypeSig(..), Type(..), Nullable(..))+import Aeson.Match.QQ.Internal.Value+ ( Matcher(..)+ , Box(..)+ , HoleSig(..)+ , Type(..)+ ) -parse :: ByteString -> Either String (Value Exp)+parse :: ByteString -> Either String (Matcher Exp) parse = Atto.parseOnly value -value :: Atto.Parser (Value Exp)+value :: Atto.Parser (Matcher Exp) value = do spaces b <- Atto.peekWord8' case b of- AnyP ->+ HoleP -> any NP -> null@@ -64,41 +68,41 @@ startOfNumber b = b >= ZeroP && b <= NineP || b == MinusP -any :: Atto.Parser (Value Exp)+any :: Atto.Parser (Matcher Exp) any = do- _ <- Atto.word8 AnyP+ _ <- Atto.word8 HoleP name <- fmap Just key <|> pure Nothing spaces- expectedType <- optional typeSig- pure (Any expectedType name)+ expectedType <- optional holeSig+ pure (Hole expectedType name) -null :: Atto.Parser (Value Exp)+null :: Atto.Parser (Matcher Exp) null = Null <$ Atto.string "null" -false :: Atto.Parser (Value Exp)+false :: Atto.Parser (Matcher Exp) false = Bool False <$ Atto.string "false" -true :: Atto.Parser (Value Exp)+true :: Atto.Parser (Matcher Exp) true = Bool True <$ Atto.string "true" -number :: Atto.Parser (Value Exp)+number :: Atto.Parser (Matcher Exp) number = fmap Number Aeson.scientific -string :: Atto.Parser (Value Exp)+string :: Atto.Parser (Matcher Exp) string = fmap String Aeson.jstring -stringCI :: Atto.Parser (Value Exp)+stringCI :: Atto.Parser (Matcher Exp) stringCI = do _ <- Atto.string "(ci)" spaces fmap (StringCI . CI.mk) Aeson.jstring -array :: Atto.Parser (Value Exp)+array :: Atto.Parser (Matcher Exp) array = do _ <- Atto.word8 OpenSquareBracketP spaces@@ -106,11 +110,11 @@ case b of CloseSquareBracketP -> do _ <- Atto.word8 CloseSquareBracketP- pure (Array Box {knownValues = Vector.empty, extendable = False})+ pure (Array Box {values = Vector.empty, extra = False}) _ -> do loop [] 0 where- loop values !n = do+ loop acc !n = do val <- value spaces b <- Atto.satisfy (\w -> w == CommaP || w == CloseSquareBracketP) Atto.<?> "',' or ']'"@@ -124,27 +128,27 @@ spaces _ <- Atto.word8 CloseSquareBracketP pure $ Array Box- { knownValues = Vector.fromListN (n + 1) (reverse (val : values))- , extendable = True+ { values = Vector.fromListN (n + 1) (reverse (val : acc))+ , extra = True } _ ->- loop (val : values) (n + 1)+ loop (val : acc) (n + 1) CloseSquareBracketP -> pure $ Array Box- { knownValues = Vector.fromListN (n + 1) (reverse (val : values))- , extendable = False+ { values = Vector.fromListN (n + 1) (reverse (val : acc))+ , extra = False } _ -> error "impossible" -arrayUO :: Atto.Parser (Value Exp)+arrayUO :: Atto.Parser (Matcher Exp) arrayUO = do _ <- Atto.string "(unordered)" spaces Array box <- array pure (ArrayUO box) -object :: Atto.Parser (Value Exp)+object :: Atto.Parser (Matcher Exp) object = do _ <- Atto.word8 OpenCurlyBracketP spaces@@ -152,11 +156,11 @@ case b of CloseCurlyBracketP -> do _ <- Atto.word8 CloseCurlyBracketP- pure (Object Box {knownValues = HashMap.empty, extendable = False})+ pure (Object Box {values = HashMap.empty, extra = False}) _ -> loop [] where- loop values = do+ loop acc = do k <- key spaces _ <- Atto.word8 ColonP@@ -174,15 +178,15 @@ spaces _ <- Atto.word8 CloseCurlyBracketP pure $ Object Box- { knownValues = HashMap.fromList ((k, val) : values)- , extendable = True+ { values = HashMap.fromList ((k, val) : acc)+ , extra = True } _ ->- loop ((k, val) : values)+ loop ((k, val) : acc) CloseCurlyBracketP -> pure $ Object Box- { knownValues = HashMap.fromList ((k, val) : values)- , extendable = False+ { values = HashMap.fromList ((k, val) : acc)+ , extra = False } _ -> error "impossible"@@ -196,7 +200,7 @@ rest = () <$ Atto.string "..." -haskellExp :: Atto.Parser (Value Exp)+haskellExp :: Atto.Parser (Matcher Exp) haskellExp = fmap Ext (Atto.string "#{" *> go) where@@ -204,8 +208,8 @@ str <- Atto.takeWhile1 (/= CloseCurlyBracketP) <* Atto.word8 CloseCurlyBracketP either fail pure (parseExp (Text.unpack (Text.decodeUtf8 str))) -typeSig :: Atto.Parser TypeSig-typeSig = do+holeSig :: Atto.Parser HoleSig+holeSig = do _ <- Atto.word8 ColonP spaces asum@@ -221,7 +225,7 @@ p name typeName = do _ <- Atto.string name q <- optional (Atto.word8 QuestionMarkP)- pure (TypeSig typeName (bool NonNullable Nullable (isJust q)))+ pure (HoleSig typeName (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@@ -230,8 +234,8 @@ Atto.skipWhile (\b -> b == SpaceP || b == NewLineP || b == CRP || b == TabP) {-# INLINE spaces #-} -pattern AnyP, NP, FP, TP, DoubleQuoteP, DotP, CommaP, HashP :: Word8-pattern AnyP = 95 -- '_'+pattern HoleP, NP, FP, TP, DoubleQuoteP, DotP, CommaP, HashP :: Word8+pattern HoleP = 95 -- '_' pattern NP = 110 -- 'n' pattern FP = 102 -- 'f' pattern TP = 116 -- 't'
src/Aeson/Match/QQ/Internal/Value.hs view
@@ -1,4 +1,5 @@ {-# LANGUAGE CPP #-}+{-# LANGUAGE DeriveFunctor #-} {-# LANGUAGE DeriveLift #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE NamedFieldPuns #-}@@ -9,13 +10,12 @@ {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE ViewPatterns #-} module Aeson.Match.QQ.Internal.Value- ( Value(..)+ ( Matcher(..) , Box(..) , Array , Object- , TypeSig(..)+ , HoleSig(..) , Type(..)- , Nullable(..) , embed ) where @@ -47,24 +47,34 @@ import Prelude hiding (any, null) -data Value ext- = Any (Maybe TypeSig) (Maybe Text)+-- | A value constructed using 'qq' that attempts to match+-- a JSON document.+data Matcher ext+ = Hole (Maybe HoleSig) (Maybe Text)+ -- ^ Optionally typed, optionally named _hole.+ -- If a type is provided, the _hole only matches those values+ -- that have that type.+ -- If a name is provided, the matched value is returned+ -- to the user. | Null | Bool Bool | Number Scientific | String Text | StringCI (CI Text)+ -- ^ Case-insensitive strings | Array (Array ext) | ArrayUO (Array ext)+ -- ^ Unordered arrays | Object (Object ext) | Ext ext- deriving (Show, Eq)+ -- ^ External values spliced into a 'Matcher' using the `#{}` syntax+ deriving (Show, Eq, Functor) -instance Aeson.ToJSON ext => Aeson.ToJSON (Value ext) where+instance Aeson.ToJSON ext => Aeson.ToJSON (Matcher ext) where toJSON = Aeson.object . \case- Any type_ name ->- [ "type" .= ("any" :: Text)+ Hole type_ name ->+ [ "type" .= ("hole" :: Text) , "expected-type" .= type_ , "name" .= name ]@@ -104,62 +114,65 @@ , "value" .= v ] +-- | A wrapper for those matchers that support the `...` syntax. data Box a = Box- { knownValues :: a- , extendable :: Bool- } deriving (Show, Eq)+ { values :: a+ , extra :: Bool+ -- ^ Are extra, not specifically mentioned by a 'Matcher', values+ -- allowed in a 'Value'?+ } deriving (Show, Eq, Functor) instance Aeson.ToJSON a => Aeson.ToJSON (Box a) where toJSON Box {..} = Aeson.object- [ "known-values" .= knownValues- , "extendable" .= extendable+ [ "values" .= values+ , "extra" .= extra ] -type Array ext = Box (Vector (Value ext))+type Array ext = Box (Vector (Matcher ext)) -type Object ext = Box (HashMap Text (Value ext))+type Object ext = Box (HashMap Text (Matcher ext)) --- | Convert `Value Exp` to `Value Aeson.Value`. This uses a roundabout way to get+-- | Convert `'Matcher' 'Exp'` to `'Matcher' 'Aeson.Value'`. This uses a roundabout way to get -- `Aeson.Value` from `ToJSON.toEncoding` to avoid calling `Aeson.toJSON` which may be -- undefined for some datatypes.-instance ext ~ Exp => Lift (Value ext) where+instance ext ~ Exp => Lift (Matcher ext) where lift = \case- Any type_ name ->- [| Any type_ $(pure (maybe (ConE 'Nothing) (AppE (ConE 'Just) . AppE (VarE 'fromString) . LitE . textL) name)) :: Value Aeson.Value |]+ Hole type_ name ->+ [| Hole type_ $(pure (maybe (ConE 'Nothing) (AppE (ConE 'Just) . AppE (VarE 'fromString) . LitE . textL) name)) :: Matcher Aeson.Value |] Null ->- [| Null :: Value Aeson.Value |]+ [| Null :: Matcher Aeson.Value |] Bool b ->- [| Bool b :: Value Aeson.Value |]+ [| Bool b :: Matcher Aeson.Value |] Number n ->- [| Number (fromRational $(pure (LitE (RationalL (toRational n))))) :: Value Aeson.Value |]+ [| Number (fromRational $(pure (LitE (RationalL (toRational n))))) :: Matcher Aeson.Value |] String str ->- [| String (fromString $(pure (LitE (textL str)))) :: Value Aeson.Value |]+ [| String (fromString $(pure (LitE (textL str)))) :: Matcher Aeson.Value |] StringCI str ->- [| StringCI (fromString $(pure (LitE (textL (CI.original str))))) :: Value Aeson.Value |]- Array Box {knownValues, extendable} -> [|+ [| StringCI (fromString $(pure (LitE (textL (CI.original str))))) :: Matcher Aeson.Value |]+ Array Box {values, extra} -> [| Array Box- { knownValues =- Vector.fromList $(fmap (ListE . Vector.toList) (traverse lift knownValues))- , extendable- } :: Value Aeson.Value+ { values =+ Vector.fromList $(fmap (ListE . Vector.toList) (traverse lift values))+ , extra+ } :: Matcher Aeson.Value |]- ArrayUO Box {knownValues, extendable} -> [|+ ArrayUO Box {values, extra} -> [| ArrayUO Box- { knownValues =- Vector.fromList $(fmap (ListE . Vector.toList) (traverse lift knownValues))- , extendable- } :: Value Aeson.Value+ { values =+ Vector.fromList $(fmap (ListE . Vector.toList) (traverse lift values))+ , extra+ } :: Matcher Aeson.Value |]- Object Box {knownValues, extendable} -> [|+ Object Box {values, extra} -> [| Object Box- { knownValues =- HashMap.fromList $(fmap (ListE . map (\(k, v) -> TupE [Just (LitE (textL k)), Just v]) . HashMap.toList) (traverse lift knownValues))- , extendable- } :: Value Aeson.Value+ { values =+ HashMap.fromList $(fmap (ListE . map (\(k, v) -> TupE [Just (LitE (textL k)), Just v]) . HashMap.toList) (traverse lift values))+ , extra+ } :: Matcher Aeson.Value |] Ext ext ->- [| Ext (let ~(Just val) = Aeson.decode (Aeson.encodingToLazyByteString (Aeson.toEncoding $(pure ext))) in val) :: Value Aeson.Value |]+ [| Ext (let ~(Just val) = Aeson.decode (Aeson.encodingToLazyByteString (Aeson.toEncoding $(pure ext))) in val) :: Matcher Aeson.Value |] where textL = StringL . Text.unpack@@ -170,26 +183,35 @@ unsafeTExpCoerce . lift #endif -data TypeSig = TypeSig+-- | _hole type signature+data HoleSig = HoleSig { type_ :: Type- , nullable :: Nullable+ , nullable :: Bool } deriving (Show, Eq, Lift) -instance Aeson.ToJSON TypeSig where- toJSON TypeSig {..} =+instance Aeson.ToJSON HoleSig where+ toJSON HoleSig {..} = Aeson.object [ "type" .= type_ , "nullable" .= nullable ] +-- | _hole type data Type = BoolT+ -- ^ @_ : bool@ | NumberT+ -- ^ @_ : number@ | StringT+ -- ^ @_ : string@ | StringCIT+ -- ^ @_ : ci-string@ | ArrayT+ -- ^ @_ : array@ | ArrayUOT+ -- ^ @_ : unordered-array@ | ObjectT+ -- ^ @_ : object@ deriving (Show, Eq, Lift) instance Aeson.ToJSON Type where@@ -198,23 +220,12 @@ BoolT {} -> "bool" :: Text NumberT {} -> "number" StringT {} -> "string"- StringCIT {} -> "string-ci"+ StringCIT {} -> "ci-string" ArrayT {} -> "array" ArrayUOT {} -> "array-unordered" ObjectT {} -> "object" -data Nullable- = Nullable- | NonNullable- deriving (Show, Eq, Lift)--instance Aeson.ToJSON Nullable where- toJSON =- Aeson.toJSON . \case- Nullable -> True- NonNullable -> False--embed :: Aeson.Value -> Value ext+embed :: Aeson.Value -> Matcher ext embed = \case Aeson.Null -> Null@@ -225,10 +236,10 @@ Aeson.String n -> String n Aeson.Array xs ->- Array Box {knownValues = fmap embed xs, extendable = False}+ Array Box {values = fmap embed xs, extra = False} #if MIN_VERSION_aeson(2,0,0) Aeson.Object (Aeson.toHashMapText -> o) -> #else Aeson.Object o -> #endif- Object Box {knownValues = fmap embed o, extendable = False}+ Object Box {values = fmap embed o, extra = False}
test/Aeson/Match/QQSpec.hs view
@@ -18,11 +18,11 @@ spec = do describe "parse" $ it "specs" $ do- [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| _ |] `shouldBe` Hole Nothing Nothing+ [qq| _hole |] `shouldBe` Hole Nothing (pure "hole")+ [qq| _"fancy hole" |] `shouldBe` Hole Nothing (pure "fancy hole")+ [qq| _typed-hole : number |] `shouldBe` Hole (pure (HoleSig NumberT False)) (pure "typed-hole")+ [qq| _typed-nullable-hole : number? |] `shouldBe` Hole (pure (HoleSig NumberT True)) (pure "typed-nullable-hole") [qq| null |] `shouldBe` Null @@ -35,36 +35,36 @@ [qq| "foo" |] `shouldBe` String "foo" [qq| [] |] `shouldBe`- Array Box {knownValues = [], extendable = False}+ Array Box {values = [], extra = False} [qq| [1, 2, 3] |] `shouldBe`- Array Box {knownValues = [Number 1, Number 2, Number 3], extendable = False}+ Array Box {values = [Number 1, Number 2, Number 3], extra = False} [qq| [1, _, 3] |] `shouldBe`- Array Box {knownValues = [Number 1, Any Nothing Nothing, Number 3], extendable = False}+ Array Box {values = [Number 1, Hole Nothing Nothing, Number 3], extra = False} [qq| [1, _, 3, ...] |] `shouldBe`- Array Box {knownValues = [Number 1, Any Nothing Nothing, Number 3], extendable = True}+ Array Box {values = [Number 1, Hole Nothing Nothing, Number 3], extra = True} [qq| (unordered) [] |] `shouldBe`- ArrayUO Box {knownValues = [], extendable = False}+ ArrayUO Box {values = [], extra = False} [qq| (unordered) [1, 2, 3] |] `shouldBe`- ArrayUO Box {knownValues = [Number 1, Number 2, Number 3], extendable = False}+ ArrayUO Box {values = [Number 1, Number 2, Number 3], extra = False} [qq| (unordered) [1, _, 3] |] `shouldBe`- ArrayUO Box {knownValues = [Number 1, Any Nothing Nothing, Number 3], extendable = False}+ ArrayUO Box {values = [Number 1, Hole Nothing Nothing, Number 3], extra = False} [qq| (unordered) [1, _, 3, ...] |] `shouldBe`- ArrayUO Box {knownValues = [Number 1, Any Nothing Nothing, Number 3], extendable = True}+ ArrayUO Box {values = [Number 1, Hole Nothing Nothing, Number 3], extra = True} [qq| {} |] `shouldBe`- Object Box {knownValues = [], extendable = False}+ Object Box {values = [], extra = False} [qq| {foo: 4} |] `shouldBe`- Object Box {knownValues = [("foo", Number 4)], extendable = False}+ Object Box {values = [("foo", Number 4)], extra = False} [qq| {foo: 4, "bar": 7} |] `shouldBe`- Object Box {knownValues = [("foo", Number 4), ("bar", Number 7)], extendable = False}+ Object Box {values = [("foo", Number 4), ("bar", Number 7)], extra = False} [qq| {foo: 4, "bar": 7, ...} |] `shouldBe`- Object Box {knownValues = [("foo", Number 4), ("bar", Number 7)], extendable = True}+ Object Box {values = [("foo", Number 4), ("bar", Number 7)], extra = True} [qq| {foo: #{4 + 7 :: Int}} |] `shouldBe`- Object Box {knownValues = [("foo", Ext (Aeson.Number 11))], extendable = False}+ Object Box {values = [("foo", Ext (Aeson.Number 11))], extra = False} [qq| {foo: #{4 + 7 :: ToEncoding Int}} |] `shouldBe`- Object Box {knownValues = [("foo", Ext (Aeson.Number 11))], extendable = False}+ Object Box {values = [("foo", Ext (Aeson.Number 11))], extra = False} describe "match" $ do it "specs" $ do@@ -154,14 +154,14 @@ [qq| {foo: []} |] `shouldBe` Object (Box- { knownValues = [("foo", Array (Box {knownValues = [], extendable = False}))]- , extendable = False+ { values = [("foo", Array (Box {values = [], extra = False}))]+ , extra = False }) [qq| [{}] |] `shouldBe` Array (Box- { knownValues = [Object (Box {knownValues = [], extendable = False})]- , extendable = False+ { values = [Object (Box {values = [], extra = False})]+ , extra = False }) -- https://github.com/supki/aeson-match-qq/issues/13@@ -253,11 +253,11 @@ toEncoding = Aeson.toEncoding . unToEncoding -shouldMatch :: Value Aeson.Value -> Aeson.Value -> Expectation+shouldMatch :: HasCallStack => Matcher Aeson.Value -> Aeson.Value -> Expectation shouldMatch a b = match a b `shouldBe` pure mempty -shouldNotMatch :: Value Aeson.Value -> Aeson.Value -> Expectation+shouldNotMatch :: HasCallStack => Matcher Aeson.Value -> Aeson.Value -> Expectation shouldNotMatch a b = match a b `shouldNotBe` pure mempty