{-# 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
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
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))