{-# LANGUAGE CPP #-}

-- | Internal building-blocks for JSON 'Value' expectations
module Test.Hspec.Expectations.Json.Internal
  ( -- * Pretty diff
    assertBoolWithDiff

    -- * Pruning 'Object's
  , Superset (..)
  , Subset (..)
  , pruneJson

    -- * Sorting 'Array's
  , Sortable (..)
  , sortJsonArrays
  , vectorSortOn

    -- * Dealing with 'Scientific'
  , normalizeScientific
  , filterNullFields
  , expandHeterogenousArrays
  )
where

import Prelude

import Data.Aeson
#if MIN_VERSION_Diff(0,4,0)
import Data.Algorithm.Diff (PolyDiff(..), getDiff)
#else
import Data.Algorithm.Diff (Diff(..), getDiff)
#endif
#if MIN_VERSION_aeson(2,0,0)
import qualified Data.Aeson.KeyMap as KeyMap
#else
import qualified Data.HashMap.Strict as KeyMap
#endif
import Data.List (sortOn)
import qualified Data.Scientific as Scientific
import Data.Text (Text)
import qualified Data.Text as T
import Data.Vector (Vector)
import qualified Data.Vector as V
import GHC.Stack (HasCallStack)
import qualified Test.HUnit as HUnit
import Test.Hspec.Expectations.Json.Color

-- So we can call HashMap KeyMap in older aeson
{-# ANN module ("HLint: ignore Avoid restricted qualification" :: String) #-}

assertBoolWithDiff :: HasCallStack => Bool -> Text -> Text -> IO ()
assertBoolWithDiff :: HasCallStack => Bool -> Text -> Text -> IO ()
assertBoolWithDiff Bool
asserting Text
expected Text
got = do
  Color -> [Char] -> [Char]
colorize <- forall (m :: * -> *). MonadIO m => m (Color -> [Char] -> [Char])
getColorize
  forall a b c. (a -> b -> c) -> b -> a -> c
flip HasCallStack => [Char] -> Bool -> IO ()
HUnit.assertBool Bool
asserting forall b c a. (b -> c) -> (a -> b) -> a -> c
. [[Char]] -> [Char]
unlines forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> b) -> [a] -> [b]
map (forall {b}. (Color -> [Char] -> b) -> PolyDiff [Char] [Char] -> b
addSign Color -> [Char] -> [Char]
colorize) forall a b. (a -> b) -> a -> b
$
    forall a. Eq a => [a] -> [a] -> [Diff a]
getDiff
      ([Char] -> [[Char]]
lines (Text -> [Char]
T.unpack Text
expected))
      ([Char] -> [[Char]]
lines (Text -> [Char]
T.unpack Text
got))
 where
  addSign :: (Color -> [Char] -> b) -> PolyDiff [Char] [Char] -> b
addSign Color -> [Char] -> b
colorize = \case
    Both [Char]
_ [Char]
s -> Color -> [Char] -> b
colorize Color
Reset forall a b. (a -> b) -> a -> b
$ [Char]
"   " forall a. [a] -> [a] -> [a]
++ [Char]
s
    First [Char]
s -> Color -> [Char] -> b
colorize Color
Red forall a b. (a -> b) -> a -> b
$ [Char]
"---" forall a. [a] -> [a] -> [a]
++ [Char]
s
    Second [Char]
s -> Color -> [Char] -> b
colorize Color
Green forall a b. (a -> b) -> a -> b
$ [Char]
"+++" forall a. [a] -> [a] -> [a]
++ [Char]
s

newtype Superset = Superset Value

newtype Subset = Subset Value

-- | Recursively remove items in the 'Superset' value not present in 'Subset'
pruneJson :: Superset -> Subset -> Value
pruneJson :: Superset -> Subset -> Value
pruneJson (Superset Value
sup) (Subset Value
sub) = case (Value
sup, Value
sub) of
  (Object Object
a, Object Object
b) ->
    Object -> Value
Object forall a b. (a -> b) -> a -> b
$
      forall a b c. (a -> b -> c) -> KeyMap a -> KeyMap b -> KeyMap c
KeyMap.intersectionWith (\Value
x Value
y -> Superset -> Subset -> Value
pruneJson (Value -> Superset
Superset Value
x) (Value -> Subset
Subset Value
y)) Object
a Object
b
  -- Pruning elements in Arrays is *extremely* tricky in that it interacts with
  -- both sorting and matching in what should be a function independent of those
  -- concerns. There are no good options here, so we make some concessions:
  --
  -- 1. It's expected you don't subset differently in different elements of the
  --    same list. If you have an assertion that needs this behavior, do it
  --    manually, please
  --
  -- 2. It's expected that sorting will be done after pruning, if you intend to
  --    match irrespective of extra keys or ordering (shouldMatchJson does this)
  --
  -- Therefore, we grab the first element from the Subset Array (if present) and
  -- prune all elements of the Superset Array using it. This ensures that
  -- different sorts or length in the Superset side are preserved, but we
  -- are still able to prune *before* the sorting required for matching, which
  -- is important.
  --
  -- Other options such as sort-before-prune, or pair-wise pruning (with align
  -- or zip) all correctly handle some cases but not all. And most importantly,
  -- the cases those options don't handle come out as confusing assertion
  -- failures.
  --
  (Array Vector Value
a, Array Vector Value
b) -> Vector Value -> Value
Array forall a b. (a -> b) -> a -> b
$ case Vector Value
b forall a. Vector a -> Int -> Maybe a
V.!? Int
0 of
    Maybe Value
Nothing -> Vector Value
a
    Just Value
y -> (\Value
x -> Superset -> Subset -> Value
pruneJson (Value -> Superset
Superset Value
x) (Value -> Subset
Subset Value
y)) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Vector Value
a
  (Value
x, Value
_) -> Value
x

-- | Expand objects in arrays to have null values for omitted fields
--
-- ex: [{a:1}, {b:1}] -> [{a:1, b:null}, {a:null, b:1}]
expandHeterogenousArrays :: Value -> Value
expandHeterogenousArrays :: Value -> Value
expandHeterogenousArrays = Vector Value -> Value -> Value
go forall a. Monoid a => a
mempty
 where
  collectAllKeys :: Value -> Object
collectAllKeys = \case
    Object Object
km -> Value
Null forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ Object
km
    Value
_ -> forall v. KeyMap v
KeyMap.empty
  go :: Vector Value -> Value -> Value
go Vector Value
vec = \case
    Object Object
km ->
      let
        -- Set all keys not present in this level of the object to null
        nullCurrentLevel :: Object
        nullCurrentLevel :: Object
nullCurrentLevel = forall v. KeyMap v -> KeyMap v -> KeyMap v
KeyMap.union Object
km (forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap Value -> Object
collectAllKeys Vector Value
vec)
        -- `mapWithKey` is not available for all version of `KeyMap`
        mapWithKey :: ((Key, v) -> (Key, v)) -> KeyMap v -> KeyMap v
mapWithKey (Key, v) -> (Key, v)
f = forall v. [(Key, v)] -> KeyMap v
KeyMap.fromList forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Key, v) -> (Key, v)
f forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall v. KeyMap v -> [(Key, v)]
KeyMap.toList
        -- Recurse over all properties
        nullChildren :: Object -> Object
        nullChildren :: Object -> Object
nullChildren = forall {v} {v}. ((Key, v) -> (Key, v)) -> KeyMap v -> KeyMap v
mapWithKey forall a b. (a -> b) -> a -> b
$ \(Key
k, Value
v) -> (Key
k, Vector Value -> Value -> Value
go (Key -> Vector Value
siblingProperties Key
k) Value
v)
        -- Gather all values at the specified key
        siblingProperties :: Key -> Vector Value
siblingProperties Key
k =
          forall a b. (a -> Maybe b) -> Vector a -> Vector b
V.mapMaybe
            ( \case
                Object Object
km' -> forall v. Key -> KeyMap v -> Maybe v
KeyMap.lookup Key
k Object
km'
                Value
_ -> forall a. Maybe a
Nothing
            )
            Vector Value
vec
      in
        Object -> Value
Object forall a b. (a -> b) -> a -> b
$ Object -> Object
nullChildren Object
nullCurrentLevel
    Array Vector Value
v -> Vector Value -> Value
Array forall a b. (a -> b) -> a -> b
$ Vector Value -> Value -> Value
go Vector Value
v forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Vector Value
v
    Value
x -> Value
x

newtype Sortable = Sortable Value
  deriving newtype (Sortable -> Sortable -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Sortable -> Sortable -> Bool
$c/= :: Sortable -> Sortable -> Bool
== :: Sortable -> Sortable -> Bool
$c== :: Sortable -> Sortable -> Bool
Eq)

instance Ord Sortable where
  Sortable Value
a compare :: Sortable -> Sortable -> Ordering
`compare` Sortable Value
b = case (Value
a, Value
b) of
    (String Text
x, String Text
y) -> Text
x forall a. Ord a => a -> a -> Ordering
`compare` Text
y
    (Number Scientific
x, Number Scientific
y) -> Scientific
x forall a. Ord a => a -> a -> Ordering
`compare` Scientific
y
    (Bool Bool
x, Bool Bool
y) -> Bool
x forall a. Ord a => a -> a -> Ordering
`compare` Bool
y
    (Value
Null, Value
Null) -> Ordering
EQ -- forgive me
    (Array Vector Value
x, Array Vector Value
y) -> forall a b. (a -> b) -> Vector a -> Vector b
V.map Value -> Sortable
Sortable Vector Value
x forall a. Ord a => a -> a -> Ordering
`compare` forall a b. (a -> b) -> Vector a -> Vector b
V.map Value -> Sortable
Sortable Vector Value
y
    (Object Object
x, Object Object
y) ->
      (Value -> Sortable
Sortable forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Object
x) forall a. Ord a => a -> a -> Ordering
`compare` (Value -> Sortable
Sortable forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Object
y)
    (Value
x, Value
y) -> Value -> Int
arbitraryRank Value
x forall a. Ord a => a -> a -> Ordering
`compare` Value -> Int
arbitraryRank Value
y
   where
    arbitraryRank :: Value -> Int
    arbitraryRank :: Value -> Int
arbitraryRank = \case
      Object {} -> Int
5
      Array {} -> Int
4
      String {} -> Int
3
      Number {} -> Int
2
      Bool {} -> Int
1
      Value
Null -> Int
0

sortJsonArrays :: Value -> Value
sortJsonArrays :: Value -> Value
sortJsonArrays = \case
  Array Vector Value
v -> Vector Value -> Value
Array forall a b. (a -> b) -> a -> b
$ forall b a. Ord b => (a -> b) -> Vector a -> Vector a
vectorSortOn Value -> Sortable
Sortable forall a b. (a -> b) -> a -> b
$ Value -> Value
sortJsonArrays forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Vector Value
v
  Object Object
hm -> Object -> Value
Object forall a b. (a -> b) -> a -> b
$ Value -> Value
sortJsonArrays forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Object
hm
  x :: Value
x@String {} -> Value
x
  x :: Value
x@Number {} -> Value
x
  x :: Value
x@Bool {} -> Value
x
  x :: Value
x@Null {} -> Value
x

vectorSortOn :: Ord b => (a -> b) -> Vector a -> Vector a
vectorSortOn :: forall b a. Ord b => (a -> b) -> Vector a -> Vector a
vectorSortOn a -> b
f Vector a
v = Vector a
v forall a. Vector a -> [(Int, a)] -> Vector a
V.// forall a b. [a] -> [b] -> [(a, b)]
zip [Int
0 ..] [a]
sorted
 where
  sorted :: [a]
sorted = forall b a. Ord b => (a -> b) -> [a] -> [a]
sortOn a -> b
f forall a b. (a -> b) -> a -> b
$ forall a. Vector a -> [a]
V.toList Vector a
v

-- | Normalize all 'Number' values to 'Double' precision
--
-- Internally, @1@ and @1.0@ are represented as different values of the
-- 'Scientific' data type. These will compare equally, but if there is some
-- /other/ difference that fails the assertion, they will render as a difference
-- in the message, confusing the reader.
--
-- This sends them through an 'id' function as 'Double', which will make either
-- print as @1.0@ consistently.
normalizeScientific :: Value -> Value
normalizeScientific :: Value -> Value
normalizeScientific = \case
  Object Object
hm -> Object -> Value
Object forall a b. (a -> b) -> a -> b
$ Value -> Value
normalizeScientific forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Object
hm
  Array Vector Value
vs -> Vector Value -> Value
Array forall a b. (a -> b) -> a -> b
$ Value -> Value
normalizeScientific forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Vector Value
vs
  x :: Value
x@String {} -> Value
x
  Number Scientific
sci ->
    Scientific -> Value
Number forall a b. (a -> b) -> a -> b
$ forall a. RealFloat a => a -> Scientific
Scientific.fromFloatDigits @Double forall a b. (a -> b) -> a -> b
$ forall a. RealFloat a => Scientific -> a
Scientific.toRealFloat Scientific
sci
  x :: Value
x@Bool {} -> Value
x
  x :: Value
x@Value
Null -> Value
x

filterNullFields :: Value -> Value
filterNullFields :: Value -> Value
filterNullFields = Value -> Value
go
 where
  go :: Value -> Value
  go :: Value -> Value
go = \case
    Object Object
km -> Object -> Value
Object forall a b. (a -> b) -> a -> b
$ forall a b. (a -> Maybe b) -> KeyMap a -> KeyMap b
KeyMap.mapMaybe Value -> Maybe Value
objectFilter Object
km
    Array Vector Value
vec -> Vector Value -> Value
Array forall a b. (a -> b) -> a -> b
$ Value -> Value
filterNullFields forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Vector Value
vec
    Value
x -> Value
x
  objectFilter :: Value -> Maybe Value
  objectFilter :: Value -> Maybe Value
objectFilter = \case
    Object Object
km -> forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ Object -> Value
Object forall a b. (a -> b) -> a -> b
$ forall a b. (a -> Maybe b) -> KeyMap a -> KeyMap b
KeyMap.mapMaybe Value -> Maybe Value
objectFilter Object
km
    Array Vector Value
vec -> forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ Vector Value -> Value
Array forall a b. (a -> b) -> a -> b
$ Value -> Value
filterNullFields forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Vector Value
vec
    Value
Null -> forall a. Maybe a
Nothing
    Value
x -> forall a. a -> Maybe a
Just Value
x