{-# LANGUAGE CPP #-}
{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE DerivingStrategies #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE UnicodeSyntax #-}

-- |
-- Module: Configuration.Utils.Internal.JsonTools
-- Copyright: Copyright © 2020 Lars Kuhtz <lakuhtz@gmail.com>
-- License: MIT
-- Maintainer: Lars Kuhtz <lakuhtz@gmail.com>
-- Stability: experimental
--
-- The difference algorithms uses the following identies on JSON Values:
--
-- * An array equals the same array with all Null entries removed.
-- * An object equals the same object with all Null valued properties removed.
--
module Configuration.Utils.Internal.JsonTools
( Diff(..)
, diff
, resolve

-- * Conflict Resoluation Strategies
, merge
, mergeLeft
, mergeRight
, resolveLeft
, resolveOnlyLeft
, resolveRight
, resolveOnlyRight
) where

import Control.Applicative

import Data.Aeson
import Data.Aeson.Types
import Data.Foldable
#if MIN_VERSION_aeson(2,0,0)
import qualified Data.Aeson.KeyMap as HM
#else
import qualified Data.HashMap.Strict as HM
#endif
import qualified Data.Vector as V

import GHC.Generics

-- -------------------------------------------------------------------------- --
-- Representation of Difference between to Values

-- | Represent differences between two values
--
data Diff a
    = OnlyLeft a
    | OnlyRight a
    | Conflict a a
    | Both a
    deriving (Diff a -> Diff a -> Bool
forall a. Eq a => Diff a -> Diff a -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Diff a -> Diff a -> Bool
$c/= :: forall a. Eq a => Diff a -> Diff a -> Bool
== :: Diff a -> Diff a -> Bool
$c== :: forall a. Eq a => Diff a -> Diff a -> Bool
Eq, Diff a -> Diff a -> Ordering
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
forall {a}. Ord a => Eq (Diff a)
forall a. Ord a => Diff a -> Diff a -> Bool
forall a. Ord a => Diff a -> Diff a -> Ordering
forall a. Ord a => Diff a -> Diff a -> Diff a
min :: Diff a -> Diff a -> Diff a
$cmin :: forall a. Ord a => Diff a -> Diff a -> Diff a
max :: Diff a -> Diff a -> Diff a
$cmax :: forall a. Ord a => Diff a -> Diff a -> Diff a
>= :: Diff a -> Diff a -> Bool
$c>= :: forall a. Ord a => Diff a -> Diff a -> Bool
> :: Diff a -> Diff a -> Bool
$c> :: forall a. Ord a => Diff a -> Diff a -> Bool
<= :: Diff a -> Diff a -> Bool
$c<= :: forall a. Ord a => Diff a -> Diff a -> Bool
< :: Diff a -> Diff a -> Bool
$c< :: forall a. Ord a => Diff a -> Diff a -> Bool
compare :: Diff a -> Diff a -> Ordering
$ccompare :: forall a. Ord a => Diff a -> Diff a -> Ordering
Ord, forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
forall a x. Rep (Diff a) x -> Diff a
forall a x. Diff a -> Rep (Diff a) x
$cto :: forall a x. Rep (Diff a) x -> Diff a
$cfrom :: forall a x. Diff a -> Rep (Diff a) x
Generic)

instance ToJSON a ⇒ ToJSON (Diff a) where
    toJSON :: Diff a -> Value
toJSON (OnlyLeft a
a) = [Pair] -> Value
object [Key
"$left" forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= a
a]
    toJSON (OnlyRight a
a) = [Pair] -> Value
object [Key
"$right" forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= a
a]
    toJSON (Both a
a) = [Pair] -> Value
object [Key
"$both" forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= a
a]
    toJSON (Conflict a
a a
b) = [Pair] -> Value
object [Key
"$left" forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= a
a, Key
"$right" forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= a
b]
    {-# INLINE toJSON #-}

instance FromJSON a ⇒ FromJSON (Diff a) where
    parseJSON :: Value -> Parser (Diff a)
parseJSON Value
a = Value -> Parser (Diff a)
conflict Value
a forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Value -> Parser (Diff a)
right Value
a forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Value -> Parser (Diff a)
left Value
a forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Value -> Parser (Diff a)
both Value
a
      where
        conflict :: Value -> Parser (Diff a)
conflict = forall a. String -> (Object -> Parser a) -> Value -> Parser a
withObject String
"Diff.Conflict" forall a b. (a -> b) -> a -> b
$ \Object
o → forall a. a -> a -> Diff a
Conflict
            forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Object
o forall a. FromJSON a => Object -> Key -> Parser a
.: Key
"$left"
            forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Object
o forall a. FromJSON a => Object -> Key -> Parser a
.: Key
"$right"
        right :: Value -> Parser (Diff a)
right = forall a. String -> (Object -> Parser a) -> Value -> Parser a
withObject String
"Diff.OnlyRight" forall a b. (a -> b) -> a -> b
$ \Object
o → forall a. a -> Diff a
OnlyRight
            forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Object
o forall a. FromJSON a => Object -> Key -> Parser a
.: Key
"$right"
        left :: Value -> Parser (Diff a)
left = forall a. String -> (Object -> Parser a) -> Value -> Parser a
withObject String
"Diff.OnlyLeft" forall a b. (a -> b) -> a -> b
$ \Object
o → forall a. a -> Diff a
OnlyLeft
            forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Object
o forall a. FromJSON a => Object -> Key -> Parser a
.: Key
"$left"
        both :: Value -> Parser (Diff a)
both = forall a. String -> (Object -> Parser a) -> Value -> Parser a
withObject String
"Diff.Both" forall a b. (a -> b) -> a -> b
$ \Object
o → forall a. a -> Diff a
Both
            forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Object
o forall a. FromJSON a => Object -> Key -> Parser a
.: Key
"$both"
    {-# INLINE parseJSON #-}

-- -------------------------------------------------------------------------- --
-- Resolve Diff Value

-- | Resolve differences between two JSON values using the provided conflict
-- resolution function.
--
resolve ∷ (Diff Value → Value) → Value → Value
resolve :: (Diff Value -> Value) -> Value -> Value
resolve Diff Value -> Value
f = Value -> Value
go
  where
    go :: Value -> Value
go Value
v = case Diff Value -> Value
f forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a b. (a -> Parser b) -> a -> Maybe b
parseMaybe forall a. FromJSON a => Value -> Parser a
parseJSON Value
v of
        Just Value
x → Value
x
        Maybe Value
Nothing → case Value
v of
            (Object Object
a) → Object -> Value
Object forall a b. (a -> b) -> a -> b
$ forall v. (v -> Bool) -> KeyMap v -> KeyMap v
HM.filter (forall a. Eq a => a -> a -> Bool
/= Value
Null) forall a b. (a -> b) -> a -> b
$ Value -> Value
go forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Object
a
            (Array Array
a) → Array -> Value
Array forall a b. (a -> b) -> a -> b
$ forall a. (a -> Bool) -> Vector a -> Vector a
V.filter (forall a. Eq a => a -> a -> Bool
/= Value
Null) forall a b. (a -> b) -> a -> b
$ Value -> Value
go forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Array
a
            Value
a → Value
a

-- | Merge all non-conflicting differences. Leave the conflict annotations in
-- the result.
--
merge ∷ Diff Value → Value
merge :: Diff Value -> Value
merge (OnlyLeft Value
a) = Value
a
merge (OnlyRight Value
a) = Value
a
merge (Conflict Value
a Value
b) = forall a. ToJSON a => a -> Value
toJSON forall a b. (a -> b) -> a -> b
$ forall a. a -> a -> Diff a
Conflict Value
a Value
b
merge (Both Value
a) = Value
a

-- | Merge all differences. Pick the left value in case of a conflict.
--
mergeLeft ∷ Diff Value → Value
mergeLeft :: Diff Value -> Value
mergeLeft (OnlyLeft Value
a) = Value
a
mergeLeft (OnlyRight Value
a) = Value
a
mergeLeft (Conflict Value
a Value
_) = Value
a
mergeLeft (Both Value
a) = Value
a

-- | Merge all differences. Pick the right value in case of a conflict.
--
mergeRight ∷ Diff Value → Value
mergeRight :: Diff Value -> Value
mergeRight (OnlyLeft Value
a) = Value
a
mergeRight (OnlyRight Value
a) = Value
a
mergeRight (Conflict Value
_ Value
a) = Value
a
mergeRight (Both Value
a) = Value
a

-- | Resolve all differences by choosing the left value.
--
resolveLeft ∷ Diff Value → Value
resolveLeft :: Diff Value -> Value
resolveLeft (OnlyLeft Value
a) = Value
a
resolveLeft (OnlyRight Value
_) = Value
Null
resolveLeft (Conflict Value
a Value
_) = Value
a
resolveLeft (Both Value
a) = Value
a

-- | Keep values that /only/ occure in the left value. Remove all values that
-- occur in the right value or in both.
--
-- The result is the left value minus the right value.
--
resolveOnlyLeft ∷ Diff Value → Value
resolveOnlyLeft :: Diff Value -> Value
resolveOnlyLeft (OnlyLeft Value
a) = Value
a
resolveOnlyLeft (OnlyRight Value
_) = Value
Null
resolveOnlyLeft (Conflict Value
a Value
_) = Value
a
resolveOnlyLeft (Both Value
_) = Value
Null

-- | Resolve all differences by choosing the right value.
--
resolveRight ∷ Diff Value → Value
resolveRight :: Diff Value -> Value
resolveRight (OnlyLeft Value
_) = Value
Null
resolveRight (OnlyRight Value
a) = Value
a
resolveRight (Conflict Value
_ Value
a) = Value
a
resolveRight (Both Value
a) = Value
a

-- | Keep values that /only/ occure in the right value. Remove all values that
-- occur in the left value or in both.
--
-- The result is the right value minus the left value.
--
resolveOnlyRight ∷ Diff Value → Value
resolveOnlyRight :: Diff Value -> Value
resolveOnlyRight (OnlyLeft Value
_) = Value
Null
resolveOnlyRight (OnlyRight Value
a) = Value
a
resolveOnlyRight (Conflict Value
_ Value
a) = Value
a
resolveOnlyRight (Both Value
_) = Value
Null

-- -------------------------------------------------------------------------- --
-- Compute Difference between two JSON Values

-- | Merge two JSON values and annotate the result with the differences.
--
diff ∷ Value → Value → Value
diff :: Value -> Value -> Value
diff Value
a Value
b | Value
a forall a. Eq a => a -> a -> Bool
== Value
b = forall a. ToJSON a => a -> Value
toJSON forall a b. (a -> b) -> a -> b
$ forall a. a -> Diff a
Both Value
a
diff (Object Object
a) (Object Object
b) = Object -> Value
Object forall a b. (a -> b) -> a -> b
$ Object -> Object -> Object
mergeObjects Object
a Object
b
diff (Array Array
a) (Array Array
b) = Array -> Value
Array forall a b. (a -> b) -> a -> b
$ Array -> Array -> Array
mergeVectors Array
a Array
b
diff Value
a Value
b
    | Value
a forall a. Eq a => a -> a -> Bool
== Value
Null = forall a. ToJSON a => a -> Value
toJSON forall a b. (a -> b) -> a -> b
$ forall a. a -> Diff a
OnlyRight Value
b
    | Value
b forall a. Eq a => a -> a -> Bool
== Value
Null = forall a. ToJSON a => a -> Value
toJSON forall a b. (a -> b) -> a -> b
$ forall a. a -> Diff a
OnlyLeft Value
a
    | Bool
otherwise = forall a. ToJSON a => a -> Value
toJSON forall a b. (a -> b) -> a -> b
$ forall a. a -> a -> Diff a
Conflict Value
a Value
b

mergeObjects ∷ Object → Object → Object
mergeObjects :: Object -> Object -> Object
mergeObjects Object
l Object
r
    = (forall a. ToJSON a => a -> Value
toJSON forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. a -> Diff a
OnlyLeft forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall v v'. KeyMap v -> KeyMap v' -> KeyMap v
HM.difference Object
l Object
r)
    forall a. Semigroup a => a -> a -> a
<> (forall a. ToJSON a => a -> Value
toJSON forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. a -> Diff a
OnlyRight forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall v v'. KeyMap v -> KeyMap v' -> KeyMap v
HM.difference Object
r Object
l)
    forall a. Semigroup a => a -> a -> a
<> forall a b c. (a -> b -> c) -> KeyMap a -> KeyMap b -> KeyMap c
HM.intersectionWith Value -> Value -> Value
diff Object
l Object
r

-- | A naive list merge with a lookAhead of 1
--
mergeVectors ∷ Array → Array → Array
mergeVectors :: Array -> Array -> Array
mergeVectors Array
a Array
b = forall a. [a] -> Vector a
V.fromList forall a b. (a -> b) -> a -> b
$ forall a. ToJSON a => a -> Value
toJSON forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall {a}. Eq a => [a] -> [a] -> [Diff a]
go (forall (t :: * -> *) a. Foldable t => t a -> [a]
toList Array
a) (forall (t :: * -> *) a. Foldable t => t a -> [a]
toList Array
b)
  where
    go :: [a] -> [a] -> [Diff a]
go [a]
a' [] = forall a. a -> Diff a
OnlyLeft forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [a]
a'
    go [] [a]
b' = forall a. a -> Diff a
OnlyRight forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [a]
b'
    go al :: [a]
al@(a
ha0 : a
ha1 : [a]
ta) bl :: [a]
bl@(a
hb0 : a
hb1 : [a]
tb)
        | a
ha0 forall a. Eq a => a -> a -> Bool
== a
hb0 = forall a. a -> Diff a
Both a
ha0 forall a. a -> [a] -> [a]
: [a] -> [a] -> [Diff a]
go (a
ha1 forall a. a -> [a] -> [a]
: [a]
ta) (a
hb1 forall a. a -> [a] -> [a]
: [a]
tb)
        | a
ha0 forall a. Eq a => a -> a -> Bool
== a
hb1 = forall a. a -> Diff a
OnlyRight a
hb0 forall a. a -> [a] -> [a]
: [a] -> [a] -> [Diff a]
go [a]
al (a
hb1 forall a. a -> [a] -> [a]
: [a]
tb)
        | a
ha1 forall a. Eq a => a -> a -> Bool
== a
hb0 = forall a. a -> Diff a
OnlyLeft a
ha0 forall a. a -> [a] -> [a]
: [a] -> [a] -> [Diff a]
go (a
ha1 forall a. a -> [a] -> [a]
: [a]
ta) [a]
bl
        | Bool
otherwise = forall a. a -> a -> Diff a
Conflict a
ha0 a
hb0 forall a. a -> [a] -> [a]
: [a] -> [a] -> [Diff a]
go (a
ha1 forall a. a -> [a] -> [a]
: [a]
ta) (a
hb1 forall a. a -> [a] -> [a]
: [a]
tb)
    go (a
ha0 : [a]
ta) (a
hb0 : [a]
tb)
        | a
ha0 forall a. Eq a => a -> a -> Bool
== a
hb0 = forall a. a -> Diff a
Both a
ha0 forall a. a -> [a] -> [a]
: [a] -> [a] -> [Diff a]
go [a]
ta [a]
tb
        | Bool
otherwise = forall a. a -> a -> Diff a
Conflict a
ha0 a
hb0 forall a. a -> [a] -> [a]
: [a] -> [a] -> [Diff a]
go [a]
ta [a]
tb