{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE TypeOperators #-}

module Distribution.Compat.Semigroup
  ( gmappend
  , gmempty
  ) where

import GHC.Generics

-- 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 :: forall a. (Generic a, GSemigroup (Rep a)) => a -> a -> a
gmappend a
x a
y = Rep a (ZonkAny 1) -> a
forall a x. Generic a => Rep a x -> a
forall x. Rep a x -> a
to (Rep a (ZonkAny 1) -> Rep a (ZonkAny 1) -> Rep a (ZonkAny 1)
forall p. Rep a p -> Rep a p -> Rep a p
forall (f :: * -> *) p. GSemigroup f => f p -> f p -> f p
gmappend' (a -> Rep a (ZonkAny 1)
forall x. a -> Rep a x
forall a x. Generic a => a -> Rep a x
from a
x) (a -> Rep a (ZonkAny 1)
forall x. a -> Rep a x
forall a x. Generic a => a -> Rep a x
from a
y))

class GSemigroup f where
  gmappend' :: f p -> f p -> f p

instance Semigroup a => GSemigroup (K1 i a) where
  gmappend' :: forall p. K1 i a p -> K1 i a p -> K1 i a p
gmappend' (K1 a
x) (K1 a
y) = a -> K1 i a p
forall k i c (p :: k). c -> K1 i c p
K1 (a
x a -> a -> a
forall a. Semigroup a => a -> a -> a
<> a
y)

instance GSemigroup f => GSemigroup (M1 i c f) where
  gmappend' :: forall p. M1 i c f p -> M1 i c f p -> M1 i c f p
gmappend' (M1 f p
x) (M1 f p
y) = f p -> M1 i c f p
forall k i (c :: Meta) (f :: k -> *) (p :: k). f p -> M1 i c f p
M1 (f p -> f p -> f p
forall p. f p -> f p -> f p
forall (f :: * -> *) p. GSemigroup f => f p -> f p -> f p
gmappend' f p
x f p
y)

instance (GSemigroup f, GSemigroup g) => GSemigroup (f :*: g) where
  gmappend' :: forall p. (:*:) f g p -> (:*:) f g p -> (:*:) f g p
gmappend' (f p
x1 :*: g p
x2) (f p
y1 :*: g p
y2) = f p -> f p -> f p
forall p. f p -> f p -> f p
forall (f :: * -> *) p. GSemigroup f => f p -> f p -> f p
gmappend' f p
x1 f p
y1 f p -> g p -> (:*:) f g p
forall k (f :: k -> *) (g :: k -> *) (p :: k).
f p -> g p -> (:*:) f g p
:*: g p -> g p -> g p
forall p. g p -> g p -> g p
forall (f :: * -> *) p. GSemigroup f => f p -> f p -> f p
gmappend' g p
x2 g p
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 :: forall a. (Generic a, GMonoid (Rep a)) => a
gmempty = Rep a (ZonkAny 0) -> a
forall a x. Generic a => Rep a x -> a
forall x. Rep a x -> a
to Rep a (ZonkAny 0)
forall p. Rep a p
forall (f :: * -> *) p. GMonoid f => f p
gmempty'

class GSemigroup f => GMonoid f where
  gmempty' :: f p

instance Monoid a => GMonoid (K1 i a) where
  gmempty' :: forall p. K1 i a p
gmempty' = a -> K1 i a p
forall k i c (p :: k). c -> K1 i c p
K1 a
forall a. Monoid a => a
mempty

instance GMonoid f => GMonoid (M1 i c f) where
  gmempty' :: forall p. M1 i c f p
gmempty' = f p -> M1 i c f p
forall k i (c :: Meta) (f :: k -> *) (p :: k). f p -> M1 i c f p
M1 f p
forall p. f p
forall (f :: * -> *) p. GMonoid f => f p
gmempty'

instance (GMonoid f, GMonoid g) => GMonoid (f :*: g) where
  gmempty' :: forall p. (:*:) f g p
gmempty' = f p
forall p. f p
forall (f :: * -> *) p. GMonoid f => f p
gmempty' f p -> g p -> (:*:) f g p
forall k (f :: k -> *) (g :: k -> *) (p :: k).
f p -> g p -> (:*:) f g p
:*: g p
forall p. g p
forall (f :: * -> *) p. GMonoid f => f p
gmempty'