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

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

-- | 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
--   deriving Monoid    via GenericMonoid X
-- @
--
-- Note: Do NOT attempt to @derive Semigroup via GenericMonoid@. That will lead
-- to infinite recursion.
newtype GenericMonoid a = GenericMonoid a
    deriving Int -> GenericMonoid a -> ShowS
[GenericMonoid a] -> ShowS
GenericMonoid a -> String
(Int -> GenericMonoid a -> ShowS)
-> (GenericMonoid a -> String)
-> ([GenericMonoid a] -> ShowS)
-> Show (GenericMonoid a)
forall a. Show a => Int -> GenericMonoid a -> ShowS
forall a. Show a => [GenericMonoid a] -> ShowS
forall a. Show a => GenericMonoid a -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [GenericMonoid a] -> ShowS
$cshowList :: forall a. Show a => [GenericMonoid a] -> ShowS
show :: GenericMonoid a -> String
$cshow :: forall a. Show a => GenericMonoid a -> String
showsPrec :: Int -> GenericMonoid a -> ShowS
$cshowsPrec :: forall a. Show a => Int -> GenericMonoid a -> ShowS
Show

instance Semigroup a => Semigroup (GenericMonoid a) where
    GenericMonoid a
a <> :: GenericMonoid a -> GenericMonoid a -> GenericMonoid a
<> GenericMonoid a
b = a -> GenericMonoid a
forall a. a -> GenericMonoid a
GenericMonoid (a -> GenericMonoid a) -> a -> GenericMonoid a
forall a b. (a -> b) -> a -> b
$ a
a a -> a -> a
forall a. Semigroup a => a -> a -> a
<> a
b

instance
    (Semigroup a, Generic a, MemptyProduct (Rep a))
    => Monoid (GenericMonoid a) where
    mempty :: GenericMonoid a
mempty = a -> GenericMonoid a
forall a. a -> GenericMonoid a
GenericMonoid a
forall a. (Generic a, MemptyProduct (Rep a)) => a
genericMempty

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

class MemptyProduct f where
    genericMempty' :: f k

instance MemptyProduct c => MemptyProduct (D1 md c) where
    genericMempty' :: D1 md c k
genericMempty' = 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
forall (f :: * -> *) k. MemptyProduct f => f k
genericMempty'

instance MemptyProduct s => MemptyProduct (C1 md s) where
    genericMempty' :: C1 md s k
genericMempty' = s k -> C1 md s k
forall k i (c :: Meta) (f :: k -> *) (p :: k). f p -> M1 i c f p
M1 s k
forall (f :: * -> *) k. MemptyProduct f => f k
genericMempty'

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

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

instance Monoid t => MemptyProduct (S1 m (Rec0 t)) where
    genericMempty' :: S1 m (Rec0 t) k
genericMempty' = 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
forall a. Monoid a => a
mempty)