From 78799a63c35412e55ac183828963c4aa246e6429 Mon Sep 17 00:00:00 2001
From: John Ericson <John.Ericson@Obsidian.Systems>
Date: Wed, 13 Oct 2021 17:26:56 -0400
Subject: [PATCH] Pull `Additive` into its own module

---
 ChangeLog.md                   |  3 ++
 patch.cabal                    |  1 +
 src/Data/Patch.hs              | 14 +---------
 src/Data/Semigroup/Additive.hs | 50 ++++++++++++++++++++++++++++++++++
 4 files changed, 55 insertions(+), 13 deletions(-)
 create mode 100644 src/Data/Semigroup/Additive.hs

diff --git a/ChangeLog.md b/ChangeLog.md
index 12ae41ee..aa7eeb6a 100644
--- a/ChangeLog.md
+++ b/ChangeLog.md
@@ -2,6 +2,9 @@
 
 ## Unreleased
 
+* `Additive` now lives in `Data.Semigroup.Additive`, but is still reexported
+  from `Data.Patch` for compatability.
+
 * Rewrite `PatchMapWithMove` in terms of `PatchMapWithPatchingMove`.
   Care is taken to make this not a breaking change.
   In particular, `PatchMapWithMove` is a newtype of `PatchMapWithPatchingMove`, as is the `NodeInfo` and `From` of `PatchMapWithPatchingMove`'s versions of those.
diff --git a/patch.cabal b/patch.cabal
index 782b125e..5c7e5fca 100644
--- a/patch.cabal
+++ b/patch.cabal
@@ -53,6 +53,7 @@ library
                  , Data.Patch.Map
                  , Data.Patch.MapWithMove
                  , Data.Patch.MapWithPatchingMove
+                 , Data.Semigroup.Additive
 
   ghc-options: -Wall -fwarn-redundant-constraints -fwarn-tabs
   default-extensions: PolyKinds
diff --git a/src/Data/Patch.hs b/src/Data/Patch.hs
index 7b6eb85e..bd63d633 100644
--- a/src/Data/Patch.hs
+++ b/src/Data/Patch.hs
@@ -23,6 +23,7 @@ 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
@@ -45,9 +46,6 @@ class (Semigroup q, Monoid q) => Group q where
   (~~) :: q -> q -> q
   r ~~ s = r <> negateG s
 
--- | An 'Additive' 'Semigroup' is one where (<>) is commutative
-class Semigroup q => Additive q where
-
 -- | The elements of an 'Additive' 'Semigroup' can be considered as patches of their own type.
 newtype AdditivePatch p = AdditivePatch { unAdditivePatch :: p }
 
@@ -58,19 +56,15 @@ instance Additive p => Patch (AdditivePatch p) where
 instance (Ord k, Group q) => Group (MonoidalMap k q) where
   negateG = fmap negateG
 
-instance (Ord k, Additive q) => Additive (MonoidalMap k q)
-
 -- | Trivial group.
 instance Group () where
   negateG _ = ()
   _ ~~ _ = ()
-instance Additive ()
 
 -- | Product group.  A Pair of groups gives rise to a group
 instance (Group a, Group b) => Group (a, b) where
   negateG (a, b) = (negateG a, negateG b)
   (a, b) ~~ (c, d) = (a ~~ c, b ~~ d)
-instance (Additive a, Additive b) => Additive (a, b)
 
 -- 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
@@ -78,29 +72,23 @@ instance (Additive a, Additive b) => Additive (a, b)
 instance Group (f (g a)) => Group ((f :.: g) a) where
   negateG (Comp1 xs) = Comp1 (negateG xs)
   Comp1 xs ~~ Comp1 ys = Comp1 (xs ~~ ys)
-instance Additive (f (g a)) => Additive ((f :.: g) a)
 
 -- | Product of groups, Functor style.
 instance (Group (f a), Group (g a)) => Group ((f :*: g) a) where
   negateG (a :*: b) = negateG a :*: negateG b
   (a :*: b) ~~ (c :*: d) = (a ~~ c) :*: (b ~~ d)
-instance (Additive (f a), Additive (g a)) => Additive ((f :*: g) a)
 
 -- | Trivial group, Functor style
 instance Group (Proxy x) where
   negateG _ = Proxy
   _ ~~ _ = Proxy
-instance Additive (Proxy x)
 
 -- | Const lifts groups into a functor.
 deriving instance Group a => Group (Const a x)
-instance Additive a => Additive (Const a x)
 -- | Ideitnty lifts groups pointwise (at only one point)
 deriving instance Group a => Group (Identity a)
-instance Additive a => Additive (Identity a)
 
 -- | Functions lift groups pointwise.
 instance Group b => Group (a -> b) where
   negateG f = negateG . f
   (~~) = liftA2 (~~)
-instance Additive b => Additive (a -> b)
diff --git a/src/Data/Semigroup/Additive.hs b/src/Data/Semigroup/Additive.hs
new file mode 100644
index 00000000..07dae425
--- /dev/null
+++ b/src/Data/Semigroup/Additive.hs
@@ -0,0 +1,50 @@
+{-# LANGUAGE CPP #-}
+{-# LANGUAGE TypeOperators #-}
+{-# LANGUAGE TypeFamilies #-}
+-- |
+-- Module:
+--   Data.Semigroup.Additive
+-- Description:
+--   This module defines a class for commutative semigroups, until it is moved
+--   to another library.
+module Data.Semigroup.Additive
+  ( Additive
+  ) where
+
+import Data.Functor.Const (Const (..))
+import Data.Functor.Identity
+-- For base-orphans, TODO don't cheat.
+import Data.Map.Monoidal ()
+import Data.Proxy
+#if !MIN_VERSION_base(4,11,0)
+import Data.Semigroup (Semigroup (..))
+#endif
+import GHC.Generics
+
+-- | An 'Additive' 'Semigroup' is one where (<>) is commutative
+class Semigroup q => Additive q where
+
+-- | Trivial group.
+instance Additive ()
+
+-- | Product group.  A Pair of groups gives rise to a group
+instance (Additive a, Additive b) => Additive (a, b)
+
+-- 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 Additive (f (g a)) => Additive ((f :.: g) a)
+
+-- | Product of groups, Functor style.
+instance (Additive (f a), Additive (g a)) => Additive ((f :*: g) a)
+
+-- | Trivial group, Functor style
+instance Additive (Proxy x)
+
+-- | Const lifts groups into a functor.
+instance Additive a => Additive (Const a x)
+-- | Ideitnty lifts groups pointwise (at only one point)
+instance Additive a => Additive (Identity a)
+
+-- | Functions lift groups pointwise.
+instance Additive b => Additive (a -> b)