-- | Expectations on JSON 'Value's
--
-- Semantics:
--
-- +--------------------------+-------------------+-------------------+
-- | Assertion that fails on: | extra Object keys | wrong Array order +
-- +==========================+===================+===================+
-- | 'shouldBeJson'           | Yes               | Yes               |
-- +--------------------------+-------------------+-------------------+
-- | 'shouldBeUnorderedJson'  | Yes               | No                |
-- +--------------------------+-------------------+-------------------+
-- | 'shouldMatchJson'        | No                | No                |
-- +--------------------------+-------------------+-------------------+
-- | 'shouldMatchOrderedJson' | No                | Yes               |
-- +--------------------------+-------------------+-------------------+
module Test.Hspec.Expectations.Json
  ( shouldMatchJson
  , shouldBeJson
  , shouldBeJsonNormalized
  , Normalizer
  , defaultNormalizer
  , treatNullsAsMissing
  , ignoreArrayOrdering
  , subsetActualToExpected
  , expandHeterogenousArrays

    -- * Legacy API

    -- | Prefer to use shouldBeJsonNormalized with the appropriate 'Normalizer'
  , shouldBeUnorderedJson
  , shouldMatchOrderedJson

    -- * As predicates

    -- | These are only created when a specific need arises
  , matchesJson
  ) where

import Prelude

import Control.Monad (unless)
import Data.Aeson
import Data.Aeson.Encode.Pretty (encodePretty)
import Data.Bifunctor
import Data.Semigroup (Endo (..))
import Data.Text.Lazy (toStrict)
import Data.Text.Lazy.Encoding (decodeUtf8)
import GHC.Stack
import Test.Hspec.Expectations.Json.Internal
  ( Subset (..)
  , Superset (..)
  , assertBoolWithDiff
  , filterNullFields
  , normalizeScientific
  , pruneJson
  , sortJsonArrays
  )
import qualified Test.Hspec.Expectations.Json.Internal as Internal

-- $setup
-- >>> :set -XQuasiQuotes
-- >>> import Data.Aeson.QQ (aesonQQ)
-- >>> import Test.HUnit.Lang (HUnitFailure(..), formatFailureReason)
-- >>> import Control.Exception (handle)
-- >>> let printFailure (HUnitFailure _ r) = putStr $ formatFailureReason r
-- >>> let catchFailure f = handle printFailure $ f >> putStrLn "<passed>"

newtype Actual a = Actual a
  deriving (forall a b. a -> Actual b -> Actual a
forall a b. (a -> b) -> Actual a -> Actual b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
<$ :: forall a b. a -> Actual b -> Actual a
$c<$ :: forall a b. a -> Actual b -> Actual a
fmap :: forall a b. (a -> b) -> Actual a -> Actual b
$cfmap :: forall a b. (a -> b) -> Actual a -> Actual b
Functor)

newtype Expected a = Expected a
  deriving (forall a b. a -> Expected b -> Expected a
forall a b. (a -> b) -> Expected a -> Expected b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
<$ :: forall a b. a -> Expected b -> Expected a
$c<$ :: forall a b. a -> Expected b -> Expected a
fmap :: forall a b. (a -> b) -> Expected a -> Expected b
$cfmap :: forall a b. (a -> b) -> Expected a -> Expected b
Functor)

newtype Normalizer = Normalizer
  { Normalizer -> Endo (Actual Value, Expected Value)
normalize :: Endo (Actual Value, Expected Value)
  }
  deriving newtype (NonEmpty Normalizer -> Normalizer
Normalizer -> Normalizer -> Normalizer
forall b. Integral b => b -> Normalizer -> Normalizer
forall a.
(a -> a -> a)
-> (NonEmpty a -> a)
-> (forall b. Integral b => b -> a -> a)
-> Semigroup a
stimes :: forall b. Integral b => b -> Normalizer -> Normalizer
$cstimes :: forall b. Integral b => b -> Normalizer -> Normalizer
sconcat :: NonEmpty Normalizer -> Normalizer
$csconcat :: NonEmpty Normalizer -> Normalizer
<> :: Normalizer -> Normalizer -> Normalizer
$c<> :: Normalizer -> Normalizer -> Normalizer
Semigroup, Semigroup Normalizer
Normalizer
[Normalizer] -> Normalizer
Normalizer -> Normalizer -> Normalizer
forall a.
Semigroup a -> a -> (a -> a -> a) -> ([a] -> a) -> Monoid a
mconcat :: [Normalizer] -> Normalizer
$cmconcat :: [Normalizer] -> Normalizer
mappend :: Normalizer -> Normalizer -> Normalizer
$cmappend :: Normalizer -> Normalizer -> Normalizer
mempty :: Normalizer
$cmempty :: Normalizer
Monoid)

normalizeBoth :: (Value -> Value) -> Normalizer
normalizeBoth :: (Value -> Value) -> Normalizer
normalizeBoth Value -> Value
f = Endo (Actual Value, Expected Value) -> Normalizer
Normalizer forall a b. (a -> b) -> a -> b
$ forall a. (a -> a) -> Endo a
Endo forall a b. (a -> b) -> a -> b
$ forall (p :: * -> * -> *) a b c d.
Bifunctor p =>
(a -> b) -> (c -> d) -> p a c -> p b d
bimap (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Value -> Value
f) (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Value -> Value
f)

treatNullsAsMissing :: Normalizer
treatNullsAsMissing :: Normalizer
treatNullsAsMissing = (Value -> Value) -> Normalizer
normalizeBoth Value -> Value
filterNullFields

ignoreArrayOrdering :: Normalizer
ignoreArrayOrdering :: Normalizer
ignoreArrayOrdering = (Value -> Value) -> Normalizer
normalizeBoth Value -> Value
sortJsonArrays

expandHeterogenousArrays :: Normalizer
expandHeterogenousArrays :: Normalizer
expandHeterogenousArrays = (Value -> Value) -> Normalizer
normalizeBoth Value -> Value
Internal.expandHeterogenousArrays

subsetActualToExpected :: Normalizer
subsetActualToExpected :: Normalizer
subsetActualToExpected = Endo (Actual Value, Expected Value) -> Normalizer
Normalizer forall a b. (a -> b) -> a -> b
$ forall a. (a -> a) -> Endo a
Endo (Actual Value, Expected Value) -> (Actual Value, Expected Value)
go
 where
  go :: (Actual Value, Expected Value) -> (Actual Value, Expected Value)
go (Actual Value
a, Expected Value
b) =
    let a' :: Value
a' = Superset -> Subset -> Value
pruneJson (Value -> Superset
Superset Value
a) (Value -> Subset
Subset Value
b)
    in  (forall a. a -> Actual a
Actual Value
a', forall a. a -> Expected a
Expected Value
b)

defaultNormalizer :: Normalizer
defaultNormalizer :: Normalizer
defaultNormalizer =
  Normalizer
ignoreArrayOrdering forall a. Semigroup a => a -> a -> a
<> Normalizer
subsetActualToExpected

shouldBeJsonNormalized :: HasCallStack => Normalizer -> Value -> Value -> IO ()
shouldBeJsonNormalized :: HasCallStack => Normalizer -> Value -> Value -> IO ()
shouldBeJsonNormalized Normalizer
normalizer Value
a Value
b =
  forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (Value
a forall a. Eq a => a -> a -> Bool
== Value
b) forall a b. (a -> b) -> a -> b
$
    HasCallStack => Bool -> Text -> Text -> IO ()
assertBoolWithDiff (Value
a' forall a. Eq a => a -> a -> Bool
== Value
b') (Value -> Text
toText Value
b) (Value -> Text
toText Value
a)
 where
  toText :: Value -> Text
toText = Text -> Text
toStrict forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> Text
decodeUtf8 forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. ToJSON a => a -> ByteString
encodePretty forall b c a. (b -> c) -> (a -> b) -> a -> c
. Value -> Value
normalizeScientific
  (Actual Value
a', Expected Value
b') = forall a. Endo a -> a -> a
appEndo (Normalizer -> Endo (Actual Value, Expected Value)
normalize Normalizer
normalizer) (forall a. a -> Actual a
Actual Value
a, forall a. a -> Expected a
Expected Value
b)

-- | Compare two JSON values, with a useful diff
--
-- >>> :{
-- catchFailure $
--   [aesonQQ| { "a": true, "b": false } |] `shouldBeJson`
--   [aesonQQ| { "a": true, "b": false } |]
-- :}
-- <passed>
--
-- >>> :{
-- catchFailure $
--   [aesonQQ| { "a": true, "b": false } |] `shouldBeJson`
--   [aesonQQ| { "a": true, "b": true  } |]
-- :}
--    {
--        "a": true,
-- ---    "b": true
-- +++    "b": false
--    }
shouldBeJson :: HasCallStack => Value -> Value -> IO ()
shouldBeJson :: HasCallStack => Value -> Value -> IO ()
shouldBeJson = HasCallStack => Normalizer -> Value -> Value -> IO ()
shouldBeJsonNormalized forall a. Monoid a => a
mempty

infix 1 `shouldBeJson`

-- | 'shouldBeJson', ignoring Array ordering
--
-- >>> :{
-- catchFailure $
--   [aesonQQ| { "a": [true, false], "b": false } |] `shouldBeUnorderedJson`
--   [aesonQQ| { "a": [false, true], "b": false } |]
-- :}
-- <passed>
--
-- >>> :{
-- catchFailure $
--   [aesonQQ| { "a": [true, false], "b": false, "c": true } |] `shouldBeUnorderedJson`
--   [aesonQQ| { "a": [false, true], "b": true             } |]
-- :}
--    {
--        "a": [
--            false,
--            true
--        ],
-- ---    "b": true
-- +++    "b": false,
-- +++    "c": true
--    }
shouldBeUnorderedJson :: HasCallStack => Value -> Value -> IO ()
shouldBeUnorderedJson :: HasCallStack => Value -> Value -> IO ()
shouldBeUnorderedJson = HasCallStack => Normalizer -> Value -> Value -> IO ()
shouldBeJsonNormalized Normalizer
ignoreArrayOrdering

infix 1 `shouldBeUnorderedJson`

-- | 'shouldBeJson', ignoring extra Object keys or Array ordering
--
-- >>> :{
-- catchFailure $
--   [aesonQQ| { "a": [true, false], "b": false, "c": true } |] `shouldMatchJson`
--   [aesonQQ| { "a": [false, true], "b": false            } |]
-- :}
-- <passed>
--
-- >>> :{
-- catchFailure $
--   [aesonQQ| { "a": [true, false], "b": false, "c": true } |] `shouldMatchJson`
--   [aesonQQ| { "a": [false, true], "b": true             } |]
-- :}
--    {
--        "a": [
--            false,
--            true
--        ],
-- ---    "b": true
-- +++    "b": false
--    }
shouldMatchJson :: HasCallStack => Value -> Value -> IO ()
shouldMatchJson :: HasCallStack => Value -> Value -> IO ()
shouldMatchJson = HasCallStack => Normalizer -> Value -> Value -> IO ()
shouldBeJsonNormalized Normalizer
defaultNormalizer

infix 1 `shouldMatchJson`

-- | Compare JSON values with the same semantics as 'shouldMatchJson'
matchesJson :: Value -> Value -> Bool
matchesJson :: Value -> Value -> Bool
matchesJson Value
sup Value
sub = Value
sup forall a. Eq a => a -> a -> Bool
== Value
sub Bool -> Bool -> Bool
|| Value
sup' forall a. Eq a => a -> a -> Bool
== Value
sub'
 where
  (Actual Value
sup', Expected Value
sub') = forall a. Endo a -> a -> a
appEndo (Normalizer -> Endo (Actual Value, Expected Value)
normalize Normalizer
defaultNormalizer) (forall a. a -> Actual a
Actual Value
sup, forall a. a -> Expected a
Expected Value
sub)

-- | 'shouldBeJson', ignoring extra Object keys
--
-- >>> :{
-- catchFailure $
--   [aesonQQ| { "a": [true, false], "b": false, "c": true } |] `shouldMatchOrderedJson`
--   [aesonQQ| { "a": [true, false], "b": false            } |]
-- :}
-- <passed>
--
-- >>> :{
-- catchFailure $
--   [aesonQQ| { "a": [true, false], "b": false, "c": true } |] `shouldMatchOrderedJson`
--   [aesonQQ| { "a": [false, true], "b": true             } |]
-- :}
--    {
--        "a": [
-- ---        false,
-- ---        true
-- +++        true,
-- +++        false
--        ],
-- ---    "b": true
-- +++    "b": false
--    }
shouldMatchOrderedJson :: HasCallStack => Value -> Value -> IO ()
shouldMatchOrderedJson :: HasCallStack => Value -> Value -> IO ()
shouldMatchOrderedJson = HasCallStack => Normalizer -> Value -> Value -> IO ()
shouldBeJsonNormalized Normalizer
subsetActualToExpected

infix 1 `shouldMatchOrderedJson`