{-# LANGUAGE AllowAmbiguousTypes  #-} -- due to tag type class design
{-# LANGUAGE UndecidableInstances #-} -- due to generic type class design

module Generic.Data.Function.FoldMap.Constructor where

import GHC.Generics
import Data.Kind ( type Constraint, type Type )

import Generic.Data.Wrappers ( NoRec0, type ENoRec0, EmptyRec0 )
import GHC.TypeLits ( TypeError )

-- | Implementation enumeration type class for generic 'foldMap'.
--
-- The type variable is uninstantiated, used purely as a tag.
-- Good types include the type class used inside (providing you define the
-- type class/it's not an orphan instance), or a custom void data type.
-- See the binrep library on Hackage for an example.
class GenericFoldMap tag where
    -- | The target 'Monoid' to 'foldMap' to.
    type GenericFoldMapM tag :: Type

    -- | The type class providing the map function in 'foldMap' for permitted
    --   types.
    type GenericFoldMapC tag a :: Constraint

    -- | The map function in 'foldMap' (first argument).
    genericFoldMapF :: GenericFoldMapC tag a => a -> GenericFoldMapM tag

-- | 'foldMap' over types with no fields in any constructor.
instance GenericFoldMap (NoRec0 (m :: Type)) where
    type GenericFoldMapM (NoRec0 m)   = m
    type GenericFoldMapC (NoRec0 m) _ = TypeError ENoRec0
    genericFoldMapF :: forall a.
GenericFoldMapC (NoRec0 m) a =>
a -> GenericFoldMapM (NoRec0 m)
genericFoldMapF = a -> m
a -> GenericFoldMapM (NoRec0 m)
forall a. HasCallStack => a
undefined
    -- ^ TODO why safe

-- | 'foldMap' over types where all fields map to 'mempty'.
instance Monoid m => GenericFoldMap (EmptyRec0 m) where
    type GenericFoldMapM (EmptyRec0 m)   = m
    type GenericFoldMapC (EmptyRec0 m) _ = ()
    genericFoldMapF :: forall a.
GenericFoldMapC (EmptyRec0 m) a =>
a -> GenericFoldMapM (EmptyRec0 m)
genericFoldMapF a
_ = m
GenericFoldMapM (EmptyRec0 m)
forall a. Monoid a => a
mempty

-- | 'foldMap' on individual constructors (products).
class GFoldMapC tag f where gFoldMapC :: f p -> GenericFoldMapM tag

-- | 'foldMap' on individual constructors (products).
instance (Semigroup (GenericFoldMapM tag), GFoldMapC tag l, GFoldMapC tag r)
  => GFoldMapC tag (l :*: r) where
    gFoldMapC :: forall (p :: k). (:*:) l r p -> GenericFoldMapM tag
gFoldMapC (l p
l :*: r p
r) = forall (tag :: k) (f :: k -> Type) (p :: k).
GFoldMapC tag f =>
f p -> GenericFoldMapM tag
forall {k} {k} (tag :: k) (f :: k -> Type) (p :: k).
GFoldMapC tag f =>
f p -> GenericFoldMapM tag
gFoldMapC @tag l p
l GenericFoldMapM tag -> GenericFoldMapM tag -> GenericFoldMapM tag
forall a. Semigroup a => a -> a -> a
<> forall (tag :: k) (f :: k -> Type) (p :: k).
GFoldMapC tag f =>
f p -> GenericFoldMapM tag
forall {k} {k} (tag :: k) (f :: k -> Type) (p :: k).
GFoldMapC tag f =>
f p -> GenericFoldMapM tag
gFoldMapC @tag r p
r

instance (GenericFoldMap tag, GenericFoldMapC tag a)
  => GFoldMapC tag (S1 c (Rec0 a)) where
    gFoldMapC :: forall (p :: k). S1 c (Rec0 a) p -> GenericFoldMapM tag
gFoldMapC (M1 (K1 a
a)) = forall (tag :: k) a.
(GenericFoldMap tag, GenericFoldMapC tag a) =>
a -> GenericFoldMapM tag
forall {k} (tag :: k) a.
(GenericFoldMap tag, GenericFoldMapC tag a) =>
a -> GenericFoldMapM tag
genericFoldMapF @tag a
a

-- | Wow, look! Nothing!
instance Monoid (GenericFoldMapM tag) => GFoldMapC tag U1 where
    gFoldMapC :: forall (p :: k). U1 p -> GenericFoldMapM tag
gFoldMapC U1 p
U1 = GenericFoldMapM tag
forall a. Monoid a => a
mempty