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

    -- * Actions
  , reify
  , reflect
  , delimit
  , delimit'
  , capture

    -- * Interpretations
  , runCapture
  , runCaptureWithC

  -- * Prompt types
  , Ref(..)
  ) where

import Control.Monad
import Control.Monad.Cont (ContT(..))

import Polysemy
import Polysemy.Internal
import Polysemy.Internal.Union

import Polysemy.Cont.Internal (Ref(..))

-----------------------------------------------------------------------------
-- | A less powerful variant of 'Polysemy.Shift.Shift' that may always be
-- interpreted safely. Unlike 'Polysemy.Shift.Shift',
-- continuations can't leave the scope in which they are provided.
--
-- __Note__: Any computation used in a higher-order effect will
-- be delimited.
--
-- Activating polysemy-plugin is highly recommended when using this effect
-- in order to avoid ambiguous types.
data Capture ref m a where
  Reify    :: (forall s. ref s a -> m s) -> Capture ref m a
  Reflect  :: ref s a -> a -> Capture ref m s
  Delimit  :: m a -> Capture ref m a
  Delimit' :: m a -> Capture ref m (Maybe a)

makeSem_ ''Capture

-----------------------------------------------------------------------------
-- | Reifies the current continuation in the form of a prompt, and passes it to
-- the first argument.
reify :: forall ref a r
      .  Member (Capture ref) r
      => (forall s. ref s a -> Sem r s)
      -> Sem r a

-----------------------------------------------------------------------------
-- | Provide an answer to a prompt, jumping to its reified continuation.
-- This will not abort the current continuation, and the
-- reified computation will return its final result when finished.
--
-- The provided continuation may fail locally in its subcontinuations.
-- It may sometimes become necessary to handle such cases. To do so,
-- use 'delimit'' together with 'reflect' (the reified continuation
-- is already delimited).
reflect :: forall ref s a r
        .  Member (Capture ref) r
        => ref s a
        -> a
        -> Sem r s

-----------------------------------------------------------------------------
-- | Delimits any continuations
delimit :: forall ref a r
        .  Member (Capture ref) r
        => Sem r a
        -> Sem r a

-----------------------------------------------------------------------------
-- | Delimits any continuations, and detects if any subcontinuation
-- has failed locally.
delimit' :: forall ref a r
         .  Member (Capture ref) r
         => Sem r a
         -> Sem r (Maybe a)

-----------------------------------------------------------------------------
-- | A restricted version of 'Polysemy.Shift.shift'.
-- Executing the provided continuation will not abort execution.
--
-- The provided continuation may fail locally in its subcontinuations.
-- It may sometimes become necessary to handle such cases, in
-- which case such failure may be detected by using 'delimit'' together
-- with the provided continuation (the provided continuation
-- is already delimited).
capture :: forall ref r a
         . Member (Capture ref) r
        => (forall s. (a -> Sem r s) -> Sem r s)
        -> Sem r a
capture :: (forall s. (a -> Sem r s) -> Sem r s) -> Sem r a
capture forall s. (a -> Sem r s) -> Sem r s
cc = (forall s. ref s a -> Sem r s) -> Sem r a
forall (ref :: * -> * -> *) a (r :: EffectRow).
Member (Capture ref) r =>
(forall s. ref s a -> Sem r s) -> Sem r a
reify @ref (\ref s a
ref -> (a -> Sem r s) -> Sem r s
forall s. (a -> Sem r s) -> Sem r s
cc (ref s a -> a -> Sem r s
forall (ref :: * -> * -> *) s a (r :: EffectRow).
Member (Capture ref) r =>
ref s a -> a -> Sem r s
reflect ref s a
ref))
{-# INLINE capture #-}

-----------------------------------------------------------------------------
-- | Runs a 'Capture' effect by providing @'pure' '.' 'Just'@ as the final
-- continuation.
--
-- The final return type is wrapped in a 'Maybe' due to the fact that
-- any continuation may fail locally.
runCapture :: Sem (Capture (Ref (Sem r))': r) a -> Sem r (Maybe a)
runCapture :: Sem (Capture (Ref (Sem r)) : r) a -> Sem r (Maybe a)
runCapture = (a -> Sem r (Maybe a))
-> Sem (Capture (Ref (Sem r)) : r) a -> Sem r (Maybe a)
forall a (r :: EffectRow) s.
(a -> Sem r (Maybe s))
-> Sem (Capture (Ref (Sem r)) : r) a -> Sem r (Maybe s)
runCaptureWithC (Maybe a -> Sem r (Maybe a)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe a -> Sem r (Maybe a))
-> (a -> Maybe a) -> a -> Sem r (Maybe a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> Maybe a
forall a. a -> Maybe a
Just)
{-# INLINE runCapture #-}

-----------------------------------------------------------------------------
-- | Runs a 'Capture' effect by explicitly providing a final
-- continuation.
--
-- The final return type is wrapped in a 'Maybe' due to the fact that
-- any continuation may fail locally.
runCaptureWithC :: (a -> Sem r (Maybe s))
                -> Sem (Capture (Ref (Sem r)) ': r) a
                -> Sem r (Maybe s)
runCaptureWithC :: (a -> Sem r (Maybe s))
-> Sem (Capture (Ref (Sem r)) : r) a -> Sem r (Maybe s)
runCaptureWithC a -> Sem r (Maybe s)
c (Sem forall (m :: * -> *).
Monad m =>
(forall x.
 Union
   (Capture (Ref (Sem r)) : r) (Sem (Capture (Ref (Sem r)) : r)) x
 -> m x)
-> m a
m) = (ContT (Maybe s) (Sem r) a
-> (a -> Sem r (Maybe s)) -> Sem r (Maybe s)
forall k (r :: k) (m :: k -> *) a. ContT r m a -> (a -> m r) -> m r
`runContT` a -> Sem r (Maybe s)
c) (ContT (Maybe s) (Sem r) a -> Sem r (Maybe s))
-> ContT (Maybe s) (Sem r) a -> Sem r (Maybe s)
forall a b. (a -> b) -> a -> b
$ (forall x.
 Union
   (Capture (Ref (Sem r)) : r) (Sem (Capture (Ref (Sem r)) : r)) x
 -> ContT (Maybe s) (Sem r) x)
-> ContT (Maybe s) (Sem r) a
forall (m :: * -> *).
Monad m =>
(forall x.
 Union
   (Capture (Ref (Sem r)) : r) (Sem (Capture (Ref (Sem r)) : r)) x
 -> m x)
-> m a
m ((forall x.
  Union
    (Capture (Ref (Sem r)) : r) (Sem (Capture (Ref (Sem r)) : r)) x
  -> ContT (Maybe s) (Sem r) x)
 -> ContT (Maybe s) (Sem r) a)
-> (forall x.
    Union
      (Capture (Ref (Sem r)) : r) (Sem (Capture (Ref (Sem r)) : r)) x
    -> ContT (Maybe s) (Sem r) x)
-> ContT (Maybe s) (Sem r) a
forall a b. (a -> b) -> a -> b
$ \Union
  (Capture (Ref (Sem r)) : r) (Sem (Capture (Ref (Sem r)) : r)) x
u ->
    case Union
  (Capture (Ref (Sem r)) : r) (Sem (Capture (Ref (Sem r)) : r)) x
-> Either
     (Union r (Sem (Capture (Ref (Sem r)) : r)) x)
     (Weaving
        (Capture (Ref (Sem r))) (Sem (Capture (Ref (Sem r)) : r)) x)
forall (e :: (* -> *) -> * -> *) (r :: EffectRow) (m :: * -> *) a.
Union (e : r) m a -> Either (Union r m a) (Weaving e m a)
decomp Union
  (Capture (Ref (Sem r)) : r) (Sem (Capture (Ref (Sem r)) : r)) x
u of
      Right (Weaving Capture (Ref (Sem r)) (Sem rInitial) a
e f ()
s forall x.
f (Sem rInitial x) -> Sem (Capture (Ref (Sem r)) : r) (f x)
wv f a -> x
ex forall x. f x -> Maybe x
ins) ->
        ((x -> Sem r (Maybe s)) -> Sem r (Maybe s))
-> ContT (Maybe s) (Sem r) x
forall k (r :: k) (m :: k -> *) a.
((a -> m r) -> m r) -> ContT r m a
ContT (((x -> Sem r (Maybe s)) -> Sem r (Maybe s))
 -> ContT (Maybe s) (Sem r) x)
-> ((x -> Sem r (Maybe s)) -> Sem r (Maybe s))
-> ContT (Maybe s) (Sem r) x
forall a b. (a -> b) -> a -> b
$ \x -> Sem r (Maybe s)
c' ->
          case Capture (Ref (Sem r)) (Sem rInitial) a
e of
            Reflect Ref (Sem r) a a
ref a
a ->
                  Ref (Sem r) a a -> a -> Sem r a
forall k (m :: k -> *) (s :: k) a. Ref m s a -> a -> m s
runRef Ref (Sem r) a a
ref a
a
              Sem r a -> (a -> Sem r (Maybe s)) -> Sem r (Maybe s)
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= x -> Sem r (Maybe s)
c' (x -> Sem r (Maybe s)) -> (a -> x) -> a -> Sem r (Maybe s)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. f a -> x
ex (f a -> x) -> (a -> f a) -> a -> x
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)
            Reify forall s. Ref (Sem r) s a -> Sem rInitial s
main ->
              (f (Maybe s) -> Sem r (Maybe s))
-> Sem (Capture (Ref (Sem r)) : r) (f (Maybe s)) -> Sem r (Maybe s)
forall a (r :: EffectRow) s.
(a -> Sem r (Maybe s))
-> Sem (Capture (Ref (Sem r)) : r) a -> Sem r (Maybe s)
runCaptureWithC
                (Maybe s -> Sem r (Maybe s)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe s -> Sem r (Maybe s))
-> (f (Maybe s) -> Maybe s) -> f (Maybe s) -> Sem r (Maybe s)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Maybe (Maybe s) -> Maybe s
forall (m :: * -> *) a. Monad m => m (m a) -> m a
join (Maybe (Maybe s) -> Maybe s)
-> (f (Maybe s) -> Maybe (Maybe s)) -> f (Maybe s) -> Maybe s
forall b c a. (b -> c) -> (a -> b) -> a -> c
. f (Maybe s) -> Maybe (Maybe s)
forall x. f x -> Maybe x
ins)
                (f (Sem rInitial (Maybe s))
-> Sem (Capture (Ref (Sem r)) : r) (f (Maybe s))
forall x.
f (Sem rInitial x) -> Sem (Capture (Ref (Sem r)) : r) (f x)
wv (Ref (Sem r) (Maybe s) a -> Sem rInitial (Maybe s)
forall s. Ref (Sem r) s a -> Sem rInitial s
main ((a -> Sem r (Maybe s)) -> Ref (Sem r) (Maybe s) a
forall k (m :: k -> *) (s :: k) a. (a -> m s) -> Ref m s a
Ref (x -> Sem r (Maybe s)
c' (x -> Sem r (Maybe s)) -> (a -> x) -> a -> Sem r (Maybe s)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. f a -> x
ex (f a -> x) -> (a -> f a) -> a -> x
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))) Sem rInitial (Maybe s) -> f () -> f (Sem rInitial (Maybe s))
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ f ()
s))
            Delimit Sem rInitial a
main ->
                  (f a -> Sem r (Maybe (f a)))
-> Sem (Capture (Ref (Sem r)) : r) (f a) -> Sem r (Maybe (f a))
forall a (r :: EffectRow) s.
(a -> Sem r (Maybe s))
-> Sem (Capture (Ref (Sem r)) : r) a -> Sem r (Maybe s)
runCaptureWithC
                    (Maybe (f a) -> Sem r (Maybe (f a))
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe (f a) -> Sem r (Maybe (f a)))
-> (f a -> Maybe (f a)) -> f a -> Sem r (Maybe (f a))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. f a -> Maybe (f a)
forall a. a -> Maybe a
Just)
                    (f (Sem rInitial a) -> Sem (Capture (Ref (Sem r)) : r) (f a)
forall x.
f (Sem rInitial x) -> Sem (Capture (Ref (Sem r)) : r) (f x)
wv (Sem rInitial a
main Sem rInitial a -> f () -> f (Sem rInitial a)
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ f ()
s))
              Sem r (Maybe (f a))
-> (Maybe (f a) -> Sem r (Maybe s)) -> Sem r (Maybe s)
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Sem r (Maybe s)
-> (f a -> Sem r (Maybe s)) -> Maybe (f a) -> Sem r (Maybe s)
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (Maybe s -> Sem r (Maybe s)
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe s
forall a. Maybe a
Nothing) (x -> Sem r (Maybe s)
c' (x -> Sem r (Maybe s)) -> (f a -> x) -> f a -> Sem r (Maybe s)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. f a -> x
ex)
            Delimit' Sem rInitial a
main ->
                  (f a -> Sem r (Maybe (f a)))
-> Sem (Capture (Ref (Sem r)) : r) (f a) -> Sem r (Maybe (f a))
forall a (r :: EffectRow) s.
(a -> Sem r (Maybe s))
-> Sem (Capture (Ref (Sem r)) : r) a -> Sem r (Maybe s)
runCaptureWithC
                    (Maybe (f a) -> Sem r (Maybe (f a))
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe (f a) -> Sem r (Maybe (f a)))
-> (f a -> Maybe (f a)) -> f a -> Sem r (Maybe (f a))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. f a -> Maybe (f a)
forall a. a -> Maybe a
Just)
                    (f (Sem rInitial a) -> Sem (Capture (Ref (Sem r)) : r) (f a)
forall x.
f (Sem rInitial x) -> Sem (Capture (Ref (Sem r)) : r) (f x)
wv (Sem rInitial a
main Sem rInitial a -> f () -> f (Sem rInitial a)
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ f ()
s))
              Sem r (Maybe (f a))
-> (Maybe (f a) -> Sem r (Maybe s)) -> Sem r (Maybe s)
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Sem r (Maybe s)
-> (f a -> Sem r (Maybe s)) -> Maybe (f a) -> Sem r (Maybe s)
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (x -> Sem r (Maybe s)
c' (f a -> x
ex (Maybe a
forall a. Maybe a
Nothing Maybe a -> f () -> f (Maybe a)
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ f ()
s))) (x -> Sem r (Maybe s)
c' (x -> Sem r (Maybe s)) -> (f a -> x) -> f a -> Sem r (Maybe s)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. f a -> x
ex (f a -> x) -> (f a -> f a) -> f a -> x
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (a -> Maybe a) -> f a -> f (Maybe a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap a -> Maybe a
forall a. a -> Maybe a
Just)
      Left Union r (Sem (Capture (Ref (Sem r)) : r)) x
g -> ((x -> Sem r (Maybe s)) -> Sem r (Maybe s))
-> ContT (Maybe s) (Sem r) x
forall k (r :: k) (m :: k -> *) a.
((a -> m r) -> m r) -> ContT r m a
ContT (((x -> Sem r (Maybe s)) -> Sem r (Maybe s))
 -> ContT (Maybe s) (Sem r) x)
-> ((x -> Sem r (Maybe s)) -> Sem r (Maybe s))
-> ContT (Maybe s) (Sem r) x
forall a b. (a -> b) -> a -> b
$ \x -> Sem r (Maybe s)
c' ->
            Union r (Sem r) (Maybe x) -> Sem r (Maybe x)
forall (r :: EffectRow) a. Union r (Sem r) a -> Sem r a
liftSem (Maybe ()
-> (forall x.
    Maybe (Sem (Capture (Ref (Sem r)) : r) x) -> Sem r (Maybe x))
-> (forall x. Maybe x -> Maybe x)
-> Union r (Sem (Capture (Ref (Sem r)) : r)) x
-> Union r (Sem r) (Maybe x)
forall (s :: * -> *) (n :: * -> *) (m :: * -> *) (r :: EffectRow)
       a.
(Functor s, Functor n) =>
s ()
-> (forall x. s (m x) -> n (s x))
-> (forall x. s x -> Maybe x)
-> Union r m a
-> Union r n (s a)
weave (() -> Maybe ()
forall a. a -> Maybe a
Just ()) (Sem r (Maybe x)
-> (Sem (Capture (Ref (Sem r)) : r) x -> Sem r (Maybe x))
-> Maybe (Sem (Capture (Ref (Sem r)) : r) x)
-> Sem r (Maybe x)
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (Maybe x -> Sem r (Maybe x)
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe x
forall a. Maybe a
Nothing) Sem (Capture (Ref (Sem r)) : r) x -> Sem r (Maybe x)
forall (r :: EffectRow) a.
Sem (Capture (Ref (Sem r)) : r) a -> Sem r (Maybe a)
runCapture) forall a. a -> a
forall x. Maybe x -> Maybe x
id Union r (Sem (Capture (Ref (Sem r)) : r)) x
g)
        Sem r (Maybe x) -> (Maybe x -> Sem r (Maybe s)) -> Sem r (Maybe s)
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Sem r (Maybe s)
-> (x -> Sem r (Maybe s)) -> Maybe x -> Sem r (Maybe s)
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (Maybe s -> Sem r (Maybe s)
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe s
forall a. Maybe a
Nothing) x -> Sem r (Maybe s)
c'
{-# INLINE runCaptureWithC #-}