{-# LANGUAGE CPP #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-}
-- |
-- Module:
--   Data.Patch
-- Description:
--   This module defines the 'Patch' class.
module Data.Patch
  ( module Data.Patch
  , module X
  ) where

import Control.Applicative
import Data.Functor.Const (Const (..))
import Data.Functor.Identity
import Data.Map.Monoidal (MonoidalMap)
import Data.Proxy
#if !MIN_VERSION_base(4,11,0)
import Data.Semigroup (Semigroup (..))
#endif
import GHC.Generics

import Data.Semigroup.Additive as X
import Data.Patch.Class as X
import Data.Patch.DMap as X hiding (getDeletions)
import Data.Patch.DMapWithMove as X
  ( PatchDMapWithMove, const2PatchDMapWithMoveWith, mapPatchDMapWithMove
  , patchDMapWithMoveToPatchMapWithMoveWith
  , traversePatchDMapWithMoveWithKey, unPatchDMapWithMove
  , unsafePatchDMapWithMove, weakenPatchDMapWithMoveWith
  )
import Data.Patch.IntMap as X hiding (getDeletions)
import Data.Patch.Map as X
import Data.Patch.MapWithMove as X
  ( PatchMapWithMove, patchMapWithMoveNewElements
  , patchMapWithMoveNewElementsMap, unPatchMapWithMove
  , unsafePatchMapWithMove
  )

-- | A 'Group' is a 'Monoid' where every element has an inverse.
class (Semigroup q, Monoid q) => Group q where
  negateG :: q -> q
  (~~) :: q -> q -> q
  q
r ~~ q
s = q
r q -> q -> q
forall a. Semigroup a => a -> a -> a
<> q -> q
forall q. Group q => q -> q
negateG q
s

-- | The elements of an 'Additive' 'Semigroup' can be considered as patches of their own type.
newtype AdditivePatch p = AdditivePatch { AdditivePatch p -> p
unAdditivePatch :: p }

instance Additive p => Patch (AdditivePatch p) where
  type PatchTarget (AdditivePatch p) = p
  apply :: AdditivePatch p
-> PatchTarget (AdditivePatch p)
-> Maybe (PatchTarget (AdditivePatch p))
apply (AdditivePatch p
p) PatchTarget (AdditivePatch p)
q = p -> Maybe p
forall a. a -> Maybe a
Just (p -> Maybe p) -> p -> Maybe p
forall a b. (a -> b) -> a -> b
$ p
p p -> p -> p
forall a. Semigroup a => a -> a -> a
<> p
PatchTarget (AdditivePatch p)
q

instance (Ord k, Group q) => Group (MonoidalMap k q) where
  negateG :: MonoidalMap k q -> MonoidalMap k q
negateG = (q -> q) -> MonoidalMap k q -> MonoidalMap k q
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap q -> q
forall q. Group q => q -> q
negateG

-- | Trivial group.
instance Group () where
  negateG :: () -> ()
negateG ()
_ = ()
  ()
_ ~~ :: () -> () -> ()
~~ ()
_ = ()

-- | Product group.  A Pair of groups gives rise to a group
instance (Group a, Group b) => Group (a, b) where
  negateG :: (a, b) -> (a, b)
negateG (a
a, b
b) = (a -> a
forall q. Group q => q -> q
negateG a
a, b -> b
forall q. Group q => q -> q
negateG b
b)
  (a
a, b
b) ~~ :: (a, b) -> (a, b) -> (a, b)
~~ (a
c, b
d) = (a
a a -> a -> a
forall q. Group q => q -> q -> q
~~ a
c, b
b b -> b -> b
forall q. Group q => q -> q -> q
~~ b
d)

-- See https://gitlab.haskell.org/ghc/ghc/issues/11135#note_111802 for the reason Compose is not also provided.
-- Base does not define Monoid (Compose f g a) so this is the best we can
-- really do for functor composition.
instance Group (f (g a)) => Group ((f :.: g) a) where
  negateG :: (:.:) f g a -> (:.:) f g a
negateG (Comp1 f (g a)
xs) = f (g a) -> (:.:) f g a
forall k2 k1 (f :: k2 -> *) (g :: k1 -> k2) (p :: k1).
f (g p) -> (:.:) f g p
Comp1 (f (g a) -> f (g a)
forall q. Group q => q -> q
negateG f (g a)
xs)
  Comp1 f (g a)
xs ~~ :: (:.:) f g a -> (:.:) f g a -> (:.:) f g a
~~ Comp1 f (g a)
ys = f (g a) -> (:.:) f g a
forall k2 k1 (f :: k2 -> *) (g :: k1 -> k2) (p :: k1).
f (g p) -> (:.:) f g p
Comp1 (f (g a)
xs f (g a) -> f (g a) -> f (g a)
forall q. Group q => q -> q -> q
~~ f (g a)
ys)

-- | Product of groups, Functor style.
instance (Group (f a), Group (g a)) => Group ((f :*: g) a) where
  negateG :: (:*:) f g a -> (:*:) f g a
negateG (f a
a :*: g a
b) = f a -> f a
forall q. Group q => q -> q
negateG f a
a f a -> g a -> (:*:) f g a
forall k (f :: k -> *) (g :: k -> *) (p :: k).
f p -> g p -> (:*:) f g p
:*: g a -> g a
forall q. Group q => q -> q
negateG g a
b
  (f a
a :*: g a
b) ~~ :: (:*:) f g a -> (:*:) f g a -> (:*:) f g a
~~ (f a
c :*: g a
d) = (f a
a f a -> f a -> f a
forall q. Group q => q -> q -> q
~~ f a
c) f a -> g a -> (:*:) f g a
forall k (f :: k -> *) (g :: k -> *) (p :: k).
f p -> g p -> (:*:) f g p
:*: (g a
b g a -> g a -> g a
forall q. Group q => q -> q -> q
~~ g a
d)

-- | Trivial group, Functor style
instance Group (Proxy x) where
  negateG :: Proxy x -> Proxy x
negateG Proxy x
_ = Proxy x
forall k (t :: k). Proxy t
Proxy
  Proxy x
_ ~~ :: Proxy x -> Proxy x -> Proxy x
~~ Proxy x
_ = Proxy x
forall k (t :: k). Proxy t
Proxy

-- | Const lifts groups into a functor.
deriving instance Group a => Group (Const a x)

-- | Identity lifts groups pointwise (at only one point)
deriving instance Group a => Group (Identity a)

-- | Functions lift groups pointwise.
instance Group b => Group (a -> b) where
  negateG :: (a -> b) -> a -> b
negateG a -> b
f = b -> b
forall q. Group q => q -> q
negateG (b -> b) -> (a -> b) -> a -> b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> b
f
  ~~ :: (a -> b) -> (a -> b) -> a -> b
(~~) = (b -> b -> b) -> (a -> b) -> (a -> b) -> a -> b
forall (f :: * -> *) a b c.
Applicative f =>
(a -> b -> c) -> f a -> f b -> f c
liftA2 b -> b -> b
forall q. Group q => q -> q -> q
(~~)