{-# LANGUAGE CPP #-}
{-# LANGUAGE RankNTypes #-}

-- |
-- Module      : Control.Concurrent.Classy.Async
-- Copyright   : (c) 2016--2017 Michael Walker
-- License     : MIT
-- Maintainer  : Michael Walker <mike@barrucadu.co.uk>
-- Stability   : stable
-- Portability : RankNTypes
--
-- This module is a version of the
-- <https://hackage.haskell.org/package/async async> package. It
-- provides a set of operations for running @MonadConc@ operations
-- asynchronously and waiting for their results.
--
-- For example, assuming a suitable @getURL@ function, we can fetch
-- the contents of two web pages at the same time:
--
-- > withAsync (getURL url1) $ \a1 -> do
-- > withAsync (getURL url2) $ \a2 -> do
-- > page1 <- wait a1
-- > page2 <- wait a2
-- > ...
--
-- The 'withAsync' function starts an operation in a separate thread,
-- and kills it if the inner action finishes before it completes.
--
-- Unlike the regular async package, the @Alternative@ instance for
-- 'Concurrently' uses @forever yield@ in the definition of @empty@,
-- rather than @forever (threadDelay maxBound)@.
module Control.Concurrent.Classy.Async
  ( -- * Asynchronous actions
    Async

  -- * Spawning
  , async
  , asyncN
  , asyncBound
  , asyncBoundN
  , asyncOn
  , asyncOnN
  , asyncWithUnmask
  , asyncWithUnmaskN
  , asyncOnWithUnmask
  , asyncOnWithUnmaskN

  -- * Spawning with automatic 'cancel'ation
  , withAsync
  , withAsyncN
  , withAsyncBound
  , withAsyncBoundN
  , withAsyncOn
  , withAsyncOnN
  , withAsyncWithUnmask
  , withAsyncWithUnmaskN
  , withAsyncOnWithUnmask
  , withAsyncOnWithUnmaskN

  -- * Querying 'Async's
  , wait, waitSTM
  , poll, pollSTM
  , waitCatch, waitCatchSTM
  , cancel
  , uninterruptibleCancel
  , cancelWith
  , asyncThreadId

  -- * Waiting for multiple 'Async's
  , waitAny, waitAnySTM
  , waitAnyCatch, waitAnyCatchSTM
  , waitAnyCancel
  , waitAnyCatchCancel
  , waitEither, waitEitherSTM
  , waitEitherCatch, waitEitherCatchSTM
  , waitEitherCancel
  , waitEitherCatchCancel
  , waitEither_, waitEitherSTM_
  , waitBoth, waitBothSTM

  -- * Linking
  , link
  , link2

  -- * Convenient utilities
  , race
  , race_
  , concurrently, concurrently_
  , mapConcurrently, mapConcurrently_
  , forConcurrently, forConcurrently_
  , replicateConcurrently, replicateConcurrently_
  , Concurrently(..)
  ) where

import           Control.Applicative
import           Control.Concurrent.Classy.STM.TMVar (newEmptyTMVar, putTMVar,
                                                      readTMVar)
import           Control.Exception                   (AsyncException(ThreadKilled),
                                                      BlockedIndefinitelyOnSTM(..),
                                                      Exception, SomeException)
import           Control.Monad
import           Control.Monad.Catch                 (finally, onException, try)
import           Control.Monad.Conc.Class
import           Control.Monad.STM.Class
import           Data.Foldable                       (foldMap)
import           Data.Semigroup                      (Semigroup(..))

-----------------------------------------------------------------------------------------
-- Asynchronous and Concurrent Actions

-- | An asynchronous action spawned by 'async' or
-- 'withAsync'. Asynchronous actions are executed in a separate
-- thread, and operations are provided for waiting for asynchronous
-- actions to complete and obtaining their results (see e.g. 'wait').
--
-- Note that, unlike the \"async\" package, 'Async' here does not have
-- an 'Ord' instance. This is because 'MonadConc' 'ThreadId's do not
-- necessarily have one.
--
-- @since 1.1.1.0
data Async m a = Async
  { forall (m :: * -> *) a. Async m a -> ThreadId m
asyncThreadId :: !(ThreadId m)
  , forall (m :: * -> *) a. Async m a -> STM m (Either SomeException a)
_asyncWait :: STM m (Either SomeException a)
  }

-- | @since 1.1.1.0
instance MonadConc m => Eq (Async m a) where
  Async ThreadId m
t1 STM m (Either SomeException a)
_ == :: Async m a -> Async m a -> Bool
== Async ThreadId m
t2 STM m (Either SomeException a)
_ = ThreadId m
t1 ThreadId m -> ThreadId m -> Bool
forall a. Eq a => a -> a -> Bool
== ThreadId m
t2

-- | @since 1.1.1.0
instance MonadConc m => Functor (Async m) where
  fmap :: forall a b. (a -> b) -> Async m a -> Async m b
fmap a -> b
f (Async ThreadId m
t STM m (Either SomeException a)
w) = ThreadId m -> STM m (Either SomeException b) -> Async m b
forall (m :: * -> *) a.
ThreadId m -> STM m (Either SomeException a) -> Async m a
Async ThreadId m
t (STM m (Either SomeException b) -> Async m b)
-> STM m (Either SomeException b) -> Async m b
forall a b. (a -> b) -> a -> b
$ (a -> b) -> Either SomeException a -> Either SomeException b
forall a b.
(a -> b) -> Either SomeException a -> Either SomeException b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap a -> b
f (Either SomeException a -> Either SomeException b)
-> STM m (Either SomeException a) -> STM m (Either SomeException b)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> STM m (Either SomeException a)
w

-- | A value of type @Concurrently m a@ is a @MonadConc@ operation
-- that can be composed with other @Concurrently@ values, using the
-- @Applicative@ and @Alternative@ instances.
--
-- Calling @runConcurrently@ on a value of type @Concurrently m a@
-- will execute the @MonadConc@ operations it contains concurrently,
-- before delivering the result of type @a@.
--
-- For example
--
-- > (page1, page2, page3)
-- >   <- runConcurrently $ (,,)
-- >   <$> Concurrently (getURL "url1")
-- >   <*> Concurrently (getURL "url2")
-- >   <*> Concurrently (getURL "url3")
--
-- @since 1.1.1.0
newtype Concurrently m a = Concurrently { forall (m :: * -> *) a. Concurrently m a -> m a
runConcurrently :: m a }

-- | @since 1.1.1.0
instance MonadConc m => Functor (Concurrently m) where
  fmap :: forall a b. (a -> b) -> Concurrently m a -> Concurrently m b
fmap a -> b
f (Concurrently m a
a) = m b -> Concurrently m b
forall (m :: * -> *) a. m a -> Concurrently m a
Concurrently (m b -> Concurrently m b) -> m b -> Concurrently m b
forall a b. (a -> b) -> a -> b
$ a -> b
f (a -> b) -> m a -> m b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> m a
a

-- | @since 1.1.1.0
instance MonadConc m => Applicative (Concurrently m) where
  pure :: forall a. a -> Concurrently m a
pure = m a -> Concurrently m a
forall (m :: * -> *) a. m a -> Concurrently m a
Concurrently (m a -> Concurrently m a) -> (a -> m a) -> a -> Concurrently m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> m a
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure

  Concurrently m (a -> b)
fs <*> :: forall a b.
Concurrently m (a -> b) -> Concurrently m a -> Concurrently m b
<*> Concurrently m a
as =
    m b -> Concurrently m b
forall (m :: * -> *) a. m a -> Concurrently m a
Concurrently (m b -> Concurrently m b) -> m b -> Concurrently m b
forall a b. (a -> b) -> a -> b
$ (\(a -> b
f, a
a) -> a -> b
f a
a) ((a -> b, a) -> b) -> m (a -> b, a) -> m b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> m (a -> b) -> m a -> m (a -> b, a)
forall (m :: * -> *) a b. MonadConc m => m a -> m b -> m (a, b)
concurrently m (a -> b)
fs m a
as

-- | @since 1.1.1.0
instance MonadConc m => Alternative (Concurrently m) where
  empty :: forall a. Concurrently m a
empty = m a -> Concurrently m a
forall (m :: * -> *) a. m a -> Concurrently m a
Concurrently (m a -> Concurrently m a) -> m a -> Concurrently m a
forall a b. (a -> b) -> a -> b
$ m () -> m a
forall (f :: * -> *) a b. Applicative f => f a -> f b
forever m ()
forall (m :: * -> *). MonadConc m => m ()
yield

  Concurrently m a
as <|> :: forall a. Concurrently m a -> Concurrently m a -> Concurrently m a
<|> Concurrently m a
bs =
    m a -> Concurrently m a
forall (m :: * -> *) a. m a -> Concurrently m a
Concurrently (m a -> Concurrently m a) -> m a -> Concurrently m a
forall a b. (a -> b) -> a -> b
$ (a -> a) -> (a -> a) -> Either a a -> a
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either a -> a
forall a. a -> a
id a -> a
forall a. a -> a
id (Either a a -> a) -> m (Either a a) -> m a
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> m a -> m a -> m (Either a a)
forall (m :: * -> *) a b.
MonadConc m =>
m a -> m b -> m (Either a b)
race m a
as m a
bs

-- | @since 1.1.2.0
instance (MonadConc m, Semigroup a) => Semigroup (Concurrently m a) where
  <> :: Concurrently m a -> Concurrently m a -> Concurrently m a
(<>) = (a -> a -> a)
-> Concurrently m a -> Concurrently m a -> Concurrently m a
forall a b c.
(a -> b -> c)
-> Concurrently m a -> Concurrently m b -> Concurrently m c
forall (f :: * -> *) a b c.
Applicative f =>
(a -> b -> c) -> f a -> f b -> f c
liftA2 a -> a -> a
forall a. Semigroup a => a -> a -> a
(<>)

-- | @since 1.1.2.0
instance (MonadConc m, Monoid a) => Monoid (Concurrently m a) where
  mempty :: Concurrently m a
mempty = a -> Concurrently m a
forall a. a -> Concurrently m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure a
forall a. Monoid a => a
mempty
#if MIN_VERSION_base(4,11,0)
  mappend :: Concurrently m a -> Concurrently m a -> Concurrently m a
mappend = Concurrently m a -> Concurrently m a -> Concurrently m a
forall a. Semigroup a => a -> a -> a
(<>)
#else
  mappend = liftA2 mappend
#endif

-------------------------------------------------------------------------------
-- Spawning

-- | Spawn an asynchronous action in a separate thread.
--
-- @since 1.1.1.0
async :: MonadConc m => m a -> m (Async m a)
async :: forall (m :: * -> *) a. MonadConc m => m a -> m (Async m a)
async = (m () -> m (ThreadId m)) -> m a -> m (Async m a)
forall (m :: * -> *) a.
MonadConc m =>
(m () -> m (ThreadId m)) -> m a -> m (Async m a)
asyncUsing m () -> m (ThreadId m)
forall (m :: * -> *). MonadConc m => m () -> m (ThreadId m)
fork

-- | Like 'async', but using a named thread for better debugging information.
--
-- @since 1.2.1.0
asyncN :: MonadConc m => String -> m a -> m (Async m a)
asyncN :: forall (m :: * -> *) a.
MonadConc m =>
String -> m a -> m (Async m a)
asyncN String
name = (m () -> m (ThreadId m)) -> m a -> m (Async m a)
forall (m :: * -> *) a.
MonadConc m =>
(m () -> m (ThreadId m)) -> m a -> m (Async m a)
asyncUsing (String -> m () -> m (ThreadId m)
forall (m :: * -> *).
MonadConc m =>
String -> m () -> m (ThreadId m)
forkN String
name)

-- | Like 'async' but uses 'forkOS' internally.
--
-- @since 1.3.0.0
asyncBound :: MonadConc m => m a -> m (Async m a)
asyncBound :: forall (m :: * -> *) a. MonadConc m => m a -> m (Async m a)
asyncBound = (m () -> m (ThreadId m)) -> m a -> m (Async m a)
forall (m :: * -> *) a.
MonadConc m =>
(m () -> m (ThreadId m)) -> m a -> m (Async m a)
asyncUsing m () -> m (ThreadId m)
forall (m :: * -> *). MonadConc m => m () -> m (ThreadId m)
forkOS

-- | Like 'asyncBound', but using a named thread for better debugging
-- information.
--
-- @since 1.3.0.0
asyncBoundN :: MonadConc m => String -> m a -> m (Async m a)
asyncBoundN :: forall (m :: * -> *) a.
MonadConc m =>
String -> m a -> m (Async m a)
asyncBoundN String
name = (m () -> m (ThreadId m)) -> m a -> m (Async m a)
forall (m :: * -> *) a.
MonadConc m =>
(m () -> m (ThreadId m)) -> m a -> m (Async m a)
asyncUsing (String -> m () -> m (ThreadId m)
forall (m :: * -> *).
MonadConc m =>
String -> m () -> m (ThreadId m)
forkOSN String
name)

-- | Like 'async' but using 'forkOn' internally.
--
-- @since 1.1.1.0
asyncOn :: MonadConc m => Int -> m a -> m (Async m a)
asyncOn :: forall (m :: * -> *) a. MonadConc m => Int -> m a -> m (Async m a)
asyncOn = (m () -> m (ThreadId m)) -> m a -> m (Async m a)
forall (m :: * -> *) a.
MonadConc m =>
(m () -> m (ThreadId m)) -> m a -> m (Async m a)
asyncUsing ((m () -> m (ThreadId m)) -> m a -> m (Async m a))
-> (Int -> m () -> m (ThreadId m)) -> Int -> m a -> m (Async m a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> m () -> m (ThreadId m)
forall (m :: * -> *). MonadConc m => Int -> m () -> m (ThreadId m)
forkOn

-- | Like 'asyncOn' but using a named thread for better debugging information.
--
-- @since 1.2.1.0
asyncOnN :: MonadConc m => String -> Int -> m a -> m (Async m a)
asyncOnN :: forall (m :: * -> *) a.
MonadConc m =>
String -> Int -> m a -> m (Async m a)
asyncOnN String
name = (m () -> m (ThreadId m)) -> m a -> m (Async m a)
forall (m :: * -> *) a.
MonadConc m =>
(m () -> m (ThreadId m)) -> m a -> m (Async m a)
asyncUsing ((m () -> m (ThreadId m)) -> m a -> m (Async m a))
-> (Int -> m () -> m (ThreadId m)) -> Int -> m a -> m (Async m a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Int -> m () -> m (ThreadId m)
forall (m :: * -> *).
MonadConc m =>
String -> Int -> m () -> m (ThreadId m)
forkOnN String
name

-- | Like 'async' but using 'forkWithUnmask' internally.
--
-- @since 1.1.1.0
asyncWithUnmask :: MonadConc m => ((forall b. m b -> m b) -> m a) -> m (Async m a)
asyncWithUnmask :: forall (m :: * -> *) a.
MonadConc m =>
((forall b. m b -> m b) -> m a) -> m (Async m a)
asyncWithUnmask = (((forall b. m b -> m b) -> m ()) -> m (ThreadId m))
-> ((forall b. m b -> m b) -> m a) -> m (Async m a)
forall (m :: * -> *) a.
MonadConc m =>
(((forall b. m b -> m b) -> m ()) -> m (ThreadId m))
-> ((forall b. m b -> m b) -> m a) -> m (Async m a)
asyncUnmaskUsing ((forall b. m b -> m b) -> m ()) -> m (ThreadId m)
forall (m :: * -> *).
MonadConc m =>
((forall a. m a -> m a) -> m ()) -> m (ThreadId m)
forkWithUnmask

-- | Like 'asyncWithUnmask' but using a named thread for better debugging information.
--
-- @since 1.2.1.0
asyncWithUnmaskN :: MonadConc m => String -> ((forall b. m b -> m b) -> m a) -> m (Async m a)
asyncWithUnmaskN :: forall (m :: * -> *) a.
MonadConc m =>
String -> ((forall b. m b -> m b) -> m a) -> m (Async m a)
asyncWithUnmaskN String
name = (((forall b. m b -> m b) -> m ()) -> m (ThreadId m))
-> ((forall b. m b -> m b) -> m a) -> m (Async m a)
forall (m :: * -> *) a.
MonadConc m =>
(((forall b. m b -> m b) -> m ()) -> m (ThreadId m))
-> ((forall b. m b -> m b) -> m a) -> m (Async m a)
asyncUnmaskUsing (String -> ((forall b. m b -> m b) -> m ()) -> m (ThreadId m)
forall (m :: * -> *).
MonadConc m =>
String -> ((forall a. m a -> m a) -> m ()) -> m (ThreadId m)
forkWithUnmaskN String
name)

-- | Like 'asyncOn' but using 'forkOnWithUnmask' internally.
--
-- @since 1.1.1.0
asyncOnWithUnmask :: MonadConc m => Int -> ((forall b. m b -> m b) -> m a) -> m (Async m a)
asyncOnWithUnmask :: forall (m :: * -> *) a.
MonadConc m =>
Int -> ((forall b. m b -> m b) -> m a) -> m (Async m a)
asyncOnWithUnmask Int
i = (((forall b. m b -> m b) -> m ()) -> m (ThreadId m))
-> ((forall b. m b -> m b) -> m a) -> m (Async m a)
forall (m :: * -> *) a.
MonadConc m =>
(((forall b. m b -> m b) -> m ()) -> m (ThreadId m))
-> ((forall b. m b -> m b) -> m a) -> m (Async m a)
asyncUnmaskUsing (Int -> ((forall b. m b -> m b) -> m ()) -> m (ThreadId m)
forall (m :: * -> *).
MonadConc m =>
Int -> ((forall a. m a -> m a) -> m ()) -> m (ThreadId m)
forkOnWithUnmask Int
i)

-- | Like 'asyncOnWithUnmask' but using a named thread for better debugging information.
--
-- @since 1.2.1.0
asyncOnWithUnmaskN :: MonadConc m => String -> Int -> ((forall b. m b -> m b) -> m a) -> m (Async m a)
asyncOnWithUnmaskN :: forall (m :: * -> *) a.
MonadConc m =>
String -> Int -> ((forall b. m b -> m b) -> m a) -> m (Async m a)
asyncOnWithUnmaskN String
name Int
i = (((forall b. m b -> m b) -> m ()) -> m (ThreadId m))
-> ((forall b. m b -> m b) -> m a) -> m (Async m a)
forall (m :: * -> *) a.
MonadConc m =>
(((forall b. m b -> m b) -> m ()) -> m (ThreadId m))
-> ((forall b. m b -> m b) -> m a) -> m (Async m a)
asyncUnmaskUsing (String -> Int -> ((forall b. m b -> m b) -> m ()) -> m (ThreadId m)
forall (m :: * -> *).
MonadConc m =>
String -> Int -> ((forall a. m a -> m a) -> m ()) -> m (ThreadId m)
forkOnWithUnmaskN String
name Int
i)

-- | Fork a thread with the given forking function
asyncUsing :: MonadConc m => (m () -> m (ThreadId m)) -> m a -> m (Async m a)
asyncUsing :: forall (m :: * -> *) a.
MonadConc m =>
(m () -> m (ThreadId m)) -> m a -> m (Async m a)
asyncUsing m () -> m (ThreadId m)
doFork m a
action = do
  TMVar (STM m) (Either SomeException a)
var <- STM m (TMVar (STM m) (Either SomeException a))
-> m (TMVar (STM m) (Either SomeException a))
forall a. STM m a -> m a
forall (m :: * -> *) a. MonadConc m => STM m a -> m a
atomically STM m (TMVar (STM m) (Either SomeException a))
forall (stm :: * -> *) a. MonadSTM stm => stm (TMVar stm a)
newEmptyTMVar
  ThreadId m
tid <- ((forall a. m a -> m a) -> m (ThreadId m)) -> m (ThreadId m)
forall (m :: * -> *) b.
MonadConc m =>
((forall a. m a -> m a) -> m b) -> m b
mask (((forall a. m a -> m a) -> m (ThreadId m)) -> m (ThreadId m))
-> ((forall a. m a -> m a) -> m (ThreadId m)) -> m (ThreadId m)
forall a b. (a -> b) -> a -> b
$ \forall a. m a -> m a
restore -> m () -> m (ThreadId m)
doFork (m () -> m (ThreadId m)) -> m () -> m (ThreadId m)
forall a b. (a -> b) -> a -> b
$ m a -> m (Either SomeException a)
forall (m :: * -> *) e a.
(HasCallStack, MonadCatch m, Exception e) =>
m a -> m (Either e a)
try (m a -> m a
forall a. m a -> m a
restore m a
action) m (Either SomeException a)
-> (Either SomeException a -> m ()) -> m ()
forall a b. m a -> (a -> m b) -> m b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= STM m () -> m ()
forall a. STM m a -> m a
forall (m :: * -> *) a. MonadConc m => STM m a -> m a
atomically (STM m () -> m ())
-> (Either SomeException a -> STM m ())
-> Either SomeException a
-> m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TMVar (STM m) (Either SomeException a)
-> Either SomeException a -> STM m ()
forall (stm :: * -> *) a.
MonadSTM stm =>
TMVar stm a -> a -> stm ()
putTMVar TMVar (STM m) (Either SomeException a)
var
  Async m a -> m (Async m a)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ThreadId m -> STM m (Either SomeException a) -> Async m a
forall (m :: * -> *) a.
ThreadId m -> STM m (Either SomeException a) -> Async m a
Async ThreadId m
tid (TMVar (STM m) (Either SomeException a)
-> STM m (Either SomeException a)
forall (stm :: * -> *) a. MonadSTM stm => TMVar stm a -> stm a
readTMVar TMVar (STM m) (Either SomeException a)
var))

-- | Fork a thread with the given forking function and give it an
-- action to unmask exceptions
asyncUnmaskUsing :: MonadConc m => (((forall b. m b -> m b) -> m ()) -> m (ThreadId m)) -> ((forall b. m b -> m b) -> m a) -> m (Async m a)
asyncUnmaskUsing :: forall (m :: * -> *) a.
MonadConc m =>
(((forall b. m b -> m b) -> m ()) -> m (ThreadId m))
-> ((forall b. m b -> m b) -> m a) -> m (Async m a)
asyncUnmaskUsing ((forall b. m b -> m b) -> m ()) -> m (ThreadId m)
doFork (forall b. m b -> m b) -> m a
action = do
  TMVar (STM m) (Either SomeException a)
var <- STM m (TMVar (STM m) (Either SomeException a))
-> m (TMVar (STM m) (Either SomeException a))
forall a. STM m a -> m a
forall (m :: * -> *) a. MonadConc m => STM m a -> m a
atomically STM m (TMVar (STM m) (Either SomeException a))
forall (stm :: * -> *) a. MonadSTM stm => stm (TMVar stm a)
newEmptyTMVar
  ThreadId m
tid <- ((forall b. m b -> m b) -> m ()) -> m (ThreadId m)
doFork (((forall b. m b -> m b) -> m ()) -> m (ThreadId m))
-> ((forall b. m b -> m b) -> m ()) -> m (ThreadId m)
forall a b. (a -> b) -> a -> b
$ \forall b. m b -> m b
restore -> m a -> m (Either SomeException a)
forall (m :: * -> *) e a.
(HasCallStack, MonadCatch m, Exception e) =>
m a -> m (Either e a)
try ((forall b. m b -> m b) -> m a
action m b -> m b
forall b. m b -> m b
restore) m (Either SomeException a)
-> (Either SomeException a -> m ()) -> m ()
forall a b. m a -> (a -> m b) -> m b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= STM m () -> m ()
forall a. STM m a -> m a
forall (m :: * -> *) a. MonadConc m => STM m a -> m a
atomically (STM m () -> m ())
-> (Either SomeException a -> STM m ())
-> Either SomeException a
-> m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TMVar (STM m) (Either SomeException a)
-> Either SomeException a -> STM m ()
forall (stm :: * -> *) a.
MonadSTM stm =>
TMVar stm a -> a -> stm ()
putTMVar TMVar (STM m) (Either SomeException a)
var
  Async m a -> m (Async m a)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ThreadId m -> STM m (Either SomeException a) -> Async m a
forall (m :: * -> *) a.
ThreadId m -> STM m (Either SomeException a) -> Async m a
Async ThreadId m
tid (TMVar (STM m) (Either SomeException a)
-> STM m (Either SomeException a)
forall (stm :: * -> *) a. MonadSTM stm => TMVar stm a -> stm a
readTMVar TMVar (STM m) (Either SomeException a)
var))

-- | Spawn an asynchronous action in a separate thread, and pass its
-- @Async@ handle to the supplied function. When the function returns
-- or throws an exception, 'uninterruptibleCancel' is called on the @Async@.
--
-- > withAsync action inner = bracket (async action) uninterruptiblCancel inner
--
-- This is a useful variant of 'async' that ensures an @Async@ is
-- never left running unintentionally.
--
-- Since 'uninterruptibleCancel' may block, 'withAsync' may also
-- block; see 'uninterruptibleCancel' for details.
--
-- @since 1.1.1.0
withAsync :: MonadConc m => m a -> (Async m a -> m b) -> m b
withAsync :: forall (m :: * -> *) a b.
MonadConc m =>
m a -> (Async m a -> m b) -> m b
withAsync = (m () -> m (ThreadId m)) -> m a -> (Async m a -> m b) -> m b
forall (m :: * -> *) a b.
MonadConc m =>
(m () -> m (ThreadId m)) -> m a -> (Async m a -> m b) -> m b
withAsyncUsing m () -> m (ThreadId m)
forall (m :: * -> *). MonadConc m => m () -> m (ThreadId m)
fork

-- | Like 'withAsync' but using a named thread for better debugging
-- information.
--
-- @since 1.2.3.0
withAsyncN :: MonadConc m => String -> m a -> (Async m a -> m b) -> m b
withAsyncN :: forall (m :: * -> *) a b.
MonadConc m =>
String -> m a -> (Async m a -> m b) -> m b
withAsyncN String
name = (m () -> m (ThreadId m)) -> m a -> (Async m a -> m b) -> m b
forall (m :: * -> *) a b.
MonadConc m =>
(m () -> m (ThreadId m)) -> m a -> (Async m a -> m b) -> m b
withAsyncUsing (String -> m () -> m (ThreadId m)
forall (m :: * -> *).
MonadConc m =>
String -> m () -> m (ThreadId m)
forkN String
name)

-- | Like 'withAsync' but uses 'forkOS' internally.
--
-- @since 1.3.0.0
withAsyncBound :: MonadConc m => m a -> (Async m a -> m b) -> m b
withAsyncBound :: forall (m :: * -> *) a b.
MonadConc m =>
m a -> (Async m a -> m b) -> m b
withAsyncBound = (m () -> m (ThreadId m)) -> m a -> (Async m a -> m b) -> m b
forall (m :: * -> *) a b.
MonadConc m =>
(m () -> m (ThreadId m)) -> m a -> (Async m a -> m b) -> m b
withAsyncUsing m () -> m (ThreadId m)
forall (m :: * -> *). MonadConc m => m () -> m (ThreadId m)
forkOS

-- | Like 'withAsyncBound' but using a named thread for better
-- debugging information.
--
-- @since 1.3.0.0
withAsyncBoundN :: MonadConc m => String -> m a -> (Async m a -> m b) -> m b
withAsyncBoundN :: forall (m :: * -> *) a b.
MonadConc m =>
String -> m a -> (Async m a -> m b) -> m b
withAsyncBoundN String
name = (m () -> m (ThreadId m)) -> m a -> (Async m a -> m b) -> m b
forall (m :: * -> *) a b.
MonadConc m =>
(m () -> m (ThreadId m)) -> m a -> (Async m a -> m b) -> m b
withAsyncUsing (String -> m () -> m (ThreadId m)
forall (m :: * -> *).
MonadConc m =>
String -> m () -> m (ThreadId m)
forkOSN String
name)

-- | Like 'withAsync' but uses 'forkOn' internally.
--
-- @since 1.1.1.0
withAsyncOn :: MonadConc m => Int -> m a -> (Async m a -> m b) -> m b
withAsyncOn :: forall (m :: * -> *) a b.
MonadConc m =>
Int -> m a -> (Async m a -> m b) -> m b
withAsyncOn = (m () -> m (ThreadId m)) -> m a -> (Async m a -> m b) -> m b
forall (m :: * -> *) a b.
MonadConc m =>
(m () -> m (ThreadId m)) -> m a -> (Async m a -> m b) -> m b
withAsyncUsing ((m () -> m (ThreadId m)) -> m a -> (Async m a -> m b) -> m b)
-> (Int -> m () -> m (ThreadId m))
-> Int
-> m a
-> (Async m a -> m b)
-> m b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> m () -> m (ThreadId m)
forall (m :: * -> *). MonadConc m => Int -> m () -> m (ThreadId m)
forkOn

-- | Like 'withAsyncOn' but using a named thread for better debugging
-- information.
--
-- @since 1.2.3.0
withAsyncOnN :: MonadConc m => String -> Int -> m a -> (Async m a -> m b) -> m b
withAsyncOnN :: forall (m :: * -> *) a b.
MonadConc m =>
String -> Int -> m a -> (Async m a -> m b) -> m b
withAsyncOnN String
name Int
i = (m () -> m (ThreadId m)) -> m a -> (Async m a -> m b) -> m b
forall (m :: * -> *) a b.
MonadConc m =>
(m () -> m (ThreadId m)) -> m a -> (Async m a -> m b) -> m b
withAsyncUsing (String -> Int -> m () -> m (ThreadId m)
forall (m :: * -> *).
MonadConc m =>
String -> Int -> m () -> m (ThreadId m)
forkOnN String
name Int
i)

-- | Like 'withAsync' bit uses 'forkWithUnmask' internally.
--
-- @since 1.1.1.0
withAsyncWithUnmask :: MonadConc m => ((forall x. m x -> m x) -> m a) -> (Async m a -> m b) -> m b
withAsyncWithUnmask :: forall (m :: * -> *) a b.
MonadConc m =>
((forall x. m x -> m x) -> m a) -> (Async m a -> m b) -> m b
withAsyncWithUnmask = (((forall x. m x -> m x) -> m ()) -> m (ThreadId m))
-> ((forall x. m x -> m x) -> m a) -> (Async m a -> m b) -> m b
forall (m :: * -> *) a b.
MonadConc m =>
(((forall x. m x -> m x) -> m ()) -> m (ThreadId m))
-> ((forall x. m x -> m x) -> m a) -> (Async m a -> m b) -> m b
withAsyncUnmaskUsing ((forall x. m x -> m x) -> m ()) -> m (ThreadId m)
forall (m :: * -> *).
MonadConc m =>
((forall a. m a -> m a) -> m ()) -> m (ThreadId m)
forkWithUnmask

-- | Like 'withAsyncWithUnmask' but using a named thread for better
-- debugging information.
--
-- @since 1.2.3.0
withAsyncWithUnmaskN :: MonadConc m => String -> ((forall x. m x -> m x) -> m a) -> (Async m a -> m b) -> m b
withAsyncWithUnmaskN :: forall (m :: * -> *) a b.
MonadConc m =>
String
-> ((forall x. m x -> m x) -> m a) -> (Async m a -> m b) -> m b
withAsyncWithUnmaskN String
name = (((forall x. m x -> m x) -> m ()) -> m (ThreadId m))
-> ((forall x. m x -> m x) -> m a) -> (Async m a -> m b) -> m b
forall (m :: * -> *) a b.
MonadConc m =>
(((forall x. m x -> m x) -> m ()) -> m (ThreadId m))
-> ((forall x. m x -> m x) -> m a) -> (Async m a -> m b) -> m b
withAsyncUnmaskUsing (String -> ((forall x. m x -> m x) -> m ()) -> m (ThreadId m)
forall (m :: * -> *).
MonadConc m =>
String -> ((forall a. m a -> m a) -> m ()) -> m (ThreadId m)
forkWithUnmaskN String
name)

-- | Like 'withAsyncOn' bit uses 'forkOnWithUnmask' internally.
--
-- @since 1.1.1.0
withAsyncOnWithUnmask :: MonadConc m => Int -> ((forall x. m x -> m x) -> m a) -> (Async m a -> m b) -> m b
withAsyncOnWithUnmask :: forall (m :: * -> *) a b.
MonadConc m =>
Int -> ((forall x. m x -> m x) -> m a) -> (Async m a -> m b) -> m b
withAsyncOnWithUnmask Int
i = (((forall x. m x -> m x) -> m ()) -> m (ThreadId m))
-> ((forall x. m x -> m x) -> m a) -> (Async m a -> m b) -> m b
forall (m :: * -> *) a b.
MonadConc m =>
(((forall x. m x -> m x) -> m ()) -> m (ThreadId m))
-> ((forall x. m x -> m x) -> m a) -> (Async m a -> m b) -> m b
withAsyncUnmaskUsing (Int -> ((forall x. m x -> m x) -> m ()) -> m (ThreadId m)
forall (m :: * -> *).
MonadConc m =>
Int -> ((forall a. m a -> m a) -> m ()) -> m (ThreadId m)
forkOnWithUnmask Int
i)

-- | Like 'withAsyncOnWithUnmask' but using a named thread for better
-- debugging information.
--
-- @since 1.2.3.0
withAsyncOnWithUnmaskN :: MonadConc m
  => String -> Int -> ((forall x. m x -> m x) -> m a) -> (Async m a -> m b) -> m b
withAsyncOnWithUnmaskN :: forall (m :: * -> *) a b.
MonadConc m =>
String
-> Int
-> ((forall x. m x -> m x) -> m a)
-> (Async m a -> m b)
-> m b
withAsyncOnWithUnmaskN String
name Int
i = (((forall x. m x -> m x) -> m ()) -> m (ThreadId m))
-> ((forall x. m x -> m x) -> m a) -> (Async m a -> m b) -> m b
forall (m :: * -> *) a b.
MonadConc m =>
(((forall x. m x -> m x) -> m ()) -> m (ThreadId m))
-> ((forall x. m x -> m x) -> m a) -> (Async m a -> m b) -> m b
withAsyncUnmaskUsing (String -> Int -> ((forall x. m x -> m x) -> m ()) -> m (ThreadId m)
forall (m :: * -> *).
MonadConc m =>
String -> Int -> ((forall a. m a -> m a) -> m ()) -> m (ThreadId m)
forkOnWithUnmaskN String
name Int
i)

-- | Helper for 'withAsync' and 'withAsyncOn': fork a thread with the
-- given forking function and kill it when the inner action completes.
withAsyncUsing :: MonadConc m => (m () -> m (ThreadId m)) -> m a -> (Async m a -> m b) -> m b
withAsyncUsing :: forall (m :: * -> *) a b.
MonadConc m =>
(m () -> m (ThreadId m)) -> m a -> (Async m a -> m b) -> m b
withAsyncUsing m () -> m (ThreadId m)
doFork m a
action Async m a -> m b
inner = do
  TMVar (STM m) (Either SomeException a)
var <- STM m (TMVar (STM m) (Either SomeException a))
-> m (TMVar (STM m) (Either SomeException a))
forall a. STM m a -> m a
forall (m :: * -> *) a. MonadConc m => STM m a -> m a
atomically STM m (TMVar (STM m) (Either SomeException a))
forall (stm :: * -> *) a. MonadSTM stm => stm (TMVar stm a)
newEmptyTMVar
  ThreadId m
tid <- ((forall a. m a -> m a) -> m (ThreadId m)) -> m (ThreadId m)
forall (m :: * -> *) b.
MonadConc m =>
((forall a. m a -> m a) -> m b) -> m b
mask (((forall a. m a -> m a) -> m (ThreadId m)) -> m (ThreadId m))
-> ((forall a. m a -> m a) -> m (ThreadId m)) -> m (ThreadId m)
forall a b. (a -> b) -> a -> b
$ \forall a. m a -> m a
restore -> m () -> m (ThreadId m)
doFork (m () -> m (ThreadId m)) -> m () -> m (ThreadId m)
forall a b. (a -> b) -> a -> b
$ m a -> m (Either SomeException a)
forall (m :: * -> *) e a.
(HasCallStack, MonadCatch m, Exception e) =>
m a -> m (Either e a)
try (m a -> m a
forall a. m a -> m a
restore m a
action) m (Either SomeException a)
-> (Either SomeException a -> m ()) -> m ()
forall a b. m a -> (a -> m b) -> m b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= STM m () -> m ()
forall a. STM m a -> m a
forall (m :: * -> *) a. MonadConc m => STM m a -> m a
atomically (STM m () -> m ())
-> (Either SomeException a -> STM m ())
-> Either SomeException a
-> m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TMVar (STM m) (Either SomeException a)
-> Either SomeException a -> STM m ()
forall (stm :: * -> *) a.
MonadSTM stm =>
TMVar stm a -> a -> stm ()
putTMVar TMVar (STM m) (Either SomeException a)
var
  Async m a -> (Async m a -> m b) -> m b
forall (m :: * -> *) a b.
MonadConc m =>
Async m a -> (Async m a -> m b) -> m b
withAsyncDo (ThreadId m -> STM m (Either SomeException a) -> Async m a
forall (m :: * -> *) a.
ThreadId m -> STM m (Either SomeException a) -> Async m a
Async ThreadId m
tid (TMVar (STM m) (Either SomeException a)
-> STM m (Either SomeException a)
forall (stm :: * -> *) a. MonadSTM stm => TMVar stm a -> stm a
readTMVar TMVar (STM m) (Either SomeException a)
var)) Async m a -> m b
inner

-- | Helper for 'withAsyncWithUnmask' and 'withAsyncOnWithUnmask':
-- fork a thread with the given forking function, give it an action to
-- unmask exceptions, and kill it when the inner action completed.
withAsyncUnmaskUsing :: MonadConc m => (((forall x. m x -> m x) -> m ()) -> m (ThreadId m)) -> ((forall x. m x -> m x) -> m a) -> (Async m a -> m b) -> m b
withAsyncUnmaskUsing :: forall (m :: * -> *) a b.
MonadConc m =>
(((forall x. m x -> m x) -> m ()) -> m (ThreadId m))
-> ((forall x. m x -> m x) -> m a) -> (Async m a -> m b) -> m b
withAsyncUnmaskUsing ((forall x. m x -> m x) -> m ()) -> m (ThreadId m)
doFork (forall x. m x -> m x) -> m a
action Async m a -> m b
inner = do
  TMVar (STM m) (Either SomeException a)
var <- STM m (TMVar (STM m) (Either SomeException a))
-> m (TMVar (STM m) (Either SomeException a))
forall a. STM m a -> m a
forall (m :: * -> *) a. MonadConc m => STM m a -> m a
atomically STM m (TMVar (STM m) (Either SomeException a))
forall (stm :: * -> *) a. MonadSTM stm => stm (TMVar stm a)
newEmptyTMVar
  ThreadId m
tid <- ((forall x. m x -> m x) -> m ()) -> m (ThreadId m)
doFork (((forall x. m x -> m x) -> m ()) -> m (ThreadId m))
-> ((forall x. m x -> m x) -> m ()) -> m (ThreadId m)
forall a b. (a -> b) -> a -> b
$ \forall x. m x -> m x
restore -> m a -> m (Either SomeException a)
forall (m :: * -> *) e a.
(HasCallStack, MonadCatch m, Exception e) =>
m a -> m (Either e a)
try ((forall x. m x -> m x) -> m a
action m x -> m x
forall x. m x -> m x
restore) m (Either SomeException a)
-> (Either SomeException a -> m ()) -> m ()
forall a b. m a -> (a -> m b) -> m b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= STM m () -> m ()
forall a. STM m a -> m a
forall (m :: * -> *) a. MonadConc m => STM m a -> m a
atomically (STM m () -> m ())
-> (Either SomeException a -> STM m ())
-> Either SomeException a
-> m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TMVar (STM m) (Either SomeException a)
-> Either SomeException a -> STM m ()
forall (stm :: * -> *) a.
MonadSTM stm =>
TMVar stm a -> a -> stm ()
putTMVar TMVar (STM m) (Either SomeException a)
var
  Async m a -> (Async m a -> m b) -> m b
forall (m :: * -> *) a b.
MonadConc m =>
Async m a -> (Async m a -> m b) -> m b
withAsyncDo (ThreadId m -> STM m (Either SomeException a) -> Async m a
forall (m :: * -> *) a.
ThreadId m -> STM m (Either SomeException a) -> Async m a
Async ThreadId m
tid (TMVar (STM m) (Either SomeException a)
-> STM m (Either SomeException a)
forall (stm :: * -> *) a. MonadSTM stm => TMVar stm a -> stm a
readTMVar TMVar (STM m) (Either SomeException a)
var)) Async m a -> m b
inner

-- | Helper for 'withAsyncUsing' and 'withAsyncUnmaskUsing': run the
-- inner action and kill the async thread when done.
withAsyncDo :: MonadConc m => Async m a -> (Async m a -> m b) -> m b
withAsyncDo :: forall (m :: * -> *) a b.
MonadConc m =>
Async m a -> (Async m a -> m b) -> m b
withAsyncDo Async m a
a Async m a -> m b
inner = do
  b
res <- Async m a -> m b
inner Async m a
a m b -> (SomeException -> m b) -> m b
forall (m :: * -> *) a.
MonadConc m =>
m a -> (SomeException -> m a) -> m a
`catchAll` (\SomeException
e -> Async m a -> m ()
forall (m :: * -> *) a. MonadConc m => Async m a -> m ()
uninterruptibleCancel Async m a
a m () -> m b -> m b
forall a b. m a -> m b -> m b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> SomeException -> m b
forall (m :: * -> *) e a. (MonadConc m, Exception e) => e -> m a
throw SomeException
e)
  Async m a -> m ()
forall (m :: * -> *) a. MonadConc m => Async m a -> m ()
cancel Async m a
a
  b -> m b
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure b
res

catchAll :: MonadConc m => m a -> (SomeException -> m a) -> m a
catchAll :: forall (m :: * -> *) a.
MonadConc m =>
m a -> (SomeException -> m a) -> m a
catchAll = m a -> (SomeException -> m a) -> m a
forall (m :: * -> *) e a.
(MonadConc m, Exception e) =>
m a -> (e -> m a) -> m a
catch

-------------------------------------------------------------------------------
-- Querying

-- | Wait for an asynchronous action to complete, and return its
-- value. If the asynchronous value threw an exception, then the
-- exception is re-thrown by 'wait'.
--
-- > wait = atomically . waitSTM
--
-- @since 1.1.1.0
wait :: MonadConc m => Async m a -> m a
wait :: forall (m :: * -> *) a. MonadConc m => Async m a -> m a
wait = STM m a -> m a
forall a. STM m a -> m a
forall (m :: * -> *) a. MonadConc m => STM m a -> m a
atomically (STM m a -> m a) -> (Async m a -> STM m a) -> Async m a -> m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Async m a -> STM m a
forall (m :: * -> *) a. MonadConc m => Async m a -> STM m a
waitSTM

-- | A version of 'wait' that can be used inside a @MonadSTM@ transaction.
--
-- @since 1.1.1.0
waitSTM :: MonadConc m => Async m a -> STM m a
waitSTM :: forall (m :: * -> *) a. MonadConc m => Async m a -> STM m a
waitSTM Async m a
a = do
 Either SomeException a
r <- Async m a -> STM m (Either SomeException a)
forall (m :: * -> *) a.
MonadConc m =>
Async m a -> STM m (Either SomeException a)
waitCatchSTM Async m a
a
 (SomeException -> STM m a)
-> (a -> STM m a) -> Either SomeException a -> STM m a
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either SomeException -> STM m a
forall (stm :: * -> *) e a.
(MonadSTM stm, Exception e) =>
e -> stm a
throwSTM a -> STM m a
forall a. a -> STM m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Either SomeException a
r

-- | Check whether an 'Async' has completed yet. If it has not
-- completed yet, then the result is @Nothing@, otherwise the result
-- is @Just e@ where @e@ is @Left x@ if the @Async@ raised an
-- exception @x@, or @Right a@ if it returned a value @a@.
--
-- > poll = atomically . pollSTM
--
-- @since 1.1.1.0
poll :: MonadConc m => Async m a -> m (Maybe (Either SomeException a))
poll :: forall (m :: * -> *) a.
MonadConc m =>
Async m a -> m (Maybe (Either SomeException a))
poll = STM m (Maybe (Either SomeException a))
-> m (Maybe (Either SomeException a))
forall a. STM m a -> m a
forall (m :: * -> *) a. MonadConc m => STM m a -> m a
atomically (STM m (Maybe (Either SomeException a))
 -> m (Maybe (Either SomeException a)))
-> (Async m a -> STM m (Maybe (Either SomeException a)))
-> Async m a
-> m (Maybe (Either SomeException a))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Async m a -> STM m (Maybe (Either SomeException a))
forall (m :: * -> *) a.
MonadConc m =>
Async m a -> STM m (Maybe (Either SomeException a))
pollSTM

-- | A version of 'poll' that can be used inside a @MonadSTM@ transaction.
--
-- @since 1.1.1.0
pollSTM :: MonadConc m => Async m a -> STM m (Maybe (Either SomeException a))
pollSTM :: forall (m :: * -> *) a.
MonadConc m =>
Async m a -> STM m (Maybe (Either SomeException a))
pollSTM (Async ThreadId m
_ STM m (Either SomeException a)
w) = (Either SomeException a -> Maybe (Either SomeException a)
forall a. a -> Maybe a
Just (Either SomeException a -> Maybe (Either SomeException a))
-> STM m (Either SomeException a)
-> STM m (Maybe (Either SomeException a))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> STM m (Either SomeException a)
w) STM m (Maybe (Either SomeException a))
-> STM m (Maybe (Either SomeException a))
-> STM m (Maybe (Either SomeException a))
forall (stm :: * -> *) a. MonadSTM stm => stm a -> stm a -> stm a
`orElse` Maybe (Either SomeException a)
-> STM m (Maybe (Either SomeException a))
forall a. a -> STM m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe (Either SomeException a)
forall a. Maybe a
Nothing

-- | Wait for an asynchronous action to complete, and return either
-- @Left e@ if the action raised an exception @e@, or @Right a@ if it
-- returned a value @a@.
--
-- @since 1.1.1.0
waitCatch :: MonadConc m => Async m a -> m (Either SomeException a)
waitCatch :: forall (m :: * -> *) a.
MonadConc m =>
Async m a -> m (Either SomeException a)
waitCatch = m (Either SomeException a) -> m (Either SomeException a)
forall {m :: * -> *} {a}. MonadConc m => m a -> m a
tryAgain (m (Either SomeException a) -> m (Either SomeException a))
-> (Async m a -> m (Either SomeException a))
-> Async m a
-> m (Either SomeException a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. STM m (Either SomeException a) -> m (Either SomeException a)
forall a. STM m a -> m a
forall (m :: * -> *) a. MonadConc m => STM m a -> m a
atomically (STM m (Either SomeException a) -> m (Either SomeException a))
-> (Async m a -> STM m (Either SomeException a))
-> Async m a
-> m (Either SomeException a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Async m a -> STM m (Either SomeException a)
forall (m :: * -> *) a.
MonadConc m =>
Async m a -> STM m (Either SomeException a)
waitCatchSTM where
  -- See: https://github.com/simonmar/async/issues/14
  tryAgain :: m a -> m a
tryAgain m a
f = m a
f m a -> (BlockedIndefinitelyOnSTM -> m a) -> m a
forall (m :: * -> *) e a.
(MonadConc m, Exception e) =>
m a -> (e -> m a) -> m a
`catch` \BlockedIndefinitelyOnSTM
BlockedIndefinitelyOnSTM -> m a
f

-- | A version of 'waitCatch' that can be used inside a @MonadSTM@ transaction.
--
-- @since 1.1.1.0
waitCatchSTM :: MonadConc m => Async m a -> STM m (Either SomeException a)
waitCatchSTM :: forall (m :: * -> *) a.
MonadConc m =>
Async m a -> STM m (Either SomeException a)
waitCatchSTM (Async ThreadId m
_ STM m (Either SomeException a)
w) = STM m (Either SomeException a)
w

-- | Cancel an asynchronous action by throwing the @ThreadKilled@
-- exception to it, and waiting for the 'Async' thread to quit. Has no
-- effect if the 'Async' has already completed.
--
-- > cancel a = throwTo (asyncThreadId a) ThreadKilled <* waitCatch a
--
-- Note that 'cancel' will not terminate until the thread the 'Async'
-- refers to has terminated. This means that 'cancel' will block for
-- as long as said thread blocks when receiving an asynchronous
-- exception.
--
-- An asynchronous 'cancel' can of course be obtained by wrapping
-- 'cancel' itself in 'async'.
--
-- @since 1.1.1.0
cancel :: MonadConc m => Async m a -> m ()
cancel :: forall (m :: * -> *) a. MonadConc m => Async m a -> m ()
cancel a :: Async m a
a@(Async ThreadId m
tid STM m (Either SomeException a)
_) = ThreadId m -> AsyncException -> m ()
forall e. Exception e => ThreadId m -> e -> m ()
forall (m :: * -> *) e.
(MonadConc m, Exception e) =>
ThreadId m -> e -> m ()
throwTo ThreadId m
tid AsyncException
ThreadKilled m () -> m (Either SomeException a) -> m ()
forall a b. m a -> m b -> m a
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* Async m a -> m (Either SomeException a)
forall (m :: * -> *) a.
MonadConc m =>
Async m a -> m (Either SomeException a)
waitCatch Async m a
a

-- | Cancel an asynchronous action.
--
-- This is a variant of 'cancel' but it is not interruptible.
--
-- @since 1.1.2.0
uninterruptibleCancel :: MonadConc m => Async m a -> m ()
uninterruptibleCancel :: forall (m :: * -> *) a. MonadConc m => Async m a -> m ()
uninterruptibleCancel = m () -> m ()
forall (m :: * -> *) a. (HasCallStack, MonadMask m) => m a -> m a
uninterruptibleMask_ (m () -> m ()) -> (Async m a -> m ()) -> Async m a -> m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Async m a -> m ()
forall (m :: * -> *) a. MonadConc m => Async m a -> m ()
cancel

-- | Cancel an asynchronous action by throwing the supplied exception
-- to it.
--
-- > cancelWith a e = throwTo (asyncThreadId a) e
--
-- The notes about the synchronous nature of 'cancel' also apply to
-- 'cancelWith'.
--
-- @since 1.1.1.0
cancelWith :: (MonadConc m, Exception e) => Async m a -> e -> m ()
cancelWith :: forall (m :: * -> *) e a.
(MonadConc m, Exception e) =>
Async m a -> e -> m ()
cancelWith (Async ThreadId m
tid STM m (Either SomeException a)
_) = ThreadId m -> e -> m ()
forall e. Exception e => ThreadId m -> e -> m ()
forall (m :: * -> *) e.
(MonadConc m, Exception e) =>
ThreadId m -> e -> m ()
throwTo ThreadId m
tid


-------------------------------------------------------------------------------
-- Waiting for multiple 'Async's

-- | Wait for any of the supplied 'Async's to complete.  If the first
-- to complete throws an exception, then that exception is re-thrown
-- by 'waitAny'.
--
-- If multiple 'Async's complete or have completed, then the value
-- returned corresponds to the first completed 'Async' in the list.
--
-- @since 1.1.1.0
waitAny :: MonadConc m => [Async m a] -> m (Async m a, a)
waitAny :: forall (m :: * -> *) a.
MonadConc m =>
[Async m a] -> m (Async m a, a)
waitAny = STM m (Async m a, a) -> m (Async m a, a)
forall a. STM m a -> m a
forall (m :: * -> *) a. MonadConc m => STM m a -> m a
atomically (STM m (Async m a, a) -> m (Async m a, a))
-> ([Async m a] -> STM m (Async m a, a))
-> [Async m a]
-> m (Async m a, a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Async m a] -> STM m (Async m a, a)
forall (m :: * -> *) a.
MonadConc m =>
[Async m a] -> STM m (Async m a, a)
waitAnySTM

-- | A version of 'waitAny' that can be used inside a @MonadSTM@
-- transaction.
--
-- @since 1.1.1.0
waitAnySTM :: MonadConc m => [Async m a] -> STM m (Async m a, a)
waitAnySTM :: forall (m :: * -> *) a.
MonadConc m =>
[Async m a] -> STM m (Async m a, a)
waitAnySTM = (Async m a -> STM m (Async m a, a) -> STM m (Async m a, a))
-> STM m (Async m a, a) -> [Async m a] -> STM m (Async m a, a)
forall a b. (a -> b -> b) -> b -> [a] -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (STM m (Async m a, a)
-> STM m (Async m a, a) -> STM m (Async m a, a)
forall (stm :: * -> *) a. MonadSTM stm => stm a -> stm a -> stm a
orElse (STM m (Async m a, a)
 -> STM m (Async m a, a) -> STM m (Async m a, a))
-> (Async m a -> STM m (Async m a, a))
-> Async m a
-> STM m (Async m a, a)
-> STM m (Async m a, a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (\Async m a
a -> do a
r <- Async m a -> STM m a
forall (m :: * -> *) a. MonadConc m => Async m a -> STM m a
waitSTM Async m a
a; (Async m a, a) -> STM m (Async m a, a)
forall a. a -> STM m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Async m a
a, a
r))) STM m (Async m a, a)
forall (stm :: * -> *) a. MonadSTM stm => stm a
retry

-- | Wait for any of the supplied asynchronous operations to complete.
-- The value returned is a pair of the 'Async' that completed, and the
-- result that would be returned by 'wait' on that 'Async'.
--
-- If multiple 'Async's complete or have completed, then the value
-- returned corresponds to the first completed 'Async' in the list.
--
-- @since 1.1.1.0
waitAnyCatch :: MonadConc m => [Async m a] -> m (Async m a, Either SomeException a)
waitAnyCatch :: forall (m :: * -> *) a.
MonadConc m =>
[Async m a] -> m (Async m a, Either SomeException a)
waitAnyCatch = STM m (Async m a, Either SomeException a)
-> m (Async m a, Either SomeException a)
forall a. STM m a -> m a
forall (m :: * -> *) a. MonadConc m => STM m a -> m a
atomically (STM m (Async m a, Either SomeException a)
 -> m (Async m a, Either SomeException a))
-> ([Async m a] -> STM m (Async m a, Either SomeException a))
-> [Async m a]
-> m (Async m a, Either SomeException a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Async m a] -> STM m (Async m a, Either SomeException a)
forall (m :: * -> *) a.
MonadConc m =>
[Async m a] -> STM m (Async m a, Either SomeException a)
waitAnyCatchSTM

-- | A version of 'waitAnyCatch' that can be used inside a @MonadSTM@
-- transaction.
--
-- @since 1.1.1.0
waitAnyCatchSTM :: MonadConc m => [Async m a] -> STM m (Async m a, Either SomeException a)
waitAnyCatchSTM :: forall (m :: * -> *) a.
MonadConc m =>
[Async m a] -> STM m (Async m a, Either SomeException a)
waitAnyCatchSTM = (Async m a
 -> STM m (Async m a, Either SomeException a)
 -> STM m (Async m a, Either SomeException a))
-> STM m (Async m a, Either SomeException a)
-> [Async m a]
-> STM m (Async m a, Either SomeException a)
forall a b. (a -> b -> b) -> b -> [a] -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (STM m (Async m a, Either SomeException a)
-> STM m (Async m a, Either SomeException a)
-> STM m (Async m a, Either SomeException a)
forall (stm :: * -> *) a. MonadSTM stm => stm a -> stm a -> stm a
orElse (STM m (Async m a, Either SomeException a)
 -> STM m (Async m a, Either SomeException a)
 -> STM m (Async m a, Either SomeException a))
-> (Async m a -> STM m (Async m a, Either SomeException a))
-> Async m a
-> STM m (Async m a, Either SomeException a)
-> STM m (Async m a, Either SomeException a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (\Async m a
a -> do Either SomeException a
r <- Async m a -> STM m (Either SomeException a)
forall (m :: * -> *) a.
MonadConc m =>
Async m a -> STM m (Either SomeException a)
waitCatchSTM Async m a
a; (Async m a, Either SomeException a)
-> STM m (Async m a, Either SomeException a)
forall a. a -> STM m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Async m a
a, Either SomeException a
r))) STM m (Async m a, Either SomeException a)
forall (stm :: * -> *) a. MonadSTM stm => stm a
retry

-- | Like 'waitAny', but also cancels the other asynchronous
-- operations as soon as one has completed.
--
-- @since 1.1.1.0
waitAnyCancel :: MonadConc m => [Async m a] -> m (Async m a, a)
waitAnyCancel :: forall (m :: * -> *) a.
MonadConc m =>
[Async m a] -> m (Async m a, a)
waitAnyCancel [Async m a]
asyncs = [Async m a] -> m (Async m a, a)
forall (m :: * -> *) a.
MonadConc m =>
[Async m a] -> m (Async m a, a)
waitAny [Async m a]
asyncs m (Async m a, a) -> m () -> m (Async m a, a)
forall (m :: * -> *) a b.
(HasCallStack, MonadMask m) =>
m a -> m b -> m a
`finally` (Async m a -> m ()) -> [Async m a] -> m ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ Async m a -> m ()
forall (m :: * -> *) a. MonadConc m => Async m a -> m ()
cancel [Async m a]
asyncs

-- | Like 'waitAnyCatch', but also cancels the other asynchronous
-- operations as soon as one has completed.
--
-- @since 1.1.1.0
waitAnyCatchCancel :: MonadConc m => [Async m a] -> m (Async m a, Either SomeException a)
waitAnyCatchCancel :: forall (m :: * -> *) a.
MonadConc m =>
[Async m a] -> m (Async m a, Either SomeException a)
waitAnyCatchCancel [Async m a]
asyncs = [Async m a] -> m (Async m a, Either SomeException a)
forall (m :: * -> *) a.
MonadConc m =>
[Async m a] -> m (Async m a, Either SomeException a)
waitAnyCatch [Async m a]
asyncs m (Async m a, Either SomeException a)
-> m () -> m (Async m a, Either SomeException a)
forall (m :: * -> *) a b.
(HasCallStack, MonadMask m) =>
m a -> m b -> m a
`finally` (Async m a -> m ()) -> [Async m a] -> m ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ Async m a -> m ()
forall (m :: * -> *) a. MonadConc m => Async m a -> m ()
cancel [Async m a]
asyncs

-- | Wait for the first of two @Async@s to finish.  If the @Async@
-- that finished first raised an exception, then the exception is
-- re-thrown by 'waitEither'.
--
-- @since 1.1.1.0
waitEither :: MonadConc m => Async m a -> Async m b -> m (Either a b)
waitEither :: forall (m :: * -> *) a b.
MonadConc m =>
Async m a -> Async m b -> m (Either a b)
waitEither Async m a
left Async m b
right = STM m (Either a b) -> m (Either a b)
forall a. STM m a -> m a
forall (m :: * -> *) a. MonadConc m => STM m a -> m a
atomically (STM m (Either a b) -> m (Either a b))
-> STM m (Either a b) -> m (Either a b)
forall a b. (a -> b) -> a -> b
$ Async m a -> Async m b -> STM m (Either a b)
forall (m :: * -> *) a b.
MonadConc m =>
Async m a -> Async m b -> STM m (Either a b)
waitEitherSTM Async m a
left Async m b
right

-- | A version of 'waitEither' that can be used inside a @MonadSTM@
-- transaction.
--
-- @since 1.1.1.0
waitEitherSTM :: MonadConc m => Async m a -> Async m b -> STM m (Either a b)
waitEitherSTM :: forall (m :: * -> *) a b.
MonadConc m =>
Async m a -> Async m b -> STM m (Either a b)
waitEitherSTM Async m a
left Async m b
right =
  (a -> Either a b
forall a b. a -> Either a b
Left (a -> Either a b) -> STM m a -> STM m (Either a b)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Async m a -> STM m a
forall (m :: * -> *) a. MonadConc m => Async m a -> STM m a
waitSTM Async m a
left) STM m (Either a b) -> STM m (Either a b) -> STM m (Either a b)
forall (stm :: * -> *) a. MonadSTM stm => stm a -> stm a -> stm a
`orElse` (b -> Either a b
forall a b. b -> Either a b
Right (b -> Either a b) -> STM m b -> STM m (Either a b)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Async m b -> STM m b
forall (m :: * -> *) a. MonadConc m => Async m a -> STM m a
waitSTM Async m b
right)

-- | Wait for the first of two @Async@s to finish.
--
-- @since 1.1.1.0
waitEitherCatch :: MonadConc m => Async m a -> Async m b
  -> m (Either (Either SomeException a) (Either SomeException b))
waitEitherCatch :: forall (m :: * -> *) a b.
MonadConc m =>
Async m a
-> Async m b
-> m (Either (Either SomeException a) (Either SomeException b))
waitEitherCatch Async m a
left Async m b
right = STM m (Either (Either SomeException a) (Either SomeException b))
-> m (Either (Either SomeException a) (Either SomeException b))
forall a. STM m a -> m a
forall (m :: * -> *) a. MonadConc m => STM m a -> m a
atomically (STM m (Either (Either SomeException a) (Either SomeException b))
 -> m (Either (Either SomeException a) (Either SomeException b)))
-> STM m (Either (Either SomeException a) (Either SomeException b))
-> m (Either (Either SomeException a) (Either SomeException b))
forall a b. (a -> b) -> a -> b
$ Async m a
-> Async m b
-> STM m (Either (Either SomeException a) (Either SomeException b))
forall (m :: * -> *) a b.
MonadConc m =>
Async m a
-> Async m b
-> STM m (Either (Either SomeException a) (Either SomeException b))
waitEitherCatchSTM Async m a
left Async m b
right

-- | A version of 'waitEitherCatch' that can be used inside a
-- @MonadSTM@ transaction.
--
-- @since 1.1.1.0
waitEitherCatchSTM :: MonadConc m => Async m a -> Async m b
  -> STM m (Either (Either SomeException a) (Either SomeException b))
waitEitherCatchSTM :: forall (m :: * -> *) a b.
MonadConc m =>
Async m a
-> Async m b
-> STM m (Either (Either SomeException a) (Either SomeException b))
waitEitherCatchSTM Async m a
left Async m b
right =
  (Either SomeException a
-> Either (Either SomeException a) (Either SomeException b)
forall a b. a -> Either a b
Left (Either SomeException a
 -> Either (Either SomeException a) (Either SomeException b))
-> STM m (Either SomeException a)
-> STM m (Either (Either SomeException a) (Either SomeException b))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Async m a -> STM m (Either SomeException a)
forall (m :: * -> *) a.
MonadConc m =>
Async m a -> STM m (Either SomeException a)
waitCatchSTM Async m a
left) STM m (Either (Either SomeException a) (Either SomeException b))
-> STM m (Either (Either SomeException a) (Either SomeException b))
-> STM m (Either (Either SomeException a) (Either SomeException b))
forall (stm :: * -> *) a. MonadSTM stm => stm a -> stm a -> stm a
`orElse` (Either SomeException b
-> Either (Either SomeException a) (Either SomeException b)
forall a b. b -> Either a b
Right (Either SomeException b
 -> Either (Either SomeException a) (Either SomeException b))
-> STM m (Either SomeException b)
-> STM m (Either (Either SomeException a) (Either SomeException b))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Async m b -> STM m (Either SomeException b)
forall (m :: * -> *) a.
MonadConc m =>
Async m a -> STM m (Either SomeException a)
waitCatchSTM Async m b
right)

-- | Like 'waitEither', but also 'cancel's both @Async@s before
-- returning.
--
-- @since 1.1.1.0
waitEitherCancel :: MonadConc m => Async m a -> Async m b -> m (Either a b)
waitEitherCancel :: forall (m :: * -> *) a b.
MonadConc m =>
Async m a -> Async m b -> m (Either a b)
waitEitherCancel Async m a
left Async m b
right =
  Async m a -> Async m b -> m (Either a b)
forall (m :: * -> *) a b.
MonadConc m =>
Async m a -> Async m b -> m (Either a b)
waitEither Async m a
left Async m b
right m (Either a b) -> m () -> m (Either a b)
forall (m :: * -> *) a b.
(HasCallStack, MonadMask m) =>
m a -> m b -> m a
`finally` (Async m a -> m ()
forall (m :: * -> *) a. MonadConc m => Async m a -> m ()
cancel Async m a
left m () -> m () -> m ()
forall a b. m a -> m b -> m b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Async m b -> m ()
forall (m :: * -> *) a. MonadConc m => Async m a -> m ()
cancel Async m b
right)

-- | Like 'waitEitherCatch', but also 'cancel's both @Async@s before
-- returning.
--
-- @since 1.1.1.0
waitEitherCatchCancel :: MonadConc m => Async m a -> Async m b
  -> m (Either (Either SomeException a) (Either SomeException b))
waitEitherCatchCancel :: forall (m :: * -> *) a b.
MonadConc m =>
Async m a
-> Async m b
-> m (Either (Either SomeException a) (Either SomeException b))
waitEitherCatchCancel Async m a
left Async m b
right =
  Async m a
-> Async m b
-> m (Either (Either SomeException a) (Either SomeException b))
forall (m :: * -> *) a b.
MonadConc m =>
Async m a
-> Async m b
-> m (Either (Either SomeException a) (Either SomeException b))
waitEitherCatch Async m a
left Async m b
right m (Either (Either SomeException a) (Either SomeException b))
-> m ()
-> m (Either (Either SomeException a) (Either SomeException b))
forall (m :: * -> *) a b.
(HasCallStack, MonadMask m) =>
m a -> m b -> m a
`finally` (Async m a -> m ()
forall (m :: * -> *) a. MonadConc m => Async m a -> m ()
cancel Async m a
left m () -> m () -> m ()
forall a b. m a -> m b -> m b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Async m b -> m ()
forall (m :: * -> *) a. MonadConc m => Async m a -> m ()
cancel Async m b
right)

-- | Like 'waitEither', but the result is ignored.
--
-- @since 1.1.1.0
waitEither_ :: MonadConc m => Async m a -> Async m b -> m ()
waitEither_ :: forall (m :: * -> *) a b.
MonadConc m =>
Async m a -> Async m b -> m ()
waitEither_ Async m a
left Async m b
right = STM m () -> m ()
forall a. STM m a -> m a
forall (m :: * -> *) a. MonadConc m => STM m a -> m a
atomically (STM m () -> m ()) -> STM m () -> m ()
forall a b. (a -> b) -> a -> b
$ Async m a -> Async m b -> STM m ()
forall (m :: * -> *) a b.
MonadConc m =>
Async m a -> Async m b -> STM m ()
waitEitherSTM_ Async m a
left Async m b
right

-- | A version of 'waitEither_' that can be used inside a @MonadSTM@
-- transaction.
--
-- @since 1.1.1.0
waitEitherSTM_:: MonadConc m => Async m a -> Async m b -> STM m ()
waitEitherSTM_ :: forall (m :: * -> *) a b.
MonadConc m =>
Async m a -> Async m b -> STM m ()
waitEitherSTM_ Async m a
left Async m b
right = STM m (Either a b) -> STM m ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (STM m (Either a b) -> STM m ()) -> STM m (Either a b) -> STM m ()
forall a b. (a -> b) -> a -> b
$ Async m a -> Async m b -> STM m (Either a b)
forall (m :: * -> *) a b.
MonadConc m =>
Async m a -> Async m b -> STM m (Either a b)
waitEitherSTM Async m a
left Async m b
right

-- | Waits for both @Async@s to finish, but if either of them throws
-- an exception before they have both finished, then the exception is
-- re-thrown by 'waitBoth'.
--
-- @since 1.1.1.0
waitBoth :: MonadConc m => Async m a -> Async m b -> m (a, b)
waitBoth :: forall (m :: * -> *) a b.
MonadConc m =>
Async m a -> Async m b -> m (a, b)
waitBoth Async m a
left Async m b
right = STM m (a, b) -> m (a, b)
forall a. STM m a -> m a
forall (m :: * -> *) a. MonadConc m => STM m a -> m a
atomically (STM m (a, b) -> m (a, b)) -> STM m (a, b) -> m (a, b)
forall a b. (a -> b) -> a -> b
$ Async m a -> Async m b -> STM m (a, b)
forall (m :: * -> *) a b.
MonadConc m =>
Async m a -> Async m b -> STM m (a, b)
waitBothSTM Async m a
left Async m b
right

-- | A version of 'waitBoth' that can be used inside a @MonadSTM@
-- transaction.
--
-- @since 1.1.1.0
waitBothSTM :: MonadConc m => Async m a -> Async m b -> STM m (a, b)
waitBothSTM :: forall (m :: * -> *) a b.
MonadConc m =>
Async m a -> Async m b -> STM m (a, b)
waitBothSTM Async m a
left Async m b
right = do
  a
a <- Async m a -> STM m a
forall (m :: * -> *) a. MonadConc m => Async m a -> STM m a
waitSTM Async m a
left STM m a -> STM m a -> STM m a
forall (stm :: * -> *) a. MonadSTM stm => stm a -> stm a -> stm a
`orElse` (Async m b -> STM m b
forall (m :: * -> *) a. MonadConc m => Async m a -> STM m a
waitSTM Async m b
right STM m b -> STM m a -> STM m a
forall a b. STM m a -> STM m b -> STM m b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> STM m a
forall (stm :: * -> *) a. MonadSTM stm => stm a
retry)
  b
b <- Async m b -> STM m b
forall (m :: * -> *) a. MonadConc m => Async m a -> STM m a
waitSTM Async m b
right
  (a, b) -> STM m (a, b)
forall a. a -> STM m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (a
a, b
b)


-------------------------------------------------------------------------------
-- Linking

-- | Link the given @Async@ to the current thread, such that if the
-- @Async@ raises an exception, that exception will be re-thrown in
-- the current thread.
--
-- @since 1.1.1.0
link :: MonadConc m => Async m a -> m ()
link :: forall (m :: * -> *) a. MonadConc m => Async m a -> m ()
link (Async ThreadId m
_ STM m (Either SomeException a)
w) = do
  ThreadId m
me <- m (ThreadId m)
forall (m :: * -> *). MonadConc m => m (ThreadId m)
myThreadId
  m (ThreadId m) -> m ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (m (ThreadId m) -> m ()) -> m (ThreadId m) -> m ()
forall a b. (a -> b) -> a -> b
$ m () -> m (ThreadId m)
forall (m :: * -> *) a. MonadConc m => m a -> m (ThreadId m)
forkRepeat (m () -> m (ThreadId m)) -> m () -> m (ThreadId m)
forall a b. (a -> b) -> a -> b
$ do
    Either SomeException a
r <- STM m (Either SomeException a) -> m (Either SomeException a)
forall a. STM m a -> m a
forall (m :: * -> *) a. MonadConc m => STM m a -> m a
atomically STM m (Either SomeException a)
w
    case Either SomeException a
r of
      Left SomeException
e -> ThreadId m -> SomeException -> m ()
forall e. Exception e => ThreadId m -> e -> m ()
forall (m :: * -> *) e.
(MonadConc m, Exception e) =>
ThreadId m -> e -> m ()
throwTo ThreadId m
me SomeException
e
      Either SomeException a
_ -> () -> m ()
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()

-- | Link two @Async@s together, such that if either raises an
-- exception, the same exception is re-thrown in the other @Async@.
--
-- @since 1.1.1.0
link2 :: MonadConc m => Async m a -> Async m b -> m ()
link2 :: forall (m :: * -> *) a b.
MonadConc m =>
Async m a -> Async m b -> m ()
link2 left :: Async m a
left@(Async ThreadId m
tl STM m (Either SomeException a)
_)  right :: Async m b
right@(Async ThreadId m
tr STM m (Either SomeException b)
_) =
  m (ThreadId m) -> m ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (m (ThreadId m) -> m ()) -> m (ThreadId m) -> m ()
forall a b. (a -> b) -> a -> b
$ m () -> m (ThreadId m)
forall (m :: * -> *) a. MonadConc m => m a -> m (ThreadId m)
forkRepeat (m () -> m (ThreadId m)) -> m () -> m (ThreadId m)
forall a b. (a -> b) -> a -> b
$ do
    Either (Either SomeException a) (Either SomeException b)
r <- Async m a
-> Async m b
-> m (Either (Either SomeException a) (Either SomeException b))
forall (m :: * -> *) a b.
MonadConc m =>
Async m a
-> Async m b
-> m (Either (Either SomeException a) (Either SomeException b))
waitEitherCatch Async m a
left Async m b
right
    case Either (Either SomeException a) (Either SomeException b)
r of
      Left  (Left SomeException
e) -> ThreadId m -> SomeException -> m ()
forall e. Exception e => ThreadId m -> e -> m ()
forall (m :: * -> *) e.
(MonadConc m, Exception e) =>
ThreadId m -> e -> m ()
throwTo ThreadId m
tr SomeException
e
      Right (Left SomeException
e) -> ThreadId m -> SomeException -> m ()
forall e. Exception e => ThreadId m -> e -> m ()
forall (m :: * -> *) e.
(MonadConc m, Exception e) =>
ThreadId m -> e -> m ()
throwTo ThreadId m
tl SomeException
e
      Either (Either SomeException a) (Either SomeException b)
_ -> () -> m ()
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()

-- | Fork a thread that runs the supplied action, and if it raises an
-- exception, re-runs the action.  The thread terminates only when the
-- action runs to completion without raising an exception.
forkRepeat :: MonadConc m => m a -> m (ThreadId m)
forkRepeat :: forall (m :: * -> *) a. MonadConc m => m a -> m (ThreadId m)
forkRepeat m a
action = ((forall a. m a -> m a) -> m (ThreadId m)) -> m (ThreadId m)
forall (m :: * -> *) b.
MonadConc m =>
((forall a. m a -> m a) -> m b) -> m b
mask (((forall a. m a -> m a) -> m (ThreadId m)) -> m (ThreadId m))
-> ((forall a. m a -> m a) -> m (ThreadId m)) -> m (ThreadId m)
forall a b. (a -> b) -> a -> b
$ \forall a. m a -> m a
restore ->
  let go :: m ()
go = do
        Either SomeException a
r <- (m a -> m (Either SomeException a)
forall {m :: * -> *} {a}.
MonadConc m =>
m a -> m (Either SomeException a)
forall (m :: * -> *) e a.
(HasCallStack, MonadCatch m, Exception e) =>
m a -> m (Either e a)
try :: MonadConc m => m a -> m (Either SomeException a)) (m a -> m (Either SomeException a))
-> m a -> m (Either SomeException a)
forall a b. (a -> b) -> a -> b
$ m a -> m a
forall a. m a -> m a
restore m a
action
        case Either SomeException a
r of
          Left SomeException
_ -> m ()
go
          Either SomeException a
_      -> () -> m ()
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
  in m () -> m (ThreadId m)
forall (m :: * -> *). MonadConc m => m () -> m (ThreadId m)
fork m ()
go


-------------------------------------------------------------------------------
-- Convenient Utilities

-- | Run two @MonadConc@ actions concurrently, and return the first to
-- finish. The loser of the race is 'cancel'led.
--
-- > race left right =
-- >   withAsync left $ \a ->
-- >   withAsync right $ \b ->
-- >   waitEither a b
--
-- @since 1.1.1.0
race :: MonadConc m => m a -> m b -> m (Either a b)
race :: forall (m :: * -> *) a b.
MonadConc m =>
m a -> m b -> m (Either a b)
race m a
left m b
right = m a
-> m b
-> (MVar m (Either SomeException (Either a b)) -> m (Either a b))
-> m (Either a b)
forall (m :: * -> *) a b r.
MonadConc m =>
m a
-> m b
-> (MVar m (Either SomeException (Either a b)) -> m r)
-> m r
concurrently' m a
left m b
right MVar m (Either SomeException (Either a b)) -> m (Either a b)
forall {m :: * -> *} {e} {b}.
(MonadConc m, Exception e) =>
MVar m (Either e b) -> m b
collect where
  collect :: MVar m (Either e b) -> m b
collect MVar m (Either e b)
m = do
    Either e b
e <- MVar m (Either e b) -> m (Either e b)
forall a. MVar m a -> m a
forall (m :: * -> *) a. MonadConc m => MVar m a -> m a
takeMVar MVar m (Either e b)
m
    case Either e b
e of
      Left e
ex -> e -> m b
forall (m :: * -> *) e a. (MonadConc m, Exception e) => e -> m a
throw e
ex
      Right b
r -> b -> m b
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure b
r

-- | Like 'race', but the result is ignored.
--
-- > race_ left right =
-- >   withAsync left $ \a ->
-- >   withAsync right $ \b ->
-- >   waitEither_ a b
--
-- @since 1.1.1.0
race_ :: MonadConc m => m a -> m b -> m ()
race_ :: forall (m :: * -> *) a b. MonadConc m => m a -> m b -> m ()
race_ m a
a m b
b = m (Either a b) -> m ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (m (Either a b) -> m ()) -> m (Either a b) -> m ()
forall a b. (a -> b) -> a -> b
$ m a -> m b -> m (Either a b)
forall (m :: * -> *) a b.
MonadConc m =>
m a -> m b -> m (Either a b)
race m a
a m b
b

-- | Run two @MonadConc@ actions concurrently, and return both
-- results. If either action throws an exception at any time, then the
-- other action is 'cancel'led, and the exception is re-thrown by
-- 'concurrently'.
--
-- > concurrently left right =
-- >   withAsync left $ \a ->
-- >   withAsync right $ \b ->
-- >   waitBoth a b
--
-- @since 1.1.1.0
concurrently :: MonadConc m => m a -> m b -> m (a, b)
concurrently :: forall (m :: * -> *) a b. MonadConc m => m a -> m b -> m (a, b)
concurrently m a
left m b
right = m a
-> m b
-> (MVar m (Either SomeException (Either a b)) -> m (a, b))
-> m (a, b)
forall (m :: * -> *) a b r.
MonadConc m =>
m a
-> m b
-> (MVar m (Either SomeException (Either a b)) -> m r)
-> m r
concurrently' m a
left m b
right ([Either a b]
-> MVar m (Either SomeException (Either a b)) -> m (a, b)
forall {f :: * -> *} {e} {a} {b}.
(MonadConc f, Exception e) =>
[Either a b] -> MVar f (Either e (Either a b)) -> f (a, b)
collect []) where
  collect :: [Either a b] -> MVar f (Either e (Either a b)) -> f (a, b)
collect [Left a
a, Right b
b] MVar f (Either e (Either a b))
_ = (a, b) -> f (a, b)
forall a. a -> f a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (a
a, b
b)
  collect [Right b
b, Left a
a] MVar f (Either e (Either a b))
_ = (a, b) -> f (a, b)
forall a. a -> f a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (a
a, b
b)
  collect [Either a b]
xs MVar f (Either e (Either a b))
m = do
    Either e (Either a b)
e <- MVar f (Either e (Either a b)) -> f (Either e (Either a b))
forall a. MVar f a -> f a
forall (m :: * -> *) a. MonadConc m => MVar m a -> m a
takeMVar MVar f (Either e (Either a b))
m
    case Either e (Either a b)
e of
      Left e
ex -> e -> f (a, b)
forall (m :: * -> *) e a. (MonadConc m, Exception e) => e -> m a
throw e
ex
      Right Either a b
r -> [Either a b] -> MVar f (Either e (Either a b)) -> f (a, b)
collect (Either a b
rEither a b -> [Either a b] -> [Either a b]
forall a. a -> [a] -> [a]
:[Either a b]
xs) MVar f (Either e (Either a b))
m

-- | 'concurrently_' is 'concurrently' but ignores the return values.
--
-- @since 1.1.2.0
concurrently_ :: MonadConc m => m a -> m b -> m ()
concurrently_ :: forall (m :: * -> *) a b. MonadConc m => m a -> m b -> m ()
concurrently_ m a
left m b
right = m a
-> m b
-> (MVar m (Either SomeException (Either a b)) -> m ())
-> m ()
forall (m :: * -> *) a b r.
MonadConc m =>
m a
-> m b
-> (MVar m (Either SomeException (Either a b)) -> m r)
-> m r
concurrently' m a
left m b
right (Int -> MVar m (Either SomeException (Either a b)) -> m ()
forall {f :: * -> *} {e} {b}.
(MonadConc f, Exception e) =>
Int -> MVar f (Either e b) -> f ()
collect Int
0) where
  collect :: Int -> MVar f (Either e b) -> f ()
collect Int
2 MVar f (Either e b)
_ = () -> f ()
forall a. a -> f a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
  collect Int
i MVar f (Either e b)
m = do
    Either e b
e <- MVar f (Either e b) -> f (Either e b)
forall a. MVar f a -> f a
forall (m :: * -> *) a. MonadConc m => MVar m a -> m a
takeMVar MVar f (Either e b)
m
    case Either e b
e of
      Left e
ex -> e -> f ()
forall (m :: * -> *) e a. (MonadConc m, Exception e) => e -> m a
throw e
ex
      Right b
_ -> Int -> MVar f (Either e b) -> f ()
collect (Int
iInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
1::Int) MVar f (Either e b)
m

-- Run two things concurrently. Faster than the 'Async' version.
concurrently' :: MonadConc m => m a -> m b
  -> (MVar m (Either SomeException (Either a b)) -> m r)
  -> m r
concurrently' :: forall (m :: * -> *) a b r.
MonadConc m =>
m a
-> m b
-> (MVar m (Either SomeException (Either a b)) -> m r)
-> m r
concurrently' m a
left m b
right MVar m (Either SomeException (Either a b)) -> m r
collect = do
  MVar m (Either SomeException (Either a b))
done <- m (MVar m (Either SomeException (Either a b)))
forall a. m (MVar m a)
forall (m :: * -> *) a. MonadConc m => m (MVar m a)
newEmptyMVar
  ((forall a. m a -> m a) -> m r) -> m r
forall (m :: * -> *) b.
MonadConc m =>
((forall a. m a -> m a) -> m b) -> m b
mask (((forall a. m a -> m a) -> m r) -> m r)
-> ((forall a. m a -> m a) -> m r) -> m r
forall a b. (a -> b) -> a -> b
$ \forall a. m a -> m a
restore -> do
    ThreadId m
lid <- m () -> m (ThreadId m)
forall (m :: * -> *). MonadConc m => m () -> m (ThreadId m)
fork (m () -> m (ThreadId m)) -> m () -> m (ThreadId m)
forall a b. (a -> b) -> a -> b
$ m () -> m ()
forall a. m a -> m a
restore (m a
left m a -> (a -> m ()) -> m ()
forall a b. m a -> (a -> m b) -> m b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= MVar m (Either SomeException (Either a b))
-> Either SomeException (Either a b) -> m ()
forall a. MVar m a -> a -> m ()
forall (m :: * -> *) a. MonadConc m => MVar m a -> a -> m ()
putMVar MVar m (Either SomeException (Either a b))
done (Either SomeException (Either a b) -> m ())
-> (a -> Either SomeException (Either a b)) -> a -> m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Either a b -> Either SomeException (Either a b)
forall a b. b -> Either a b
Right (Either a b -> Either SomeException (Either a b))
-> (a -> Either a b) -> a -> Either SomeException (Either a b)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> Either a b
forall a b. a -> Either a b
Left)
          m () -> (SomeException -> m ()) -> m ()
forall (m :: * -> *) e a.
(MonadConc m, Exception e) =>
m a -> (e -> m a) -> m a
`catch` (MVar m (Either SomeException (Either a b))
-> Either SomeException (Either a b) -> m ()
forall a. MVar m a -> a -> m ()
forall (m :: * -> *) a. MonadConc m => MVar m a -> a -> m ()
putMVar MVar m (Either SomeException (Either a b))
done (Either SomeException (Either a b) -> m ())
-> (SomeException -> Either SomeException (Either a b))
-> SomeException
-> m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SomeException -> Either SomeException (Either a b)
forall a b. a -> Either a b
Left)

    ThreadId m
rid <- m () -> m (ThreadId m)
forall (m :: * -> *). MonadConc m => m () -> m (ThreadId m)
fork (m () -> m (ThreadId m)) -> m () -> m (ThreadId m)
forall a b. (a -> b) -> a -> b
$ m () -> m ()
forall a. m a -> m a
restore (m b
right m b -> (b -> m ()) -> m ()
forall a b. m a -> (a -> m b) -> m b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= MVar m (Either SomeException (Either a b))
-> Either SomeException (Either a b) -> m ()
forall a. MVar m a -> a -> m ()
forall (m :: * -> *) a. MonadConc m => MVar m a -> a -> m ()
putMVar MVar m (Either SomeException (Either a b))
done (Either SomeException (Either a b) -> m ())
-> (b -> Either SomeException (Either a b)) -> b -> m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Either a b -> Either SomeException (Either a b)
forall a b. b -> Either a b
Right (Either a b -> Either SomeException (Either a b))
-> (b -> Either a b) -> b -> Either SomeException (Either a b)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. b -> Either a b
forall a b. b -> Either a b
Right)
          m () -> (SomeException -> m ()) -> m ()
forall (m :: * -> *) e a.
(MonadConc m, Exception e) =>
m a -> (e -> m a) -> m a
`catch` (MVar m (Either SomeException (Either a b))
-> Either SomeException (Either a b) -> m ()
forall a. MVar m a -> a -> m ()
forall (m :: * -> *) a. MonadConc m => MVar m a -> a -> m ()
putMVar MVar m (Either SomeException (Either a b))
done (Either SomeException (Either a b) -> m ())
-> (SomeException -> Either SomeException (Either a b))
-> SomeException
-> m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SomeException -> Either SomeException (Either a b)
forall a b. a -> Either a b
Left)

    -- See: https://github.com/simonmar/async/issues/27
    let stop :: m ()
stop = ThreadId m -> m ()
forall (m :: * -> *). MonadConc m => ThreadId m -> m ()
killThread ThreadId m
rid m () -> m () -> m ()
forall a b. m a -> m b -> m b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> ThreadId m -> m ()
forall (m :: * -> *). MonadConc m => ThreadId m -> m ()
killThread ThreadId m
lid

    r
r <- m r -> m r
forall a. m a -> m a
restore (MVar m (Either SomeException (Either a b)) -> m r
collect MVar m (Either SomeException (Either a b))
done) m r -> m () -> m r
forall (m :: * -> *) a b.
(HasCallStack, MonadCatch m) =>
m a -> m b -> m a
`onException` m ()
stop

    m ()
stop

    r -> m r
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure r
r

-- | Maps a @MonadConc@-performing function over any @Traversable@
-- data type, performing all the @MonadConc@ actions concurrently, and
-- returning the original data structure with the arguments replaced
-- by the results.
--
-- For example, @mapConcurrently@ works with lists:
--
-- > pages <- mapConcurrently getURL ["url1", "url2", "url3"]
--
-- @since 1.1.1.0
mapConcurrently :: (Traversable t, MonadConc m) => (a -> m b) -> t a -> m (t b)
mapConcurrently :: forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, MonadConc m) =>
(a -> m b) -> t a -> m (t b)
mapConcurrently a -> m b
f = Concurrently m (t b) -> m (t b)
forall (m :: * -> *) a. Concurrently m a -> m a
runConcurrently (Concurrently m (t b) -> m (t b))
-> (t a -> Concurrently m (t b)) -> t a -> m (t b)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (a -> Concurrently m b) -> t a -> Concurrently m (t b)
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> t a -> f (t b)
traverse (m b -> Concurrently m b
forall (m :: * -> *) a. m a -> Concurrently m a
Concurrently (m b -> Concurrently m b) -> (a -> m b) -> a -> Concurrently m b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> m b
f)

-- | `forConcurrently` is `mapConcurrently` with its arguments flipped
--
-- > pages <- forConcurrently ["url1", "url2", "url3"] $ \url -> getURL url
--
-- @since 1.1.1.0
forConcurrently :: (Traversable t, MonadConc m) => t a -> (a -> m b)-> m (t b)
forConcurrently :: forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, MonadConc m) =>
t a -> (a -> m b) -> m (t b)
forConcurrently = ((a -> m b) -> t a -> m (t b)) -> t a -> (a -> m b) -> m (t b)
forall a b c. (a -> b -> c) -> b -> a -> c
flip (a -> m b) -> t a -> m (t b)
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, MonadConc m) =>
(a -> m b) -> t a -> m (t b)
mapConcurrently

-- | 'mapConcurrently_' is 'mapConcurrently' with the return value
-- discarded, just like 'mapM_'.
--
-- @since 1.1.2.0
mapConcurrently_ :: (Foldable f, MonadConc m) => (a -> m b) -> f a -> m ()
mapConcurrently_ :: forall (f :: * -> *) (m :: * -> *) a b.
(Foldable f, MonadConc m) =>
(a -> m b) -> f a -> m ()
mapConcurrently_ a -> m b
f = Concurrently m () -> m ()
forall (m :: * -> *) a. Concurrently m a -> m a
runConcurrently (Concurrently m () -> m ())
-> (f a -> Concurrently m ()) -> f a -> m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (a -> Concurrently m ()) -> f a -> Concurrently m ()
forall m a. Monoid m => (a -> m) -> f a -> m
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap (m () -> Concurrently m ()
forall (m :: * -> *) a. m a -> Concurrently m a
Concurrently (m () -> Concurrently m ())
-> (a -> m ()) -> a -> Concurrently m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. m b -> m ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (m b -> m ()) -> (a -> m b) -> a -> m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> m b
f)

-- | 'forConcurrently_' is 'forConcurrently' with the return value
-- discarded, just like 'forM_'.
--
-- @since 1.1.2.0
forConcurrently_ :: (Foldable f, MonadConc m) => f a -> (a -> m b) -> m ()
forConcurrently_ :: forall (f :: * -> *) (m :: * -> *) a b.
(Foldable f, MonadConc m) =>
f a -> (a -> m b) -> m ()
forConcurrently_ = ((a -> m b) -> f a -> m ()) -> f a -> (a -> m b) -> m ()
forall a b c. (a -> b -> c) -> b -> a -> c
flip (a -> m b) -> f a -> m ()
forall (f :: * -> *) (m :: * -> *) a b.
(Foldable f, MonadConc m) =>
(a -> m b) -> f a -> m ()
mapConcurrently_

-- | Perform the action in the given number of threads.
--
-- @since 1.1.2.0
replicateConcurrently :: MonadConc m => Int -> m a -> m [a]
replicateConcurrently :: forall (m :: * -> *) a. MonadConc m => Int -> m a -> m [a]
replicateConcurrently Int
i = Concurrently m [a] -> m [a]
forall (m :: * -> *) a. Concurrently m a -> m a
runConcurrently (Concurrently m [a] -> m [a])
-> (m a -> Concurrently m [a]) -> m a -> m [a]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> Concurrently m a -> Concurrently m [a]
forall (m :: * -> *) a. Applicative m => Int -> m a -> m [a]
replicateM Int
i (Concurrently m a -> Concurrently m [a])
-> (m a -> Concurrently m a) -> m a -> Concurrently m [a]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. m a -> Concurrently m a
forall (m :: * -> *) a. m a -> Concurrently m a
Concurrently

-- | 'replicateConcurrently_' is 'replicateConcurrently' with the
-- return values discarded.
--
-- @since 1.1.2.0
replicateConcurrently_ :: MonadConc m => Int -> m a -> m ()
replicateConcurrently_ :: forall (m :: * -> *) a. MonadConc m => Int -> m a -> m ()
replicateConcurrently_ Int
i = m [a] -> m ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (m [a] -> m ()) -> (m a -> m [a]) -> m a -> m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> m a -> m [a]
forall (m :: * -> *) a. MonadConc m => Int -> m a -> m [a]
replicateConcurrently Int
i