@@ -1,4 +1,8 @@
1+{-# LANGUAGE CPP #-}
2+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
3+{-# LANGUAGE StandaloneDeriving #-}
14{-# LANGUAGE TypeFamilies #-}
5+{-# LANGUAGE TypeOperators #-}
26-- |
37-- Module:
48-- Data.Patch
@@ -10,7 +14,9 @@ module Data.Patch
1014 ) where
1115
1216import Data.Map.Monoidal (MonoidalMap)
17+#if !MIN_VERSION_base(4,9,0)
1318import Data.Semigroup (Semigroup (..), (<>))
19+#endif
1420
1521import Data.Patch.Class as X
1622import Data.Patch.DMap as X hiding (getDeletions)
@@ -23,6 +29,11 @@ import Data.Patch.Map as X
2329import Data.Patch.MapWithMove as X (PatchMapWithMove, patchMapWithMoveNewElements,
2430 patchMapWithMoveNewElementsMap, unPatchMapWithMove,
2531 unsafePatchMapWithMove)
32+import GHC.Generics
33+import Data.Functor.Identity
34+import Data.Functor.Const
35+import Data.Proxy
36+import Control.Applicative
2637
2738-- | A 'Group' is a 'Monoid' where every element has an inverse.
2839class (Semigroup q, Monoid q) => Group q where
@@ -44,3 +55,48 @@ instance (Ord k, Group q) => Group (MonoidalMap k q) where
4455 negateG = fmap negateG
4556
4657instance (Ord k, Additive q) => Additive (MonoidalMap k q)
58+
59+-- | Trivial group.
60+instance Group () where
61+ negateG _ = ()
62+ _ ~~ _ = ()
63+instance Additive ()
64+
65+-- | Product group. A Pair of groups gives rise to a group
66+instance (Group a, Group b) => Group (a, b) where
67+ negateG (a, b) = (negateG a, negateG b)
68+ (a, b) ~~ (c, d) = (a ~~ c, b ~~ d)
69+instance (Additive a, Additive b) => Additive (a, b)
70+
71+-- See https://gitlab.haskell.org/ghc/ghc/issues/11135#note_111802 for the reason Compose is not also provided.
72+-- Base does not define Monoid (Compose f g a) so this is the best we can
73+-- really do for functor composition.
74+instance Group (f (g a)) => Group ((f :.: g) a) where
75+ negateG (Comp1 xs) = Comp1 (negateG xs)
76+ Comp1 xs ~~ Comp1 ys = Comp1 (xs ~~ ys)
77+instance Additive (f (g a)) => Additive ((f :.: g) a)
78+
79+-- | Product of groups, Functor style.
80+instance (Group (f a), Group (g a)) => Group ((f :*: g) a) where
81+ negateG (a :*: b) = negateG a :*: negateG b
82+ (a :*: b) ~~ (c :*: d) = (a ~~ c) :*: (b ~~ d)
83+instance (Additive (f a), Additive (g a)) => Additive ((f :*: g) a)
84+
85+-- | Trivial group, Functor style
86+instance Group (Proxy x) where
87+ negateG _ = Proxy
88+ _ ~~ _ = Proxy
89+instance Additive (Proxy x)
90+
91+-- | Const lifts groups into a functor.
92+deriving instance Group a => Group (Const a x)
93+instance Additive a => Additive (Const a x)
94+-- | Ideitnty lifts groups pointwise (at only one point)
95+deriving instance Group a => Group (Identity a)
96+instance Additive a => Additive (Identity a)
97+
98+-- | Functions lift groups pointwise.
99+instance Group b => Group (a -> b) where
100+ negateG f = negateG . f
101+ (~~) = liftA2 (~~)
102+instance Additive b => Additive (a -> b)