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

import Prelude

import Data.Aeson
import Data.Algorithm.Diff (PolyDiff(..), getDiff)
import qualified Data.Aeson.KeyMap as KeyMap
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

assertBoolWithDiff :: HasCallStack => Bool -> Text -> Text -> IO ()
assertBoolWithDiff :: Bool -> Text -> Text -> IO ()
assertBoolWithDiff Bool
asserting Text
expected Text
got =
  (String -> Bool -> IO ()) -> Bool -> String -> IO ()
forall a b c. (a -> b -> c) -> b -> a -> c
flip HasCallStack => String -> Bool -> IO ()
String -> Bool -> IO ()
HUnit.assertBool Bool
asserting (String -> IO ())
-> ([PolyDiff String String] -> String)
-> [PolyDiff String String]
-> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [String] -> String
unlines ([String] -> String)
-> ([PolyDiff String String] -> [String])
-> [PolyDiff String String]
-> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (PolyDiff String String -> String)
-> [PolyDiff String String] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map PolyDiff String String -> String
addSign ([PolyDiff String String] -> IO ())
-> [PolyDiff String String] -> IO ()
forall a b. (a -> b) -> a -> b
$ [String] -> [String] -> [PolyDiff String String]
forall a. Eq a => [a] -> [a] -> [Diff a]
getDiff
    (String -> [String]
lines (Text -> String
T.unpack Text
expected))
    (String -> [String]
lines (Text -> String
T.unpack Text
got))
 where
  addSign :: PolyDiff String String -> String
addSign = \case
    Both String
_ String
s -> String
"   " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
s
    First String
s -> String
"---" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
s
    Second String
s -> String
"+++" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
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
    (Object -> Value) -> Object -> Value
forall a b. (a -> b) -> a -> b
$ (Value -> Value -> Value) -> Object -> Object -> Object
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 Array
a, Array Array
b) -> Array -> Value
Array (Array -> Value) -> Array -> Value
forall a b. (a -> b) -> a -> b
$ case Array
b Array -> Int -> Maybe Value
forall a. Vector a -> Int -> Maybe a
V.!? Int
0 of
    Maybe Value
Nothing -> Array
a
    Just Value
y -> (\Value
x -> Superset -> Subset -> Value
pruneJson (Value -> Superset
Superset Value
x) (Value -> Subset
Subset Value
y)) (Value -> Value) -> Array -> Array
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Array
a

  (Value
x, Value
_) -> Value
x

newtype Sortable = Sortable Value
  deriving newtype Sortable -> Sortable -> Bool
(Sortable -> Sortable -> Bool)
-> (Sortable -> Sortable -> Bool) -> Eq Sortable
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 Text -> Text -> Ordering
forall a. Ord a => a -> a -> Ordering
`compare` Text
y
    (Number Scientific
x, Number Scientific
y) -> Scientific
x Scientific -> Scientific -> Ordering
forall a. Ord a => a -> a -> Ordering
`compare` Scientific
y
    (Bool Bool
x, Bool Bool
y) -> Bool
x Bool -> Bool -> Ordering
forall a. Ord a => a -> a -> Ordering
`compare` Bool
y
    (Value
Null, Value
Null) -> Ordering
EQ -- forgive me
    (Array Array
x, Array Array
y) -> (Value -> Sortable) -> Array -> Vector Sortable
forall a b. (a -> b) -> Vector a -> Vector b
V.map Value -> Sortable
Sortable Array
x Vector Sortable -> Vector Sortable -> Ordering
forall a. Ord a => a -> a -> Ordering
`compare` (Value -> Sortable) -> Array -> Vector Sortable
forall a b. (a -> b) -> Vector a -> Vector b
V.map Value -> Sortable
Sortable Array
y
    (Object Object
x, Object Object
y) ->
      (Value -> Sortable
Sortable (Value -> Sortable) -> Object -> KeyMap Sortable
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Object
x) KeyMap Sortable -> KeyMap Sortable -> Ordering
forall a. Ord a => a -> a -> Ordering
`compare` (Value -> Sortable
Sortable (Value -> Sortable) -> Object -> KeyMap Sortable
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Object
y)
    (Value
x, Value
y) -> Value -> Int
arbitraryRank Value
x Int -> Int -> Ordering
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 Array
v -> Array -> Value
Array (Array -> Value) -> Array -> Value
forall a b. (a -> b) -> a -> b
$ (Value -> Sortable) -> Array -> Array
forall b a. Ord b => (a -> b) -> Vector a -> Vector a
vectorSortOn Value -> Sortable
Sortable (Array -> Array) -> Array -> Array
forall a b. (a -> b) -> a -> b
$ Value -> Value
sortJsonArrays (Value -> Value) -> Array -> Array
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Array
v
  Object Object
hm -> Object -> Value
Object (Object -> Value) -> Object -> Value
forall a b. (a -> b) -> a -> b
$ Value -> Value
sortJsonArrays (Value -> Value) -> Object -> Object
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 :: (a -> b) -> Vector a -> Vector a
vectorSortOn a -> b
f Vector a
v = Vector a
v Vector a -> [(Int, a)] -> Vector a
forall a. Vector a -> [(Int, a)] -> Vector a
V.// [Int] -> [a] -> [(Int, a)]
forall a b. [a] -> [b] -> [(a, b)]
zip [Int
0 ..] [a]
sorted
  where sorted :: [a]
sorted = (a -> b) -> [a] -> [a]
forall b a. Ord b => (a -> b) -> [a] -> [a]
sortOn a -> b
f ([a] -> [a]) -> [a] -> [a]
forall a b. (a -> b) -> a -> b
$ Vector a -> [a]
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 (Object -> Value) -> Object -> Value
forall a b. (a -> b) -> a -> b
$ Value -> Value
normalizeScientific (Value -> Value) -> Object -> Object
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Object
hm
  Array Array
vs -> Array -> Value
Array (Array -> Value) -> Array -> Value
forall a b. (a -> b) -> a -> b
$ Value -> Value
normalizeScientific (Value -> Value) -> Array -> Array
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Array
vs
  x :: Value
x@String{} -> Value
x
  Number Scientific
sci ->
    Scientific -> Value
Number (Scientific -> Value) -> Scientific -> Value
forall a b. (a -> b) -> a -> b
$ RealFloat Double => Double -> Scientific
forall a. RealFloat a => a -> Scientific
Scientific.fromFloatDigits @Double (Double -> Scientific) -> Double -> Scientific
forall a b. (a -> b) -> a -> b
$ Scientific -> Double
forall a. RealFloat a => Scientific -> a
Scientific.toRealFloat Scientific
sci
  x :: Value
x@Bool{} -> Value
x
  x :: Value
x@Value
Null -> Value
x