{-# LANGUAGE UndecidableInstances #-}
{-# LANGUAGE AllowAmbiguousTypes #-} -- for da test

module Generic.Data.FOnCstr where

import GHC.Generics
import GHC.TypeLits
import Data.Kind ( type Type, type Constraint )
import Generic.Type.CstrPath
import GHC.Exts ( Proxy#, proxy# )

-- | What generic functor to run on the requested constructor.
class GenericFOnCstr tag where
    -- | Functor.
    type GenericFOnCstrF tag :: Type -> Type

    -- | Constraint. Includes relevant generic meta (data type & constructor
    --   name).
    type GenericFOnCstrC tag (dtName :: Symbol) (cstrName :: Symbol) (gf :: k -> Type) :: Constraint

    -- | Generic functor.
    --
    -- We have to pass a proxy thanks to type applications not working properly
    -- with instances. (This will be easier in GHC 9.10 via
    -- RequiredTypeArguments).
    genericFOnCstrF
        :: GenericFOnCstrC tag dtName cstrName gf
        => Proxy# '(dtName, cstrName)
        -> GenericFOnCstrF tag (gf p)

-- | Run a generic functor (provided via @tag@) on the constructor name @name@.
--
-- We hope and pray that GHC removes the generic wrappers, at least the
-- constructor ones, since we do a whole bunch of nothing with them on the term
-- level. Checking this (the produced Core) is a big TODO.
class GFOnCstr tag (name :: Symbol) gf where
    gFOnCstr :: GenericFOnCstrF tag (gf p)

type family AssertValidCstrPath dtName cstr eae where
    AssertValidCstrPath dtName cstr (Right a) = a
    AssertValidCstrPath dtName cstr (Left  e) = TypeError
        (      Text "error searching for constructor " :<>: Text cstr
          :<>: Text " in data type " :<>: Text dtName :<>: Text ":"
          :$$: e )

instance
  ( turns ~ AssertValidCstrPath dtName cstrName (GCstrPath cstrName gf)
  , Functor (GenericFOnCstrF tag)
  , GFOnCstr' tag dtName cstrName turns gf
  ) => GFOnCstr tag cstrName (D1 (MetaData dtName _md2 _md3 _md4) gf) where
    {-# INLINE gFOnCstr #-}
    gFOnCstr :: forall (p :: k).
GenericFOnCstrF tag (D1 ('MetaData dtName _md2 _md3 _md4) gf p)
gFOnCstr = gf p -> M1 D ('MetaData dtName _md2 _md3 _md4) gf p
forall k i (c :: Meta) (f :: k -> Type) (p :: k). f p -> M1 i c f p
M1 (gf p -> M1 D ('MetaData dtName _md2 _md3 _md4) gf p)
-> GenericFOnCstrF tag (gf p)
-> GenericFOnCstrF
     tag (M1 D ('MetaData dtName _md2 _md3 _md4) gf p)
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (tag :: k) (dtName :: Symbol) (cstrName :: Symbol)
       (turns :: [GCstrChoice]) (gf :: k -> Type) (p :: k).
GFOnCstr' tag dtName cstrName turns gf =>
GenericFOnCstrF tag (gf p)
forall {k} {k} (tag :: k) (dtName :: Symbol) (cstrName :: Symbol)
       (turns :: [GCstrChoice]) (gf :: k -> Type) (p :: k).
GFOnCstr' tag dtName cstrName turns gf =>
GenericFOnCstrF tag (gf p)
gFOnCstr' @tag @dtName @cstrName @turns

class GFOnCstr' tag (dtName :: Symbol) (cstrName :: Symbol) (turns :: [GCstrChoice]) gf where
    gFOnCstr' :: GenericFOnCstrF tag (gf p)

{-
The following instances rely on @turns@ being valid for the current generic
representation. I don't attempt to handle this at all, because I assume my
constructor path algorithm is correct. Please let me know if you get an error
that says it came from this class.
-}
instance (Functor (GenericFOnCstrF tag), GFOnCstr' tag dtName cstrName turns l)
  => GFOnCstr' tag dtName cstrName (GoL1 : turns) (l :+: r) where
    {-# INLINE gFOnCstr' #-}
    gFOnCstr' :: forall (p :: k). GenericFOnCstrF tag ((:+:) l r p)
gFOnCstr' = l p -> (:+:) l r p
forall k (f :: k -> Type) (g :: k -> Type) (p :: k).
f p -> (:+:) f g p
L1 (l p -> (:+:) l r p)
-> GenericFOnCstrF tag (l p) -> GenericFOnCstrF tag ((:+:) l r p)
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (tag :: k) (dtName :: Symbol) (cstrName :: Symbol)
       (turns :: [GCstrChoice]) (gf :: k -> Type) (p :: k).
GFOnCstr' tag dtName cstrName turns gf =>
GenericFOnCstrF tag (gf p)
forall {k} {k} (tag :: k) (dtName :: Symbol) (cstrName :: Symbol)
       (turns :: [GCstrChoice]) (gf :: k -> Type) (p :: k).
GFOnCstr' tag dtName cstrName turns gf =>
GenericFOnCstrF tag (gf p)
gFOnCstr' @tag @dtName @cstrName @turns
instance (Functor (GenericFOnCstrF tag), GFOnCstr' tag dtName cstrName turns r)
  => GFOnCstr' tag dtName cstrName (GoR1 : turns) (l :+: r) where
    {-# INLINE gFOnCstr' #-}
    gFOnCstr' :: forall (p :: k). GenericFOnCstrF tag ((:+:) l r p)
gFOnCstr' = r p -> (:+:) l r p
forall k (f :: k -> Type) (g :: k -> Type) (p :: k).
g p -> (:+:) f g p
R1 (r p -> (:+:) l r p)
-> GenericFOnCstrF tag (r p) -> GenericFOnCstrF tag ((:+:) l r p)
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (tag :: k) (dtName :: Symbol) (cstrName :: Symbol)
       (turns :: [GCstrChoice]) (gf :: k -> Type) (p :: k).
GFOnCstr' tag dtName cstrName turns gf =>
GenericFOnCstrF tag (gf p)
forall {k} {k} (tag :: k) (dtName :: Symbol) (cstrName :: Symbol)
       (turns :: [GCstrChoice]) (gf :: k -> Type) (p :: k).
GFOnCstr' tag dtName cstrName turns gf =>
GenericFOnCstrF tag (gf p)
gFOnCstr' @tag @dtName @cstrName @turns
instance
  ( Functor (GenericFOnCstrF tag), GenericFOnCstr tag
  , GenericFOnCstrC tag dtName cstrName gf
  ) => GFOnCstr' tag dtName cstrName '[] (C1 mc gf) where
    {-# INLINE gFOnCstr' #-}
    gFOnCstr' :: forall (p :: k). GenericFOnCstrF tag (C1 mc gf p)
gFOnCstr' =
        gf p -> M1 C mc gf p
forall k i (c :: Meta) (f :: k -> Type) (p :: k). f p -> M1 i c f p
M1 (gf p -> M1 C mc gf p)
-> GenericFOnCstrF tag (gf p) -> GenericFOnCstrF tag (M1 C mc gf p)
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (tag :: k) {k} (dtName :: Symbol) (cstrName :: Symbol)
       (gf :: k -> Type) (p :: k).
(GenericFOnCstr tag, GenericFOnCstrC tag dtName cstrName gf) =>
Proxy# '(dtName, cstrName) -> GenericFOnCstrF tag (gf p)
forall {k} (tag :: k) {k} (dtName :: Symbol) (cstrName :: Symbol)
       (gf :: k -> Type) (p :: k).
(GenericFOnCstr tag, GenericFOnCstrC tag dtName cstrName gf) =>
Proxy# '(dtName, cstrName) -> GenericFOnCstrF tag (gf p)
genericFOnCstrF @tag (Proxy# '(dtName, cstrName)
forall {k} (a :: k). Proxy# a
proxy# :: Proxy# '(dtName, cstrName))

-- | Run a generic functor on the requested constructor of the given type.
genericFOnCstr
    :: forall tag (name :: Symbol) a
    .  ( Generic a, Functor (GenericFOnCstrF tag), GFOnCstr tag name (Rep a) )
    => GenericFOnCstrF tag a
genericFOnCstr :: forall {k} (tag :: k) (name :: Symbol) a.
(Generic a, Functor (GenericFOnCstrF tag),
 GFOnCstr tag name (Rep a)) =>
GenericFOnCstrF tag a
genericFOnCstr = Rep a Any -> a
forall a x. Generic a => Rep a x -> a
forall x. Rep a x -> a
to (Rep a Any -> a)
-> GenericFOnCstrF tag (Rep a Any) -> GenericFOnCstrF tag a
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (tag :: k) (name :: Symbol) (gf :: Type -> Type) p.
GFOnCstr tag name gf =>
GenericFOnCstrF tag (gf p)
forall {k} {k} (tag :: k) (name :: Symbol) (gf :: k -> Type)
       (p :: k).
GFOnCstr tag name gf =>
GenericFOnCstrF tag (gf p)
gFOnCstr @tag @name

{-
This type errors due to a "could not deduce 'GFOnCstr GX name (Rep a)'", "The
type variable 'k0' is ambiguous". Unsure why. GHC seems to indicate that it's
making a whole bunch of unused k1-3 type vars... I feel like GHC is trying to
match instances too early, and somehow backs itself into a corner.
genericFOnCstr'
    :: forall (name :: Symbol) a
    .  ( Generic a, GFOnCstr GX name (Rep a) )
    => Maybe a
genericFOnCstr' = to <$> gFOnCstr @GX @name
-}