{-# LANGUAGE TemplateHaskell #-}

module Polysemy.Async
  ( -- * Effect
    Async (..)

    -- * Actions
  , async
  , await
  , cancel

    -- * Helpers
  , sequenceConcurrently

    -- * Interpretations
  , asyncToIO
  , asyncToIOFinal
  , lowerAsync
  ) where

import qualified Control.Concurrent.Async as A
import           Polysemy
import           Polysemy.Final



------------------------------------------------------------------------------
-- | An effect for spawning asynchronous computations.
--
-- The 'Maybe' returned by 'async' is due to the fact that we can't be sure an
-- 'Polysemy.Error.Error' effect didn't fail locally.
--
-- @since 0.5.0.0
data Async m a where
  Async :: m a -> Async m (A.Async (Maybe a))
  Await :: A.Async a -> Async m a
  Cancel :: A.Async a -> Async m ()

makeSem ''Async


------------------------------------------------------------------------------
-- | Perform a sequence of effectful actions concurrently.
--
-- @since 1.2.2.0
sequenceConcurrently :: forall t r a. (Traversable t, Member Async r) =>
    t (Sem r a) -> Sem r (t (Maybe a))
sequenceConcurrently :: t (Sem r a) -> Sem r (t (Maybe a))
sequenceConcurrently t (Sem r a)
t = (Sem r a -> Sem r (Async (Maybe a)))
-> t (Sem r a) -> Sem r (t (Async (Maybe a)))
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse Sem r a -> Sem r (Async (Maybe a))
forall (r :: EffectRow) a.
Member Async r =>
Sem r a -> Sem r (Async (Maybe a))
async t (Sem r a)
t Sem r (t (Async (Maybe a)))
-> (t (Async (Maybe a)) -> Sem r (t (Maybe a)))
-> Sem r (t (Maybe a))
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (Async (Maybe a) -> Sem r (Maybe a))
-> t (Async (Maybe a)) -> Sem r (t (Maybe a))
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse Async (Maybe a) -> Sem r (Maybe a)
forall (r :: EffectRow) a. Member Async r => Async a -> Sem r a
await
{-# INLINABLE sequenceConcurrently #-}

------------------------------------------------------------------------------
-- | A more flexible --- though less performant ---
-- version of 'asyncToIOFinal'.
--
-- This function is capable of running 'Async' effects anywhere within an
-- effect stack, without relying on 'Final' to lower it into 'IO'.
-- Notably, this means that 'Polysemy.State.State' effects will be consistent
-- in the presence of 'Async'.
--
-- 'asyncToIO' is __unsafe__ if you're using 'await' inside higher-order actions
-- of other effects interpreted after 'Async'.
-- See <https://github.com/polysemy-research/polysemy/issues/205 Issue #205>.
--
-- Prefer 'asyncToIOFinal' unless you need to run pure, stateful interpreters
-- after the interpreter for 'Async'.
-- (Pure interpreters are interpreters that aren't expressed in terms of
-- another effect or monad; for example, 'Polysemy.State.runState'.)
--
-- @since 1.0.0.0
asyncToIO
    :: Member (Embed IO) r
    => Sem (Async ': r) a
    -> Sem r a
asyncToIO :: Sem (Async : r) a -> Sem r a
asyncToIO Sem (Async : r) a
m = ((forall x. Sem r x -> IO x) -> IO () -> IO a) -> Sem r a
forall (r :: EffectRow) a.
Member (Embed IO) r =>
((forall x. Sem r x -> IO x) -> IO () -> IO a) -> Sem r a
withLowerToIO (((forall x. Sem r x -> IO x) -> IO () -> IO a) -> Sem r a)
-> ((forall x. Sem r x -> IO x) -> IO () -> IO a) -> Sem r a
forall a b. (a -> b) -> a -> b
$ \forall x. Sem r x -> IO x
lower IO ()
_ -> Sem r a -> IO a
forall x. Sem r x -> IO x
lower (Sem r a -> IO a) -> Sem r a -> IO a
forall a b. (a -> b) -> a -> b
$
  (forall (rInitial :: EffectRow) x.
 Async (Sem rInitial) x -> Tactical Async (Sem rInitial) r x)
-> Sem (Async : r) a -> Sem r a
forall (e :: (* -> *) -> * -> *) (r :: EffectRow) a.
(forall (rInitial :: EffectRow) x.
 e (Sem rInitial) x -> Tactical e (Sem rInitial) r x)
-> Sem (e : r) a -> Sem r a
interpretH
    ( \case
        Async a -> do
          Sem (Async : r) (f a)
ma  <- Sem rInitial a
-> Sem
     (WithTactics Async f (Sem rInitial) r) (Sem (Async : r) (f a))
forall (m :: * -> *) a (e :: (* -> *) -> * -> *) (f :: * -> *)
       (r :: EffectRow).
m a -> Sem (WithTactics e f m r) (Sem (e : r) (f a))
runT Sem rInitial a
a
          Inspector f
ins <- Sem (WithTactics Async f (Sem rInitial) r) (Inspector f)
forall (e :: (* -> *) -> * -> *) (f :: * -> *) (m :: * -> *)
       (r :: EffectRow).
Sem (WithTactics e f m r) (Inspector f)
getInspectorT
          Async (f a)
fa  <- IO (Async (f a))
-> Sem (WithTactics Async f (Sem rInitial) r) (Async (f a))
forall (m :: * -> *) (r :: EffectRow) a.
Member (Embed m) r =>
m a -> Sem r a
embed (IO (Async (f a))
 -> Sem (WithTactics Async f (Sem rInitial) r) (Async (f a)))
-> IO (Async (f a))
-> Sem (WithTactics Async f (Sem rInitial) r) (Async (f a))
forall a b. (a -> b) -> a -> b
$ IO (f a) -> IO (Async (f a))
forall a. IO a -> IO (Async a)
A.async (IO (f a) -> IO (Async (f a))) -> IO (f a) -> IO (Async (f a))
forall a b. (a -> b) -> a -> b
$ Sem r (f a) -> IO (f a)
forall x. Sem r x -> IO x
lower (Sem r (f a) -> IO (f a)) -> Sem r (f a) -> IO (f a)
forall a b. (a -> b) -> a -> b
$ Sem (Async : r) (f a) -> Sem r (f a)
forall (r :: EffectRow) a.
Member (Embed IO) r =>
Sem (Async : r) a -> Sem r a
asyncToIO Sem (Async : r) (f a)
ma
          Async (Maybe a)
-> Sem (WithTactics Async f (Sem rInitial) r) (f (Async (Maybe a)))
forall (f :: * -> *) a (e :: (* -> *) -> * -> *) (m :: * -> *)
       (r :: EffectRow).
Functor f =>
a -> Sem (WithTactics e f m r) (f a)
pureT (Async (Maybe a)
 -> Sem
      (WithTactics Async f (Sem rInitial) r) (f (Async (Maybe a))))
-> Async (Maybe a)
-> Sem (WithTactics Async f (Sem rInitial) r) (f (Async (Maybe a)))
forall a b. (a -> b) -> a -> b
$ Inspector f -> forall x. f x -> Maybe x
forall (f :: * -> *). Inspector f -> forall x. f x -> Maybe x
inspect Inspector f
ins (f a -> Maybe a) -> Async (f a) -> Async (Maybe a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Async (f a)
fa

        Await a -> x -> Sem (WithTactics Async f (Sem rInitial) r) (f x)
forall (f :: * -> *) a (e :: (* -> *) -> * -> *) (m :: * -> *)
       (r :: EffectRow).
Functor f =>
a -> Sem (WithTactics e f m r) (f a)
pureT (x -> Sem (WithTactics Async f (Sem rInitial) r) (f x))
-> Sem (WithTactics Async f (Sem rInitial) r) x
-> Sem (WithTactics Async f (Sem rInitial) r) (f x)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< IO x -> Sem (WithTactics Async f (Sem rInitial) r) x
forall (m :: * -> *) (r :: EffectRow) a.
Member (Embed m) r =>
m a -> Sem r a
embed (Async x -> IO x
forall a. Async a -> IO a
A.wait Async x
a)
        Cancel a -> () -> Sem (WithTactics Async f (Sem rInitial) r) (f ())
forall (f :: * -> *) a (e :: (* -> *) -> * -> *) (m :: * -> *)
       (r :: EffectRow).
Functor f =>
a -> Sem (WithTactics e f m r) (f a)
pureT (() -> Sem (WithTactics Async f (Sem rInitial) r) (f ()))
-> Sem (WithTactics Async f (Sem rInitial) r) ()
-> Sem (WithTactics Async f (Sem rInitial) r) (f ())
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< IO () -> Sem (WithTactics Async f (Sem rInitial) r) ()
forall (m :: * -> *) (r :: EffectRow) a.
Member (Embed m) r =>
m a -> Sem r a
embed (Async a -> IO ()
forall a. Async a -> IO ()
A.cancel Async a
a)
    )  Sem (Async : r) a
m
{-# INLINE asyncToIO #-}

------------------------------------------------------------------------------
-- | Run an 'Async' effect in terms of 'A.async' through final 'IO'.
--
-- /Beware/: Effects that aren't interpreted in terms of 'IO'
-- will have local state semantics in regards to 'Async' effects
-- interpreted this way. See 'Final'.
--
-- Notably, unlike 'asyncToIO', this is not consistent with
-- 'Polysemy.State.State' unless 'Polysemy.State.runStateIORef' is used.
-- State that seems like it should be threaded globally throughout 'Async'
-- /will not be./
--
-- Use 'asyncToIO' instead if you need to run
-- pure, stateful interpreters after the interpreter for 'Async'.
-- (Pure interpreters are interpreters that aren't expressed in terms of
-- another effect or monad; for example, 'Polysemy.State.runState'.)
--
-- @since 1.2.0.0
asyncToIOFinal :: Member (Final IO) r
               => Sem (Async ': r) a
               -> Sem r a
asyncToIOFinal :: Sem (Async : r) a -> Sem r a
asyncToIOFinal = (forall x (rInitial :: EffectRow).
 Async (Sem rInitial) x -> Strategic IO (Sem rInitial) x)
-> Sem (Async : 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).
  Async (Sem rInitial) x -> Strategic IO (Sem rInitial) x)
 -> Sem (Async : r) a -> Sem r a)
-> (forall x (rInitial :: EffectRow).
    Async (Sem rInitial) x -> Strategic IO (Sem rInitial) x)
-> Sem (Async : r) a
-> Sem r a
forall a b. (a -> b) -> a -> b
$ \case
  Async m -> do
    Inspector f
ins <- Sem (WithStrategy IO f (Sem rInitial)) (Inspector f)
forall (m :: * -> *) (f :: * -> *) (n :: * -> *).
Sem (WithStrategy m f n) (Inspector f)
getInspectorS
    IO (f a)
m'  <- Sem rInitial a -> Sem (WithStrategy IO f (Sem rInitial)) (IO (f a))
forall (n :: * -> *) a (m :: * -> *) (f :: * -> *).
n a -> Sem (WithStrategy m f n) (m (f a))
runS Sem rInitial a
m
    IO (Async (Maybe a))
-> Strategic IO (Sem rInitial) (Async (Maybe a))
forall (m :: * -> *) a (n :: * -> *).
Functor m =>
m a -> Strategic m n a
liftS (IO (Async (Maybe a))
 -> Strategic IO (Sem rInitial) (Async (Maybe a)))
-> IO (Async (Maybe a))
-> Strategic IO (Sem rInitial) (Async (Maybe a))
forall a b. (a -> b) -> a -> b
$ IO (Maybe a) -> IO (Async (Maybe a))
forall a. IO a -> IO (Async a)
A.async (Inspector f -> forall x. f x -> Maybe x
forall (f :: * -> *). Inspector f -> forall x. f x -> Maybe x
inspect Inspector f
ins (f a -> Maybe a) -> IO (f a) -> IO (Maybe a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO (f a)
m')
  Await a -> IO x -> Strategic IO (Sem rInitial) x
forall (m :: * -> *) a (n :: * -> *).
Functor m =>
m a -> Strategic m n a
liftS (Async x -> IO x
forall a. Async a -> IO a
A.wait Async x
a)
  Cancel a -> IO () -> Strategic IO (Sem rInitial) ()
forall (m :: * -> *) a (n :: * -> *).
Functor m =>
m a -> Strategic m n a
liftS (Async a -> IO ()
forall a. Async a -> IO ()
A.cancel Async a
a)
{-# INLINE asyncToIOFinal #-}

------------------------------------------------------------------------------
-- | Run an 'Async' effect in terms of 'A.async'.
--
-- @since 1.0.0.0
lowerAsync
    :: Member (Embed IO) r
    => (forall x. Sem r x -> IO x)
       -- ^ Strategy for lowering a 'Sem' action down to 'IO'. This is likely
       -- some combination of 'runM' and other interpreters composed via '.@'.
    -> Sem (Async ': r) a
    -> Sem r a
lowerAsync :: (forall x. Sem r x -> IO x) -> Sem (Async : r) a -> Sem r a
lowerAsync forall x. Sem r x -> IO x
lower Sem (Async : r) a
m = (forall (rInitial :: EffectRow) x.
 Async (Sem rInitial) x -> Tactical Async (Sem rInitial) r x)
-> Sem (Async : r) a -> Sem r a
forall (e :: (* -> *) -> * -> *) (r :: EffectRow) a.
(forall (rInitial :: EffectRow) x.
 e (Sem rInitial) x -> Tactical e (Sem rInitial) r x)
-> Sem (e : r) a -> Sem r a
interpretH
    ( \case
        Async a -> do
          Sem (Async : r) (f a)
ma  <- Sem rInitial a
-> Sem
     (WithTactics Async f (Sem rInitial) r) (Sem (Async : r) (f a))
forall (m :: * -> *) a (e :: (* -> *) -> * -> *) (f :: * -> *)
       (r :: EffectRow).
m a -> Sem (WithTactics e f m r) (Sem (e : r) (f a))
runT Sem rInitial a
a
          Inspector f
ins <- Sem (WithTactics Async f (Sem rInitial) r) (Inspector f)
forall (e :: (* -> *) -> * -> *) (f :: * -> *) (m :: * -> *)
       (r :: EffectRow).
Sem (WithTactics e f m r) (Inspector f)
getInspectorT
          Async (f a)
fa  <- IO (Async (f a))
-> Sem (WithTactics Async f (Sem rInitial) r) (Async (f a))
forall (m :: * -> *) (r :: EffectRow) a.
Member (Embed m) r =>
m a -> Sem r a
embed (IO (Async (f a))
 -> Sem (WithTactics Async f (Sem rInitial) r) (Async (f a)))
-> IO (Async (f a))
-> Sem (WithTactics Async f (Sem rInitial) r) (Async (f a))
forall a b. (a -> b) -> a -> b
$ IO (f a) -> IO (Async (f a))
forall a. IO a -> IO (Async a)
A.async (IO (f a) -> IO (Async (f a))) -> IO (f a) -> IO (Async (f a))
forall a b. (a -> b) -> a -> b
$ Sem r (f a) -> IO (f a)
forall x. Sem r x -> IO x
lower (Sem r (f a) -> IO (f a)) -> Sem r (f a) -> IO (f a)
forall a b. (a -> b) -> a -> b
$ (forall x. Sem r x -> IO x) -> Sem (Async : r) (f a) -> Sem r (f a)
forall (r :: EffectRow) a.
Member (Embed IO) r =>
(forall x. Sem r x -> IO x) -> Sem (Async : r) a -> Sem r a
lowerAsync forall x. Sem r x -> IO x
lower Sem (Async : r) (f a)
ma
          Async (Maybe a)
-> Sem (WithTactics Async f (Sem rInitial) r) (f (Async (Maybe a)))
forall (f :: * -> *) a (e :: (* -> *) -> * -> *) (m :: * -> *)
       (r :: EffectRow).
Functor f =>
a -> Sem (WithTactics e f m r) (f a)
pureT (Async (Maybe a)
 -> Sem
      (WithTactics Async f (Sem rInitial) r) (f (Async (Maybe a))))
-> Async (Maybe a)
-> Sem (WithTactics Async f (Sem rInitial) r) (f (Async (Maybe a)))
forall a b. (a -> b) -> a -> b
$ Inspector f -> forall x. f x -> Maybe x
forall (f :: * -> *). Inspector f -> forall x. f x -> Maybe x
inspect Inspector f
ins (f a -> Maybe a) -> Async (f a) -> Async (Maybe a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Async (f a)
fa

        Await a -> x -> Sem (WithTactics Async f (Sem rInitial) r) (f x)
forall (f :: * -> *) a (e :: (* -> *) -> * -> *) (m :: * -> *)
       (r :: EffectRow).
Functor f =>
a -> Sem (WithTactics e f m r) (f a)
pureT (x -> Sem (WithTactics Async f (Sem rInitial) r) (f x))
-> Sem (WithTactics Async f (Sem rInitial) r) x
-> Sem (WithTactics Async f (Sem rInitial) r) (f x)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< IO x -> Sem (WithTactics Async f (Sem rInitial) r) x
forall (m :: * -> *) (r :: EffectRow) a.
Member (Embed m) r =>
m a -> Sem r a
embed (Async x -> IO x
forall a. Async a -> IO a
A.wait Async x
a)
        Cancel a -> () -> Sem (WithTactics Async f (Sem rInitial) r) (f ())
forall (f :: * -> *) a (e :: (* -> *) -> * -> *) (m :: * -> *)
       (r :: EffectRow).
Functor f =>
a -> Sem (WithTactics e f m r) (f a)
pureT (() -> Sem (WithTactics Async f (Sem rInitial) r) (f ()))
-> Sem (WithTactics Async f (Sem rInitial) r) ()
-> Sem (WithTactics Async f (Sem rInitial) r) (f ())
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< IO () -> Sem (WithTactics Async f (Sem rInitial) r) ()
forall (m :: * -> *) (r :: EffectRow) a.
Member (Embed m) r =>
m a -> Sem r a
embed (Async a -> IO ()
forall a. Async a -> IO ()
A.cancel Async a
a)
    )  Sem (Async : r) a
m
{-# INLINE lowerAsync #-}
{-# DEPRECATED lowerAsync "Use 'asyncToIOFinal' instead" #-}