{-# LANGUAGE AllowAmbiguousTypes, TemplateHaskell #-}
module Polysemy.Shift.Internal where

import Polysemy
import Polysemy.Internal.Union
import Polysemy.Cont.Internal (Ref(..))
import Control.Monad.Cont (ContT(..))

-----------------------------------------------------------------------------
-- | An effect for delimited continuations, formulated algebraically
-- through a variant of the 'Polysemy.Cont.Jump/'Polysemy.Cont.Subst'
-- formulation of abortive continuations.
--
-- Activating polysemy-plugin is highly recommended when using this effect
-- in order to avoid ambiguous types.
data Shift ref s m a where
  Trap    :: (ref a -> m s) -> Shift ref s m a
  Invoke  :: ref a -> a -> Shift ref s m s
  Abort   :: s   -> Shift ref s m a
  Reset   :: m s -> Shift ref s m s
  Reset'  :: m s -> Shift ref s m (Maybe s)

makeSem_ ''Shift

-----------------------------------------------------------------------------
-- | Reifies the current continuation in the form of a prompt, and passes it to
-- the first argument. Unlike 'subst', control will never return to the current
-- continuation unless the prompt is invoked via 'release'.
trap :: forall ref s a r
     .  Member (Shift ref s) r
     => (ref a -> Sem r s)
     -> Sem r a

-----------------------------------------------------------------------------
-- | Provide an answer to a prompt, jumping to its reified continuation.
-- Unlike 'jump', this will not abort the current continuation, and the
-- reified computation will instead return its final result when finished.
--
-- Any effectful state of effects which have been run before the interpreter for
-- 'Shift' will be embedded in the return value, and therefore the invocation
-- won't have any apparent effects unless these are interpreted in the final
-- monad.
--
-- Any higher-order actions will also not interact with the continuation in any
-- meaningful way; i.e. 'Polysemy.Reader.local' or 'Polysemy.Writer.censor' does
-- not affect it, 'Polysemy.Error.catch' will fail to catch any of its exceptions,
-- and 'Polysemy.Writer.listen' will always return 'mempty'.
--
-- The provided continuation may fail locally in its subcontinuations.
-- It may sometimes become necessary to handle such cases. To do so,
-- use 'reset\'' together with 'release'.
invoke :: forall ref s a r
       .  Member (Shift ref s) r
       => ref a
       -> a
       -> Sem r s


-----------------------------------------------------------------------------
-- | Aborts the current continuation with a result.
abort :: forall ref s a r
      .  Member (Shift ref s) r
      => s
      -> Sem r a

-----------------------------------------------------------------------------
-- | Delimits any continuations and calls to 'abort'.
reset :: forall ref s r
      .  Member (Shift ref s) r
      => Sem r s
      -> Sem r s

-----------------------------------------------------------------------------
-- | Delimits any continuations and calls to 'abort', and detects if
-- any subcontinuation has failed locally.
reset' :: forall ref s r
       .  Member (Shift ref s) r
       => Sem r s
       -> Sem r (Maybe s)

runShiftWeaving :: Monad m
                => (forall x. (x -> m (Maybe s)) -> Sem r x -> m (Maybe s))
                -> Weaving (Shift (Ref m (Maybe s)) s) (Sem r) a
                -> ContT (Maybe s) m a
runShiftWeaving :: (forall x. (x -> m (Maybe s)) -> Sem r x -> m (Maybe s))
-> Weaving (Shift (Ref m (Maybe s)) s) (Sem r) a
-> ContT (Maybe s) m a
runShiftWeaving forall x. (x -> m (Maybe s)) -> Sem r x -> m (Maybe s)
runW (Weaving Shift (Ref m (Maybe s)) s (Sem rInitial) a
e f ()
s forall x. f (Sem rInitial x) -> Sem r (f x)
wv f a -> a
ex forall x. f x -> Maybe x
ins) =
  (a -> a) -> ContT (Maybe s) m a -> ContT (Maybe s) m a
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (f a -> a
ex (f a -> a) -> (a -> f a) -> a -> a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (a -> f () -> f a
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ f ()
s)) (ContT (Maybe s) m a -> ContT (Maybe s) m a)
-> ContT (Maybe s) m a -> ContT (Maybe s) m a
forall a b. (a -> b) -> a -> b
$ ((a -> m (Maybe s)) -> m (Maybe s)) -> ContT (Maybe s) m a
forall k (r :: k) (m :: k -> *) a.
((a -> m r) -> m r) -> ContT r m a
ContT (((a -> m (Maybe s)) -> m (Maybe s)) -> ContT (Maybe s) m a)
-> ((a -> m (Maybe s)) -> m (Maybe s)) -> ContT (Maybe s) m a
forall a b. (a -> b) -> a -> b
$ \a -> m (Maybe s)
c ->
    case Shift (Ref m (Maybe s)) s (Sem rInitial) a
e of
      Trap Ref m (Maybe s) a -> Sem rInitial s
main ->
        (f s -> m (Maybe s)) -> Sem r (f s) -> m (Maybe s)
forall x. (x -> m (Maybe s)) -> Sem r x -> m (Maybe s)
runW (Maybe s -> m (Maybe s)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe s -> m (Maybe s)) -> (f s -> Maybe s) -> f s -> m (Maybe s)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. f s -> Maybe s
forall x. f x -> Maybe x
ins) (Sem r (f s) -> m (Maybe s)) -> Sem r (f s) -> m (Maybe s)
forall a b. (a -> b) -> a -> b
$ f (Sem rInitial s) -> Sem r (f s)
forall x. f (Sem rInitial x) -> Sem r (f x)
wv (Ref m (Maybe s) a -> Sem rInitial s
main ((a -> m (Maybe s)) -> Ref m (Maybe s) a
forall k (m :: k -> *) (s :: k) a. (a -> m s) -> Ref m s a
Ref a -> m (Maybe s)
c) Sem rInitial s -> f () -> f (Sem rInitial s)
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ f ()
s)
      Invoke Ref m (Maybe s) a
ref a
a ->
        Ref m (Maybe s) a -> a -> m (Maybe s)
forall k (m :: k -> *) (s :: k) a. Ref m s a -> a -> m s
runRef Ref m (Maybe s) a
ref a
a m (Maybe s) -> (Maybe s -> m (Maybe s)) -> m (Maybe s)
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= m (Maybe s) -> (a -> m (Maybe s)) -> Maybe a -> m (Maybe s)
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (Maybe s -> m (Maybe s)
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe s
forall a. Maybe a
Nothing) a -> m (Maybe s)
c
      Abort s
t -> Maybe s -> m (Maybe s)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (s -> Maybe s
forall a. a -> Maybe a
Just s
t)
      Reset Sem rInitial s
main ->
        (f s -> m (Maybe s)) -> Sem r (f s) -> m (Maybe s)
forall x. (x -> m (Maybe s)) -> Sem r x -> m (Maybe s)
runW (Maybe s -> m (Maybe s)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe s -> m (Maybe s)) -> (f s -> Maybe s) -> f s -> m (Maybe s)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. f s -> Maybe s
forall x. f x -> Maybe x
ins) (f (Sem rInitial s) -> Sem r (f s)
forall x. f (Sem rInitial x) -> Sem r (f x)
wv (Sem rInitial s
main Sem rInitial s -> f () -> f (Sem rInitial s)
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ f ()
s)) m (Maybe s) -> (Maybe s -> m (Maybe s)) -> m (Maybe s)
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= m (Maybe s) -> (a -> m (Maybe s)) -> Maybe a -> m (Maybe s)
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (Maybe s -> m (Maybe s)
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe s
forall a. Maybe a
Nothing) a -> m (Maybe s)
c
      Reset' Sem rInitial s
main ->
        (f s -> m (Maybe s)) -> Sem r (f s) -> m (Maybe s)
forall x. (x -> m (Maybe s)) -> Sem r x -> m (Maybe s)
runW (Maybe s -> m (Maybe s)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe s -> m (Maybe s)) -> (f s -> Maybe s) -> f s -> m (Maybe s)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. f s -> Maybe s
forall x. f x -> Maybe x
ins) (f (Sem rInitial s) -> Sem r (f s)
forall x. f (Sem rInitial x) -> Sem r (f x)
wv (Sem rInitial s
main Sem rInitial s -> f () -> f (Sem rInitial s)
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ f ()
s)) m (Maybe s) -> (Maybe s -> m (Maybe s)) -> m (Maybe s)
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= a -> m (Maybe s)
Maybe s -> m (Maybe s)
c
{-# INLINE runShiftWeaving #-}