Add `gmappend`/`gmempty` Generics-helpers (re #3169)

Cabal/Distribution/Compat/Semigroup.hs

-{-# LANGUAGE CPP #-}
+{-# LANGUAGE CPP               #-}
+{-# LANGUAGE FlexibleContexts  #-}
+{-# LANGUAGE TypeOperators     #-}
 
 -- | Compatibility layer for "Data.Semigroup"
 module Distribution.Compat.Semigroup
@@ -6,8 +8,12 @@ module Distribution.Compat.Semigroup
     , Mon.Monoid(..)
     , All(..)
     , Any(..)
+
+    , gmappend
+    , gmempty
     ) where
 
+import GHC.Generics
 #if __GLASGOW_HASKELL__ >= 711
 -- Data.Semigroup is available since GHC 8.0/base-4.9
 import Data.Semigroup
@@ -68,3 +74,63 @@ instance (Semigroup a, Semigroup b, Semigroup c, Semigroup d, Semigroup e)
     (a,b,c,d,e) <> (a',b',c',d',e') = (a<>a',b<>b',c<>c',d<>d',e<>e')
 
 #endif
+
+-------------------------------------------------------------------------------
+-------------------------------------------------------------------------------
+-- Stolen from Edward Kmett's BSD3-licensed `semigroups` package
+
+-- | Generically generate a 'Semigroup' ('<>') operation for any type
+-- implementing 'Generic'. This operation will append two values
+-- by point-wise appending their component fields. It is only defined
+-- for product types.
+--
+-- @
+-- 'gmappend' a ('gmappend' b c) = 'gmappend' ('gmappend' a b) c
+-- @
+gmappend :: (Generic a, GSemigroup (Rep a)) => a -> a -> a
+gmappend x y = to (gmappend' (from x) (from y))
+
+class GSemigroup f where
+    gmappend' :: f p -> f p -> f p
+
+instance GSemigroup U1 where
+    gmappend' _ _ = U1
+
+instance GSemigroup V1 where
+    gmappend' x y = x `seq` y `seq` error "GSemigroup.V1: gmappend'"
+
+instance Semigroup a => GSemigroup (K1 i a) where
+    gmappend' (K1 x) (K1 y) = K1 (x <> y)
+
+instance GSemigroup f => GSemigroup (M1 i c f) where
+    gmappend' (M1 x) (M1 y) = M1 (gmappend' x y)
+
+instance (GSemigroup f, GSemigroup g) => GSemigroup (f :*: g) where
+    gmappend' (x1 :*: x2) (y1 :*: y2) = gmappend' x1 y1 :*: gmappend' x2 y2
+
+-- | Generically generate a 'Monoid' 'mempty' for any product-like type
+-- implementing 'Generic'.
+--
+-- It is only defined for product types.
+--
+-- @
+-- 'gmappend' 'gmempty' a = a = 'gmappend' a 'gmempty'
+-- @
+
+gmempty :: (Generic a, GMonoid (Rep a)) => a
+gmempty = to gmempty'
+
+class GSemigroup f => GMonoid f where
+    gmempty' :: f p
+
+instance GMonoid U1 where
+    gmempty' = U1
+
+instance (Semigroup a, Monoid a) => GMonoid (K1 i a) where
+    gmempty' = K1 mempty
+
+instance GMonoid f => GMonoid (M1 i c f) where
+    gmempty' = M1 gmempty'
+
+instance (GMonoid f, GMonoid g) => GMonoid (f :*: g) where
+    gmempty' = gmempty' :*: gmempty'