{-# LANGUAGE TemplateHaskell #-}
module Control.Effect.Cont
(
Cont'(..)
, Cont
, callCC
, runCont'
, runCont
, evalCont'
, evalCont
, 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'
makeTagger ''Cont'
instance {-# OVERLAPPABLE #-} Control (Cont' tag) t m => Cont' tag (Via eff t m) where
callCC' :: ((a -> Via eff t m b) -> Via eff t m a) -> Via eff t m a
callCC' f :: (a -> Via eff t m b) -> Via eff t m a
f =
(Run (Via eff t) -> m (StT t a)) -> Via eff t m (StT t a)
forall (t :: Transformer) (m :: * -> *) a.
(MonadTransControl t, Monad m) =>
(Run t -> m a) -> t m a
liftWith
( \run :: Run (Via eff 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
$ \c :: StT t a -> m b
c -> Via eff t m a -> m (StT t a)
Run (Via eff t)
run (Via eff t m a -> m (StT t a))
-> ((a -> Via eff t m b) -> Via eff t m a)
-> (a -> Via eff t m b)
-> m (StT t a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (a -> Via eff t m b) -> Via eff t m a
f ((a -> Via eff t m b) -> m (StT t a))
-> (a -> Via eff t m b) -> m (StT t a)
forall a b. (a -> b) -> a -> b
$
\a :: a
a -> m b -> Via eff t m b
forall (t :: Transformer) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (Via eff t m a -> m (StT (Via eff t) a)
Run (Via eff t)
run (a -> Via eff 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)
)
Via eff t m (StT t a)
-> (StT t a -> Via eff t m a) -> Via eff t m a
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= m (StT t a) -> Via eff t m a
forall (t :: Transformer) (m :: * -> *) a.
(MonadTransControl t, Monad m) =>
m (StT t a) -> t m a
restoreT (m (StT t a) -> Via eff t m a)
-> (StT t a -> m (StT t a)) -> StT t a -> Via eff 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' #-}
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' f :: 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 (eff :: Effect) (t :: Transformer) (m :: * -> *) a.
Via eff t m a -> t m a
runVia
{-# INLINE runCont' #-}
runCont :: (a -> m r) -> (Cont `Via` C.ContT r) m a -> m r
runCont :: (a -> m r) -> Via (Cont' G) (ContT r) m a -> m r
runCont = forall k (tag :: k) r (m :: * -> *) a.
(a -> m r) -> Via (Cont' tag) (ContT r) m a -> m r
forall r (m :: * -> *) a.
(a -> m r) -> Via (Cont' G) (ContT r) m a -> m r
runCont' @G
{-# INLINE runCont #-}
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' #-}
evalCont :: Applicative m => (Cont `Via` C.ContT r) m r -> m r
evalCont :: Via (Cont' G) (ContT r) m r -> m r
evalCont = forall k (tag :: k) r (m :: * -> *).
Applicative m =>
Via (Cont' tag) (ContT r) m r -> m r
forall r (m :: * -> *).
Applicative m =>
Via (Cont' G) (ContT r) m r -> m r
evalCont' @G
{-# INLINE evalCont #-}