{-# LANGUAGE TemplateHaskell #-}
module Control.Effect.Cont
(
Cont'(..)
, Cont
, callCC
, evalCont'
, evalCont
, runCont'
, runCont
, tagCont'
, retagCont'
, untagCont'
) where
import qualified Control.Monad.Trans.Cont as C
import Control.Effect.Machinery
class Monad m => Cont' tag m where
callCC' :: ((a -> m b) -> m a) -> m a
makeHandler ''Cont'
makeFinder ''Cont'
makeTagger ''Cont'
instance Control '[] (Cont' tag) t m => Cont' tag (EachVia '[] t m) where
callCC' :: ((a -> EachVia '[] t m b) -> EachVia '[] t m a)
-> EachVia '[] t m a
callCC' (a -> EachVia '[] t m b) -> EachVia '[] t m a
f =
(Run (EachVia '[] t) -> m (StT t a)) -> EachVia '[] t m (StT t a)
forall (t :: Transformer) (m :: * -> *) a.
(MonadTransControl t, Monad m) =>
(Run t -> m a) -> t m a
liftWith
( \Run (EachVia '[] t)
run -> forall k (tag :: k) (m :: * -> *) a b.
Cont' tag m =>
((a -> m b) -> m a) -> m a
forall (m :: * -> *) a b. Cont' tag m => ((a -> m b) -> m a) -> m a
callCC' @tag (((StT t a -> m b) -> m (StT t a)) -> m (StT t a))
-> ((StT t a -> m b) -> m (StT t a)) -> m (StT t a)
forall a b. (a -> b) -> a -> b
$ \StT t a -> m b
c -> EachVia '[] t m a -> m (StT t a)
Run (EachVia '[] t)
run (EachVia '[] t m a -> m (StT t a))
-> ((a -> EachVia '[] t m b) -> EachVia '[] t m a)
-> (a -> EachVia '[] t m b)
-> m (StT t a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (a -> EachVia '[] t m b) -> EachVia '[] t m a
f ((a -> EachVia '[] t m b) -> m (StT t a))
-> (a -> EachVia '[] t m b) -> m (StT t a)
forall a b. (a -> b) -> a -> b
$
\a
a -> m b -> EachVia '[] t m b
forall (t :: Transformer) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (EachVia '[] t m a -> m (StT (EachVia '[] t) a)
Run (EachVia '[] t)
run (a -> EachVia '[] t m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure a
a) m (StT t a) -> (StT t a -> m b) -> m b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= StT t a -> m b
c)
)
EachVia '[] t m (StT t a)
-> (StT t a -> EachVia '[] t m a) -> EachVia '[] t m a
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= m (StT t a) -> EachVia '[] t m a
forall (t :: Transformer) (m :: * -> *) a.
(MonadTransControl t, Monad m) =>
m (StT t a) -> t m a
restoreT (m (StT t a) -> EachVia '[] t m a)
-> (StT t a -> m (StT t a)) -> StT t a -> EachVia '[] t m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. StT t a -> m (StT t a)
forall (f :: * -> *) a. Applicative f => a -> f a
pure
{-# INLINEABLE callCC' #-}
instance Cont' tag (C.ContT r m) where
callCC' :: ((a -> ContT r m b) -> ContT r m a) -> ContT r m a
callCC' = ((a -> ContT r m b) -> ContT r m a) -> ContT r m a
forall k a (r :: k) (m :: k -> *) b.
((a -> ContT r m b) -> ContT r m a) -> ContT r m a
C.callCC
{-# INLINE callCC' #-}
evalCont' :: forall tag r m. Applicative m => (Cont' tag `Via` C.ContT r) m r -> m r
evalCont' :: Via (Cont' tag) (ContT r) m r -> m r
evalCont' = (r -> m r) -> Via (Cont' tag) (ContT r) m r -> m r
forall k (tag :: k) r (m :: * -> *) a.
(a -> m r) -> Via (Cont' tag) (ContT r) m a -> m r
runCont' r -> m r
forall (f :: * -> *) a. Applicative f => a -> f a
pure
{-# INLINE evalCont' #-}
runCont' :: forall tag r m a. (a -> m r) -> (Cont' tag `Via` C.ContT r) m a -> m r
runCont' :: (a -> m r) -> Via (Cont' tag) (ContT r) m a -> m r
runCont' a -> m r
f = (ContT r m a -> (a -> m r) -> m r)
-> (a -> m r) -> ContT r m a -> m r
forall a b c. (a -> b -> c) -> b -> a -> c
flip ContT r m a -> (a -> m r) -> m r
forall k (r :: k) (m :: k -> *) a. ContT r m a -> (a -> m r) -> m r
C.runContT a -> m r
f (ContT r m a -> m r)
-> (Via (Cont' tag) (ContT r) m a -> ContT r m a)
-> Via (Cont' tag) (ContT r) m a
-> m r
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Via (Cont' tag) (ContT r) m a -> ContT r m a
forall (effs :: [(* -> *) -> Constraint]) (t :: Transformer)
(m :: * -> *) a.
EachVia effs t m a -> t m a
runVia
{-# INLINE runCont' #-}
makeUntagged ['evalCont']
makeUntagged ['runCont']