{-# LANGUAGE UndecidableInstances #-} -- due to type class design

module Generic.Data.Function.FoldMap.Constructor where

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

import Generic.Data.Function.Via
import GHC.TypeLits ( TypeError )

-- | 'Monoid's that can be generically 'foldMap'ped to.
class GenericFoldMap m where
    -- | The type class that enables mapping permitted types to the monoid.
    --
    -- The type class should provide a function that looks like
    -- 'genericFoldMapF'.
    type GenericFoldMapC m a :: Constraint

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

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

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

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

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

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

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