packages feed

aeson-match-qq (empty) → 1.0.0

raw patch · 9 files changed

+829/−0 lines, 9 filesdep +aesondep +aeson-match-qqdep +aeson-qq

Dependencies added: aeson, aeson-match-qq, aeson-qq, attoparsec, base, bytestring, either, haskell-src-meta, hspec, scientific, template-haskell, text, unordered-containers, vector

Files

+ LICENSE view
@@ -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.
+ README.markdown view
@@ -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
+ aeson-match-qq.cabal view
@@ -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
+ src/Aeson/Match/QQ.hs view
@@ -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"+  }
+ src/Aeson/Match/QQ/Internal/Match.hs view
@@ -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
+ src/Aeson/Match/QQ/Internal/Parse.hs view
@@ -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
+ src/Aeson/Match/QQ/Internal/Value.hs view
@@ -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
+ test/Aeson/Match/QQSpec.hs view
@@ -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
+ test/Spec.hs view
@@ -0,0 +1,1 @@+{-# OPTIONS_GHC -F -pgmF hspec-discover #-}