{-# 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 = undefined

-- | 'foldMap' over types where all fields map to 'mempty'.
instance Monoid m => GenericFoldMap (EmptyRec0 m) where
    type GenericFoldMapC (EmptyRec0 m) _ = ()
    genericFoldMapF _ = EmptyRec0 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 (l :*: r) = gFoldMapC l <> gFoldMapC r

instance (GenericFoldMap m, GenericFoldMapC m a)
  => GFoldMapC m (S1 c (Rec0 a)) where
    gFoldMapC (M1 (K1 a)) = genericFoldMapF a

-- | Wow, look! Nothing!
instance Monoid m => GFoldMapC m U1 where gFoldMapC U1 = mempty