{-# LANGUAGE AllowAmbiguousTypes, Trustworthy #-}
module Polysemy.Cont
  (-- * Effect
    Cont(..)

    -- * Actions
  , jump
  , subst
  , callCC

    -- * Interpretations
  , runContPure
  , runContM
  , contToFinal

    -- * Experimental Interpretations
  , runContViaFresh

    -- * Unsafe Interpretations
  , runContUnsafe

  -- * Prompt types
  , 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)

-----------------------------------------------------------------------------
-- | Call with current continuation.
-- Executing the provided continuation will abort execution.
--
-- Using the provided continuation
-- will rollback all local effectful state back to the point where
-- 'callCC' was invoked.
--
-- Higher-order effects do not interact with the continuation in any meaningful
-- way; i.e. 'Polysemy.Reader.local' or 'Polysemy.Writer.censor' does not affect
-- it, and 'Polysemy.Error.catch' will fail to catch any of its exceptions.
-- The only exception to this is if you interpret such effects /and/ 'Cont'
-- in terms of the final monad, and the final monad can perform such interactions
-- in a meaningful manner.
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 #-}

-----------------------------------------------------------------------------
-- | Runs a 'Cont' effect by providing 'pure' as the final continuation.
--
-- This is a safe variant of 'runContUnsafe', as this may only be used
-- as the final interpreter before 'run'.
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 #-}

-----------------------------------------------------------------------------
-- | Runs a 'Cont' effect by providing 'pure' as the final continuation.
--
-- This is a safe variant of 'runContUnsafe', as this may only be used
-- as the final interpreter before 'runM'.
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 #-}

-----------------------------------------------------------------------------
-- | Runs a 'Cont' effect in terms of a final 'MonadCont'
--
-- /Beware/: Effects that aren't interpreted in terms of the final monad
-- will have local state semantics in regards to 'Cont' effects
-- interpreted this way. See 'Final'.
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 #-}

-----------------------------------------------------------------------------
-- | A highly experimental 'Cont' interpreter that functions
-- through a combination of 'Error' and 'Fresh'. This may be used safely
-- anywhere in the effect stack.
--
-- 'runContViaFresh' is still under development.
-- You're encouraged to experiment with it, but don't rely on it.
-- For best results, use 'runContViaFresh' as the first interpreter you run,
-- such that all other effects are global in respect to it.
--
-- This interpreter may return 'Nothing' if the control flow becomes
-- split into separate, inconsistent parts,
-- such that backtracking fails when trying to invoke continuations.
-- For example, if you reify a continuation inside an
-- 'async':ed thread, and then have that thread return the reified
-- continuation back to the main thread through an 'await', then
-- 'runContViaFresh' will return 'Nothing' upon executing the continuation
-- in the main thread.
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 #-}

-----------------------------------------------------------------------------
-- | Runs a 'Cont' effect by providing 'pure' as the final continuation.
--
-- __Beware__: This interpreter will invalidate all higher-order effects of any
-- interpreter run after it; i.e. 'Polysemy.Reader.local' and
-- 'Polysemy.Writer.censor' will be no-ops, 'Polysemy.Error.catch' will fail
-- to catch exceptions, and 'Polysemy.Writer.listen' will always return 'mempty'.
--
-- __You should therefore use 'runContUnsafe' only /after/ running all__
-- __interpreters for your higher-order effects.__
--
-- Note that 'Final' is a higher-order effect, and thus 'runContUnsafe' can't
-- safely be used together with 'runFinal'.
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 #-}