git.iko.soy/patch
on jam@fix-docs help sign in
patch/src/Data/Patch.hs
98 lines 3.6 kB history raw
1{-# LANGUAGE GeneralizedNewtypeDeriving #-}
2{-# LANGUAGE StandaloneDeriving #-}
3{-# LANGUAGE TypeFamilies #-}
4{-# LANGUAGE TypeOperators #-}
5-- |
6-- Module:
7-- Data.Patch
8-- Description:
9-- This module defines the 'Patch' class.
10module Data.Patch
11 ( module Data.Patch
12 , module X
13 ) where
15import Data.Patch.Class as X
16import Data.Patch.DMap as X hiding (getDeletions)
17import Data.Patch.DMapWithMove as X (PatchDMapWithMove, const2PatchDMapWithMoveWith, mapPatchDMapWithMove,
18 patchDMapWithMoveToPatchMapWithMoveWith,
19 traversePatchDMapWithMoveWithKey, unPatchDMapWithMove,
20 unsafePatchDMapWithMove, weakenPatchDMapWithMoveWith)
21import Data.Patch.IntMap as X hiding (getDeletions)
22import Data.Patch.Map as X
23import Data.Patch.MapWithMove as X (PatchMapWithMove, patchMapWithMoveNewElements,
24 patchMapWithMoveNewElementsMap, unPatchMapWithMove,
25 unsafePatchMapWithMove)
26import Data.Map.Monoidal (MonoidalMap)
27import Data.Semigroup (Semigroup (..), (<>))
28import GHC.Generics
29import Data.Functor.Identity
30import Data.Functor.Const
31import Data.Proxy
32import Control.Applicative
34-- | A 'Group' is a 'Monoid' where every element has an inverse.
35class (Semigroup q, Monoid q) => Group q where
36 negateG :: q -> q
37 (~~) :: q -> q -> q
38 r ~~ s = r <> negateG s
40-- | An 'Additive' 'Semigroup' is one where (<>) is commutative
41class Semigroup q => Additive q where
43-- | The elements of an 'Additive' 'Semigroup' can be considered as patches of their own type.
44newtype AdditivePatch p = AdditivePatch { unAdditivePatch :: p }
46instance Additive p => Patch (AdditivePatch p) where
47 type PatchTarget (AdditivePatch p) = p
48 apply (AdditivePatch p) q = Just $ p <> q
50instance (Ord k, Group q) => Group (MonoidalMap k q) where
51 negateG = fmap negateG
53instance (Ord k, Additive q) => Additive (MonoidalMap k q)
55-- | Trivial group.
56instance Group () where
57 negateG _ = ()
58 _ ~~ _ = ()
59instance Additive ()
61-- | Product group. A Pair of groups gives rise to a group
62instance (Group a, Group b) => Group (a, b) where
63 negateG (a, b) = (negateG a, negateG b)
64 (a, b) ~~ (c, d) = (a ~~ c, b ~~ d)
65instance (Additive a, Additive b) => Additive (a, b)
67-- See https://gitlab.haskell.org/ghc/ghc/issues/11135#note_111802 for the reason Compose is not also provided.
68-- Base does not define Monoid (Compose f g a) so this is the best we can
69-- really do for functor composition.
70instance Group (f (g a)) => Group ((f :.: g) a) where
71 negateG (Comp1 xs) = Comp1 (negateG xs)
72 Comp1 xs ~~ Comp1 ys = Comp1 (xs ~~ ys)
73instance Additive (f (g a)) => Additive ((f :.: g) a)
75-- | Product of groups, Functor style.
76instance (Group (f a), Group (g a)) => Group ((f :*: g) a) where
77 negateG (a :*: b) = negateG a :*: negateG b
78 (a :*: b) ~~ (c :*: d) = (a ~~ c) :*: (b ~~ d)
79instance (Additive (f a), Additive (g a)) => Additive ((f :*: g) a)
81-- | Trivial group, Functor style
82instance Group (Proxy x) where
83 negateG _ = Proxy
84 _ ~~ _ = Proxy
85instance Additive (Proxy x)
87-- | Const lifts groups into a functor.
88deriving instance Group a => Group (Const a x)
89instance Additive a => Additive (Const a x)
90-- | Ideitnty lifts groups pointwise (at only one point)
91deriving instance Group a => Group (Identity a)
92instance Additive a => Additive (Identity a)
94-- | Functions lift groups pointwise.
95instance Group b => Group (a -> b) where
96 negateG f = negateG . f
97 (~~) = liftA2 (~~)
98instance Additive b => Additive (a -> b)