{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE PolyKinds #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE UndecidableInstances #-}
module Control.Variadic.Generic.Internal where

import Control.Variadic
import Data.Kind (Constraint)
import Data.Proxy (Proxy(Proxy))
import GHC.Generics
import GHC.TypeLits

-- | Runs @hoist@ on the return values each field of @r@
-- with the given natural transformation function, ignoring
-- the @close@ field, if it exists.
ghoist
  :: ( Generic (r f)
     , Generic (r g)
     , GHoist (Rep (r f)) (Rep (r g)) f g '["close"]
     )
  => (forall x. f x -> g x)
  -> r f
  -> r g
ghoist :: (forall x. f x -> g x) -> r f -> r g
ghoist = Proxy '["close"] -> (forall x. f x -> g x) -> r f -> r g
forall (r :: (* -> *) -> *) (f :: * -> *) (g :: * -> *)
       (ignored :: [Symbol]) (proxy :: [Symbol] -> *).
(Generic (r f), Generic (r g),
 GHoist (Rep (r f)) (Rep (r g)) f g ignored) =>
proxy ignored -> (forall x. f x -> g x) -> r f -> r g
ghoist' (Proxy '["close"]
forall k (t :: k). Proxy t
Proxy @'["close"])

-- | Runs @hoist@ on the return values each field of @r@
-- with the given natural transformation function; no fields
-- are ignored.
ghoist0
  :: ( Generic (r f)
     , Generic (r g)
     , GHoist (Rep (r f)) (Rep (r g)) f g '[]
     )
  => (forall x. f x -> g x)
  -> r f
  -> r g
ghoist0 :: (forall x. f x -> g x) -> r f -> r g
ghoist0 = Proxy '[] -> (forall x. f x -> g x) -> r f -> r g
forall (r :: (* -> *) -> *) (f :: * -> *) (g :: * -> *)
       (ignored :: [Symbol]) (proxy :: [Symbol] -> *).
(Generic (r f), Generic (r g),
 GHoist (Rep (r f)) (Rep (r g)) f g ignored) =>
proxy ignored -> (forall x. f x -> g x) -> r f -> r g
ghoist' (Proxy '[]
forall k (t :: k). Proxy t
Proxy @'[])

-- | Runs @hoist@ on the return values each field of @r@
-- with the given natural transformation function.
-- A supplied of @ignored@ fields is provided to signal which
-- fields should not be transformed.
ghoist'
  :: ( Generic (r f)
     , Generic (r g)
     , GHoist (Rep (r f)) (Rep (r g)) f g ignored
     )
  => proxy ignored
  -> (forall x. f x -> g x)
  -> r f
  -> r g
ghoist' :: proxy ignored -> (forall x. f x -> g x) -> r f -> r g
ghoist' proxy :: proxy ignored
proxy f :: forall x. f x -> g x
f = Rep (r g) Any -> r g
forall a x. Generic a => Rep a x -> a
to (Rep (r g) Any -> r g) -> (r f -> Rep (r g) Any) -> r f -> r g
forall b c a. (b -> c) -> (a -> b) -> a -> c
. proxy ignored
-> (forall x. f x -> g x) -> Rep (r f) Any -> Rep (r g) Any
forall (i :: * -> *) (o :: * -> *) (f :: * -> *) (g :: * -> *)
       (ignored :: [Symbol]) (proxy :: [Symbol] -> *) p.
GHoist i o f g ignored =>
proxy ignored -> (forall x. f x -> g x) -> i p -> o p
gghoist proxy ignored
proxy forall x. f x -> g x
f (Rep (r f) Any -> Rep (r g) Any)
-> (r f -> Rep (r f) Any) -> r f -> Rep (r g) Any
forall b c a. (b -> c) -> (a -> b) -> a -> c
. r f -> Rep (r f) Any
forall a x. Generic a => a -> Rep a x
from

class GHoist (i :: * -> *) (o :: * -> *) (f :: * -> *) (g :: * -> *) (ignored :: [Symbol]) where
  gghoist :: proxy ignored -> (forall x. f x -> g x) -> i p -> o p

instance (GHoist i o f g ignored) => GHoist (M1 D c i) (M1 D c o) f g ignored where
  gghoist :: proxy ignored -> (forall x. f x -> g x) -> M1 D c i p -> M1 D c o p
gghoist proxy :: proxy ignored
proxy f :: forall x. f x -> g x
f (M1 i :: i p
i) = o p -> M1 D c o p
forall k i (c :: Meta) (f :: k -> *) (p :: k). f p -> M1 i c f p
M1 (proxy ignored -> (forall x. f x -> g x) -> i p -> o p
forall (i :: * -> *) (o :: * -> *) (f :: * -> *) (g :: * -> *)
       (ignored :: [Symbol]) (proxy :: [Symbol] -> *) p.
GHoist i o f g ignored =>
proxy ignored -> (forall x. f x -> g x) -> i p -> o p
gghoist proxy ignored
proxy forall x. f x -> g x
f i p
i)

instance (GHoist i o f g ignored) => GHoist (M1 C c i) (M1 C c o) f g ignored where
  gghoist :: proxy ignored -> (forall x. f x -> g x) -> M1 C c i p -> M1 C c o p
gghoist proxy :: proxy ignored
proxy f :: forall x. f x -> g x
f (M1 i :: i p
i) = o p -> M1 C c o p
forall k i (c :: Meta) (f :: k -> *) (p :: k). f p -> M1 i c f p
M1 (proxy ignored -> (forall x. f x -> g x) -> i p -> o p
forall (i :: * -> *) (o :: * -> *) (f :: * -> *) (g :: * -> *)
       (ignored :: [Symbol]) (proxy :: [Symbol] -> *) p.
GHoist i o f g ignored =>
proxy ignored -> (forall x. f x -> g x) -> i p -> o p
gghoist proxy ignored
proxy forall x. f x -> g x
f i p
i)

instance {-# OVERLAPPING #-}
  ( VerifyIgnored n a ignored
  ) => GHoist
        (M1 S ('MetaSel ('Just n) su ss ds) (K1 R a))
        (M1 S ('MetaSel ('Just n) su ss ds) (K1 R a))
        f g ignored
  where
  gghoist :: proxy ignored
-> (forall x. f x -> g x)
-> M1 S ('MetaSel ('Just n) su ss ds) (K1 R a) p
-> M1 S ('MetaSel ('Just n) su ss ds) (K1 R a) p
gghoist _proxy :: proxy ignored
_proxy _f :: forall x. f x -> g x
_f (M1 i :: K1 R a p
i) = K1 R a p -> M1 S ('MetaSel ('Just n) su ss ds) (K1 R a) p
forall k i (c :: Meta) (f :: k -> *) (p :: k). f p -> M1 i c f p
M1 K1 R a p
i

instance
  ( GHoist (K1 R i) (K1 R o) f g ignored
  , VerifyNotIgnored n i ignored
  ) => GHoist
        (M1 S ('MetaSel ('Just n) su ss ds) (K1 R i))
        (M1 S ('MetaSel ('Just n) su ss ds) (K1 R o))
        f g ignored
  where
  gghoist :: proxy ignored
-> (forall x. f x -> g x)
-> M1 S ('MetaSel ('Just n) su ss ds) (K1 R i) p
-> M1 S ('MetaSel ('Just n) su ss ds) (K1 R o) p
gghoist proxy :: proxy ignored
proxy f :: forall x. f x -> g x
f (M1 i :: K1 R i p
i) = K1 R o p -> M1 S ('MetaSel ('Just n) su ss ds) (K1 R o) p
forall k i (c :: Meta) (f :: k -> *) (p :: k). f p -> M1 i c f p
M1 (proxy ignored -> (forall x. f x -> g x) -> K1 R i p -> K1 R o p
forall (i :: * -> *) (o :: * -> *) (f :: * -> *) (g :: * -> *)
       (ignored :: [Symbol]) (proxy :: [Symbol] -> *) p.
GHoist i o f g ignored =>
proxy ignored -> (forall x. f x -> g x) -> i p -> o p
gghoist proxy ignored
proxy forall x. f x -> g x
f K1 R i p
i)

instance
  ( GHoist i1 o1 f g ignored
  , GHoist i2 o2 f g ignored
  ) => GHoist (i1 :*: i2) (o1 :*: o2) f g ignored
  where
  gghoist :: proxy ignored
-> (forall x. f x -> g x) -> (:*:) i1 i2 p -> (:*:) o1 o2 p
gghoist proxy :: proxy ignored
proxy f :: forall x. f x -> g x
f (i1 :: i1 p
i1 :*: i2 :: i2 p
i2) = proxy ignored -> (forall x. f x -> g x) -> i1 p -> o1 p
forall (i :: * -> *) (o :: * -> *) (f :: * -> *) (g :: * -> *)
       (ignored :: [Symbol]) (proxy :: [Symbol] -> *) p.
GHoist i o f g ignored =>
proxy ignored -> (forall x. f x -> g x) -> i p -> o p
gghoist proxy ignored
proxy forall x. f x -> g x
f i1 p
i1 o1 p -> o2 p -> (:*:) o1 o2 p
forall k (f :: k -> *) (g :: k -> *) (p :: k).
f p -> g p -> (:*:) f g p
:*: proxy ignored -> (forall x. f x -> g x) -> i2 p -> o2 p
forall (i :: * -> *) (o :: * -> *) (f :: * -> *) (g :: * -> *)
       (ignored :: [Symbol]) (proxy :: [Symbol] -> *) p.
GHoist i o f g ignored =>
proxy ignored -> (forall x. f x -> g x) -> i p -> o p
gghoist proxy ignored
proxy forall x. f x -> g x
f i2 p
i2

instance
  ( Monad f
  , IsVariadic vf args (f a)
  , IsVariadic vg args (g a)
  ) => GHoist (K1 R vf) (K1 R vg) f g ignored
  where
  gghoist :: proxy ignored -> (forall x. f x -> g x) -> K1 R vf p -> K1 R vg p
gghoist _proxy :: proxy ignored
_proxy f :: forall x. f x -> g x
f (K1 vf :: vf
vf) = vg -> K1 R vg p
forall k i c (p :: k). c -> K1 i c p
K1 ((forall x. f x -> g x) -> vf -> vg
forall (f :: * -> *) vf (args :: [*]) a vg (g :: * -> *).
(Monad f, IsVariadic vf args (f a), IsVariadic vg args (g a)) =>
(forall x. f x -> g x) -> vf -> vg
vhoist forall x. f x -> g x
f vf
vf)

type VerifyIgnored e a es = VerifyIgnoredGo e a es es

type family VerifyIgnoredGo e a es orig :: Constraint where
  VerifyIgnoredGo x a (x ': xs) orig = ()
  VerifyIgnoredGo y a (x ': xs) orig = VerifyIgnoredGo y a xs orig
  VerifyIgnoredGo x a '[] orig       =
    TypeError
      ( 'Text "Field:"
          ':$$: 'Text "  "
          ':<>: 'Text x
          ':<>: 'Text " :: "
          ':<>: 'ShowType a
          ':$$: 'Text "cannot be ghoist-ed with the supplied "
          ':<>: 'Text "function and was not in the ignored fields list: "
          ':<>: 'ShowType orig
      )

type VerifyNotIgnored e a es = VerifyNotIgnoredGo e a es es

type family VerifyNotIgnoredGo e a es orig :: Constraint where
  VerifyNotIgnoredGo x a (x ': xs) orig =
    TypeError
      ( 'Text "Field:"
          ':$$: 'Text "  "
          ':<>: 'Text x
          ':<>: 'Text " :: "
          ':<>: 'ShowType a
          ':$$: 'Text "must be ghoist-ed but was present in the ignored "
          ':<>: 'Text "fields list: "
          ':<>: 'ShowType orig
      )

  VerifyNotIgnoredGo y a (x ': xs) orig = VerifyNotIgnoredGo y a xs orig
  VerifyNotIgnoredGo x a '[] orig = ()