{-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE UndecidableInstances #-} -- required below GHC 9.6

{- | 'foldMap' for sum types where constructors are encoded by mapping the
      constructor name.

Note that constructor names are unique per type. So as long as your mapping
function similarly outputs unique values of your monoid for each constructor,
you should be able to "reverse" the process (e.g. for generic 'traverse').
-}

module Generic.Data.Function.FoldMap.Sum where

import GHC.Generics
import Generic.Data.Function.Common.Generic ( conName', absurdV1 )
import Generic.Data.Function.FoldMap.Constructor
  ( GFoldMapC(gFoldMapC)
  , GenericFoldMap(type GenericFoldMapM) )

class GFoldMapSum tag gf where
    gFoldMapSum
        :: (String -> GenericFoldMapM tag) -> gf p -> GenericFoldMapM tag

instance GFoldMapSum tag gf => GFoldMapSum tag (D1 c gf) where
    gFoldMapSum :: forall (p :: k).
(String -> GenericFoldMapM tag) -> D1 c gf p -> GenericFoldMapM tag
gFoldMapSum String -> GenericFoldMapM tag
f = forall (tag :: k) (gf :: k -> Type) (p :: k).
GFoldMapSum tag gf =>
(String -> GenericFoldMapM tag) -> gf p -> GenericFoldMapM tag
forall {k} {k} (tag :: k) (gf :: k -> Type) (p :: k).
GFoldMapSum tag gf =>
(String -> GenericFoldMapM tag) -> gf p -> GenericFoldMapM tag
gFoldMapSum @tag String -> GenericFoldMapM tag
f (gf p -> GenericFoldMapM tag)
-> (D1 c gf p -> gf p) -> D1 c gf p -> GenericFoldMapM tag
forall b c a. (b -> c) -> (a -> b) -> a -> c
. D1 c gf p -> gf p
forall k i (c :: Meta) (f :: k -> Type) (p :: k). M1 i c f p -> f p
unM1

instance GFoldMapCSum tag (l :+: r) => GFoldMapSum tag (l :+: r) where
    gFoldMapSum :: forall (p :: k).
(String -> GenericFoldMapM tag)
-> (:+:) l r p -> GenericFoldMapM tag
gFoldMapSum = forall (tag :: k) (gf :: k -> Type) (p :: k).
GFoldMapCSum tag gf =>
(String -> GenericFoldMapM tag) -> gf p -> GenericFoldMapM tag
forall {k} {k} (tag :: k) (gf :: k -> Type) (p :: k).
GFoldMapCSum tag gf =>
(String -> GenericFoldMapM tag) -> gf p -> GenericFoldMapM tag
gFoldMapCSum @tag

instance GFoldMapCSum tag (C1 c gf) => GFoldMapSum tag (C1 c gf) where
    gFoldMapSum :: forall (p :: k).
(String -> GenericFoldMapM tag) -> C1 c gf p -> GenericFoldMapM tag
gFoldMapSum = forall (tag :: k) (gf :: k -> Type) (p :: k).
GFoldMapCSum tag gf =>
(String -> GenericFoldMapM tag) -> gf p -> GenericFoldMapM tag
forall {k} {k} (tag :: k) (gf :: k -> Type) (p :: k).
GFoldMapCSum tag gf =>
(String -> GenericFoldMapM tag) -> gf p -> GenericFoldMapM tag
gFoldMapCSum @tag

instance GFoldMapSum tag V1 where
    gFoldMapSum :: forall (p :: k).
(String -> GenericFoldMapM tag) -> V1 p -> GenericFoldMapM tag
gFoldMapSum String -> GenericFoldMapM tag
_ = V1 p -> GenericFoldMapM tag
forall {k} (x :: k) a. V1 x -> a
absurdV1

-- | Sum type handler prefixing constructor contents with their mapped
--   constructor name via a provided @String -> m@.
--
-- TODO rename
class GFoldMapCSum tag gf where
    gFoldMapCSum
        :: (String -> GenericFoldMapM tag) -> gf p -> GenericFoldMapM tag

instance (GFoldMapCSum tag l, GFoldMapCSum tag r)
  => GFoldMapCSum tag (l :+: r) where
    gFoldMapCSum :: forall (p :: k).
(String -> GenericFoldMapM tag)
-> (:+:) l r p -> GenericFoldMapM tag
gFoldMapCSum String -> GenericFoldMapM tag
f = \case L1 l p
l -> forall (tag :: k) (gf :: k -> Type) (p :: k).
GFoldMapCSum tag gf =>
(String -> GenericFoldMapM tag) -> gf p -> GenericFoldMapM tag
forall {k} {k} (tag :: k) (gf :: k -> Type) (p :: k).
GFoldMapCSum tag gf =>
(String -> GenericFoldMapM tag) -> gf p -> GenericFoldMapM tag
gFoldMapCSum @tag String -> GenericFoldMapM tag
f l p
l
                           R1 r p
r -> forall (tag :: k) (gf :: k -> Type) (p :: k).
GFoldMapCSum tag gf =>
(String -> GenericFoldMapM tag) -> gf p -> GenericFoldMapM tag
forall {k} {k} (tag :: k) (gf :: k -> Type) (p :: k).
GFoldMapCSum tag gf =>
(String -> GenericFoldMapM tag) -> gf p -> GenericFoldMapM tag
gFoldMapCSum @tag String -> GenericFoldMapM tag
f r p
r

instance (Semigroup (GenericFoldMapM tag), Constructor c, GFoldMapC tag gf)
  => GFoldMapCSum tag (C1 c gf) where
    gFoldMapCSum :: forall (p :: k).
(String -> GenericFoldMapM tag) -> C1 c gf p -> GenericFoldMapM tag
gFoldMapCSum String -> GenericFoldMapM tag
mapCstr (M1 gf p
a) = String -> GenericFoldMapM tag
mapCstr (forall {k} (c :: k). Constructor c => String
forall (c :: Meta). Constructor c => String
conName' @c) 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} {k1} (tag :: k) (f :: k1 -> Type) (p :: k1).
GFoldMapC tag f =>
f p -> GenericFoldMapM tag
gFoldMapC @tag gf p
a