{-# LANGUAGE CPP #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE NoImplicitPrelude #-}

module Test.Morpheus.JSONDiff
  ( jsonEQ,
  )
where

import Data.Aeson (ToJSON (..), Value (..), encode)
import Data.ByteString.Lazy.Char8 (unpack)
import GHC.Show (Show (show))
import Relude hiding (ByteString, Show, show)
import Test.Tasty.HUnit (assertFailure)

#if MIN_VERSION_aeson(2,0,0)
import Data.Aeson.KeyMap (keys, lookup)
# else
import Data.HashMap.Lazy (keys, lookup)
#endif

data Diff
  = DiffNode [(String, Diff)]
  | DiffLeaf Value Value

instance Show Diff where
  show :: Diff -> String
show (DiffNode [(String, Diff)]
xs) = String -> [String] -> String
forall a. [a] -> [[a]] -> [a]
intercalate String
"\n" (((String, Diff) -> String) -> [(String, Diff)] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map (String, Diff) -> String
forall {a}. Show a => (String, a) -> String
showField [(String, Diff)]
xs)
    where
      showField :: (String, a) -> String
showField (String
k, a
v) = String
k String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
":\n  " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> ShowS
indent (a -> String
forall a. Show a => a -> String
show a
v)
  show (DiffLeaf Value
x Value
y) =
    String
"should be:"
      String -> ShowS
forall a. Semigroup a => a -> a -> a
<> Value -> String
forall a. ToJSON a => a -> String
showLeaf Value
x
      String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
"but it is:"
      String -> ShowS
forall a. Semigroup a => a -> a -> a
<> Value -> String
forall a. ToJSON a => a -> String
showLeaf Value
y

showLeaf :: ToJSON a => a -> [Char]
showLeaf :: forall a. ToJSON a => a -> String
showLeaf a
x = String
" " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> ByteString -> String
unpack (a -> ByteString
forall a. ToJSON a => a -> ByteString
encode a
x) String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
"\n"

unescape :: String -> String
unescape :: ShowS
unescape = (Char -> String) -> ShowS
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap Char -> String
f
  where
    f :: Char -> String
f Char
'\"' = String
""
    f Char
x = Char
x Char -> ShowS
forall a. a -> [a] -> [a]
: String
""

indent :: String -> String
indent :: ShowS
indent = (Char -> String) -> ShowS
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap Char -> String
f
  where
    f :: Char -> String
f Char
'\n' = String
"\n  "
    f Char
x = Char
x Char -> ShowS
forall a. a -> [a] -> [a]
: String
""

diff :: (Value, Value) -> Maybe Diff
diff :: (Value, Value) -> Maybe Diff
diff (Object Object
beforeFields, Object Object
afterFields) = [(String, (Value, Value))] -> Maybe Diff
diffNode ([(String, (Value, Value))] -> Maybe Diff)
-> [(String, (Value, Value))] -> Maybe Diff
forall a b. (a -> b) -> a -> b
$ (Key -> (String, (Value, Value)))
-> [Key] -> [(String, (Value, Value))]
forall a b. (a -> b) -> [a] -> [b]
map Key -> (String, (Value, Value))
toPair [Key]
ks
  where
    ks :: [Key]
ks = [Key] -> [Key]
forall a. Eq a => [a] -> [a]
uniq (Object -> [Key]
forall v. KeyMap v -> [Key]
keys (Object
beforeFields Object -> Object -> Object
forall a. Semigroup a => a -> a -> a
<> Object
afterFields))
    toPair :: Key -> (String, (Value, Value))
toPair Key
key = (ShowS
unescape (Key -> String
forall a. Show a => a -> String
show Key
key), (Key -> Object -> Value
getField Key
key Object
beforeFields, Key -> Object -> Value
getField Key
key Object
afterFields))
    getField :: Key -> Object -> Value
getField Key
key = Value -> Maybe Value -> Value
forall a. a -> Maybe a -> a
fromMaybe Value
Null (Maybe Value -> Value)
-> (Object -> Maybe Value) -> Object -> Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Key -> Object -> Maybe Value
forall v. Key -> KeyMap v -> Maybe v
lookup Key
key
diff (Array Array
beforeElems, Array Array
afterElems) = [(String, (Value, Value))] -> Maybe Diff
diffNode ([String] -> [(Value, Value)] -> [(String, (Value, Value))]
forall a b. [a] -> [b] -> [(a, b)]
zip [String]
ks [(Value, Value)]
vs)
  where
    ks :: [String]
ks = (Int -> String) -> [Int] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map Int -> String
forall a. Show a => a -> String
show ([Int
1 ..] :: [Int])
    vs :: [(Value, Value)]
vs = [Value] -> [Value] -> [(Value, Value)]
zipOptional (Array -> [Value]
forall a. Vector a -> [a]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList Array
beforeElems) (Array -> [Value]
forall a. Vector a -> [a]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList Array
afterElems)
diff (Value
v1, Value
v2)
  | Value
v1 Value -> Value -> Bool
forall a. Eq a => a -> a -> Bool
== Value
v2 =
      Maybe Diff
forall a. Maybe a
Nothing
  | Bool
otherwise = Diff -> Maybe Diff
forall a. a -> Maybe a
Just (Value -> Value -> Diff
DiffLeaf Value
v1 Value
v2)

diffNode :: [(String, (Value, Value))] -> Maybe Diff
diffNode :: [(String, (Value, Value))] -> Maybe Diff
diffNode [(String, (Value, Value))]
values
  | [(String, Diff)] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [(String, Diff)]
entries = Maybe Diff
forall a. Maybe a
Nothing
  | Bool
otherwise = Diff -> Maybe Diff
forall a. a -> Maybe a
Just ([(String, Diff)] -> Diff
DiffNode [(String, Diff)]
entries)
  where
    entries :: [(String, Diff)]
entries = ((String, (Value, Value)) -> Maybe (String, Diff))
-> [(String, (Value, Value))] -> [(String, Diff)]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe (\(String
key, (Value, Value)
value) -> (String
key,) (Diff -> (String, Diff)) -> Maybe Diff -> Maybe (String, Diff)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Value, Value) -> Maybe Diff
diff (Value, Value)
value) [(String, (Value, Value))]
values

uniq :: (Eq a) => [a] -> [a]
uniq :: forall a. Eq a => [a] -> [a]
uniq [] = []
uniq (a
x : [a]
xs)
  | Maybe a -> Bool
forall a. Maybe a -> Bool
isJust ((a -> Bool) -> [a] -> Maybe a
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
find (a -> a -> Bool
forall a. Eq a => a -> a -> Bool
== a
x) [a]
xs) = [a] -> [a]
forall a. Eq a => [a] -> [a]
uniq [a]
xs
  | Bool
otherwise = a
x a -> [a] -> [a]
forall a. a -> [a] -> [a]
: [a] -> [a]
forall a. Eq a => [a] -> [a]
uniq [a]
xs

jsonEQ :: ToJSON a => a -> a -> IO ()
jsonEQ :: forall a. ToJSON a => a -> a -> IO ()
jsonEQ a
expected a
actual = case (Value, Value) -> Maybe Diff
diff (a -> Value
forall a. ToJSON a => a -> Value
toJSON a
expected, a -> Value
forall a. ToJSON a => a -> Value
toJSON a
actual) of
  Just Diff
x -> String -> IO ()
forall a. HasCallStack => String -> IO a
assertFailure (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ ShowS
indent ShowS -> ShowS
forall a b. (a -> b) -> a -> b
$ String
"\n" String -> ShowS
forall a. Semigroup a => a -> a -> a
<> Diff -> String
forall a. Show a => a -> String
show Diff
x String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
"\n"
  Maybe Diff
Nothing -> () -> IO ()
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()

zipOptional :: [Value] -> [Value] -> [(Value, Value)]
zipOptional :: [Value] -> [Value] -> [(Value, Value)]
zipOptional [] [] = []
zipOptional (Value
x : [Value]
xs) [] = (Value
x, Value
Null) (Value, Value) -> [(Value, Value)] -> [(Value, Value)]
forall a. a -> [a] -> [a]
: [Value] -> [Value] -> [(Value, Value)]
zipOptional [Value]
xs []
zipOptional [] (Value
y : [Value]
ys) = (Value
Null, Value
y) (Value, Value) -> [(Value, Value)] -> [(Value, Value)]
forall a. a -> [a] -> [a]
: [Value] -> [Value] -> [(Value, Value)]
zipOptional [] [Value]
ys
zipOptional (Value
x : [Value]
xs) (Value
y : [Value]
ys) = (Value
x, Value
y) (Value, Value) -> [(Value, Value)] -> [(Value, Value)]
forall a. a -> [a] -> [a]
: [Value] -> [Value] -> [(Value, Value)]
zipOptional [Value]
xs [Value]
ys