{-# 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 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) = forall (m :: * -> *) a.
ThreadId m -> STM m (Either SomeException a) -> Async m a
Async ThreadId m
t forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap a -> b
f 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) = forall (m :: * -> *) a. m a -> Concurrently m a
Concurrently forall a b. (a -> b) -> a -> b
$ a -> b
f 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 = forall (m :: * -> *) a. m a -> Concurrently m a
Concurrently forall b c a. (b -> c) -> (a -> b) -> a -> c
. 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 =
    forall (m :: * -> *) a. m a -> Concurrently m a
Concurrently forall a b. (a -> b) -> a -> b
$ (\(a -> b
f, a
a) -> a -> b
f a
a) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> 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 = forall (m :: * -> *) a. m a -> Concurrently m a
Concurrently forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) a b. Applicative f => f a -> f b
forever 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 =
    forall (m :: * -> *) a. m a -> Concurrently m a
Concurrently forall a b. (a -> b) -> a -> b
$ forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either forall a. a -> a
id forall a. a -> a
id forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> 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
(<>) = forall (f :: * -> *) a b c.
Applicative f =>
(a -> b -> c) -> f a -> f b -> f c
liftA2 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 = forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a. Monoid a => a
mempty
#if MIN_VERSION_base(4,11,0)
  mappend :: Concurrently m a -> Concurrently m a -> Concurrently m a
mappend = 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 = forall (m :: * -> *) a.
MonadConc m =>
(m () -> m (ThreadId m)) -> m a -> m (Async m a)
asyncUsing 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 = forall (m :: * -> *) a.
MonadConc m =>
(m () -> m (ThreadId m)) -> m a -> m (Async m a)
asyncUsing (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 = forall (m :: * -> *) a.
MonadConc m =>
(m () -> m (ThreadId m)) -> m a -> m (Async m a)
asyncUsing 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 = forall (m :: * -> *) a.
MonadConc m =>
(m () -> m (ThreadId m)) -> m a -> m (Async m a)
asyncUsing (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 = forall (m :: * -> *) a.
MonadConc m =>
(m () -> m (ThreadId m)) -> m a -> m (Async m a)
asyncUsing forall b c a. (b -> c) -> (a -> b) -> a -> c
. 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 = forall (m :: * -> *) a.
MonadConc m =>
(m () -> m (ThreadId m)) -> m a -> m (Async m a)
asyncUsing forall b c a. (b -> c) -> (a -> b) -> a -> c
. 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 (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 (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 (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 (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 (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 (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 (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 (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 <- forall (m :: * -> *) a. MonadConc m => STM m a -> m a
atomically forall (stm :: * -> *) a. MonadSTM stm => stm (TMVar stm a)
newEmptyTMVar
  ThreadId m
tid <- forall (m :: * -> *) b.
MonadConc m =>
((forall a. m a -> m a) -> m b) -> m b
mask forall a b. (a -> b) -> a -> b
$ \forall a. m a -> m a
restore -> m () -> m (ThreadId m)
doFork forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) e a.
(MonadCatch m, Exception e) =>
m a -> m (Either e a)
try (forall a. m a -> m a
restore m a
action) forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall (m :: * -> *) a. MonadConc m => STM m a -> m a
atomically forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (stm :: * -> *) a.
MonadSTM stm =>
TMVar stm a -> a -> stm ()
putTMVar TMVar (STM m) (Either SomeException a)
var
  forall (f :: * -> *) a. Applicative f => a -> f a
pure (forall (m :: * -> *) a.
ThreadId m -> STM m (Either SomeException a) -> Async m a
Async ThreadId m
tid (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 <- forall (m :: * -> *) a. MonadConc m => STM m a -> m a
atomically 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 a b. (a -> b) -> a -> b
$ \forall b. m b -> m b
restore -> forall (m :: * -> *) e a.
(MonadCatch m, Exception e) =>
m a -> m (Either e a)
try ((forall b. m b -> m b) -> m a
action forall b. m b -> m b
restore) forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall (m :: * -> *) a. MonadConc m => STM m a -> m a
atomically forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (stm :: * -> *) a.
MonadSTM stm =>
TMVar stm a -> a -> stm ()
putTMVar TMVar (STM m) (Either SomeException a)
var
  forall (f :: * -> *) a. Applicative f => a -> f a
pure (forall (m :: * -> *) a.
ThreadId m -> STM m (Either SomeException a) -> Async m a
Async ThreadId m
tid (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 = forall (m :: * -> *) a b.
MonadConc m =>
(m () -> m (ThreadId m)) -> m a -> (Async m a -> m b) -> m b
withAsyncUsing 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 = forall (m :: * -> *) a b.
MonadConc m =>
(m () -> m (ThreadId m)) -> m a -> (Async m a -> m b) -> m b
withAsyncUsing (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 = forall (m :: * -> *) a b.
MonadConc m =>
(m () -> m (ThreadId m)) -> m a -> (Async m a -> m b) -> m b
withAsyncUsing 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 = forall (m :: * -> *) a b.
MonadConc m =>
(m () -> m (ThreadId m)) -> m a -> (Async m a -> m b) -> m b
withAsyncUsing (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 = forall (m :: * -> *) a b.
MonadConc m =>
(m () -> m (ThreadId m)) -> m a -> (Async m a -> m b) -> m b
withAsyncUsing forall b c a. (b -> c) -> (a -> b) -> a -> c
. 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 = forall (m :: * -> *) a b.
MonadConc m =>
(m () -> m (ThreadId m)) -> m a -> (Async m a -> m b) -> m b
withAsyncUsing (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 (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 (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 (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 (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 (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 (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 (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 (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 <- forall (m :: * -> *) a. MonadConc m => STM m a -> m a
atomically forall (stm :: * -> *) a. MonadSTM stm => stm (TMVar stm a)
newEmptyTMVar
  ThreadId m
tid <- forall (m :: * -> *) b.
MonadConc m =>
((forall a. m a -> m a) -> m b) -> m b
mask forall a b. (a -> b) -> a -> b
$ \forall a. m a -> m a
restore -> m () -> m (ThreadId m)
doFork forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) e a.
(MonadCatch m, Exception e) =>
m a -> m (Either e a)
try (forall a. m a -> m a
restore m a
action) forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall (m :: * -> *) a. MonadConc m => STM m a -> m a
atomically forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (stm :: * -> *) a.
MonadSTM stm =>
TMVar stm a -> a -> stm ()
putTMVar TMVar (STM m) (Either SomeException a)
var
  forall (m :: * -> *) a b.
MonadConc m =>
Async m a -> (Async m a -> m b) -> m b
withAsyncDo (forall (m :: * -> *) a.
ThreadId m -> STM m (Either SomeException a) -> Async m a
Async ThreadId m
tid (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 <- forall (m :: * -> *) a. MonadConc m => STM m a -> m a
atomically 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 a b. (a -> b) -> a -> b
$ \forall x. m x -> m x
restore -> forall (m :: * -> *) e a.
(MonadCatch m, Exception e) =>
m a -> m (Either e a)
try ((forall x. m x -> m x) -> m a
action forall x. m x -> m x
restore) forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall (m :: * -> *) a. MonadConc m => STM m a -> m a
atomically forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (stm :: * -> *) a.
MonadSTM stm =>
TMVar stm a -> a -> stm ()
putTMVar TMVar (STM m) (Either SomeException a)
var
  forall (m :: * -> *) a b.
MonadConc m =>
Async m a -> (Async m a -> m b) -> m b
withAsyncDo (forall (m :: * -> *) a.
ThreadId m -> STM m (Either SomeException a) -> Async m a
Async ThreadId m
tid (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 forall (m :: * -> *) a.
MonadConc m =>
m a -> (SomeException -> m a) -> m a
`catchAll` (\SomeException
e -> forall (m :: * -> *) a. MonadConc m => Async m a -> m ()
uninterruptibleCancel Async m a
a forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall (m :: * -> *) e a. (MonadConc m, Exception e) => e -> m a
throw SomeException
e)
  forall (m :: * -> *) a. MonadConc m => Async m a -> m ()
cancel Async m a
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 = 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 = forall (m :: * -> *) a. MonadConc m => STM m a -> m a
atomically forall b c a. (b -> c) -> (a -> b) -> a -> c
. 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 <- forall (m :: * -> *) a.
MonadConc m =>
Async m a -> STM m (Either SomeException a)
waitCatchSTM Async m a
a
 forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either forall (stm :: * -> *) e a.
(MonadSTM stm, Exception e) =>
e -> stm a
throwSTM 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 = forall (m :: * -> *) a. MonadConc m => STM m a -> m a
atomically forall b c a. (b -> c) -> (a -> b) -> a -> c
. 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) = (forall a. a -> Maybe a
Just forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> STM m (Either SomeException a)
w) forall (stm :: * -> *) a. MonadSTM stm => stm a -> stm a -> stm a
`orElse` forall (f :: * -> *) a. Applicative f => a -> f a
pure 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 = forall {m :: * -> *} {a}. MonadConc m => m a -> m a
tryAgain forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (m :: * -> *) a. MonadConc m => STM m a -> m a
atomically forall b c a. (b -> c) -> (a -> b) -> a -> c
. 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 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)
_) = forall (m :: * -> *) e.
(MonadConc m, Exception e) =>
ThreadId m -> e -> m ()
throwTo ThreadId m
tid AsyncException
ThreadKilled forall (f :: * -> *) a b. Applicative f => f a -> f b -> f 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 = forall (m :: * -> *) a. MonadMask m => m a -> m a
uninterruptibleMask_ forall b c a. (b -> c) -> (a -> b) -> a -> c
. 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)
_) = 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 = forall (m :: * -> *) a. MonadConc m => STM m a -> m a
atomically forall b c a. (b -> c) -> (a -> b) -> a -> c
. 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 = forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (forall (stm :: * -> *) a. MonadSTM stm => stm a -> stm a -> stm a
orElse forall b c a. (b -> c) -> (a -> b) -> a -> c
. (\Async m a
a -> do a
r <- forall (m :: * -> *) a. MonadConc m => Async m a -> STM m a
waitSTM Async m a
a; forall (f :: * -> *) a. Applicative f => a -> f a
pure (Async m a
a, a
r))) 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 = forall (m :: * -> *) a. MonadConc m => STM m a -> m a
atomically forall b c a. (b -> c) -> (a -> b) -> a -> c
. 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 = forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (forall (stm :: * -> *) a. MonadSTM stm => stm a -> stm a -> stm a
orElse forall b c a. (b -> c) -> (a -> b) -> a -> c
. (\Async m a
a -> do Either SomeException a
r <- forall (m :: * -> *) a.
MonadConc m =>
Async m a -> STM m (Either SomeException a)
waitCatchSTM Async m a
a; forall (f :: * -> *) a. Applicative f => a -> f a
pure (Async m a
a, Either SomeException a
r))) 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 = forall (m :: * -> *) a.
MonadConc m =>
[Async m a] -> m (Async m a, a)
waitAny [Async m a]
asyncs forall (m :: * -> *) a b. MonadMask m => m a -> m b -> m a
`finally` forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ 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 = forall (m :: * -> *) a.
MonadConc m =>
[Async m a] -> m (Async m a, Either SomeException a)
waitAnyCatch [Async m a]
asyncs forall (m :: * -> *) a b. MonadMask m => m a -> m b -> m a
`finally` forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ 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 = forall (m :: * -> *) a. MonadConc m => STM m a -> m a
atomically forall a b. (a -> b) -> 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 =
  (forall a b. a -> Either a b
Left forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *) a. MonadConc m => Async m a -> STM m a
waitSTM Async m a
left) forall (stm :: * -> *) a. MonadSTM stm => stm a -> stm a -> stm a
`orElse` (forall a b. b -> Either a b
Right forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f 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 = forall (m :: * -> *) a. MonadConc m => STM m a -> m a
atomically forall a b. (a -> b) -> a -> 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 =
  (forall a b. a -> Either a b
Left forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *) a.
MonadConc m =>
Async m a -> STM m (Either SomeException a)
waitCatchSTM Async m a
left) forall (stm :: * -> *) a. MonadSTM stm => stm a -> stm a -> stm a
`orElse` (forall a b. b -> Either a b
Right forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f 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 =
  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 forall (m :: * -> *) a b. MonadMask m => m a -> m b -> m a
`finally` (forall (m :: * -> *) a. MonadConc m => Async m a -> m ()
cancel Async m a
left forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> 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 =
  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 forall (m :: * -> *) a b. MonadMask m => m a -> m b -> m a
`finally` (forall (m :: * -> *) a. MonadConc m => Async m a -> m ()
cancel Async m a
left forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> 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 = forall (m :: * -> *) a. MonadConc m => STM m a -> m a
atomically forall a b. (a -> b) -> a -> b
$ 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 = forall (f :: * -> *) a. Functor f => f a -> f ()
void forall a b. (a -> b) -> 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 = forall (m :: * -> *) a. MonadConc m => STM m a -> m a
atomically forall a b. (a -> b) -> 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 <- forall (m :: * -> *) a. MonadConc m => Async m a -> STM m a
waitSTM Async m a
left forall (stm :: * -> *) a. MonadSTM stm => stm a -> stm a -> stm a
`orElse` (forall (m :: * -> *) a. MonadConc m => Async m a -> STM m a
waitSTM Async m b
right forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall (stm :: * -> *) a. MonadSTM stm => stm a
retry)
  b
b <- forall (m :: * -> *) a. MonadConc m => Async m a -> STM m a
waitSTM Async m b
right
  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 <- forall (m :: * -> *). MonadConc m => m (ThreadId m)
myThreadId
  forall (f :: * -> *) a. Functor f => f a -> f ()
void forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a. MonadConc m => m a -> m (ThreadId m)
forkRepeat forall a b. (a -> b) -> a -> b
$ do
    Either SomeException a
r <- 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 -> forall (m :: * -> *) e.
(MonadConc m, Exception e) =>
ThreadId m -> e -> m ()
throwTo ThreadId m
me SomeException
e
      Either SomeException 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)
_) =
  forall (f :: * -> *) a. Functor f => f a -> f ()
void forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a. MonadConc m => m a -> m (ThreadId m)
forkRepeat forall a b. (a -> b) -> a -> b
$ do
    Either (Either SomeException a) (Either SomeException b)
r <- 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) -> forall (m :: * -> *) e.
(MonadConc m, Exception e) =>
ThreadId m -> e -> m ()
throwTo ThreadId m
tr SomeException
e
      Right (Left SomeException
e) -> forall (m :: * -> *) e.
(MonadConc m, Exception e) =>
ThreadId m -> e -> m ()
throwTo ThreadId m
tl SomeException
e
      Either (Either SomeException a) (Either SomeException b)
_ -> 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 (m :: * -> *) b.
MonadConc m =>
((forall a. m a -> m a) -> m b) -> m b
mask forall a b. (a -> b) -> a -> b
$ \forall a. m a -> m a
restore ->
  let go :: m ()
go = do
        Either SomeException a
r <- (forall (m :: * -> *) e a.
(MonadCatch m, Exception e) =>
m a -> m (Either e a)
try :: MonadConc m => m a -> m (Either SomeException a)) forall a b. (a -> b) -> a -> b
$ forall a. m a -> m a
restore m a
action
        case Either SomeException a
r of
          Left SomeException
_ -> m ()
go
          Either SomeException a
_      -> forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
  in 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 = 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 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 <- 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 -> forall (m :: * -> *) e a. (MonadConc m, Exception e) => e -> m a
throw e
ex
      Right b
r -> 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 = forall (f :: * -> *) a. Functor f => f a -> f ()
void forall a b. (a -> b) -> 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 = 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 (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))
_ = 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))
_ = 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 <- 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 -> 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
rforall 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 = 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 (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)
_ = forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
  collect Int
i MVar f (Either e b)
m = do
    Either e b
e <- 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 -> 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
iforall 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 <- forall (m :: * -> *) a. MonadConc m => m (MVar m a)
newEmptyMVar
  forall (m :: * -> *) b.
MonadConc m =>
((forall a. m a -> m a) -> m b) -> m b
mask forall a b. (a -> b) -> a -> b
$ \forall a. m a -> m a
restore -> do
    ThreadId m
lid <- forall (m :: * -> *). MonadConc m => m () -> m (ThreadId m)
fork forall a b. (a -> b) -> a -> b
$ forall a. m a -> m a
restore (m a
left forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall (m :: * -> *) a. MonadConc m => MVar m a -> a -> m ()
putMVar MVar m (Either SomeException (Either a b))
done forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. b -> Either a b
Right forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. a -> Either a b
Left)
          forall (m :: * -> *) e a.
(MonadConc m, Exception e) =>
m a -> (e -> m a) -> m a
`catch` (forall (m :: * -> *) a. MonadConc m => MVar m a -> a -> m ()
putMVar MVar m (Either SomeException (Either a b))
done forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. a -> Either a b
Left)

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

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

    r
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) forall (m :: * -> *) a b. MonadCatch m => m a -> m b -> m a
`onException` m ()
stop

    m ()
stop

    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 = forall (m :: * -> *) a. Concurrently m a -> m a
runConcurrently forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse (forall (m :: * -> *) a. m a -> Concurrently m a
Concurrently 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 = forall a b c. (a -> b -> c) -> b -> a -> c
flip 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 = forall (m :: * -> *) a. Concurrently m a -> m a
runConcurrently forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap (forall (m :: * -> *) a. m a -> Concurrently m a
Concurrently forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *) a. Functor f => f a -> f ()
void 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_ = forall a b c. (a -> b -> c) -> b -> a -> c
flip 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 = forall (m :: * -> *) a. Concurrently m a -> m a
runConcurrently forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (m :: * -> *) a. Applicative m => Int -> m a -> m [a]
replicateM Int
i forall b c a. (b -> c) -> (a -> b) -> a -> c
. 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 = forall (f :: * -> *) a. Functor f => f a -> f ()
void forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (m :: * -> *) a. MonadConc m => Int -> m a -> m [a]
replicateConcurrently Int
i