{-# LANGUAGE AllowAmbiguousTypes, TemplateHaskell, Trustworthy #-}
module Polysemy.Capture
(
Capture(..)
, reify
, reflect
, delimit
, delimit'
, capture
, runCapture
, runCaptureWithC
, Ref(..)
) where
import Control.Monad
import Control.Monad.Cont (ContT(..))
import Polysemy
import Polysemy.Internal
import Polysemy.Internal.Union
import Polysemy.Cont.Internal (Ref(..))
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
reify :: forall ref a r
. Member (Capture ref) r
=> (forall s. ref s a -> Sem r s)
-> Sem r a
reflect :: forall ref s a r
. Member (Capture ref) r
=> ref s a
-> a
-> Sem r s
delimit :: forall ref a r
. Member (Capture ref) r
=> Sem r a
-> Sem r a
delimit' :: forall ref a r
. Member (Capture ref) r
=> Sem r a
-> Sem r (Maybe a)
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 #-}
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 #-}
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 #-}