{-# LANGUAGE TypeFamilies #-}

{-|
Copyright: © 2021-2023 IOHK, 2024 Cardano Foundation
License: Apache-2.0
-}
module Data.Delta.Core
    ( Delta (..)
    , NoChange (..)
    , Replace (..)
    ) where

import Prelude

import Data.Kind
    ( Type
    )
import Data.List.NonEmpty
    ( NonEmpty
    )
import Data.Monoid
    ( Endo (..)
    )

{-------------------------------------------------------------------------------
    Delta types
-------------------------------------------------------------------------------}
-- | Type class for delta types.
class Delta delta where
    -- | Base type for which @delta@ represents a delta.
    -- This is implemented as a type family, so that we can have
    -- multiple delta types for the same base type.
    type Base delta :: Type
    -- | Apply a delta to the base type.
    --
    -- Whenever the type @delta@ is a 'Semigroup', we require that
    --
    -- prop> apply (d1 <> d2) = apply d1 . apply d2
    --
    -- This means that deltas are applied __right-to-left__:
    -- @d1@ is applied __after__ @d2@.
    --
    -- Whenever the type @delta@ is a 'Monoid', we require that
    --
    -- prop> apply mempty = id
    apply :: delta -> Base delta -> Base delta

-- | 'Endo' is the most general delta, which allows any change.
instance Delta (Endo a) where
    type Base (Endo a) = a
    apply :: Endo a -> Base (Endo a) -> Base (Endo a)
apply (Endo a -> a
f) = a -> a
Base (Endo a) -> Base (Endo a)
f

-- | The least general delta, where nothing is changed.
data NoChange (a :: Type) = NoChange
    deriving (NoChange a -> NoChange a -> Bool
(NoChange a -> NoChange a -> Bool)
-> (NoChange a -> NoChange a -> Bool) -> Eq (NoChange a)
forall a. NoChange a -> NoChange a -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: forall a. NoChange a -> NoChange a -> Bool
== :: NoChange a -> NoChange a -> Bool
$c/= :: forall a. NoChange a -> NoChange a -> Bool
/= :: NoChange a -> NoChange a -> Bool
Eq, Eq (NoChange a)
Eq (NoChange a) =>
(NoChange a -> NoChange a -> Ordering)
-> (NoChange a -> NoChange a -> Bool)
-> (NoChange a -> NoChange a -> Bool)
-> (NoChange a -> NoChange a -> Bool)
-> (NoChange a -> NoChange a -> Bool)
-> (NoChange a -> NoChange a -> NoChange a)
-> (NoChange a -> NoChange a -> NoChange a)
-> Ord (NoChange a)
NoChange a -> NoChange a -> Bool
NoChange a -> NoChange a -> Ordering
NoChange a -> NoChange a -> NoChange a
forall a. Eq (NoChange 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. NoChange a -> NoChange a -> Bool
forall a. NoChange a -> NoChange a -> Ordering
forall a. NoChange a -> NoChange a -> NoChange a
$ccompare :: forall a. NoChange a -> NoChange a -> Ordering
compare :: NoChange a -> NoChange a -> Ordering
$c< :: forall a. NoChange a -> NoChange a -> Bool
< :: NoChange a -> NoChange a -> Bool
$c<= :: forall a. NoChange a -> NoChange a -> Bool
<= :: NoChange a -> NoChange a -> Bool
$c> :: forall a. NoChange a -> NoChange a -> Bool
> :: NoChange a -> NoChange a -> Bool
$c>= :: forall a. NoChange a -> NoChange a -> Bool
>= :: NoChange a -> NoChange a -> Bool
$cmax :: forall a. NoChange a -> NoChange a -> NoChange a
max :: NoChange a -> NoChange a -> NoChange a
$cmin :: forall a. NoChange a -> NoChange a -> NoChange a
min :: NoChange a -> NoChange a -> NoChange a
Ord, Int -> NoChange a -> ShowS
[NoChange a] -> ShowS
NoChange a -> String
(Int -> NoChange a -> ShowS)
-> (NoChange a -> String)
-> ([NoChange a] -> ShowS)
-> Show (NoChange a)
forall a. Int -> NoChange a -> ShowS
forall a. [NoChange a] -> ShowS
forall a. NoChange a -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: forall a. Int -> NoChange a -> ShowS
showsPrec :: Int -> NoChange a -> ShowS
$cshow :: forall a. NoChange a -> String
show :: NoChange a -> String
$cshowList :: forall a. [NoChange a] -> ShowS
showList :: [NoChange a] -> ShowS
Show)

-- | prop> apply NoChange a = a
instance Delta (NoChange a) where
    type Base (NoChange a) = a
    apply :: NoChange a -> Base (NoChange a) -> Base (NoChange a)
apply NoChange a
_ Base (NoChange a)
a = Base (NoChange a)
a

-- | Trivial delta type for the type @a@ that replaces the value wholesale.
newtype Replace a = Replace a
    deriving (Replace a -> Replace a -> Bool
(Replace a -> Replace a -> Bool)
-> (Replace a -> Replace a -> Bool) -> Eq (Replace a)
forall a. Eq a => Replace a -> Replace a -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: forall a. Eq a => Replace a -> Replace a -> Bool
== :: Replace a -> Replace a -> Bool
$c/= :: forall a. Eq a => Replace a -> Replace a -> Bool
/= :: Replace a -> Replace a -> Bool
Eq, Eq (Replace a)
Eq (Replace a) =>
(Replace a -> Replace a -> Ordering)
-> (Replace a -> Replace a -> Bool)
-> (Replace a -> Replace a -> Bool)
-> (Replace a -> Replace a -> Bool)
-> (Replace a -> Replace a -> Bool)
-> (Replace a -> Replace a -> Replace a)
-> (Replace a -> Replace a -> Replace a)
-> Ord (Replace a)
Replace a -> Replace a -> Bool
Replace a -> Replace a -> Ordering
Replace a -> Replace a -> Replace 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 (Replace a)
forall a. Ord a => Replace a -> Replace a -> Bool
forall a. Ord a => Replace a -> Replace a -> Ordering
forall a. Ord a => Replace a -> Replace a -> Replace a
$ccompare :: forall a. Ord a => Replace a -> Replace a -> Ordering
compare :: Replace a -> Replace a -> Ordering
$c< :: forall a. Ord a => Replace a -> Replace a -> Bool
< :: Replace a -> Replace a -> Bool
$c<= :: forall a. Ord a => Replace a -> Replace a -> Bool
<= :: Replace a -> Replace a -> Bool
$c> :: forall a. Ord a => Replace a -> Replace a -> Bool
> :: Replace a -> Replace a -> Bool
$c>= :: forall a. Ord a => Replace a -> Replace a -> Bool
>= :: Replace a -> Replace a -> Bool
$cmax :: forall a. Ord a => Replace a -> Replace a -> Replace a
max :: Replace a -> Replace a -> Replace a
$cmin :: forall a. Ord a => Replace a -> Replace a -> Replace a
min :: Replace a -> Replace a -> Replace a
Ord, Int -> Replace a -> ShowS
[Replace a] -> ShowS
Replace a -> String
(Int -> Replace a -> ShowS)
-> (Replace a -> String)
-> ([Replace a] -> ShowS)
-> Show (Replace a)
forall a. Show a => Int -> Replace a -> ShowS
forall a. Show a => [Replace a] -> ShowS
forall a. Show a => Replace a -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: forall a. Show a => Int -> Replace a -> ShowS
showsPrec :: Int -> Replace a -> ShowS
$cshow :: forall a. Show a => Replace a -> String
show :: Replace a -> String
$cshowList :: forall a. Show a => [Replace a] -> ShowS
showList :: [Replace a] -> ShowS
Show)

-- |
-- prop> apply (Replace a) _ = a
instance Delta (Replace a) where
    type Base (Replace a) = a
    apply :: Replace a -> Base (Replace a) -> Base (Replace a)
apply (Replace a
a) Base (Replace a)
_ = a
Base (Replace a)
a

-- | Combine replacements. The first argument takes precedence.
-- Hence, 'apply' is a morphism:
--
-- prop> apply (Replace a <> Replace b) = apply (Replace a) . apply (Replace b)
--
-- More strongly, we have
--
-- prop> apply (Replace a <> _) = apply (Replace a)
instance Semigroup (Replace a) where
    Replace a
r <> :: Replace a -> Replace a -> Replace a
<> Replace a
_ = Replace a
r

-- | A delta can be optionally applied.
instance Delta delta => Delta (Maybe delta) where
    type Base (Maybe delta) = Base delta
    apply :: Maybe delta -> Base (Maybe delta) -> Base (Maybe delta)
apply = (Base delta -> Base delta)
-> (delta -> Base delta -> Base delta)
-> Maybe delta
-> Base delta
-> Base delta
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Base delta -> Base delta
forall a. a -> a
id delta -> Base delta -> Base delta
forall delta. Delta delta => delta -> Base delta -> Base delta
apply

-- | A list of deltas can be applied like a single delta.
-- This overloading of 'apply' is very convenient.
--
-- Order is important: The 'head' of the list is applied __last__,
-- so deltas are applied __right-to-left__.
-- Hence, 'apply' is a morphism
--
-- prop> apply []         = id
-- prop> apply (d1 ++ d2) = apply d1 . apply d2
instance Delta delta => Delta [delta] where
    type Base [delta] = Base delta
    apply :: [delta] -> Base [delta] -> Base [delta]
apply [delta]
ds Base [delta]
a = (delta -> Base delta -> Base delta)
-> Base delta -> [delta] -> Base delta
forall a b. (a -> b -> b) -> b -> [a] -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr delta -> Base delta -> Base delta
forall delta. Delta delta => delta -> Base delta -> Base delta
apply Base delta
Base [delta]
a [delta]
ds

-- | For convenience, a nonempty list of deltas
-- can be applied like a list of deltas.
--
-- Remember that deltas are applied right-to-left.
instance Delta delta => Delta (NonEmpty delta) where
    type Base (NonEmpty delta) = Base delta
    apply :: NonEmpty delta -> Base (NonEmpty delta) -> Base (NonEmpty delta)
apply NonEmpty delta
ds Base (NonEmpty delta)
a = (delta -> Base delta -> Base delta)
-> Base delta -> NonEmpty delta -> Base delta
forall a b. (a -> b -> b) -> b -> NonEmpty a -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr delta -> Base delta -> Base delta
forall delta. Delta delta => delta -> Base delta -> Base delta
apply Base delta
Base (NonEmpty delta)
a NonEmpty delta
ds

-- | A pair of deltas represents a delta for a pair.
instance (Delta d1, Delta d2) => Delta (d1,d2) where
    type Base (d1, d2) = (Base d1, Base d2)
    apply :: (d1, d2) -> Base (d1, d2) -> Base (d1, d2)
apply (d1
d1,d2
d2) (Base d1
a1,Base d2
a2) = (d1 -> Base d1 -> Base d1
forall delta. Delta delta => delta -> Base delta -> Base delta
apply d1
d1 Base d1
a1, d2 -> Base d2 -> Base d2
forall delta. Delta delta => delta -> Base delta -> Base delta
apply d2
d2 Base d2
a2)

-- | A triple of deltas represents a delta for a triple.
instance (Delta d1, Delta d2, Delta d3) => Delta (d1,d2,d3) where
    type Base (d1,d2,d3) = (Base d1,Base d2,Base d3)
    apply :: (d1, d2, d3) -> Base (d1, d2, d3) -> Base (d1, d2, d3)
apply (d1
d1,d2
d2,d3
d3) (Base d1
a1,Base d2
a2,Base d3
a3) = (d1 -> Base d1 -> Base d1
forall delta. Delta delta => delta -> Base delta -> Base delta
apply d1
d1 Base d1
a1, d2 -> Base d2 -> Base d2
forall delta. Delta delta => delta -> Base delta -> Base delta
apply d2
d2 Base d2
a2, d3 -> Base d3 -> Base d3
forall delta. Delta delta => delta -> Base delta -> Base delta
apply d3
d3 Base d3
a3)

-- | A 4-tuple of deltas represents a delta for a 4-tuple.
instance (Delta d1, Delta d2, Delta d3, Delta d4) => Delta (d1,d2,d3,d4) where
    type Base (d1,d2,d3,d4) = (Base d1,Base d2,Base d3,Base d4)
    apply :: (d1, d2, d3, d4) -> Base (d1, d2, d3, d4) -> Base (d1, d2, d3, d4)
apply (d1
d1,d2
d2,d3
d3,d4
d4) (Base d1
a1,Base d2
a2,Base d3
a3,Base d4
a4) =
        (d1 -> Base d1 -> Base d1
forall delta. Delta delta => delta -> Base delta -> Base delta
apply d1
d1 Base d1
a1, d2 -> Base d2 -> Base d2
forall delta. Delta delta => delta -> Base delta -> Base delta
apply d2
d2 Base d2
a2, d3 -> Base d3 -> Base d3
forall delta. Delta delta => delta -> Base delta -> Base delta
apply d3
d3 Base d3
a3, d4 -> Base d4 -> Base d4
forall delta. Delta delta => delta -> Base delta -> Base delta
apply d4
d4 Base d4
a4)