{-# LANGUAGE UndecidableInstances #-} -- due to type families in constraints
{-# LANGUAGE AllowAmbiguousTypes  #-} -- due to class design

module Generic.Data.Function.FoldMap.Sum where

import GHC.Generics
import Generic.Data.Function.Common.Generic ( absurdV1 )
import Generic.Data.Function.FoldMap.Constructor
  ( GFoldMapC(gFoldMapC)
  , GenericFoldMap(type GenericFoldMapM) )
import Generic.Data.MetaParse.Cstr
import GHC.Exts ( proxy# )
import GHC.TypeLits ( Symbol )

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

instance GFoldMapSumD tag sumtag dtName gf
  => GFoldMapSum tag sumtag (D1 (MetaData dtName _md2 _md3 _md4) gf) where
    gFoldMapSum :: forall (p :: k).
ParseCstrTo sumtag (GenericFoldMapM tag)
-> D1 ('MetaData dtName _md2 _md3 _md4) gf p -> GenericFoldMapM tag
gFoldMapSum ParseCstrTo sumtag (GenericFoldMapM tag)
f = forall (tag :: k) (sumtag :: k) (dtName :: Symbol)
       (gf :: k -> Type) (p :: k).
GFoldMapSumD tag sumtag dtName gf =>
ParseCstrTo sumtag (GenericFoldMapM tag)
-> gf p -> GenericFoldMapM tag
forall {k} {k} {k} {k} (tag :: k) (sumtag :: k) (dtName :: k)
       (gf :: k -> Type) (p :: k).
GFoldMapSumD tag sumtag dtName gf =>
ParseCstrTo sumtag (GenericFoldMapM tag)
-> gf p -> GenericFoldMapM tag
gFoldMapSumD @tag @sumtag @dtName Proxy# x -> GenericFoldMapM tag
ParseCstrTo sumtag (GenericFoldMapM tag)
f (gf p -> GenericFoldMapM tag)
-> (D1 ('MetaData dtName _md2 _md3 _md4) gf p -> gf p)
-> D1 ('MetaData dtName _md2 _md3 _md4) gf p
-> GenericFoldMapM tag
forall b c a. (b -> c) -> (a -> b) -> a -> c
. D1 ('MetaData dtName _md2 _md3 _md4) gf p -> gf p
forall k i (c :: Meta) (f :: k -> Type) (p :: k). M1 i c f p -> f p
unM1

class GFoldMapSumD tag sumtag dtName gf where
    gFoldMapSumD
        :: ParseCstrTo sumtag (GenericFoldMapM tag)
        -> gf p -> GenericFoldMapM tag

instance GFoldMapSumD tag sumtag dtName V1 where
    gFoldMapSumD :: forall (p :: k).
ParseCstrTo sumtag (GenericFoldMapM tag)
-> V1 p -> GenericFoldMapM tag
gFoldMapSumD ParseCstrTo sumtag (GenericFoldMapM tag)
_ = V1 p -> GenericFoldMapM tag
forall {k} (x :: k) a. V1 x -> a
absurdV1

instance GFoldMapCSum tag sumtag dtName (C1 c gf)
  => GFoldMapSumD tag sumtag dtName (C1 c gf) where
    gFoldMapSumD :: forall (p :: k).
ParseCstrTo sumtag (GenericFoldMapM tag)
-> C1 c gf p -> GenericFoldMapM tag
gFoldMapSumD = forall (tag :: k) (sumtag :: k) (dtName :: Symbol)
       (gf :: k -> Type) (p :: k).
GFoldMapCSum tag sumtag dtName gf =>
ParseCstrTo sumtag (GenericFoldMapM tag)
-> gf p -> GenericFoldMapM tag
forall {k} {k} {k} (tag :: k) (sumtag :: k) (dtName :: Symbol)
       (gf :: k -> Type) (p :: k).
GFoldMapCSum tag sumtag dtName gf =>
ParseCstrTo sumtag (GenericFoldMapM tag)
-> gf p -> GenericFoldMapM tag
gFoldMapCSum @tag @sumtag @dtName

instance GFoldMapCSum tag sumtag dtName (l :+: r)
  => GFoldMapSumD tag sumtag dtName (l :+: r) where
    gFoldMapSumD :: forall (p :: k).
ParseCstrTo sumtag (GenericFoldMapM tag)
-> (:+:) l r p -> GenericFoldMapM tag
gFoldMapSumD = forall (tag :: k) (sumtag :: k) (dtName :: Symbol)
       (gf :: k -> Type) (p :: k).
GFoldMapCSum tag sumtag dtName gf =>
ParseCstrTo sumtag (GenericFoldMapM tag)
-> gf p -> GenericFoldMapM tag
forall {k} {k} {k} (tag :: k) (sumtag :: k) (dtName :: Symbol)
       (gf :: k -> Type) (p :: k).
GFoldMapCSum tag sumtag dtName gf =>
ParseCstrTo sumtag (GenericFoldMapM tag)
-> gf p -> GenericFoldMapM tag
gFoldMapCSum @tag @sumtag @dtName

class GFoldMapCSum tag sumtag (dtName :: Symbol) gf where
    gFoldMapCSum
        :: ParseCstrTo sumtag (GenericFoldMapM tag)
        -> gf p -> GenericFoldMapM tag

instance (GFoldMapCSum tag sumtag dtName l, GFoldMapCSum tag sumtag dtName r)
  => GFoldMapCSum tag sumtag dtName (l :+: r) where
    gFoldMapCSum :: forall (p :: k).
ParseCstrTo sumtag (GenericFoldMapM tag)
-> (:+:) l r p -> GenericFoldMapM tag
gFoldMapCSum ParseCstrTo sumtag (GenericFoldMapM tag)
f = \case L1 l p
l -> forall (tag :: k) (sumtag :: k) (dtName :: Symbol)
       (gf :: k -> Type) (p :: k).
GFoldMapCSum tag sumtag dtName gf =>
ParseCstrTo sumtag (GenericFoldMapM tag)
-> gf p -> GenericFoldMapM tag
forall {k} {k} {k} (tag :: k) (sumtag :: k) (dtName :: Symbol)
       (gf :: k -> Type) (p :: k).
GFoldMapCSum tag sumtag dtName gf =>
ParseCstrTo sumtag (GenericFoldMapM tag)
-> gf p -> GenericFoldMapM tag
gFoldMapCSum @tag @sumtag @dtName Proxy# x -> GenericFoldMapM tag
ParseCstrTo sumtag (GenericFoldMapM tag)
f l p
l
                           R1 r p
r -> forall (tag :: k) (sumtag :: k) (dtName :: Symbol)
       (gf :: k -> Type) (p :: k).
GFoldMapCSum tag sumtag dtName gf =>
ParseCstrTo sumtag (GenericFoldMapM tag)
-> gf p -> GenericFoldMapM tag
forall {k} {k} {k} (tag :: k) (sumtag :: k) (dtName :: Symbol)
       (gf :: k -> Type) (p :: k).
GFoldMapCSum tag sumtag dtName gf =>
ParseCstrTo sumtag (GenericFoldMapM tag)
-> gf p -> GenericFoldMapM tag
gFoldMapCSum @tag @sumtag @dtName Proxy# x -> GenericFoldMapM tag
ParseCstrTo sumtag (GenericFoldMapM tag)
f r p
r

-- TODO could play with this. Perhaps Unsatisfiable (GHC 9.8) is better?
instance
  ( Semigroup (GenericFoldMapM tag), GFoldMapC tag gf
  , ReifyCstrParseResult sumtag cstrParsed
  , ForceGCParse dtName cstr (ParseCstr sumtag cstr) ~ cstrParsed
  ) => GFoldMapCSum tag sumtag dtName (C1 (MetaCons cstr _mc2 _mc3) gf) where
    gFoldMapCSum :: forall (p :: k).
ParseCstrTo sumtag (GenericFoldMapM tag)
-> C1 ('MetaCons cstr _mc2 _mc3) gf p -> GenericFoldMapM tag
gFoldMapCSum ParseCstrTo sumtag (GenericFoldMapM tag)
mapReifyCstr (M1 gf p
a) =
        Proxy# cstrParsed -> GenericFoldMapM tag
ParseCstrTo sumtag (GenericFoldMapM tag)
mapReifyCstr (forall {k} (a :: k). Proxy# a
forall (a :: CstrParseResult sumtag). Proxy# a
proxy# @cstrParsed) 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