{-# LANGUAGE ExistentialQuantification #-}
{-# LANGUAGE RankNTypes #-}
module Control.Effect.Lift.Internal
( Lift(..)
) where

import Control.Effect.Class
import Data.Functor.Compose

-- | @since 1.0.0.0
data Lift sig m k
  = forall a . LiftWith
    (forall ctx . Functor ctx => ctx () -> (forall a . ctx (m a) -> sig (ctx a)) -> sig (ctx a))
    (a -> m k)

instance Functor m => Functor (Lift sig m) where
  fmap :: (a -> b) -> Lift sig m a -> Lift sig m b
fmap f :: a -> b
f (LiftWith with :: forall (ctx :: * -> *).
Functor ctx =>
ctx () -> (forall a. ctx (m a) -> sig (ctx a)) -> sig (ctx a)
with k :: a -> m a
k) = (forall (ctx :: * -> *).
 Functor ctx =>
 ctx () -> (forall a. ctx (m a) -> sig (ctx a)) -> sig (ctx a))
-> (a -> m b) -> Lift sig m b
forall (sig :: * -> *) (m :: * -> *) k a.
(forall (ctx :: * -> *).
 Functor ctx =>
 ctx () -> (forall a. ctx (m a) -> sig (ctx a)) -> sig (ctx a))
-> (a -> m k) -> Lift sig m k
LiftWith forall (ctx :: * -> *).
Functor ctx =>
ctx () -> (forall a. ctx (m a) -> sig (ctx a)) -> sig (ctx a)
with ((a -> b) -> m a -> m b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap a -> b
f (m a -> m b) -> (a -> m a) -> a -> m b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> m a
k)

instance HFunctor (Lift sig) where
  hmap :: (forall x. m x -> n x) -> Lift sig m a -> Lift sig n a
hmap f :: forall x. m x -> n x
f (LiftWith go :: forall (ctx :: * -> *).
Functor ctx =>
ctx () -> (forall a. ctx (m a) -> sig (ctx a)) -> sig (ctx a)
go k :: a -> m a
k) = (forall (ctx :: * -> *).
 Functor ctx =>
 ctx () -> (forall a. ctx (n a) -> sig (ctx a)) -> sig (ctx a))
-> (a -> n a) -> Lift sig n a
forall (sig :: * -> *) (m :: * -> *) k a.
(forall (ctx :: * -> *).
 Functor ctx =>
 ctx () -> (forall a. ctx (m a) -> sig (ctx a)) -> sig (ctx a))
-> (a -> m k) -> Lift sig m k
LiftWith (\c :: ctx ()
c lift :: forall a. ctx (n a) -> sig (ctx a)
lift -> ctx () -> (forall a. ctx (m a) -> sig (ctx a)) -> sig (ctx a)
forall (ctx :: * -> *).
Functor ctx =>
ctx () -> (forall a. ctx (m a) -> sig (ctx a)) -> sig (ctx a)
go ctx ()
c (ctx (n a) -> sig (ctx a)
forall a. ctx (n a) -> sig (ctx a)
lift (ctx (n a) -> sig (ctx a))
-> (ctx (m a) -> ctx (n a)) -> ctx (m a) -> sig (ctx a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (m a -> n a) -> ctx (m a) -> ctx (n a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap m a -> n a
forall x. m x -> n x
f)) (m a -> n a
forall x. m x -> n x
f (m a -> n a) -> (a -> m a) -> a -> n a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> m a
k)

instance Functor sig => Effect (Lift sig) where
  thread :: ctx ()
-> (forall x. ctx (m x) -> n (ctx x))
-> Lift sig m a
-> Lift sig n (ctx a)
thread ctx :: ctx ()
ctx dst :: forall x. ctx (m x) -> n (ctx x)
dst (LiftWith with :: forall (ctx :: * -> *).
Functor ctx =>
ctx () -> (forall a. ctx (m a) -> sig (ctx a)) -> sig (ctx a)
with k :: a -> m a
k) = (forall (ctx :: * -> *).
 Functor ctx =>
 ctx ()
 -> (forall a. ctx (n a) -> sig (ctx a)) -> sig (ctx (ctx a)))
-> (ctx a -> n (ctx a)) -> Lift sig n (ctx a)
forall (sig :: * -> *) (m :: * -> *) k a.
(forall (ctx :: * -> *).
 Functor ctx =>
 ctx () -> (forall a. ctx (m a) -> sig (ctx a)) -> sig (ctx a))
-> (a -> m k) -> Lift sig m k
LiftWith
    (\ ctx' :: ctx ()
ctx' dst' :: forall a. ctx (n a) -> sig (ctx a)
dst' -> Compose ctx ctx a -> ctx (ctx a)
forall k1 (f :: k1 -> *) k2 (g :: k2 -> k1) (a :: k2).
Compose f g a -> f (g a)
getCompose (Compose ctx ctx a -> ctx (ctx a))
-> sig (Compose ctx ctx a) -> sig (ctx (ctx a))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Compose ctx ctx ()
-> (forall a. Compose ctx ctx (m a) -> sig (Compose ctx ctx a))
-> sig (Compose ctx ctx a)
forall (ctx :: * -> *).
Functor ctx =>
ctx () -> (forall a. ctx (m a) -> sig (ctx a)) -> sig (ctx a)
with (ctx (ctx ()) -> Compose ctx ctx ()
forall k k1 (f :: k -> *) (g :: k1 -> k) (a :: k1).
f (g a) -> Compose f g a
Compose (ctx ()
ctx ctx () -> ctx () -> ctx (ctx ())
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ ctx ()
ctx')) ((ctx (ctx a) -> Compose ctx ctx a)
-> sig (ctx (ctx a)) -> sig (Compose ctx ctx a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ctx (ctx a) -> Compose ctx ctx a
forall k k1 (f :: k -> *) (g :: k1 -> k) (a :: k1).
f (g a) -> Compose f g a
Compose (sig (ctx (ctx a)) -> sig (Compose ctx ctx a))
-> (Compose ctx ctx (m a) -> sig (ctx (ctx a)))
-> Compose ctx ctx (m a)
-> sig (Compose ctx ctx a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ctx (n (ctx a)) -> sig (ctx (ctx a))
forall a. ctx (n a) -> sig (ctx a)
dst' (ctx (n (ctx a)) -> sig (ctx (ctx a)))
-> (Compose ctx ctx (m a) -> ctx (n (ctx a)))
-> Compose ctx ctx (m a)
-> sig (ctx (ctx a))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (ctx (m a) -> n (ctx a)) -> ctx (ctx (m a)) -> ctx (n (ctx a))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ctx (m a) -> n (ctx a)
forall x. ctx (m x) -> n (ctx x)
dst (ctx (ctx (m a)) -> ctx (n (ctx a)))
-> (Compose ctx ctx (m a) -> ctx (ctx (m a)))
-> Compose ctx ctx (m a)
-> ctx (n (ctx a))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Compose ctx ctx (m a) -> ctx (ctx (m a))
forall k1 (f :: k1 -> *) k2 (g :: k2 -> k1) (a :: k2).
Compose f g a -> f (g a)
getCompose))
    (ctx (m a) -> n (ctx a)
forall x. ctx (m x) -> n (ctx x)
dst (ctx (m a) -> n (ctx a))
-> (ctx a -> ctx (m a)) -> ctx a -> n (ctx a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (a -> m a) -> ctx a -> ctx (m a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap a -> m a
k)