diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,26 @@ +Copyright (c) 2018, Matvey Aksenov + +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + + * Redistributions in binary form must reproduce the above + copyright notice, this list of conditions and the following + disclaimer in the documentation and/or other materials provided + with the distribution. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. diff --git a/README.markdown b/README.markdown new file mode 100644 --- /dev/null +++ b/README.markdown @@ -0,0 +1,43 @@ +aeson-match-qq +============== + +[![Build status](https://circleci.com/gh/supki/aeson-match-qq.svg?style=svg)](https://circleci.com/gh/supki/aeson-match-qq) + +Declarative JSON matchers. + +Motivation +---------- + +When testing an HTTP service that spouts JSON documents, it's often inconvenient to write out the whole response as +the expected value. Sometimes, you only care about a couple specific properties, or simply want to ensure that the +response has certain structure. This package provides a quasiquoter to define declarative matchers using a variation +of the familiar syntax. + +Features +-------- + +### Basic JSON construction + +Since this package is heavily inspired by [aeson-qq][0], the parser tries to follow its behavior and has support for +optional quotes for simple keys and the `#{exp}` syntax for Haskell expression interpolation. It currently does not support +variable keys though and there are no plans to add them. + +### Spread-like syntax for arrays and objects + +This syntax allows you to match only the part of the structure you care about: + +`[match| [1, 2, 3, ...] |]` matches arrays starting with `[1, 2, 3]` +`[match| {foo: 1, bar: 2, ...} |]` matches objects that are supersets of `{foo: 1, bar: 2}` + +### Holes + +Holes are placeholders that match anything: + +`[match| _ |]` matches any JSON document +`[match| {foo: _} |]` matches any object that has the `foo` property. + +If a hole is named, its value will be returned from `match` + +`[match| {foo: {bar: _n} |]` will return `{n: 4}` if matched with `{foo: {bar: 4}}` + + [0]: https://hackage.haskell.org/package/aeson-qq diff --git a/aeson-match-qq.cabal b/aeson-match-qq.cabal new file mode 100644 --- /dev/null +++ b/aeson-match-qq.cabal @@ -0,0 +1,63 @@ +cabal-version: 1.12 + +-- This file has been generated from package.yaml by hpack version 0.31.2. +-- +-- see: https://github.com/sol/hpack +-- +-- hash: 57b8bf8d01a999a9e081c25a75f1254dbf1f7d23805594b588bed35eb03b9a7a + +name: aeson-match-qq +version: 1.0.0 +synopsis: Matching Aeson values with a quasiquoter +description: See README.markdown +category: Web +maintainer: matvey.aksenov@gmail.com +copyright: Matvey Aksenov 2020 +license: BSD2 +license-file: LICENSE +build-type: Simple +extra-source-files: + README.markdown + +library + exposed-modules: + Aeson.Match.QQ + Aeson.Match.QQ.Internal.Match + Aeson.Match.QQ.Internal.Parse + Aeson.Match.QQ.Internal.Value + other-modules: + Paths_aeson_match_qq + hs-source-dirs: + src + ghc-options: -funbox-strict-fields -Wall + build-depends: + aeson + , attoparsec + , base >=4.7 && <5 + , bytestring + , either + , haskell-src-meta + , scientific + , template-haskell + , text + , unordered-containers + , vector + default-language: Haskell2010 + +test-suite spec + type: exitcode-stdio-1.0 + main-is: Spec.hs + other-modules: + Aeson.Match.QQSpec + Paths_aeson_match_qq + hs-source-dirs: + test + ghc-options: -Wall -threaded -with-rtsopts=-N + build-depends: + aeson + , aeson-match-qq + , aeson-qq + , base >=4.7 && <5 + , hspec + , unordered-containers + default-language: Haskell2010 diff --git a/src/Aeson/Match/QQ.hs b/src/Aeson/Match/QQ.hs new file mode 100644 --- /dev/null +++ b/src/Aeson/Match/QQ.hs @@ -0,0 +1,40 @@ +module Aeson.Match.QQ + ( Value(..) + , Array + , Object + , Box(..) + , Path + , PathElem(..) + , parse + , qq + , match + , mismatch + , missingPathElem + , extraArrayValues + , extraObjectValues + ) where + +import Data.String (IsString(..)) +import Language.Haskell.TH.Quote (QuasiQuoter(..)) +import Language.Haskell.TH.Syntax (Lift(..)) + +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) + + +qq :: QuasiQuoter +qq = QuasiQuoter + { quoteExp = \str -> + case parse (fromString str) of + Left err -> + error ("Aeson.Match.QQ.qq: " ++ err) + Right val -> + lift val + , quotePat = + \_ -> error "Aeson.Match.QQ.qq: no quotePat" + , quoteType = + \_ -> error "Aeson.Match.QQ.qq: no quoteType" + , quoteDec = + \_ -> error "Aeson.Match.QQ.qq: no quoteDec" + } diff --git a/src/Aeson/Match/QQ/Internal/Match.hs b/src/Aeson/Match/QQ/Internal/Match.hs new file mode 100644 --- /dev/null +++ b/src/Aeson/Match/QQ/Internal/Match.hs @@ -0,0 +1,207 @@ +{-# LANGUAGE ApplicativeDo #-} +{-# LANGUAGE DuplicateRecordFields #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} +module Aeson.Match.QQ.Internal.Match where + +import Control.Applicative (liftA2) +import Control.Monad (unless) +import Data.Aeson ((.=)) +import qualified Data.Aeson as Aeson +import Data.Either.Validation (Validation, eitherToValidation) +import Data.HashMap.Strict (HashMap) +import qualified Data.HashMap.Strict as HashMap +import Data.List.NonEmpty (NonEmpty) +import Data.String (IsString(..)) +import Data.Text (Text) +import Data.Vector (Vector) +import qualified Data.Vector as Vector +import Prelude hiding (any, null) + +import Aeson.Match.QQ.Internal.Value (Value(..), Box(..)) + + +match :: Value Aeson.Value -> Aeson.Value -> Validation (NonEmpty VE) (HashMap Text Aeson.Value) +match = + go [] + where + 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) + (Null, Aeson.Null) -> + pure mempty + (Null, _) -> do + mismatched + pure mempty + (Bool b, Aeson.Bool b') -> do + unless (b == b') mismatched + pure mempty + (Bool _, _) -> do + mismatched + pure mempty + (Number n, Aeson.Number n') -> do + unless (n == n') mismatched + pure mempty + (Number _, _) -> do + mismatched + pure mempty + (String str, Aeson.String str') -> do + unless (str == str') mismatched + pure mempty + (String _, _) -> do + mismatched + pure mempty + (Array Box {knownValues, extendable}, Aeson.Array arr) -> + let knownValuesL = Vector.length knownValues + arrL = Vector.length arr + fold f = + Vector.ifoldr (\i v a -> liftA2 HashMap.union a (f i v)) (pure mempty) + in + unless + (extendable || knownValuesL == arrL) + (extraArrayValues (reverse path) (Vector.drop knownValuesL arr)) *> + fold + (\i v -> maybe (missingPathElem (reverse path) (Idx i)) (go (Idx i : path) v) (arr Vector.!? i)) + knownValues + (Array _, _) -> do + mismatched + pure mempty + (Object Box {knownValues, extendable}, Aeson.Object o) -> + let knownValuesL = HashMap.size knownValues + oL = HashMap.size o + fold f = + HashMap.foldrWithKey (\k v a -> liftA2 HashMap.union a (f k v)) (pure mempty) + in + unless + (extendable || knownValuesL == oL) + (extraObjectValues (reverse path) (HashMap.difference o knownValues)) *> + fold + (\k v -> maybe (missingPathElem (reverse path) (Key k)) (go (Key k : path) v) (HashMap.lookup k o)) + knownValues + (Object _, _) -> do + mismatched + pure mempty + (Ext val, val') -> do + unless (val == val') mismatched + pure mempty + +mismatch :: Path -> Value Aeson.Value -> Aeson.Value -> Validation (NonEmpty VE) a +mismatch path matcher given = + throwE (Mismatch MkMismatch {..}) + +missingPathElem :: Path -> PathElem -> Validation (NonEmpty VE) a +missingPathElem path missing = + throwE (MissingPathElem MkMissingPathElem {..}) + +extraArrayValues :: Path -> Vector Aeson.Value -> Validation (NonEmpty VE) a +extraArrayValues path values = + throwE (ExtraArrayValues MkExtraArrayValues {..}) + +extraObjectValues :: Path -> HashMap Text Aeson.Value -> Validation (NonEmpty VE) a +extraObjectValues path values = + throwE (ExtraObjectValues MkExtraObjectValues {..}) + +throwE :: e -> Validation (NonEmpty e) a +throwE = + eitherToValidation . Left . pure + +data VE + = Mismatch Mismatch + | MissingPathElem MissingPathElem + | ExtraArrayValues ExtraArrayValues + | ExtraObjectValues ExtraObjectValues + deriving (Show, Eq) + +instance Aeson.ToJSON VE where + toJSON = + Aeson.object . \case + Mismatch v -> + [ "type" .= ("mismatch" :: Text) + , "value" .= v + ] + MissingPathElem v -> + [ "type" .= ("missing-path-elem" :: Text) + , "value" .= v + ] + ExtraArrayValues v -> + [ "type" .= ("extra-array-values" :: Text) + , "value" .= v + ] + ExtraObjectValues v -> + [ "type" .= ("extra-object-values" :: Text) + , "value" .= v + ] + +data MissingPathElem = MkMissingPathElem + { path :: Path + , missing :: PathElem + } deriving (Show, Eq) + +instance Aeson.ToJSON MissingPathElem where + toJSON MkMissingPathElem {..} = + Aeson.object + [ "path" .= path + , "missing" .= missing + ] + +data Mismatch = MkMismatch + { path :: Path + , matcher :: Value Aeson.Value + , given :: Aeson.Value + } deriving (Show, Eq) + +instance Aeson.ToJSON Mismatch where + toJSON MkMismatch {..} = + Aeson.object + [ "path" .= path + , "matcher" .= matcher + , "given" .= given + ] + +data ExtraArrayValues = MkExtraArrayValues + { path :: Path + , values :: Vector Aeson.Value + } deriving (Show, Eq) + +instance Aeson.ToJSON ExtraArrayValues where + toJSON MkExtraArrayValues {..} = + Aeson.object + [ "path" .= path + , "values" .= values + ] + +data ExtraObjectValues = MkExtraObjectValues + { path :: Path + , values :: HashMap Text Aeson.Value + } deriving (Show, Eq) + +instance Aeson.ToJSON ExtraObjectValues where + toJSON MkExtraObjectValues {..} = + Aeson.object + [ "path" .= path + , "values" .= values + ] + +type Path = [PathElem] + +data PathElem + = Key Text + | Idx Int + deriving (Show, Eq) + +instance Aeson.ToJSON PathElem where + toJSON = \case + Key k -> + Aeson.String k + Idx i -> + Aeson.Number (fromIntegral i) + +instance IsString PathElem where + fromString = + Key . fromString diff --git a/src/Aeson/Match/QQ/Internal/Parse.hs b/src/Aeson/Match/QQ/Internal/Parse.hs new file mode 100644 --- /dev/null +++ b/src/Aeson/Match/QQ/Internal/Parse.hs @@ -0,0 +1,218 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE PatternSynonyms #-} +module Aeson.Match.QQ.Internal.Parse + ( parse + ) where + +import Control.Applicative ((<|>)) +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.ByteString (ByteString) +import qualified Data.Char as Char +import qualified Data.HashMap.Strict as HashMap +import Data.Text (Text) +import qualified Data.Text as Text +import qualified Data.Text.Encoding as Text +import qualified Data.Vector as Vector +import Data.Word (Word8) +import Language.Haskell.Meta.Parse (parseExp) +import Language.Haskell.TH (Exp(..)) +import Prelude hiding (any, null) + +import Aeson.Match.QQ.Internal.Value (Value(..), Box(..)) + + +parse :: ByteString -> Either String (Value Exp) +parse = + Atto.parseOnly value + +value :: Atto.Parser (Value Exp) +value = do + spaces + b <- Atto.peekWord8' + case b of + AnyP -> + any + NP -> + null + FP -> + false + TP -> + true + DoubleQuoteP -> + string + OpenSquareBracketP -> + array + OpenCurlyBracketP -> + object + HashP -> + haskellExp + _ | startOfNumber b -> + number + | otherwise -> + fail ("a value cannot start with " ++ show b) + where + startOfNumber b = + b >= ZeroP && b <= NineP || b == MinusP + +any :: Atto.Parser (Value Exp) +any = do + _ <- Atto.word8 AnyP + fmap (Any . Just) key <|> pure (Any Nothing) + +null :: Atto.Parser (Value Exp) +null = + Null <$ Atto.string "null" + +false :: Atto.Parser (Value Exp) +false = + Bool False <$ Atto.string "false" + +true :: Atto.Parser (Value Exp) +true = + Bool True <$ Atto.string "true" + +number :: Atto.Parser (Value Exp) +number = + fmap Number Aeson.scientific + +string :: Atto.Parser (Value Exp) +string = + fmap String Aeson.jstring + +array :: Atto.Parser (Value Exp) +array = do + _ <- Atto.word8 OpenSquareBracketP + spaces + b <- Atto.peekWord8' + case b of + CloseSquareBracketP -> + pure (Array Box {knownValues = Vector.empty, extendable = False}) + _ -> do + loop [] 0 + where + loop values !n = do + val <- value + spaces + b <- Atto.satisfy (\w -> w == CommaP || w == CloseSquareBracketP) Atto. "',' or ']'" + case b of + CommaP -> do + spaces + b' <- Atto.peekWord8' + case b' of + DotP -> do + rest + spaces + _ <- Atto.word8 CloseSquareBracketP + pure $ Array Box + { knownValues = Vector.fromListN (n + 1) (reverse (val : values)) + , extendable = True + } + _ -> + loop (val : values) (n + 1) + CloseSquareBracketP -> + pure $ Array Box + { knownValues = Vector.fromListN (n + 1) (reverse (val : values)) + , extendable = False + } + _ -> + error "impossible" + +object :: Atto.Parser (Value Exp) +object = do + _ <- Atto.word8 OpenCurlyBracketP + spaces + b <- Atto.peekWord8' + case b of + CloseCurlyBracketP -> + pure (Object Box {knownValues = HashMap.empty, extendable = False}) + _ -> + loop [] + where + loop values = do + k <- key + spaces + _ <- Atto.word8 ColonP + spaces + val <- value + spaces + b <- Atto.satisfy (\b -> b == CommaP || b == CloseCurlyBracketP) Atto. "',' or '}'" + case b of + CommaP -> do + spaces + b' <- Atto.peekWord8' + case b' of + DotP -> do + rest + spaces + _ <- Atto.word8 CloseCurlyBracketP + pure $ Object Box + { knownValues = HashMap.fromList ((k, val) : values) + , extendable = True + } + _ -> + loop ((k, val) : values) + CloseCurlyBracketP -> + pure $ Object Box + { knownValues = HashMap.fromList ((k, val) : values) + , extendable = False + } + _ -> + error "impossible" + +key :: Atto.Parser Text +key = + Aeson.jstring <|> + fmap (Text.decodeUtf8 . ByteString.pack) (Atto.many1 (Atto.satisfy (\c -> Char.chr (fromIntegral c) `notElem` ("\\ \":;><${}[]," :: String)))) + +rest :: Atto.Parser () +rest = + () <$ Atto.string "..." + +haskellExp :: Atto.Parser (Value Exp) +haskellExp = + fmap Ext (Atto.string "#{" *> go) + where + go = do + str <- Atto.takeWhile1 (/= CloseCurlyBracketP) <* Atto.word8 CloseCurlyBracketP + either fail pure (parseExp (Text.unpack (Text.decodeUtf8 str))) + +-- 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 () +spaces = + 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 NP = 110 -- 'n' +pattern FP = 102 -- 'f' +pattern TP = 116 -- 't' +pattern DoubleQuoteP = 34 -- '"' +pattern CommaP = 44 -- ',' +pattern DotP = 46 -- '.' +pattern HashP = 35 -- '#' + +pattern OpenSquareBracketP, CloseSquareBracketP :: Word8 +pattern OpenSquareBracketP = 91 -- '[' +pattern CloseSquareBracketP = 93 -- ']' + +pattern OpenCurlyBracketP, CloseCurlyBracketP, ColonP :: Word8 +pattern OpenCurlyBracketP = 123 -- '{' +pattern CloseCurlyBracketP = 125 -- '}' +pattern ColonP = 58 -- ':' + +pattern ZeroP, NineP, MinusP :: Word8 +pattern ZeroP = 48 -- '0' +pattern NineP = 57 -- '9' +pattern MinusP = 45 -- '-' + +pattern SpaceP, NewLineP, CRP, TabP :: Word8 +pattern SpaceP = 0x20 +pattern NewLineP = 0x0a +pattern CRP = 0x0d +pattern TabP = 0x09 diff --git a/src/Aeson/Match/QQ/Internal/Value.hs b/src/Aeson/Match/QQ/Internal/Value.hs new file mode 100644 --- /dev/null +++ b/src/Aeson/Match/QQ/Internal/Value.hs @@ -0,0 +1,125 @@ +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeFamilies #-} +module Aeson.Match.QQ.Internal.Value + ( Value(..) + , Box(..) + , Array + , Object + ) where + +import Data.Aeson ((.=)) +import qualified Data.Aeson as Aeson +import qualified Data.Aeson.Encoding.Internal as Aeson (encodingToLazyByteString) +import Data.HashMap.Strict (HashMap) +import qualified Data.HashMap.Strict as HashMap +import Data.Scientific (Scientific) +import Data.String (fromString) +import Data.Text (Text) +import qualified Data.Text as Text +import Data.Vector (Vector) +import qualified Data.Vector as Vector +import Language.Haskell.TH (Exp(..), Lit(..)) +import Language.Haskell.TH.Syntax (Lift(..)) +import Prelude hiding (any, null) + + +data Value ext + = Any (Maybe Text) + | Null + | Bool Bool + | Number Scientific + | String Text + | Array (Array ext) + | Object (Object ext) + | Ext ext + deriving (Show, Eq) + +instance Aeson.ToJSON ext => Aeson.ToJSON (Value ext) where + toJSON = + Aeson.object . \case + Any name -> + [ "type" .= ("any" :: Text) + , "name" .= name + ] + Null -> + [ "type" .= ("null" :: Text) + ] + Bool v -> + [ "type" .= ("bool" :: Text) + , "value" .= v + ] + Number v -> + [ "type" .= ("number" :: Text) + , "value" .= v + ] + String v -> + [ "type" .= ("string" :: Text) + , "value" .= v + ] + Array v -> + [ "type" .= ("array" :: Text) + , "value" .= v + ] + Object v -> + [ "type" .= ("object" :: Text) + , "value" .= v + ] + Ext v -> + [ "type" .= ("extension" :: Text) + , "value" .= v + ] + +data Box a = Box + { knownValues :: a + , extendable :: Bool + } deriving (Show, Eq) + +instance Aeson.ToJSON a => Aeson.ToJSON (Box a) where + toJSON Box {..} = + Aeson.object + [ "known-values" .= knownValues + , "extendable" .= extendable + ] + +type Array ext = Box (Vector (Value ext)) + +type Object ext = Box (HashMap Text (Value ext)) + +-- | Convert `Value Exp` to `Value 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 + lift = \case + Any name -> + [| Any $(pure (maybe (ConE 'Nothing) (AppE (ConE 'Just) . AppE (VarE 'fromString) . LitE . textL) name)) :: Value Aeson.Value |] + Null -> + [| Null :: Value Aeson.Value |] + Bool b -> + [| Bool b :: Value Aeson.Value |] + Number n -> + [| Number (fromRational $(pure (LitE (RationalL (toRational n))))) :: Value Aeson.Value |] + String str -> + [| String (fromString $(pure (LitE (textL str)))) :: Value Aeson.Value |] + Array Box {knownValues, extendable} -> [| + Array Box + { knownValues = + Vector.fromList $(fmap (ListE . Vector.toList) (traverse lift knownValues)) + , extendable + } :: Value Aeson.Value + |] + Object Box {knownValues, extendable} -> [| + Object Box + { knownValues = + HashMap.fromList $(fmap (ListE . map (\(k, v) -> TupE [LitE (textL k), v]) . HashMap.toList) (traverse lift knownValues)) + , extendable + } :: Value Aeson.Value + |] + Ext ext -> + [| Ext (let Just val = Aeson.decode (Aeson.encodingToLazyByteString (Aeson.toEncoding $(pure ext))) in val) :: Value Aeson.Value |] + where + textL = + StringL . Text.unpack diff --git a/test/Aeson/Match/QQSpec.hs b/test/Aeson/Match/QQSpec.hs new file mode 100644 --- /dev/null +++ b/test/Aeson/Match/QQSpec.hs @@ -0,0 +1,106 @@ +{-# LANGUAGE GeneralisedNewtypeDeriving #-} +{-# LANGUAGE OverloadedLists #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE QuasiQuotes #-} +module Aeson.Match.QQSpec (spec) where + +import qualified Data.Aeson as Aeson +import Data.Aeson.QQ (aesonQQ) +import qualified Data.HashMap.Strict as HashMap +import Test.Hspec + +import Aeson.Match.QQ + + +spec :: Spec +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| null |] `shouldBe` Null + + [qq| false |] `shouldBe` Bool False + [qq| true |] `shouldBe` Bool True + + [qq| 4 |] `shouldBe` Number 4 + [qq| -7 |] `shouldBe` Number (-7) + + [qq| "foo" |] `shouldBe` String "foo" + + [qq| [] |] `shouldBe` + Array Box {knownValues = [], extendable = False} + [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} + [qq| [1, _, 3, ...] |] `shouldBe` + Array Box {knownValues = [Number 1, Any Nothing, Number 3], extendable = True} + + [qq| {} |] `shouldBe` + Object Box {knownValues = [], extendable = False} + [qq| {foo: 4} |] `shouldBe` + Object Box {knownValues = [("foo", Number 4)], extendable = False} + [qq| {foo: 4, "bar": 7} |] `shouldBe` + Object Box {knownValues = [("foo", Number 4), ("bar", Number 7)], extendable = False} + [qq| {foo: 4, "bar": 7, ...} |] `shouldBe` + Object Box {knownValues = [("foo", Number 4), ("bar", Number 7)], extendable = True} + + [qq| {foo: #{4 + 7 :: Int}} |] `shouldBe` + Object Box {knownValues = [("foo", Ext (Aeson.Number 11))], extendable = False} + [qq| {foo: #{4 + 7 :: ToEncoding Int}} |] `shouldBe` + Object Box {knownValues = [("foo", Ext (Aeson.Number 11))], extendable = False} + + describe "match" $ do + it "specs" $ do + [qq| _ |] `shouldMatch` [aesonQQ| {foo: 4, bar: 7} |] + [qq| null |] `shouldMatch` [aesonQQ| null |] + [qq| true |] `shouldMatch` [aesonQQ| true |] + [qq| false |] `shouldMatch` [aesonQQ| false |] + [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| {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| null |] `shouldNotMatch` [aesonQQ| 4 |] + [qq| true |] `shouldNotMatch` [aesonQQ| false |] + [qq| false |] `shouldNotMatch` [aesonQQ| true |] + [qq| 4 |] `shouldNotMatch` [aesonQQ| 7 |] + [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, 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 |] + + it "paths" $ do + match [qq| {foo: {bar: {baz: [1, 4]}}} |] [aesonQQ| {foo: {bar: {baz: [1, 7]}}} |] `shouldBe` + mismatch ["foo", "bar", "baz", Idx 1] [qq| 4 |] [aesonQQ| 7 |] + + it "named holes" $ do + match [qq| {foo: _hole} |] [aesonQQ| {foo: {bar: {baz: [1, 4]}}} |] `shouldBe` + pure (HashMap.singleton "hole" [aesonQQ| {bar: {baz: [1, 4]}} |]) + +newtype ToEncoding a = ToEncoding { unToEncoding :: a } + deriving (Show, Eq, Num) + +instance Aeson.ToJSON a => Aeson.ToJSON (ToEncoding a) where + toJSON = + error "ToJSON is undefined" + toEncoding = + Aeson.toEncoding . unToEncoding + +shouldMatch :: Value Aeson.Value -> Aeson.Value -> Expectation +shouldMatch a b = + match a b `shouldBe` pure mempty + +shouldNotMatch :: Value Aeson.Value -> Aeson.Value -> Expectation +shouldNotMatch a b = + match a b `shouldNotBe` pure mempty diff --git a/test/Spec.hs b/test/Spec.hs new file mode 100644 --- /dev/null +++ b/test/Spec.hs @@ -0,0 +1,1 @@ +{-# OPTIONS_GHC -F -pgmF hspec-discover #-}