git.iko.soy/patch
on dpatch-map-inner-patch help sign in
patch/src/Data/Patch.hs
114 lines 4.0 kB history raw
1{-# LANGUAGE CPP #-}
2{-# LANGUAGE GeneralizedNewtypeDeriving #-}
3{-# LANGUAGE StandaloneDeriving #-}
4{-# LANGUAGE TypeFamilies #-}
5{-# LANGUAGE TypeOperators #-}
6-- |
7-- Module:
8-- Data.Patch
9-- Description:
10-- This module defines the 'Patch' class.
11module Data.Patch
12 ( module Data.Patch
13 , module X
14 ) where
16import Control.Applicative
17import Data.Functor.Const (Const (..))
18import Data.Functor.Identity
19import Data.Map.Monoidal (MonoidalMap)
20import Data.Proxy
21#if !MIN_VERSION_base(4,11,0)
22import Data.Semigroup (Semigroup (..))
23#endif
24import GHC.Generics
26import Data.Patch.Class as X
27import Data.Patch.DMap as X hiding (getDeletions)
28import Data.Patch.DMapWithMove as X
29 ( PatchDMapWithMove, const2PatchDMapWithMoveWith, mapPatchDMapWithMove
30 , patchDMapWithMoveToPatchMapWithMoveWith
31 , traversePatchDMapWithMoveWithKey, unPatchDMapWithMove
32 , unsafePatchDMapWithMove, weakenPatchDMapWithMoveWith
33 )
34import Data.Patch.DMapWithPatchingMove as X
35 ( PatchDMapWithPatchingMove, const2PatchDMapWithPatchingMoveWith, mapPatchDMapWithPatchingMove
36 , patchDMapWithPatchingMoveToPatchMapWithPatchingMoveWith
37 , traversePatchDMapWithPatchingMoveWithKey, unPatchDMapWithPatchingMove
38 , unsafePatchDMapWithPatchingMove, weakenPatchDMapWithPatchingMoveWith
39 )
40import Data.Patch.IntMap as X hiding (getDeletions)
41import Data.Patch.Map as X
42import Data.Patch.MapWithMove as X
43 ( PatchMapWithMove, patchMapWithMoveNewElements
44 , patchMapWithMoveNewElementsMap, unPatchMapWithMove
45 , unsafePatchMapWithMove
46 )
48-- | A 'Group' is a 'Monoid' where every element has an inverse.
49class (Semigroup q, Monoid q) => Group q where
50 negateG :: q -> q
51 (~~) :: q -> q -> q
52 r ~~ s = r <> negateG s
54-- | An 'Additive' 'Semigroup' is one where (<>) is commutative
55class Semigroup q => Additive q where
57-- | The elements of an 'Additive' 'Semigroup' can be considered as patches of their own type.
58newtype AdditivePatch p = AdditivePatch { unAdditivePatch :: p }
60instance Additive p => PatchHet (AdditivePatch p) where
61 type PatchSource (AdditivePatch p) = p
62 type PatchTarget (AdditivePatch p) = p
63instance Additive p => Patch (AdditivePatch p) where
64 apply (AdditivePatch p) q = Just $ p <> q
66instance (Ord k, Group q) => Group (MonoidalMap k q) where
67 negateG = fmap negateG
69instance (Ord k, Additive q) => Additive (MonoidalMap k q)
71-- | Trivial group.
72instance Group () where
73 negateG ~() = ()
74 ~() ~~ ~() = ()
75instance Additive ()
77-- | Product group. A Pair of groups gives rise to a group
78instance (Group a, Group b) => Group (a, b) where
79 negateG (a, b) = (negateG a, negateG b)
80 (a, b) ~~ (c, d) = (a ~~ c, b ~~ d)
81instance (Additive a, Additive b) => Additive (a, b)
83-- See https://gitlab.haskell.org/ghc/ghc/issues/11135#note_111802 for the reason Compose is not also provided.
84-- Base does not define Monoid (Compose f g a) so this is the best we can
85-- really do for functor composition.
86instance Group (f (g a)) => Group ((f :.: g) a) where
87 negateG (Comp1 xs) = Comp1 (negateG xs)
88 Comp1 xs ~~ Comp1 ys = Comp1 (xs ~~ ys)
89instance Additive (f (g a)) => Additive ((f :.: g) a)
91-- | Product of groups, Functor style.
92instance (Group (f a), Group (g a)) => Group ((f :*: g) a) where
93 negateG (a :*: b) = negateG a :*: negateG b
94 (a :*: b) ~~ (c :*: d) = (a ~~ c) :*: (b ~~ d)
95instance (Additive (f a), Additive (g a)) => Additive ((f :*: g) a)
97-- | Trivial group, Functor style
98instance Group (Proxy x) where
99 negateG ~Proxy = Proxy
100 ~Proxy ~~ ~Proxy = Proxy
101instance Additive (Proxy x)
103-- | Const lifts groups into a functor.
104deriving instance Group a => Group (Const a x)
105instance Additive a => Additive (Const a x)
106-- | Ideitnty lifts groups pointwise (at only one point)
107deriving instance Group a => Group (Identity a)
108instance Additive a => Additive (Identity a)
110-- | Functions lift groups pointwise.
111instance Group b => Group (a -> b) where
112 negateG f = negateG . f
113 (~~) = liftA2 (~~)
114instance Additive b => Additive (a -> b)