{-# LANGUAGE AllowAmbiguousTypes, Trustworthy #-}
module Polysemy.Cont
(
Cont(..)
, jump
, subst
, callCC
, runContPure
, runContM
, contToFinal
, runContViaFresh
, runContUnsafe
, Ref(..)
, ExitRef(..)
, ViaFreshRef
) where
import Data.Void
import Polysemy
import Polysemy.Final
import Polysemy.Cont.Internal
import Polysemy.Error
import Polysemy.Fresh
import Control.Monad.Cont (MonadCont(), ContT(..), runContT)
import qualified Control.Monad.Cont as C (callCC)
callCC :: forall ref r a
. Member (Cont ref) r
=> ((forall b. a -> Sem r b) -> Sem r a)
-> Sem r a
callCC :: ((forall b. a -> Sem r b) -> Sem r a) -> Sem r a
callCC (forall b. a -> Sem r b) -> Sem r a
cc = (ref a -> Sem r a) -> (a -> Sem r a) -> Sem r a
forall (ref :: * -> *) a b (r :: EffectRow).
Member (Cont ref) r =>
(ref a -> Sem r b) -> (a -> Sem r b) -> Sem r b
subst @ref (\ref a
ref -> (forall b. a -> Sem r b) -> Sem r a
cc (ref a -> a -> Sem r b
forall (ref :: * -> *) a b (r :: EffectRow).
Member (Cont ref) r =>
ref a -> a -> Sem r b
jump ref a
ref)) a -> Sem r a
forall (f :: * -> *) a. Applicative f => a -> f a
pure
{-# INLINE callCC #-}
runContPure :: Sem '[Cont (Ref (Sem '[]) a)] a -> Sem '[] a
runContPure :: Sem '[Cont (Ref (Sem '[]) a)] a -> Sem '[] a
runContPure = Sem '[Cont (Ref (Sem '[]) a)] a -> Sem '[] a
forall (r :: EffectRow) a.
Sem (Cont (Ref (Sem r) a) : r) a -> Sem r a
runContUnsafe
{-# INLINE runContPure #-}
runContM :: Sem '[Cont (Ref (Sem '[Embed m]) a), Embed m] a -> Sem '[Embed m] a
runContM :: Sem '[Cont (Ref (Sem '[Embed m]) a), Embed m] a -> Sem '[Embed m] a
runContM = Sem '[Cont (Ref (Sem '[Embed m]) a), Embed m] a -> Sem '[Embed m] a
forall (r :: EffectRow) a.
Sem (Cont (Ref (Sem r) a) : r) a -> Sem r a
runContUnsafe
{-# INLINE runContM #-}
contToFinal :: (Member (Final m) r, MonadCont m)
=> Sem (Cont (ExitRef m) ': r) a
-> Sem r a
contToFinal :: Sem (Cont (ExitRef m) : r) a -> Sem r a
contToFinal = (forall x (rInitial :: EffectRow).
Cont (ExitRef m) (Sem rInitial) x -> Strategic m (Sem rInitial) x)
-> Sem (Cont (ExitRef m) : r) a -> Sem r a
forall (m :: * -> *) (e :: (* -> *) -> * -> *) (r :: EffectRow) a.
Member (Final m) r =>
(forall x (rInitial :: EffectRow).
e (Sem rInitial) x -> Strategic m (Sem rInitial) x)
-> Sem (e : r) a -> Sem r a
interpretFinal ((forall x (rInitial :: EffectRow).
Cont (ExitRef m) (Sem rInitial) x -> Strategic m (Sem rInitial) x)
-> Sem (Cont (ExitRef m) : r) a -> Sem r a)
-> (forall x (rInitial :: EffectRow).
Cont (ExitRef m) (Sem rInitial) x -> Strategic m (Sem rInitial) x)
-> Sem (Cont (ExitRef m) : r) a
-> Sem r a
forall a b. (a -> b) -> a -> b
$ \case
Jump ref a -> m (f x) -> Sem (WithStrategy m f (Sem rInitial)) (m (f x))
forall (f :: * -> *) a. Applicative f => a -> f a
pure (m (f x) -> Sem (WithStrategy m f (Sem rInitial)) (m (f x)))
-> m (f x) -> Sem (WithStrategy m f (Sem rInitial)) (m (f x))
forall a b. (a -> b) -> a -> b
$ ExitRef m a -> a -> m (f x)
forall k (m :: k -> *) a. ExitRef m a -> forall (b :: k). a -> m b
enterExit ExitRef m a
ref a
a
Subst main cb -> do
f (ExitRef m a) -> m (f x)
main' <- (ExitRef m a -> Sem rInitial x)
-> Sem
(WithStrategy m f (Sem rInitial)) (f (ExitRef m a) -> m (f x))
forall a (n :: * -> *) b (m :: * -> *) (f :: * -> *).
(a -> n b) -> Sem (WithStrategy m f n) (f a -> m (f b))
bindS ExitRef m a -> Sem rInitial x
main
f a -> m (f x)
cb' <- (a -> Sem rInitial x)
-> Sem (WithStrategy m f (Sem rInitial)) (f a -> m (f x))
forall a (n :: * -> *) b (m :: * -> *) (f :: * -> *).
(a -> n b) -> Sem (WithStrategy m f n) (f a -> m (f b))
bindS a -> Sem rInitial x
cb
f ()
s <- Sem (WithStrategy m f (Sem rInitial)) (f ())
forall (m :: * -> *) (f :: * -> *) (n :: * -> *).
Sem (WithStrategy m f n) (f ())
getInitialStateS
m (f x) -> Sem (WithStrategy m f (Sem rInitial)) (m (f x))
forall (f :: * -> *) a. Applicative f => a -> f a
pure (m (f x) -> Sem (WithStrategy m f (Sem rInitial)) (m (f x)))
-> m (f x) -> Sem (WithStrategy m f (Sem rInitial)) (m (f x))
forall a b. (a -> b) -> a -> b
$ ((f x -> m Void) -> m (f x)) -> m (f x)
forall (m :: * -> *) a b. MonadCont m => ((a -> m b) -> m a) -> m a
C.callCC (((f x -> m Void) -> m (f x)) -> m (f x))
-> ((f x -> m Void) -> m (f x)) -> m (f x)
forall a b. (a -> b) -> a -> b
$ \f x -> m Void
exit ->
f (ExitRef m a) -> m (f x)
main' ((forall b. a -> m b) -> ExitRef m a
forall k (m :: k -> *) a.
(forall (b :: k). a -> m b) -> ExitRef m a
ExitRef (\a
a -> f a -> m (f x)
cb' (a
a a -> f () -> f a
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ f ()
s) m (f x) -> (f x -> m b) -> m b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= m Void -> m b
forall (f :: * -> *) a. Functor f => f Void -> f a
vacuous (m Void -> m b) -> (f x -> m Void) -> f x -> m b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. f x -> m Void
exit) ExitRef m a -> f () -> f (ExitRef m a)
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ f ()
s)
{-# INLINE contToFinal #-}
runContViaFresh :: forall uniq r a
. (Member (Fresh uniq) r, Eq uniq)
=> Sem (Cont (ViaFreshRef uniq) ': r) a
-> Sem r (Maybe a)
runContViaFresh :: Sem (Cont (ViaFreshRef uniq) : r) a -> Sem r (Maybe a)
runContViaFresh =
let
hush :: Either a a -> Maybe a
hush (Right a
a) = a -> Maybe a
forall a. a -> Maybe a
Just a
a
hush Either a a
_ = Maybe a
forall a. Maybe a
Nothing
in
(Either (uniq, Any) a -> Maybe a)
-> Sem r (Either (uniq, Any) a) -> Sem r (Maybe a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Either (uniq, Any) a -> Maybe a
forall a a. Either a a -> Maybe a
hush
(Sem r (Either (uniq, Any) a) -> Sem r (Maybe a))
-> (Sem (Cont (ViaFreshRef uniq) : r) a
-> Sem r (Either (uniq, Any) a))
-> Sem (Cont (ViaFreshRef uniq) : r) a
-> Sem r (Maybe a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Sem (Error (uniq, Any) : r) a -> Sem r (Either (uniq, Any) a)
forall e (r :: EffectRow) a.
Sem (Error e : r) a -> Sem r (Either e a)
runError
(Sem (Error (uniq, Any) : r) a -> Sem r (Either (uniq, Any) a))
-> (Sem (Cont (ViaFreshRef uniq) : r) a
-> Sem (Error (uniq, Any) : r) a)
-> Sem (Cont (ViaFreshRef uniq) : r) a
-> Sem r (Either (uniq, Any) a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (ContT a (Sem (Error (uniq, Any) : r)) a
-> (a -> Sem (Error (uniq, Any) : r) a)
-> Sem (Error (uniq, Any) : r) a
forall k (r :: k) (m :: k -> *) a. ContT r m a -> (a -> m r) -> m r
`runContT` a -> Sem (Error (uniq, Any) : r) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure)
(ContT a (Sem (Error (uniq, Any) : r)) a
-> Sem (Error (uniq, Any) : r) a)
-> (Sem (Cont (ViaFreshRef uniq) : r) a
-> ContT a (Sem (Error (uniq, Any) : r)) a)
-> Sem (Cont (ViaFreshRef uniq) : r) a
-> Sem (Error (uniq, Any) : r) a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Sem (Cont (ViaFreshRef uniq) : r) a
-> ContT a (Sem (Error (uniq, Any) : r)) a
forall uniq s (r :: EffectRow) a.
(Member (Fresh uniq) r, Eq uniq) =>
Sem (Cont (ViaFreshRef uniq) : r) a
-> ContT s (Sem (Error (uniq, Any) : r)) a
runContViaFreshInC
{-# INLINE runContViaFresh #-}
runContUnsafe :: Sem (Cont (Ref (Sem r) a) ': r) a -> Sem r a
runContUnsafe :: Sem (Cont (Ref (Sem r) a) : r) a -> Sem r a
runContUnsafe = (a -> Sem r a) -> Sem (Cont (Ref (Sem r) a) : r) a -> Sem r a
forall a (r :: EffectRow) s.
(a -> Sem r s) -> Sem (Cont (Ref (Sem r) s) : r) a -> Sem r s
runContWithCUnsafe a -> Sem r a
forall (f :: * -> *) a. Applicative f => a -> f a
pure
{-# INLINE runContUnsafe #-}