Add Applicative, Semigroup, and Monoid instances in GHC.Generics

Reviewers: hvr, bgamari, alpmestan, RyanGlScott

Reviewed By: RyanGlScott

Subscribers: RyanGlScott, rwbarton, thomie, carter

Differential Revision: https://phabricator.haskell.org/D4447

2 files changed, 61 insertions, 1 deletions

diff --git a/libraries/base/GHC/Generics.hs b/libraries/base/GHC/Generics.hs
index ff44cf81c3..9ac05286ab 100644
--- a/libraries/base/GHC/Generics.hs
+++ b/libraries/base/GHC/Generics.hs
@@ -740,7 +740,8 @@ import GHC.Types
 -- Needed for instances
 import GHC.Arr     ( Ix )
 import GHC.Base    ( Alternative(..), Applicative(..), Functor(..)
-                   , Monad(..), MonadPlus(..), NonEmpty(..), String, coerce )
+                   , Monad(..), MonadPlus(..), NonEmpty(..), String, coerce
+                   , Semigroup(..), Monoid(..) )
 import GHC.Classes ( Eq(..), Ord(..) )
 import GHC.Enum    ( Bounded, Enum )
 import GHC.Read    ( Read(..) )
@@ -765,6 +766,10 @@ data V1 (p :: k)
            , Generic1 -- ^ @since 4.9.0.0
            )
 
+-- | @since 4.12.0.0
+instance Semigroup (V1 p) where
+  v <> _ = v
+
 -- | Unit: used for constructors without arguments
 data U1 (p :: k) = U1
   deriving ( Generic  -- ^ @since 4.7.0.0
@@ -808,6 +813,14 @@ instance Monad U1 where
 -- | @since 4.9.0.0
 instance MonadPlus U1
 
+-- | @since 4.12.0.0
+instance Semigroup (U1 p) where
+  _ <> _ = U1
+
+-- | @since 4.12.0.0
+instance Monoid (U1 p) where
+  mempty = U1
+
 -- | Used for marking occurrences of the parameter
 newtype Par1 p = Par1 { unPar1 :: p }
   deriving ( Eq       -- ^ @since 4.7.0.0
@@ -829,6 +842,12 @@ instance Applicative Par1 where
 instance Monad Par1 where
   Par1 x >>= f = f x
 
+-- | @since 4.12.0.0
+deriving instance Semigroup p => Semigroup (Par1 p)
+
+-- | @since 4.12.0.0
+deriving instance Monoid p => Monoid (Par1 p)
+
 -- | Recursive calls of kind @* -> *@ (or kind @k -> *@, when @PolyKinds@
 -- is enabled)
 newtype Rec1 (f :: k -> *) (p :: k) = Rec1 { unRec1 :: f p }
@@ -854,6 +873,12 @@ instance Monad f => Monad (Rec1 f) where
 -- | @since 4.9.0.0
 deriving instance MonadPlus f => MonadPlus (Rec1 f)
 
+-- | @since 4.12.0.0
+deriving instance Semigroup (f p) => Semigroup (Rec1 f p)
+
+-- | @since 4.12.0.0
+deriving instance Monoid (f p) => Monoid (Rec1 f p)
+
 -- | Constants, additional parameters and recursion of kind @*@
 newtype K1 (i :: *) c (p :: k) = K1 { unK1 :: c }
   deriving ( Eq       -- ^ @since 4.7.0.0
@@ -865,6 +890,18 @@ newtype K1 (i :: *) c (p :: k) = K1 { unK1 :: c }
            , Generic1 -- ^ @since 4.9.0.0
            )
 
+-- | @since 4.12.0.0
+instance Monoid c => Applicative (K1 i c) where
+  pure _ = K1 mempty
+  liftA2 = \_ -> coerce (mappend :: c -> c -> c)
+  (<*>) = coerce (mappend :: c -> c -> c)
+
+-- | @since 4.12.0.0
+deriving instance Semigroup c => Semigroup (K1 i c p)
+
+-- | @since 4.12.0.0
+deriving instance Monoid c => Monoid (K1 i c p)
+
 -- | @since 4.9.0.0
 deriving instance Applicative f => Applicative (M1 i c f)
 
@@ -877,6 +914,12 @@ deriving instance Monad f => Monad (M1 i c f)
 -- | @since 4.9.0.0
 deriving instance MonadPlus f => MonadPlus (M1 i c f)
 
+-- | @since 4.12.0.0
+deriving instance Semigroup (f p) => Semigroup (M1 i c f p)
+
+-- | @since 4.12.0.0
+deriving instance Monoid (f p) => Monoid (M1 i c f p)
+
 -- | Meta-information (constructor names, etc.)
 newtype M1 (i :: *) (c :: Meta) (f :: k -> *) (p :: k) = M1 { unM1 :: f p }
   deriving ( Eq       -- ^ @since 4.7.0.0
@@ -933,6 +976,14 @@ instance (Monad f, Monad g) => Monad (f :*: g) where
 -- | @since 4.9.0.0
 instance (MonadPlus f, MonadPlus g) => MonadPlus (f :*: g)
 
+-- | @since 4.12.0.0
+instance (Semigroup (f p), Semigroup (g p)) => Semigroup ((f :*: g) p) where
+  (x1 :*: y1) <> (x2 :*: y2) = (x1 <> x2) :*: (y1 <> y2)
+
+-- | @since 4.12.0.0
+instance (Monoid (f p), Monoid (g p)) => Monoid ((f :*: g) p) where
+  mempty = mempty :*: mempty
+
 -- | Composition of functors
 infixr 7 :.:
 newtype (:.:) (f :: k2 -> *) (g :: k1 -> k2) (p :: k1) =
@@ -958,6 +1009,12 @@ instance (Alternative f, Applicative g) => Alternative (f :.: g) where
   (<|>) = coerce ((<|>) :: f (g a) -> f (g a) -> f (g a)) ::
     forall a . (f :.: g) a -> (f :.: g) a -> (f :.: g) a
 
+-- | @since 4.12.0.0
+deriving instance Semigroup (f (g p)) => Semigroup ((f :.: g) p)
+
+-- | @since 4.12.0.0
+deriving instance Monoid (f (g p)) => Monoid ((f :.: g) p)
+
 -- | Constants of unlifted kinds
 --
 -- @since 4.9.0.0
diff --git a/libraries/base/changelog.md b/libraries/base/changelog.md
index fdac6f283e..47fe01148d 100644
--- a/libraries/base/changelog.md
+++ b/libraries/base/changelog.md
@@ -6,6 +6,9 @@
 
   * `($!)` is now representation-polymorphic like `($)`.
 
+  * Add `Applicative` (for `K1`), `Semigroup` and `Monoid` instances in
+    `GHC.Generics`. (#14849)
+
 ## 4.11.0.0 *TBA*
   * Bundled with GHC 8.4.1