Merge pull request haskell#3193 from hvr/pr/issue-3169

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

Cabal/Distribution/Compat/Semigroup.hs

@@ -1,20 +1,32 @@
-{-# LANGUAGE CPP #-}
+{-# LANGUAGE CPP               #-}
+{-# LANGUAGE FlexibleContexts  #-}
+{-# LANGUAGE TypeOperators     #-}
 
 -- | Compatibility layer for "Data.Semigroup"
 module Distribution.Compat.Semigroup
     ( 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
 import qualified Data.Monoid as Mon
 #else
 -- provide internal simplified non-exposed class for older GHCs
 import Data.Monoid as Mon (Monoid(..), All(..), Any(..), Dual(..))
+-- containers
+import Data.Set (Set)
+import Data.IntSet (IntSet)
+import Data.Map (Map)
+import Data.IntMap (IntMap)
+
 
 class Semigroup a where
     (<>) :: a -> a -> a
@@ -67,4 +79,76 @@ instance (Semigroup a, Semigroup b, Semigroup c, Semigroup d, Semigroup e)
          => Semigroup (a, b, c, d, e) where
     (a,b,c,d,e) <> (a',b',c',d',e') = (a<>a',b<>b',c<>c',d<>d',e<>e')
 
+-- containers instances
+instance Semigroup IntSet where
+  (<>) = mappend
+
+instance Ord a => Semigroup (Set a) where
+  (<>) = mappend
+
+instance Semigroup (IntMap v) where
+  (<>) = mappend
+
+instance Ord k => Semigroup (Map k v) where
+  (<>) = mappend
 #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'