```{-# LANGUAGE DeriveFunctor #-}
module Control.Effect.Carrier.Internal.Stepped where

import Data.Coerce
import Control.Applicative
import Control.Effect.Internal
import Control.Effect.Internal.Utils
import Control.Effect.Internal.Membership
import Control.Effect.Internal.Derive
import Control.Effect.Internal.Union

data FOEff e x where
FOEff :: e q x -> FOEff e x

-- | A constraint that @e@ is first-order.
--
-- This is automatically deduced by the compiler.
class    (forall m n x. Coercible (e m x) (e n x))
=> FirstOrder (e :: Effect)
instance (forall m n x. Coercible (e m x) (e n x))
=> FirstOrder e

-- | A carrier for any __first-order__ effect @e@ that allows for
-- dividing a computation into several steps, where
-- each step is seperated by the use of the effect.
--
-- This can be used to implement coroutines.
newtype SteppedC (e :: Effect) m a = SteppedC {
SteppedC e m a -> FreeT (FOEff e) m a
unSteppedC :: FreeT (FOEff e) m a
}
deriving ( a -> SteppedC e m b -> SteppedC e m a
(a -> b) -> SteppedC e m a -> SteppedC e m b
(forall a b. (a -> b) -> SteppedC e m a -> SteppedC e m b)
-> (forall a b. a -> SteppedC e m b -> SteppedC e m a)
-> Functor (SteppedC e m)
forall a b. a -> SteppedC e m b -> SteppedC e m a
forall a b. (a -> b) -> SteppedC e m a -> SteppedC e m b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
forall (e :: Effect) (m :: * -> *) a b.
a -> SteppedC e m b -> SteppedC e m a
forall (e :: Effect) (m :: * -> *) a b.
(a -> b) -> SteppedC e m a -> SteppedC e m b
<\$ :: a -> SteppedC e m b -> SteppedC e m a
\$c<\$ :: forall (e :: Effect) (m :: * -> *) a b.
a -> SteppedC e m b -> SteppedC e m a
fmap :: (a -> b) -> SteppedC e m a -> SteppedC e m b
\$cfmap :: forall (e :: Effect) (m :: * -> *) a b.
(a -> b) -> SteppedC e m a -> SteppedC e m b
Functor, Functor (SteppedC e m)
a -> SteppedC e m a
Functor (SteppedC e m)
-> (forall a. a -> SteppedC e m a)
-> (forall a b.
SteppedC e m (a -> b) -> SteppedC e m a -> SteppedC e m b)
-> (forall a b c.
(a -> b -> c)
-> SteppedC e m a -> SteppedC e m b -> SteppedC e m c)
-> (forall a b. SteppedC e m a -> SteppedC e m b -> SteppedC e m b)
-> (forall a b. SteppedC e m a -> SteppedC e m b -> SteppedC e m a)
-> Applicative (SteppedC e m)
SteppedC e m a -> SteppedC e m b -> SteppedC e m b
SteppedC e m a -> SteppedC e m b -> SteppedC e m a
SteppedC e m (a -> b) -> SteppedC e m a -> SteppedC e m b
(a -> b -> c) -> SteppedC e m a -> SteppedC e m b -> SteppedC e m c
forall a. a -> SteppedC e m a
forall a b. SteppedC e m a -> SteppedC e m b -> SteppedC e m a
forall a b. SteppedC e m a -> SteppedC e m b -> SteppedC e m b
forall a b.
SteppedC e m (a -> b) -> SteppedC e m a -> SteppedC e m b
forall a b c.
(a -> b -> c) -> SteppedC e m a -> SteppedC e m b -> SteppedC e m c
forall (f :: * -> *).
Functor f
-> (forall a. a -> f a)
-> (forall a b. f (a -> b) -> f a -> f b)
-> (forall a b c. (a -> b -> c) -> f a -> f b -> f c)
-> (forall a b. f a -> f b -> f b)
-> (forall a b. f a -> f b -> f a)
-> Applicative f
forall (e :: Effect) (m :: * -> *). Functor (SteppedC e m)
forall (e :: Effect) (m :: * -> *) a. a -> SteppedC e m a
forall (e :: Effect) (m :: * -> *) a b.
SteppedC e m a -> SteppedC e m b -> SteppedC e m a
forall (e :: Effect) (m :: * -> *) a b.
SteppedC e m a -> SteppedC e m b -> SteppedC e m b
forall (e :: Effect) (m :: * -> *) a b.
SteppedC e m (a -> b) -> SteppedC e m a -> SteppedC e m b
forall (e :: Effect) (m :: * -> *) a b c.
(a -> b -> c) -> SteppedC e m a -> SteppedC e m b -> SteppedC e m c
<* :: SteppedC e m a -> SteppedC e m b -> SteppedC e m a
\$c<* :: forall (e :: Effect) (m :: * -> *) a b.
SteppedC e m a -> SteppedC e m b -> SteppedC e m a
*> :: SteppedC e m a -> SteppedC e m b -> SteppedC e m b
\$c*> :: forall (e :: Effect) (m :: * -> *) a b.
SteppedC e m a -> SteppedC e m b -> SteppedC e m b
liftA2 :: (a -> b -> c) -> SteppedC e m a -> SteppedC e m b -> SteppedC e m c
\$cliftA2 :: forall (e :: Effect) (m :: * -> *) a b c.
(a -> b -> c) -> SteppedC e m a -> SteppedC e m b -> SteppedC e m c
<*> :: SteppedC e m (a -> b) -> SteppedC e m a -> SteppedC e m b
\$c<*> :: forall (e :: Effect) (m :: * -> *) a b.
SteppedC e m (a -> b) -> SteppedC e m a -> SteppedC e m b
pure :: a -> SteppedC e m a
\$cpure :: forall (e :: Effect) (m :: * -> *) a. a -> SteppedC e m a
\$cp1Applicative :: forall (e :: Effect) (m :: * -> *). Functor (SteppedC e m)
Applicative, Applicative (SteppedC e m)
a -> SteppedC e m a
Applicative (SteppedC e m)
-> (forall a b.
SteppedC e m a -> (a -> SteppedC e m b) -> SteppedC e m b)
-> (forall a b. SteppedC e m a -> SteppedC e m b -> SteppedC e m b)
-> (forall a. a -> SteppedC e m a)
SteppedC e m a -> (a -> SteppedC e m b) -> SteppedC e m b
SteppedC e m a -> SteppedC e m b -> SteppedC e m b
forall a. a -> SteppedC e m a
forall a b. SteppedC e m a -> SteppedC e m b -> SteppedC e m b
forall a b.
SteppedC e m a -> (a -> SteppedC e m b) -> SteppedC e m b
forall (m :: * -> *).
Applicative m
-> (forall a b. m a -> (a -> m b) -> m b)
-> (forall a b. m a -> m b -> m b)
-> (forall a. a -> m a)
forall (e :: Effect) (m :: * -> *). Applicative (SteppedC e m)
forall (e :: Effect) (m :: * -> *) a. a -> SteppedC e m a
forall (e :: Effect) (m :: * -> *) a b.
SteppedC e m a -> SteppedC e m b -> SteppedC e m b
forall (e :: Effect) (m :: * -> *) a b.
SteppedC e m a -> (a -> SteppedC e m b) -> SteppedC e m b
return :: a -> SteppedC e m a
\$creturn :: forall (e :: Effect) (m :: * -> *) a. a -> SteppedC e m a
>> :: SteppedC e m a -> SteppedC e m b -> SteppedC e m b
\$c>> :: forall (e :: Effect) (m :: * -> *) a b.
SteppedC e m a -> SteppedC e m b -> SteppedC e m b
>>= :: SteppedC e m a -> (a -> SteppedC e m b) -> SteppedC e m b
\$c>>= :: forall (e :: Effect) (m :: * -> *) a b.
SteppedC e m a -> (a -> SteppedC e m b) -> SteppedC e m b
\$cp1Monad :: forall (e :: Effect) (m :: * -> *). Applicative (SteppedC e m)
-> (forall a. String -> SteppedC e m a) -> MonadFail (SteppedC e m)
String -> SteppedC e m a
forall a. String -> SteppedC e m a
forall (m :: * -> *).
Monad m -> (forall a. String -> m a) -> MonadFail m
forall (e :: Effect) (m :: * -> *).
forall (e :: Effect) (m :: * -> *) a.
String -> SteppedC e m a
fail :: String -> SteppedC e m a
\$cfail :: forall (e :: Effect) (m :: * -> *) a.
String -> SteppedC e m a
\$cp1MonadFail :: forall (e :: Effect) (m :: * -> *).
-> (forall a. IO a -> SteppedC e m a) -> MonadIO (SteppedC e m)
IO a -> SteppedC e m a
forall a. IO a -> SteppedC e m a
forall (m :: * -> *).
Monad m -> (forall a. IO a -> m a) -> MonadIO m
forall (e :: Effect) (m :: * -> *).
forall (e :: Effect) (m :: * -> *) a.
IO a -> SteppedC e m a
liftIO :: IO a -> SteppedC e m a
\$cliftIO :: forall (e :: Effect) (m :: * -> *) a.
IO a -> SteppedC e m a
\$cp1MonadIO :: forall (e :: Effect) (m :: * -> *).
e -> SteppedC e m a
-> (forall e a. Exception e => e -> SteppedC e m a)
forall e a. Exception e => e -> SteppedC e m a
forall (m :: * -> *).
Monad m -> (forall e a. Exception e => e -> m a) -> MonadThrow m
forall (e :: Effect) (m :: * -> *).
forall (e :: Effect) (m :: * -> *) e a.
e -> SteppedC e m a
throwM :: e -> SteppedC e m a
\$cthrowM :: forall (e :: Effect) (m :: * -> *) e a.
e -> SteppedC e m a
\$cp1MonadThrow :: forall (e :: Effect) (m :: * -> *).
-> (forall e a.
Exception e =>
SteppedC e m a -> (e -> SteppedC e m a) -> SteppedC e m a)
SteppedC e m a -> (e -> SteppedC e m a) -> SteppedC e m a
forall e a.
Exception e =>
SteppedC e m a -> (e -> SteppedC e m a) -> SteppedC e m a
forall (m :: * -> *).
-> (forall e a. Exception e => m a -> (e -> m a) -> m a)
forall (e :: Effect) (m :: * -> *).
forall (e :: Effect) (m :: * -> *) e a.
SteppedC e m a -> (e -> SteppedC e m a) -> SteppedC e m a
catch :: SteppedC e m a -> (e -> SteppedC e m a) -> SteppedC e m a
\$ccatch :: forall (e :: Effect) (m :: * -> *) e a.
SteppedC e m a -> (e -> SteppedC e m a) -> SteppedC e m a
\$cp1MonadCatch :: forall (e :: Effect) (m :: * -> *).
)
deriving m a -> SteppedC e m a
(forall (m :: * -> *) a. Monad m => m a -> SteppedC e m a)
forall (m :: * -> *) a. Monad m => m a -> SteppedC e m a
forall (t :: Effect).
(forall (m :: * -> *) a. Monad m => m a -> t m a) -> MonadTrans t
forall (e :: Effect) (m :: * -> *) a.
m a -> SteppedC e m a
lift :: m a -> SteppedC e m a
\$clift :: forall (e :: Effect) (m :: * -> *) a.
m a -> SteppedC e m a

sendStepped :: e q a -> SteppedC e m a
sendStepped :: e q a -> SteppedC e m a
sendStepped = FreeT (FOEff e) m a -> SteppedC e m a
forall (e :: Effect) (m :: * -> *) a.
FreeT (FOEff e) m a -> SteppedC e m a
SteppedC (FreeT (FOEff e) m a -> SteppedC e m a)
-> (e q a -> FreeT (FOEff e) m a) -> e q a -> SteppedC e m a
forall c b a. Coercible c b => (b -> c) -> (a -> b) -> a -> c
#. FOEff e a -> FreeT (FOEff e) m a
forall (f :: * -> *) a (m :: * -> *). f a -> FreeT f m a
liftF (FOEff e a -> FreeT (FOEff e) m a)
-> (e q a -> FOEff e a) -> e q a -> FreeT (FOEff e) m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. e q a -> FOEff e a
forall k k (e :: k -> k -> *) (q :: k) (x :: k). e q x -> FOEff e x
FOEff
{-# INLINE sendStepped #-}

instance ( Threads (FreeT (FOEff e)) (Prims m)
, Carrier m
)
=> Carrier (SteppedC e m) where
type Derivs (SteppedC e m) = e ': Derivs m
type Prims  (SteppedC e m) = Prims m

algPrims :: Algebra' (Prims (SteppedC e m)) (SteppedC e m) a
algPrims = (Union (Prims m) (FreeT (FOEff e) m) a -> FreeT (FOEff e) m a)
-> Algebra' (Prims m) (SteppedC e m) a
coerce (Algebra (Prims m) m -> Algebra (Prims m) (FreeT (FOEff e) m)
forall (t :: Effect) (p :: [Effect]) (m :: * -> *).
Algebra p m -> Algebra p (t m)
thread @(FreeT (FOEff e)) (Carrier m => Algebra (Prims m) m
forall (m :: * -> *) a. Carrier m => Algebra' (Prims m) m a
algPrims @m))
{-# INLINEABLE algPrims #-}

reformulate :: Reformulation'
(Derivs (SteppedC e m)) (Prims (SteppedC e m)) (SteppedC e m) z a
reformulate forall x. SteppedC e m x -> z x
n Algebra (Prims (SteppedC e m)) z
alg = Algebra' (Derivs m) z a
-> (forall (z :: * -> *). Coercible z z => e z a -> z a)
-> Algebra' (e : Derivs m) z a
forall (e :: Effect) (r :: [Effect]) (m :: * -> *) a.
Algebra' r m a
-> (forall (z :: * -> *). Coercible z m => e z a -> m a)
-> Algebra' (e : r) m a
powerAlg' (Reformulation' (Derivs m) (Prims m) m z a
forall (m :: * -> *) (z :: * -> *) a.
Reformulation' (Derivs m) (Prims m) m z a
reformulate (SteppedC e m x -> z x
forall x. SteppedC e m x -> z x
n (SteppedC e m x -> z x) -> (m x -> SteppedC e m x) -> m x -> z x
forall b c a. (b -> c) -> (a -> b) -> a -> c
. m x -> SteppedC e m x
forall (t :: Effect) (m :: * -> *) a.
m a -> t m a
lift) forall x. Union (Prims m) z x -> z x
Algebra (Prims (SteppedC e m)) z
alg) (SteppedC e m a -> z a
forall x. SteppedC e m x -> z x
n (SteppedC e m a -> z a)
-> (e z a -> SteppedC e m a) -> e z a -> z a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. e z a -> SteppedC e m a
forall (e :: Effect) (q :: * -> *) a (m :: * -> *).
e q a -> SteppedC e m a
sendStepped)
{-# INLINEABLE reformulate #-}

-- | A stack of continuations of @m@ that eventually produces a result of type @a@.
-- Each continuation is seperated by the use of the effect @e@.
data Steps (e :: Effect) m a where
Done :: a -> Steps e m a
More :: e q x -> (x -> m (Steps e m a)) -> Steps e m a

deriving instance Functor m => Functor (Steps e m)

instance Functor m => Applicative (Steps e m) where
pure :: a -> Steps e m a
pure = a -> Steps e m a
forall a (e :: Effect) (m :: * -> *). a -> Steps e m a
Done
{-# INLINE pure #-}

liftA2 :: (a -> b -> c) -> Steps e m a -> Steps e m b -> Steps e m c
liftA2 a -> b -> c
f (Done a
a) Steps e m b
fb = (b -> c) -> Steps e m b -> Steps e m c
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (a -> b -> c
f a
a) Steps e m b
fb
liftA2 a -> b -> c
f (More e q x
e x -> m (Steps e m a)
c) Steps e m b
fb = e q x -> (x -> m (Steps e m c)) -> Steps e m c
forall (e :: Effect) (q :: * -> *) x (m :: * -> *) a.
e q x -> (x -> m (Steps e m a)) -> Steps e m a
More e q x
e ((Steps e m a -> Steps e m c) -> m (Steps e m a) -> m (Steps e m c)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\Steps e m a
fa -> (a -> b -> c) -> Steps e m a -> Steps e m b -> Steps e m c
forall (f :: * -> *) a b c.
Applicative f =>
(a -> b -> c) -> f a -> f b -> f c
liftA2 a -> b -> c
f Steps e m a
fa Steps e m b
fb) (m (Steps e m a) -> m (Steps e m c))
-> (x -> m (Steps e m a)) -> x -> m (Steps e m c)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. x -> m (Steps e m a)
c)

instance Functor m => Monad (Steps e m) where
Done a
a >>= :: Steps e m a -> (a -> Steps e m b) -> Steps e m b
>>= a -> Steps e m b
f = a -> Steps e m b
f a
a
More e q x
e x -> m (Steps e m a)
c >>= a -> Steps e m b
f = e q x -> (x -> m (Steps e m b)) -> Steps e m b
forall (e :: Effect) (q :: * -> *) x (m :: * -> *) a.
e q x -> (x -> m (Steps e m a)) -> Steps e m a
More e q x
e ((Steps e m a -> Steps e m b) -> m (Steps e m a) -> m (Steps e m b)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Steps e m a -> (a -> Steps e m b) -> Steps e m b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= a -> Steps e m b
f) (m (Steps e m a) -> m (Steps e m b))
-> (x -> m (Steps e m a)) -> x -> m (Steps e m b)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. x -> m (Steps e m a)
c)

-- | Run the __first-order__ effect @e@ by breaking the computation using it
-- into steps, where each step is seperated by the use of an action of @e@.
steps :: forall e m a p
. ( Carrier m
)
=> SteppedC e m a -> m (Steps e m a)
steps :: SteppedC e m a -> m (Steps e m a)
steps =
(a -> Steps e m a)
-> (forall x.
(x -> m (Steps e m a)) -> FOEff e x -> m (Steps e m a))
-> FreeT (FOEff e) m a
-> m (Steps e m a)
forall (m :: * -> *) a b (f :: * -> *).
(a -> b)
-> (forall x. (x -> m b) -> f x -> m b) -> FreeT f m a -> m b
foldFreeT
a -> Steps e m a
forall a (e :: Effect) (m :: * -> *). a -> Steps e m a
Done
(\x -> m (Steps e m a)
c (FOEff e) -> Steps e m a -> m (Steps e m a)
forall (m :: * -> *) a. Monad m => a -> m a
return (e q x -> (x -> m (Steps e m a)) -> Steps e m a
forall (e :: Effect) (q :: * -> *) x (m :: * -> *) a.
e q x -> (x -> m (Steps e m a)) -> Steps e m a
More e q x
e x -> m (Steps e m a)
c))
(FreeT (FOEff e) m a -> m (Steps e m a))
-> (SteppedC e m a -> FreeT (FOEff e) m a)
-> SteppedC e m a
-> m (Steps e m a)
forall b a c. Coercible b a => (b -> c) -> (a -> b) -> a -> c
.# SteppedC e m a -> FreeT (FOEff e) m a
forall (e :: Effect) (m :: * -> *) a.
SteppedC e m a -> FreeT (FOEff e) m a
unSteppedC
{-# INLINE steps #-}

liftSteps :: (MonadTrans t, Monad m) => Steps e m a -> Steps e (t m) a
liftSteps :: Steps e m a -> Steps e (t m) a
liftSteps (Done a
a) = a -> Steps e (t m) a
forall a (e :: Effect) (m :: * -> *). a -> Steps e m a
Done a
a
liftSteps (More e q x
e x -> m (Steps e m a)
c) = e q x -> (x -> t m (Steps e (t m) a)) -> Steps e (t m) a
forall (e :: Effect) (q :: * -> *) x (m :: * -> *) a.
e q x -> (x -> m (Steps e m a)) -> Steps e m a
More e q x
e (m (Steps e (t m) a) -> t m (Steps e (t m) a)
forall (t :: Effect) (m :: * -> *) a.
m a -> t m a
lift (m (Steps e (t m) a) -> t m (Steps e (t m) a))
-> (x -> m (Steps e (t m) a)) -> x -> t m (Steps e (t m) a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Steps e m a -> Steps e (t m) a)
-> m (Steps e m a) -> m (Steps e (t m) a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Steps e m a -> Steps e (t m) a
forall (t :: Effect) (m :: * -> *) (e :: Effect) a.
Steps e m a -> Steps e (t m) a
liftSteps (m (Steps e m a) -> m (Steps e (t m) a))
-> (x -> m (Steps e m a)) -> x -> m (Steps e (t m) a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. x -> m (Steps e m a)
c)

-- | Execute all the steps of a computation.
unsteps :: forall e m a
. ( FirstOrder e
, Member e (Derivs m)
, Carrier m
)
=> Steps e m a -> m a
unsteps :: Steps e m a -> m a
unsteps (Done a
a)   = a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return a
a
unsteps (More e q x
e x -> m (Steps e m a)
c) = e m x -> m x
forall (e :: Effect) (m :: * -> *) a.
(Member e (Derivs m), Carrier m) =>
e m a -> m a
send @e (e q x -> e m x
coerce e q x
e) m x -> (x -> m (Steps e m a)) -> m (Steps e m a)
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= x -> m (Steps e m a)
c m (Steps e m a) -> (Steps e m a -> m a) -> m a
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Steps e m a -> m a
forall (e :: Effect) (m :: * -> *) a.
(FirstOrder e, Member e (Derivs m), Carrier m) =>
Steps e m a -> m a
unsteps

-- | 'SteppedThreads' accepts the following primitive effects:
--
-- * 'Control.Effect.Regional.Regional' @s@
-- * 'Control.Effect.Optional.Optional' @s@ (when @s@ is a functor)
-- * 'Control.Effect.Type.Unravel.Unravel' @p@
-- * 'Control.Effect.Type.ListenPrim.ListenPrim' @s@ (when @s@ is a 'Monoid')