{-# 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
import qualified Data.HashMap.Strict as HM
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
(Diff a -> Diff a -> Bool)
-> (Diff a -> Diff a -> Bool) -> Eq (Diff a)
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, Eq (Diff a)
Eq (Diff a)
-> (Diff a -> Diff a -> Ordering)
-> (Diff a -> Diff a -> Bool)
-> (Diff a -> Diff a -> Bool)
-> (Diff a -> Diff a -> Bool)
-> (Diff a -> Diff a -> Bool)
-> (Diff a -> Diff a -> Diff a)
-> (Diff a -> Diff a -> Diff a)
-> Ord (Diff a)
Diff a -> Diff a -> Bool
Diff a -> Diff a -> Ordering
Diff a -> Diff a -> Diff a
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
$cp1Ord :: forall a. Ord a => Eq (Diff a)
Ord, (forall x. Diff a -> Rep (Diff a) x)
-> (forall x. Rep (Diff a) x -> Diff a) -> Generic (Diff a)
forall x. Rep (Diff a) x -> Diff a
forall x. Diff a -> Rep (Diff a) x
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 [Text
"$left" Text -> a -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Text -> v -> kv
.= a
a]
    toJSON (OnlyRight a
a) = [Pair] -> Value
object [Text
"$right" Text -> a -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Text -> v -> kv
.= a
a]
    toJSON (Both a
a) = [Pair] -> Value
object [Text
"$both" Text -> a -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Text -> v -> kv
.= a
a]
    toJSON (Conflict a
a a
b) = [Pair] -> Value
object [Text
"$left" Text -> a -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Text -> v -> kv
.= a
a, Text
"$right" Text -> a -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Text -> 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 Parser (Diff a) -> Parser (Diff a) -> Parser (Diff a)
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Value -> Parser (Diff a)
right Value
a Parser (Diff a) -> Parser (Diff a) -> Parser (Diff a)
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Value -> Parser (Diff a)
left Value
a Parser (Diff a) -> Parser (Diff a) -> Parser (Diff 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 = String -> (Object -> Parser (Diff a)) -> Value -> Parser (Diff a)
forall a. String -> (Object -> Parser a) -> Value -> Parser a
withObject String
"Diff.Conflict" ((Object -> Parser (Diff a)) -> Value -> Parser (Diff a))
-> (Object -> Parser (Diff a)) -> Value -> Parser (Diff a)
forall a b. (a -> b) -> a -> b
$ \Object
o → a -> a -> Diff a
forall a. a -> a -> Diff a
Conflict
            (a -> a -> Diff a) -> Parser a -> Parser (a -> Diff a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Object
o Object -> Text -> Parser a
forall a. FromJSON a => Object -> Text -> Parser a
.: Text
"$left"
            Parser (a -> Diff a) -> Parser a -> Parser (Diff a)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Object
o Object -> Text -> Parser a
forall a. FromJSON a => Object -> Text -> Parser a
.: Text
"$right"
        right :: Value -> Parser (Diff a)
right = String -> (Object -> Parser (Diff a)) -> Value -> Parser (Diff a)
forall a. String -> (Object -> Parser a) -> Value -> Parser a
withObject String
"Diff.OnlyRight" ((Object -> Parser (Diff a)) -> Value -> Parser (Diff a))
-> (Object -> Parser (Diff a)) -> Value -> Parser (Diff a)
forall a b. (a -> b) -> a -> b
$ \Object
o → a -> Diff a
forall a. a -> Diff a
OnlyRight
            (a -> Diff a) -> Parser a -> Parser (Diff a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Object
o Object -> Text -> Parser a
forall a. FromJSON a => Object -> Text -> Parser a
.: Text
"$right"
        left :: Value -> Parser (Diff a)
left = String -> (Object -> Parser (Diff a)) -> Value -> Parser (Diff a)
forall a. String -> (Object -> Parser a) -> Value -> Parser a
withObject String
"Diff.OnlyLeft" ((Object -> Parser (Diff a)) -> Value -> Parser (Diff a))
-> (Object -> Parser (Diff a)) -> Value -> Parser (Diff a)
forall a b. (a -> b) -> a -> b
$ \Object
o → a -> Diff a
forall a. a -> Diff a
OnlyLeft
            (a -> Diff a) -> Parser a -> Parser (Diff a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Object
o Object -> Text -> Parser a
forall a. FromJSON a => Object -> Text -> Parser a
.: Text
"$left"
        both :: Value -> Parser (Diff a)
both = String -> (Object -> Parser (Diff a)) -> Value -> Parser (Diff a)
forall a. String -> (Object -> Parser a) -> Value -> Parser a
withObject String
"Diff.Both" ((Object -> Parser (Diff a)) -> Value -> Parser (Diff a))
-> (Object -> Parser (Diff a)) -> Value -> Parser (Diff a)
forall a b. (a -> b) -> a -> b
$ \Object
o → a -> Diff a
forall a. a -> Diff a
Both
            (a -> Diff a) -> Parser a -> Parser (Diff a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Object
o Object -> Text -> Parser a
forall a. FromJSON a => Object -> Text -> Parser a
.: Text
"$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 (Diff Value -> Value) -> Maybe (Diff Value) -> Maybe Value
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Value -> Parser (Diff Value)) -> Value -> Maybe (Diff Value)
forall a b. (a -> Parser b) -> a -> Maybe b
parseMaybe Value -> Parser (Diff Value)
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 (Object -> Value) -> Object -> Value
forall a b. (a -> b) -> a -> b
$ (Value -> Bool) -> Object -> Object
forall v k. (v -> Bool) -> HashMap k v -> HashMap k v
HM.filter (Value -> Value -> Bool
forall a. Eq a => a -> a -> Bool
/= Value
Null) (Object -> Object) -> Object -> Object
forall a b. (a -> b) -> a -> b
$ Value -> Value
go (Value -> Value) -> Object -> Object
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Object
a
            (Array Array
a) → Array -> Value
Array (Array -> Value) -> Array -> Value
forall a b. (a -> b) -> a -> b
$ (Value -> Bool) -> Array -> Array
forall a. (a -> Bool) -> Vector a -> Vector a
V.filter (Value -> Value -> Bool
forall a. Eq a => a -> a -> Bool
/= Value
Null) (Array -> Array) -> Array -> Array
forall a b. (a -> b) -> a -> b
$ Value -> Value
go (Value -> Value) -> Array -> Array
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) = Diff Value -> Value
forall a. ToJSON a => a -> Value
toJSON (Diff Value -> Value) -> Diff Value -> Value
forall a b. (a -> b) -> a -> b
$ Value -> Value -> Diff Value
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 Value -> Value -> Bool
forall a. Eq a => a -> a -> Bool
== Value
b = Diff Value -> Value
forall a. ToJSON a => a -> Value
toJSON (Diff Value -> Value) -> Diff Value -> Value
forall a b. (a -> b) -> a -> b
$ Value -> Diff Value
forall a. a -> Diff a
Both Value
a
diff (Object Object
a) (Object Object
b) = Object -> Value
Object (Object -> Value) -> Object -> Value
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 (Array -> Value) -> Array -> Value
forall a b. (a -> b) -> a -> b
$ Array -> Array -> Array
mergeVectors Array
a Array
b
diff Value
a Value
b
    | Value
a Value -> Value -> Bool
forall a. Eq a => a -> a -> Bool
== Value
Null = Diff Value -> Value
forall a. ToJSON a => a -> Value
toJSON (Diff Value -> Value) -> Diff Value -> Value
forall a b. (a -> b) -> a -> b
$ Value -> Diff Value
forall a. a -> Diff a
OnlyRight Value
b
    | Value
b Value -> Value -> Bool
forall a. Eq a => a -> a -> Bool
== Value
Null = Diff Value -> Value
forall a. ToJSON a => a -> Value
toJSON (Diff Value -> Value) -> Diff Value -> Value
forall a b. (a -> b) -> a -> b
$ Value -> Diff Value
forall a. a -> Diff a
OnlyLeft Value
a
    | Bool
otherwise = Diff Value -> Value
forall a. ToJSON a => a -> Value
toJSON (Diff Value -> Value) -> Diff Value -> Value
forall a b. (a -> b) -> a -> b
$ Value -> Value -> Diff Value
forall a. a -> a -> Diff a
Conflict Value
a Value
b

mergeObjects ∷ Object → Object → Object
mergeObjects :: Object -> Object -> Object
mergeObjects Object
l Object
r
    = (Diff Value -> Value
forall a. ToJSON a => a -> Value
toJSON (Diff Value -> Value) -> (Value -> Diff Value) -> Value -> Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Value -> Diff Value
forall a. a -> Diff a
OnlyLeft (Value -> Value) -> Object -> Object
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Object -> Object -> Object
forall k v w.
(Eq k, Hashable k) =>
HashMap k v -> HashMap k w -> HashMap k v
HM.difference Object
l Object
r)
    Object -> Object -> Object
forall a. Semigroup a => a -> a -> a
<> (Diff Value -> Value
forall a. ToJSON a => a -> Value
toJSON (Diff Value -> Value) -> (Value -> Diff Value) -> Value -> Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Value -> Diff Value
forall a. a -> Diff a
OnlyRight (Value -> Value) -> Object -> Object
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Object -> Object -> Object
forall k v w.
(Eq k, Hashable k) =>
HashMap k v -> HashMap k w -> HashMap k v
HM.difference Object
r Object
l)
    Object -> Object -> Object
forall a. Semigroup a => a -> a -> a
<> (Value -> Value -> Value) -> Object -> Object -> Object
forall k v1 v2 v3.
(Eq k, Hashable k) =>
(v1 -> v2 -> v3) -> HashMap k v1 -> HashMap k v2 -> HashMap k v3
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 = [Value] -> Array
forall a. [a] -> Vector a
V.fromList ([Value] -> Array) -> [Value] -> Array
forall a b. (a -> b) -> a -> b
$ Diff Value -> Value
forall a. ToJSON a => a -> Value
toJSON (Diff Value -> Value) -> [Diff Value] -> [Value]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Value] -> [Value] -> [Diff Value]
forall a. Eq a => [a] -> [a] -> [Diff a]
go (Array -> [Value]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList Array
a) (Array -> [Value]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList Array
b)
  where
    go :: [a] -> [a] -> [Diff a]
go [a]
a' [] = a -> Diff a
forall a. a -> Diff a
OnlyLeft (a -> Diff a) -> [a] -> [Diff a]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [a]
a'
    go [] [a]
b' = a -> Diff a
forall a. a -> Diff a
OnlyRight (a -> Diff a) -> [a] -> [Diff a]
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 a -> a -> Bool
forall a. Eq a => a -> a -> Bool
== a
hb0 = a -> Diff a
forall a. a -> Diff a
Both a
ha0 Diff a -> [Diff a] -> [Diff a]
forall a. a -> [a] -> [a]
: [a] -> [a] -> [Diff a]
go (a
ha1 a -> [a] -> [a]
forall a. a -> [a] -> [a]
: [a]
ta) (a
hb1 a -> [a] -> [a]
forall a. a -> [a] -> [a]
: [a]
tb)
        | a
ha0 a -> a -> Bool
forall a. Eq a => a -> a -> Bool
== a
hb1 = a -> Diff a
forall a. a -> Diff a
OnlyRight a
hb0 Diff a -> [Diff a] -> [Diff a]
forall a. a -> [a] -> [a]
: [a] -> [a] -> [Diff a]
go [a]
al (a
hb1 a -> [a] -> [a]
forall a. a -> [a] -> [a]
: [a]
tb)
        | a
ha1 a -> a -> Bool
forall a. Eq a => a -> a -> Bool
== a
hb0 = a -> Diff a
forall a. a -> Diff a
OnlyLeft a
ha0 Diff a -> [Diff a] -> [Diff a]
forall a. a -> [a] -> [a]
: [a] -> [a] -> [Diff a]
go (a
ha1 a -> [a] -> [a]
forall a. a -> [a] -> [a]
: [a]
ta) [a]
bl
        | Bool
otherwise = a -> a -> Diff a
forall a. a -> a -> Diff a
Conflict a
ha0 a
hb0 Diff a -> [Diff a] -> [Diff a]
forall a. a -> [a] -> [a]
: [a] -> [a] -> [Diff a]
go (a
ha1 a -> [a] -> [a]
forall a. a -> [a] -> [a]
: [a]
ta) (a
hb1 a -> [a] -> [a]
forall a. a -> [a] -> [a]
: [a]
tb)
    go (a
ha0 : [a]
ta) (a
hb0 : [a]
tb)
        | a
ha0 a -> a -> Bool
forall a. Eq a => a -> a -> Bool
== a
hb0 = a -> Diff a
forall a. a -> Diff a
Both a
ha0 Diff a -> [Diff a] -> [Diff a]
forall a. a -> [a] -> [a]
: [a] -> [a] -> [Diff a]
go [a]
ta [a]
tb
        | Bool
otherwise = a -> a -> Diff a
forall a. a -> a -> Diff a
Conflict a
ha0 a
hb0 Diff a -> [Diff a] -> [Diff a]
forall a. a -> [a] -> [a]
: [a] -> [a] -> [Diff a]
go [a]
ta [a]
tb