{-# LANGUAGE CPP #-}
module Test.Hspec.Expectations.Json.Internal
(
assertBoolWithDiff
, Superset (..)
, Subset (..)
, pruneJson
, Sortable (..)
, sortJsonArrays
, vectorSortOn
, 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
{-# 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
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
(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
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
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 :: ((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
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)
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
(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
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