{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE UndecidableInstances #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE TypeSynonymInstances #-}
{-# LANGUAGE FlexibleInstances #-}
module Data.Semigroup.Generic
    ( genericMappend
    , GenericSemigroup(..)
    ) where

import GHC.TypeLits
import Data.Semigroup
import GHC.Generics

-- | A newtype which allows you to using the @DerivingVia@ extension
-- to reduce boilerplate.
--
-- @
-- data X = X [Int] String
--   deriving (Generic, Show)
--   deriving Semigroup via GenericSemigroup X
-- @
newtype GenericSemigroup a = GenericSemigroup a

instance
    (Generic a, MappendProduct (Rep a))
    => Semigroup (GenericSemigroup a) where
    (GenericSemigroup a
a) <> :: GenericSemigroup a -> GenericSemigroup a -> GenericSemigroup a
<> (GenericSemigroup a
b)
        = a -> GenericSemigroup a
forall a. a -> GenericSemigroup a
GenericSemigroup (a -> GenericSemigroup a) -> a -> GenericSemigroup a
forall a b. (a -> b) -> a -> b
$ a -> a -> a
forall a. (Generic a, MappendProduct (Rep a)) => a -> a -> a
genericMappend a
a a
b

-- | A generic @`<>`@ function which works for product types where each
-- contained type is itself a @`Semigroup`@. It simply calls @`<>`@ for
-- each field.
--
-- If you don't want to use the @deriving via@ mechanism, use this function
-- to implement the `Semigroup` type class.
genericMappend :: (Generic a, MappendProduct (Rep a)) => a -> a -> a
genericMappend :: a -> a -> a
genericMappend a
a a
b = Rep a Any -> a
forall a x. Generic a => Rep a x -> a
to (Rep a Any -> a) -> Rep a Any -> a
forall a b. (a -> b) -> a -> b
$ a -> Rep a Any
forall a x. Generic a => a -> Rep a x
from a
a Rep a Any -> Rep a Any -> Rep a Any
forall (f :: * -> *) k. MappendProduct f => f k -> f k -> f k
`genericMappend'` a -> Rep a Any
forall a x. Generic a => a -> Rep a x
from a
b

class MappendProduct f where
    genericMappend' :: f k -> f k -> f k

instance
    (TypeError (Text "You can't use `genericMappend` for sum types"))
    => MappendProduct (a :+: b) where
    genericMappend' :: (:+:) a b k -> (:+:) a b k -> (:+:) a b k
genericMappend' = (:+:) a b k -> (:+:) a b k -> (:+:) a b k
forall a. HasCallStack => a
undefined

instance MappendProduct c => MappendProduct (D1 md c) where
    genericMappend' :: D1 md c k -> D1 md c k -> D1 md c k
genericMappend' (M1 c k
a) (M1 c k
b) = c k -> D1 md c k
forall k i (c :: Meta) (f :: k -> *) (p :: k). f p -> M1 i c f p
M1 (c k -> c k -> c k
forall (f :: * -> *) k. MappendProduct f => f k -> f k -> f k
genericMappend' c k
a c k
b)

instance MappendProduct s => MappendProduct (C1 mc s) where
    genericMappend' :: C1 mc s k -> C1 mc s k -> C1 mc s k
genericMappend' (M1 s k
a) (M1 s k
b) = s k -> C1 mc s k
forall k i (c :: Meta) (f :: k -> *) (p :: k). f p -> M1 i c f p
M1 (s k -> s k -> s k
forall (f :: * -> *) k. MappendProduct f => f k -> f k -> f k
genericMappend' s k
a s k
b)

instance (MappendProduct a, MappendProduct b) => MappendProduct (a :*: b) where
    genericMappend' :: (:*:) a b k -> (:*:) a b k -> (:*:) a b k
genericMappend' (a k
a :*: b k
b) (a k
a' :*: b k
b')
        = a k -> a k -> a k
forall (f :: * -> *) k. MappendProduct f => f k -> f k -> f k
genericMappend' a k
a a k
a' a k -> b k -> (:*:) a b k
forall k (f :: k -> *) (g :: k -> *) (p :: k).
f p -> g p -> (:*:) f g p
:*: b k -> b k -> b k
forall (f :: * -> *) k. MappendProduct f => f k -> f k -> f k
genericMappend' b k
b b k
b'

instance Semigroup t => MappendProduct (S1 m (Rec0 t)) where
    genericMappend' :: S1 m (Rec0 t) k -> S1 m (Rec0 t) k -> S1 m (Rec0 t) k
genericMappend' (M1 (K1 t
a)) (M1 (K1 t
b)) = K1 R t k -> S1 m (Rec0 t) k
forall k i (c :: Meta) (f :: k -> *) (p :: k). f p -> M1 i c f p
M1 (t -> K1 R t k
forall k i c (p :: k). c -> K1 i c p
K1 (t
a t -> t -> t
forall a. Semigroup a => a -> a -> a
<> t
b))