packages feed

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 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