async-2.2.2/0000755000000000000000000000000013476136253011032 5ustar0000000000000000async-2.2.2/LICENSE0000644000000000000000000000276213476136253012046 0ustar0000000000000000Copyright (c) 2012, Simon Marlow All rights reserved. Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following conditions are met: * Redistributions of source code must retain the above copyright notice, this list of conditions and the following disclaimer. * Redistributions in binary form must reproduce the above copyright notice, this list of conditions and the following disclaimer in the documentation and/or other materials provided with the distribution. * Neither the name of Simon Marlow nor the names of other contributors may be used to endorse or promote products derived from this software without specific prior written permission. THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. async-2.2.2/changelog.md0000644000000000000000000000550513476136253013310 0ustar0000000000000000## Changes in 2.2.2: - Builds with GHC 8.6.x - linkOnly and link2Only are now exported - wait now has the same behaviour with BlockedIndefinitelyOnSTM as waitCatch - Documentation fixes ## Changes in 2.2.1: - Add a Hashable instance for Async - Bump upper bounds - Documentation updates ## Changes in 2.2: - cancel now throws AsyncCancelled instead of ThreadKilled - link and link2 now wrap exceptions in ExceptionInLinkedThread when throwing to the linked thread. ExceptionInLinkedThread is a child of AsyncException in the exception hierarchy, so this maintains the invariant that exceptions thrown asynchronously should be AsyncExceptions. - link and link2 do not propagate AsyncCancelled, so it's now possible to cancel a linked thread without cancelling yourself. - Added linkOnly and link2Only to specify which exceptions should be propagated,if you want something other than the default behaviour of ignoring AsyncCancelled. - new utility function compareAsyncs for comparing Asyncs of different types. - Add a `Hashable` instance for `Async a` ## Changes in 2.1.1.1: - Make 'cancelWith' wait for the cancelled thread to terminate, like 'cancel' - Updates to dependency bounds for GHC 8.2 ## Changes in 2.1.1: - Add `concurrently_` - Add `replicateConcurrently` - Add `replicateConcurrently_` - Fix incorrect argument order in `forConcurrently_` - Generalize `mapConcurrently_` and `forConcurrently_` to `Foldable` - `withAsync` now reliably kills the thread, by using an uninterruptible cancel - Make `cancel` wait for the thread to finish, and adjust 'concurrently' to match ## Changes in 2.1.0: - Bump base dependency to allow 4.10 - Remove invalid Monad instance for `Concurrently` - Add `Monoid` and `Semigroup` instances for `Concurrently` - Add `forConcurrently` (flipped version of `mapConcurrently`) - Add STM version of all applicable IO functions: `waitAnySTM`, `waitAnyCatchSTM`, `waitEitherSTM`, `waitEitherCatchSTM`, `waitEitherSTM_`, and `waitBothSTM`. ## Changes in 2.0.2: - Add a Monad instance for `Concurrently` - Bump base dependency to allow 4.9 ## Changes in 2.0.1.6: - Add workaround to waitCatch for #14 ## Changes in 2.0.1.5: - Bump `base` dependencies for GHC 7.8 ## Changes in 2.0.1.4: - Bump `base` dependency of test suite ## Changes in 2.0.1.3: - Bump `base` dependency to allow 4.6 ## Changes in 2.0.1.2: - Bump `stm` dependency to 2.4 ## Changes in 2.0.1.1: - Safe Haskell support: `Control.Concurrent.Async` is now `Trustworthy` ## Changes in 2.0.1.0: - Added a `Functor` instance for `Async` - Added `asyncBound`, `asyncOn`, `asyncWithUnmask`, `asyncOnWithUnmask`, `withAsyncBound`, `withAsyncOn`, `withAsyncWithUnmask`, `withAsyncOnWithUnmask`. - Added `mapConcurrently` - Added `Concurrently` (with `Applicative` and `Alternative` instances) async-2.2.2/Setup.hs0000644000000000000000000000005613476136253012467 0ustar0000000000000000import Distribution.Simple main = defaultMain async-2.2.2/async.cabal0000644000000000000000000000551713476136253013143 0ustar0000000000000000name: async version: 2.2.2 -- don't forget to update ./changelog.md! synopsis: Run IO operations asynchronously and wait for their results description: This package provides a higher-level interface over threads, in which an @Async a@ is a concurrent thread that will eventually deliver a value of type @a@. The package provides ways to create @Async@ computations, wait for their results, and cancel them. . Using @Async@ is safer than using threads in two ways: . * When waiting for a thread to return a result, if the thread dies with an exception then the caller must either re-throw the exception ('wait') or handle it ('waitCatch'); the exception cannot be ignored. . * The API makes it possible to build a tree of threads that are automatically killed when their parent dies (see 'withAsync'). license: BSD3 license-file: LICENSE author: Simon Marlow maintainer: Simon Marlow copyright: (c) Simon Marlow 2012 category: Concurrency build-type: Simple cabal-version: >=1.10 homepage: https://github.com/simonmar/async bug-reports: https://github.com/simonmar/async/issues tested-with: GHC==8.6.5, GHC==8.4.4, GHC==8.2.2, GHC==8.0.2, GHC==7.10.3, GHC==7.8.4, GHC==7.6.3, GHC==7.4.2, GHC==7.2.2, GHC==7.0.4 extra-source-files: changelog.md bench/race.hs source-repository head type: git location: https://github.com/simonmar/async.git library default-language: Haskell2010 other-extensions: CPP, MagicHash, RankNTypes, UnboxedTuples if impl(ghc>=7.1) other-extensions: Trustworthy exposed-modules: Control.Concurrent.Async build-depends: base >= 4.3 && < 4.14, hashable >= 1.1.2.0 && < 1.4, stm >= 2.2 && < 2.6 test-suite test-async default-language: Haskell2010 type: exitcode-stdio-1.0 hs-source-dirs: test main-is: test-async.hs build-depends: base >= 4.3 && < 4.14, async, stm, test-framework, test-framework-hunit, HUnit flag bench default: False executable concasync if !flag(bench) buildable: False default-language: Haskell2010 hs-source-dirs: bench main-is: concasync.hs build-depends: base, async, stm ghc-options: -O2 executable conccancel if !flag(bench) buildable: False default-language: Haskell2010 hs-source-dirs: bench main-is: conccancel.hs build-depends: base, async, stm ghc-options: -O2 -threaded executable race if !flag(bench) buildable: False default-language: Haskell2010 hs-source-dirs: bench main-is: race.hs build-depends: base, async, stm ghc-options: -O2 -threaded async-2.2.2/bench/0000755000000000000000000000000013476136253012111 5ustar0000000000000000async-2.2.2/bench/concasync.hs0000644000000000000000000000047613476136253014434 0ustar0000000000000000import Control.Concurrent.Async import System.Environment import Control.Monad import Control.Concurrent main = runInUnboundThread $ do [n] <- fmap (fmap read) getArgs replicateM_ n $ concurrently (return 1) (return 2) concurrently' left right = withAsync left $ \a -> withAsync right $ \b -> waitBoth a b async-2.2.2/bench/race.hs0000644000000000000000000000033013476136253013353 0ustar0000000000000000import Control.Concurrent.Async import System.Environment import Control.Monad import Control.Concurrent main = runInUnboundThread $ do [n] <- fmap (fmap read) getArgs replicateM_ n $ race (return 1) (return 2) async-2.2.2/bench/conccancel.hs0000644000000000000000000000046713476136253014544 0ustar0000000000000000import Control.Exception import Control.Concurrent.Async import System.Environment import Control.Monad import Control.Concurrent main = runInUnboundThread $ do [n] <- fmap (fmap read) getArgs runConcurrently $ traverse Concurrently $ replicate n (threadDelay 1000000) ++ [throwIO (ErrorCall "oops")] async-2.2.2/Control/0000755000000000000000000000000013476136253012452 5ustar0000000000000000async-2.2.2/Control/Concurrent/0000755000000000000000000000000013476136253014574 5ustar0000000000000000async-2.2.2/Control/Concurrent/Async.hs0000644000000000000000000007317613476136253016223 0ustar0000000000000000{-# LANGUAGE CPP, MagicHash, UnboxedTuples, RankNTypes, ExistentialQuantification #-} #if __GLASGOW_HASKELL__ >= 701 {-# LANGUAGE Trustworthy #-} #endif #if __GLASGOW_HASKELL__ < 710 {-# LANGUAGE DeriveDataTypeable #-} #endif {-# OPTIONS -Wall #-} ----------------------------------------------------------------------------- -- | -- Module : Control.Concurrent.Async -- Copyright : (c) Simon Marlow 2012 -- License : BSD3 (see the file LICENSE) -- -- Maintainer : Simon Marlow -- Stability : provisional -- Portability : non-portable (requires concurrency) -- -- This module provides a set of operations for running IO operations -- asynchronously and waiting for their results. It is a thin layer -- over the basic concurrency operations provided by -- "Control.Concurrent". The main additional functionality it -- provides is the ability to wait for the return value of a thread, -- but the interface also provides some additional safety and -- robustness over using threads and @MVar@ directly. -- -- The basic type is @'Async' a@, which represents an asynchronous -- @IO@ action that will return a value of type @a@, or die with an -- exception. An @Async@ corresponds to a thread, and its 'ThreadId' -- can be obtained with 'asyncThreadId', although that should rarely -- be necessary. -- -- For example, to fetch two web pages at the same time, we could do -- this (assuming a suitable @getURL@ function): -- -- > do a1 <- async (getURL url1) -- > a2 <- async (getURL url2) -- > page1 <- wait a1 -- > page2 <- wait a2 -- > ... -- -- where 'async' starts the operation in a separate thread, and -- 'wait' waits for and returns the result. If the operation -- throws an exception, then that exception is re-thrown by -- 'wait'. This is one of the ways in which this library -- provides some additional safety: it is harder to accidentally -- forget about exceptions thrown in child threads. -- -- A slight improvement over the previous example is this: -- -- > withAsync (getURL url1) $ \a1 -> do -- > withAsync (getURL url2) $ \a2 -> do -- > page1 <- wait a1 -- > page2 <- wait a2 -- > ... -- -- 'withAsync' is like 'async', except that the 'Async' is -- automatically killed (using 'uninterruptibleCancel') if the -- enclosing IO operation returns before it has completed. Consider -- the case when the first 'wait' throws an exception; then the second -- 'Async' will be automatically killed rather than being left to run -- in the background, possibly indefinitely. This is the second way -- that the library provides additional safety: using 'withAsync' -- means we can avoid accidentally leaving threads running. -- Furthermore, 'withAsync' allows a tree of threads to be built, such -- that children are automatically killed if their parents die for any -- reason. -- -- The pattern of performing two IO actions concurrently and waiting -- for their results is packaged up in a combinator 'concurrently', so -- we can further shorten the above example to: -- -- > (page1, page2) <- concurrently (getURL url1) (getURL url2) -- > ... -- -- The 'Functor' instance can be used to change the result of an -- 'Async'. For example: -- -- > ghci> a <- async (return 3) -- > ghci> wait a -- > 3 -- > ghci> wait (fmap (+1) a) -- > 4 ----------------------------------------------------------------------------- module Control.Concurrent.Async ( -- * Asynchronous actions Async, -- ** Spawning async, asyncBound, asyncOn, asyncWithUnmask, asyncOnWithUnmask, -- ** Spawning with automatic 'cancel'ation withAsync, withAsyncBound, withAsyncOn, withAsyncWithUnmask, withAsyncOnWithUnmask, -- ** Querying 'Async's wait, poll, waitCatch, asyncThreadId, cancel, uninterruptibleCancel, cancelWith, AsyncCancelled(..), -- ** STM operations waitSTM, pollSTM, waitCatchSTM, -- ** Waiting for multiple 'Async's waitAny, waitAnyCatch, waitAnyCancel, waitAnyCatchCancel, waitEither, waitEitherCatch, waitEitherCancel, waitEitherCatchCancel, waitEither_, waitBoth, -- ** Waiting for multiple 'Async's in STM waitAnySTM, waitAnyCatchSTM, waitEitherSTM, waitEitherCatchSTM, waitEitherSTM_, waitBothSTM, -- ** Linking link, linkOnly, link2, link2Only, ExceptionInLinkedThread(..), -- * Convenient utilities race, race_, concurrently, concurrently_, mapConcurrently, forConcurrently, mapConcurrently_, forConcurrently_, replicateConcurrently, replicateConcurrently_, Concurrently(..), compareAsyncs, ) where import Control.Concurrent.STM import Control.Exception import Control.Concurrent import qualified Data.Foldable as F #if !MIN_VERSION_base(4,6,0) import Prelude hiding (catch) #endif import Control.Monad import Control.Applicative #if !MIN_VERSION_base(4,8,0) import Data.Monoid (Monoid(mempty,mappend)) import Data.Traversable #endif #if __GLASGOW_HASKELL__ < 710 import Data.Typeable #endif #if MIN_VERSION_base(4,9,0) import Data.Semigroup (Semigroup((<>))) #endif import Data.Hashable (Hashable(hashWithSalt)) import Data.IORef import GHC.Exts import GHC.IO hiding (finally, onException) import GHC.Conc -- ----------------------------------------------------------------------------- -- STM Async API -- | 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'). -- data Async a = Async { asyncThreadId :: {-# UNPACK #-} !ThreadId -- ^ Returns the 'ThreadId' of the thread running -- the given 'Async'. , _asyncWait :: STM (Either SomeException a) } instance Eq (Async a) where Async a _ == Async b _ = a == b instance Ord (Async a) where Async a _ `compare` Async b _ = a `compare` b instance Hashable (Async a) where hashWithSalt salt (Async a _) = hashWithSalt salt a instance Functor Async where fmap f (Async a w) = Async a (fmap (fmap f) w) -- | Compare two Asyncs that may have different types by their ThreadId. compareAsyncs :: Async a -> Async b -> Ordering compareAsyncs (Async t1 _) (Async t2 _) = compare t1 t2 -- | Spawn an asynchronous action in a separate thread. async :: IO a -> IO (Async a) async = inline asyncUsing rawForkIO -- | Like 'async' but using 'forkOS' internally. asyncBound :: IO a -> IO (Async a) asyncBound = asyncUsing forkOS -- | Like 'async' but using 'forkOn' internally. asyncOn :: Int -> IO a -> IO (Async a) asyncOn = asyncUsing . rawForkOn -- | Like 'async' but using 'forkIOWithUnmask' internally. The child -- thread is passed a function that can be used to unmask asynchronous -- exceptions. asyncWithUnmask :: ((forall b . IO b -> IO b) -> IO a) -> IO (Async a) asyncWithUnmask actionWith = asyncUsing rawForkIO (actionWith unsafeUnmask) -- | Like 'asyncOn' but using 'forkOnWithUnmask' internally. The -- child thread is passed a function that can be used to unmask -- asynchronous exceptions. asyncOnWithUnmask :: Int -> ((forall b . IO b -> IO b) -> IO a) -> IO (Async a) asyncOnWithUnmask cpu actionWith = asyncUsing (rawForkOn cpu) (actionWith unsafeUnmask) asyncUsing :: (IO () -> IO ThreadId) -> IO a -> IO (Async a) asyncUsing doFork = \action -> do var <- newEmptyTMVarIO -- t <- forkFinally action (\r -> atomically $ putTMVar var r) -- slightly faster: t <- mask $ \restore -> doFork $ try (restore action) >>= atomically . putTMVar var return (Async t (readTMVar 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 = mask $ \restore -> do -- > a <- async (restore action) -- > restore (inner a) `finally` uninterruptibleCancel a -- -- This is a useful variant of 'async' that ensures an @Async@ is -- never left running unintentionally. -- -- Note: a reference to the child thread is kept alive until the call -- to `withAsync` returns, so nesting many `withAsync` calls requires -- linear memory. -- withAsync :: IO a -> (Async a -> IO b) -> IO b withAsync = inline withAsyncUsing rawForkIO -- | Like 'withAsync' but uses 'forkOS' internally. withAsyncBound :: IO a -> (Async a -> IO b) -> IO b withAsyncBound = withAsyncUsing forkOS -- | Like 'withAsync' but uses 'forkOn' internally. withAsyncOn :: Int -> IO a -> (Async a -> IO b) -> IO b withAsyncOn = withAsyncUsing . rawForkOn -- | Like 'withAsync' but uses 'forkIOWithUnmask' internally. The -- child thread is passed a function that can be used to unmask -- asynchronous exceptions. withAsyncWithUnmask :: ((forall c. IO c -> IO c) -> IO a) -> (Async a -> IO b) -> IO b withAsyncWithUnmask actionWith = withAsyncUsing rawForkIO (actionWith unsafeUnmask) -- | Like 'withAsyncOn' but uses 'forkOnWithUnmask' internally. The -- child thread is passed a function that can be used to unmask -- asynchronous exceptions withAsyncOnWithUnmask :: Int -> ((forall c. IO c -> IO c) -> IO a) -> (Async a -> IO b) -> IO b withAsyncOnWithUnmask cpu actionWith = withAsyncUsing (rawForkOn cpu) (actionWith unsafeUnmask) withAsyncUsing :: (IO () -> IO ThreadId) -> IO a -> (Async a -> IO b) -> IO b -- The bracket version works, but is slow. We can do better by -- hand-coding it: withAsyncUsing doFork = \action inner -> do var <- newEmptyTMVarIO mask $ \restore -> do t <- doFork $ try (restore action) >>= atomically . putTMVar var let a = Async t (readTMVar var) r <- restore (inner a) `catchAll` \e -> do uninterruptibleCancel a throwIO e uninterruptibleCancel a return r -- | Wait for an asynchronous action to complete, and return its -- value. If the asynchronous action threw an exception, then the -- exception is re-thrown by 'wait'. -- -- > wait = atomically . waitSTM -- {-# INLINE wait #-} wait :: Async a -> IO a wait = tryAgain . atomically . waitSTM where -- See: https://github.com/simonmar/async/issues/14 tryAgain f = f `catch` \BlockedIndefinitelyOnSTM -> f -- | 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@. -- -- > waitCatch = atomically . waitCatchSTM -- {-# INLINE waitCatch #-} waitCatch :: Async a -> IO (Either SomeException a) waitCatch = tryAgain . atomically . waitCatchSTM where -- See: https://github.com/simonmar/async/issues/14 tryAgain f = f `catch` \BlockedIndefinitelyOnSTM -> f -- | 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 -- {-# INLINE poll #-} poll :: Async a -> IO (Maybe (Either SomeException a)) poll = atomically . pollSTM -- | A version of 'wait' that can be used inside an STM transaction. -- waitSTM :: Async a -> STM a waitSTM a = do r <- waitCatchSTM a either throwSTM return r -- | A version of 'waitCatch' that can be used inside an STM transaction. -- {-# INLINE waitCatchSTM #-} waitCatchSTM :: Async a -> STM (Either SomeException a) waitCatchSTM (Async _ w) = w -- | A version of 'poll' that can be used inside an STM transaction. -- {-# INLINE pollSTM #-} pollSTM :: Async a -> STM (Maybe (Either SomeException a)) pollSTM (Async _ w) = (Just <$> w) `orElse` return Nothing -- | Cancel an asynchronous action by throwing the @AsyncCancelled@ -- 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) AsyncCancelled <* 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 said thread blocks when receiving an asynchronous exception. -- -- For example, it could block if: -- -- * It's executing a foreign call, and thus cannot receive the asynchronous -- exception; -- * It's executing some cleanup handler after having received the exception, -- and the handler is blocking. {-# INLINE cancel #-} cancel :: Async a -> IO () cancel a@(Async t _) = throwTo t AsyncCancelled <* waitCatch a -- | The exception thrown by `cancel` to terminate a thread. data AsyncCancelled = AsyncCancelled deriving (Show, Eq #if __GLASGOW_HASKELL__ < 710 ,Typeable #endif ) instance Exception AsyncCancelled where #if __GLASGOW_HASKELL__ >= 708 fromException = asyncExceptionFromException toException = asyncExceptionToException #endif -- | Cancel an asynchronous action -- -- This is a variant of `cancel`, but it is not interruptible. {-# INLINE uninterruptibleCancel #-} uninterruptibleCancel :: Async a -> IO () uninterruptibleCancel = uninterruptibleMask_ . cancel -- | Cancel an asynchronous action by throwing the supplied exception -- to it. -- -- > cancelWith a x = throwTo (asyncThreadId a) x -- -- The notes about the synchronous nature of 'cancel' also apply to -- 'cancelWith'. cancelWith :: Exception e => Async a -> e -> IO () cancelWith a@(Async t _) e = throwTo t e <* waitCatch a -- | 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. -- {-# INLINE waitAnyCatch #-} waitAnyCatch :: [Async a] -> IO (Async a, Either SomeException a) waitAnyCatch = atomically . waitAnyCatchSTM -- | A version of 'waitAnyCatch' that can be used inside an STM transaction. -- -- @since 2.1.0 waitAnyCatchSTM :: [Async a] -> STM (Async a, Either SomeException a) waitAnyCatchSTM asyncs = foldr orElse retry $ map (\a -> do r <- waitCatchSTM a; return (a, r)) asyncs -- | Like 'waitAnyCatch', but also cancels the other asynchronous -- operations as soon as one has completed. -- waitAnyCatchCancel :: [Async a] -> IO (Async a, Either SomeException a) waitAnyCatchCancel asyncs = waitAnyCatch asyncs `finally` mapM_ cancel asyncs -- | 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. -- {-# INLINE waitAny #-} waitAny :: [Async a] -> IO (Async a, a) waitAny = atomically . waitAnySTM -- | A version of 'waitAny' that can be used inside an STM transaction. -- -- @since 2.1.0 waitAnySTM :: [Async a] -> STM (Async a, a) waitAnySTM asyncs = foldr orElse retry $ map (\a -> do r <- waitSTM a; return (a, r)) asyncs -- | Like 'waitAny', but also cancels the other asynchronous -- operations as soon as one has completed. -- waitAnyCancel :: [Async a] -> IO (Async a, a) waitAnyCancel asyncs = waitAny asyncs `finally` mapM_ cancel asyncs -- | Wait for the first of two @Async@s to finish. {-# INLINE waitEitherCatch #-} waitEitherCatch :: Async a -> Async b -> IO (Either (Either SomeException a) (Either SomeException b)) waitEitherCatch left right = tryAgain $ atomically (waitEitherCatchSTM left right) where -- See: https://github.com/simonmar/async/issues/14 tryAgain f = f `catch` \BlockedIndefinitelyOnSTM -> f -- | A version of 'waitEitherCatch' that can be used inside an STM transaction. -- -- @since 2.1.0 waitEitherCatchSTM :: Async a -> Async b -> STM (Either (Either SomeException a) (Either SomeException b)) waitEitherCatchSTM left right = (Left <$> waitCatchSTM left) `orElse` (Right <$> waitCatchSTM right) -- | Like 'waitEitherCatch', but also 'cancel's both @Async@s before -- returning. -- waitEitherCatchCancel :: Async a -> Async b -> IO (Either (Either SomeException a) (Either SomeException b)) waitEitherCatchCancel left right = waitEitherCatch left right `finally` (cancel left >> cancel right) -- | 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'. -- {-# INLINE waitEither #-} waitEither :: Async a -> Async b -> IO (Either a b) waitEither left right = atomically (waitEitherSTM left right) -- | A version of 'waitEither' that can be used inside an STM transaction. -- -- @since 2.1.0 waitEitherSTM :: Async a -> Async b -> STM (Either a b) waitEitherSTM left right = (Left <$> waitSTM left) `orElse` (Right <$> waitSTM right) -- | Like 'waitEither', but the result is ignored. -- {-# INLINE waitEither_ #-} waitEither_ :: Async a -> Async b -> IO () waitEither_ left right = atomically (waitEitherSTM_ left right) -- | A version of 'waitEither_' that can be used inside an STM transaction. -- -- @since 2.1.0 waitEitherSTM_:: Async a -> Async b -> STM () waitEitherSTM_ left right = (void $ waitSTM left) `orElse` (void $ waitSTM right) -- | Like 'waitEither', but also 'cancel's both @Async@s before -- returning. -- waitEitherCancel :: Async a -> Async b -> IO (Either a b) waitEitherCancel left right = waitEither left right `finally` (cancel left >> cancel 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'. -- {-# INLINE waitBoth #-} waitBoth :: Async a -> Async b -> IO (a,b) waitBoth left right = atomically (waitBothSTM left right) -- | A version of 'waitBoth' that can be used inside an STM transaction. -- -- @since 2.1.0 waitBothSTM :: Async a -> Async b -> STM (a,b) waitBothSTM left right = do a <- waitSTM left `orElse` (waitSTM right >> retry) b <- waitSTM right return (a,b) -- ----------------------------------------------------------------------------- -- Linking threads data ExceptionInLinkedThread = forall a . ExceptionInLinkedThread (Async a) SomeException #if __GLASGOW_HASKELL__ < 710 deriving Typeable #endif instance Show ExceptionInLinkedThread where showsPrec p (ExceptionInLinkedThread (Async t _) e) = showParen (p >= 11) $ showString "ExceptionInLinkedThread " . showsPrec 11 t . showString " " . showsPrec 11 e instance Exception ExceptionInLinkedThread where #if __GLASGOW_HASKELL__ >= 708 fromException = asyncExceptionFromException toException = asyncExceptionToException #endif -- | 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, wrapped in 'ExceptionInLinkedThread'. -- -- 'link' ignores 'AsyncCancelled' exceptions thrown in the other thread, -- so that it's safe to 'cancel' a thread you're linked to. If you want -- different behaviour, use 'linkOnly'. -- link :: Async a -> IO () link = linkOnly (not . isCancel) -- | 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, wrapped in 'ExceptionInLinkedThread'. -- -- The supplied predicate determines which exceptions in the target -- thread should be propagated to the source thread. -- linkOnly :: (SomeException -> Bool) -- ^ return 'True' if the exception -- should be propagated, 'False' -- otherwise. -> Async a -> IO () linkOnly shouldThrow a = do me <- myThreadId void $ forkRepeat $ do r <- waitCatch a case r of Left e | shouldThrow e -> throwTo me (ExceptionInLinkedThread a e) _otherwise -> return () -- | Link two @Async@s together, such that if either raises an -- exception, the same exception is re-thrown in the other @Async@, -- wrapped in 'ExceptionInLinkedThread'. -- -- 'link2' ignores 'AsyncCancelled' exceptions, so that it's possible -- to 'cancel' either thread without cancelling the other. If you -- want different behaviour, use 'link2Only'. -- link2 :: Async a -> Async b -> IO () link2 = link2Only (not . isCancel) -- | Link two @Async@s together, such that if either raises an -- exception, the same exception is re-thrown in the other @Async@, -- wrapped in 'ExceptionInLinkedThread'. -- -- The supplied predicate determines which exceptions in the target -- thread should be propagated to the source thread. -- link2Only :: (SomeException -> Bool) -> Async a -> Async b -> IO () link2Only shouldThrow left@(Async tl _) right@(Async tr _) = void $ forkRepeat $ do r <- waitEitherCatch left right case r of Left (Left e) | shouldThrow e -> throwTo tr (ExceptionInLinkedThread left e) Right (Left e) | shouldThrow e -> throwTo tl (ExceptionInLinkedThread right e) _ -> return () isCancel :: SomeException -> Bool isCancel e | Just AsyncCancelled <- fromException e = True | otherwise = False -- ----------------------------------------------------------------------------- -- | Run two @IO@ 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 -- race :: IO a -> IO b -> IO (Either a b) -- | Like 'race', but the result is ignored. -- race_ :: IO a -> IO b -> IO () -- | Run two @IO@ 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 concurrently :: IO a -> IO b -> IO (a,b) #define USE_ASYNC_VERSIONS 0 #if USE_ASYNC_VERSIONS race left right = withAsync left $ \a -> withAsync right $ \b -> waitEither a b race_ left right = withAsync left $ \a -> withAsync right $ \b -> waitEither_ a b concurrently left right = withAsync left $ \a -> withAsync right $ \b -> waitBoth a b #else -- MVar versions of race/concurrently -- More ugly than the Async versions, but quite a bit faster. -- race :: IO a -> IO b -> IO (Either a b) race left right = concurrently' left right collect where collect m = do e <- m case e of Left ex -> throwIO ex Right r -> return r -- race_ :: IO a -> IO b -> IO () race_ left right = void $ race left right -- concurrently :: IO a -> IO b -> IO (a,b) concurrently left right = concurrently' left right (collect []) where collect [Left a, Right b] _ = return (a,b) collect [Right b, Left a] _ = return (a,b) collect xs m = do e <- m case e of Left ex -> throwIO ex Right r -> collect (r:xs) m concurrently' :: IO a -> IO b -> (IO (Either SomeException (Either a b)) -> IO r) -> IO r concurrently' left right collect = do done <- newEmptyMVar mask $ \restore -> do -- Note: uninterruptibleMask here is because we must not allow -- the putMVar in the exception handler to be interrupted, -- otherwise the parent thread will deadlock when it waits for -- the thread to terminate. lid <- forkIO $ uninterruptibleMask_ $ restore (left >>= putMVar done . Right . Left) `catchAll` (putMVar done . Left) rid <- forkIO $ uninterruptibleMask_ $ restore (right >>= putMVar done . Right . Right) `catchAll` (putMVar done . Left) count <- newIORef (2 :: Int) let takeDone = do r <- takeMVar done -- interruptible -- Decrement the counter so we know how many takes are left. -- Since only the parent thread is calling this, we can -- use non-atomic modifications. -- NB. do this *after* takeMVar, because takeMVar might be -- interrupted. modifyIORef count (subtract 1) return r let tryAgain f = f `catch` \BlockedIndefinitelyOnMVar -> f stop = do -- kill right before left, to match the semantics of -- the version using withAsync. (#27) uninterruptibleMask_ $ do count' <- readIORef count -- we only need to use killThread if there are still -- children alive. Note: forkIO here is because the -- child thread could be in an uninterruptible -- putMVar. when (count' > 0) $ void $ forkIO $ do throwTo rid AsyncCancelled throwTo lid AsyncCancelled -- ensure the children are really dead replicateM_ count' (tryAgain $ takeMVar done) r <- collect (tryAgain $ takeDone) `onException` stop stop return r #endif -- | maps an @IO@-performing function over any @Traversable@ data -- type, performing all the @IO@ actions concurrently, and returning -- the original data structure with the arguments replaced by the -- results. -- -- If any of the actions throw an exception, then all other actions are -- cancelled and the exception is re-thrown. -- -- For example, @mapConcurrently@ works with lists: -- -- > pages <- mapConcurrently getURL ["url1", "url2", "url3"] -- mapConcurrently :: Traversable t => (a -> IO b) -> t a -> IO (t b) mapConcurrently f = runConcurrently . traverse (Concurrently . f) -- | `forConcurrently` is `mapConcurrently` with its arguments flipped -- -- > pages <- forConcurrently ["url1", "url2", "url3"] $ \url -> getURL url -- -- @since 2.1.0 forConcurrently :: Traversable t => t a -> (a -> IO b) -> IO (t b) forConcurrently = flip mapConcurrently -- | `mapConcurrently_` is `mapConcurrently` with the return value discarded, -- just like @mapM_@. mapConcurrently_ :: F.Foldable f => (a -> IO b) -> f a -> IO () mapConcurrently_ f = runConcurrently . F.foldMap (Concurrently . void . f) -- | `forConcurrently_` is `forConcurrently` with the return value discarded, -- just like @forM_@. forConcurrently_ :: F.Foldable f => f a -> (a -> IO b) -> IO () forConcurrently_ = flip mapConcurrently_ -- | 'concurrently', but ignore the result values -- -- @since 2.1.1 concurrently_ :: IO a -> IO b -> IO () concurrently_ left right = concurrently' left right (collect 0) where collect 2 _ = return () collect i m = do e <- m case e of Left ex -> throwIO ex Right _ -> collect (i + 1 :: Int) m -- | Perform the action in the given number of threads. -- -- @since 2.1.1 replicateConcurrently :: Int -> IO a -> IO [a] replicateConcurrently cnt = runConcurrently . sequenceA . replicate cnt . Concurrently -- | Same as 'replicateConcurrently', but ignore the results. -- -- @since 2.1.1 replicateConcurrently_ :: Int -> IO a -> IO () replicateConcurrently_ cnt = runConcurrently . F.fold . replicate cnt . Concurrently . void -- ----------------------------------------------------------------------------- -- | A value of type @Concurrently a@ is an @IO@ operation that can be -- composed with other @Concurrently@ values, using the @Applicative@ -- and @Alternative@ instances. -- -- Calling @runConcurrently@ on a value of type @Concurrently a@ will -- execute the @IO@ 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") -- newtype Concurrently a = Concurrently { runConcurrently :: IO a } instance Functor Concurrently where fmap f (Concurrently a) = Concurrently $ f <$> a instance Applicative Concurrently where pure = Concurrently . return Concurrently fs <*> Concurrently as = Concurrently $ (\(f, a) -> f a) <$> concurrently fs as instance Alternative Concurrently where empty = Concurrently $ forever (threadDelay maxBound) Concurrently as <|> Concurrently bs = Concurrently $ either id id <$> race as bs #if MIN_VERSION_base(4,9,0) -- | Only defined by @async@ for @base >= 4.9@ -- -- @since 2.1.0 instance Semigroup a => Semigroup (Concurrently a) where (<>) = liftA2 (<>) -- | @since 2.1.0 instance (Semigroup a, Monoid a) => Monoid (Concurrently a) where mempty = pure mempty mappend = (<>) #else -- | @since 2.1.0 instance Monoid a => Monoid (Concurrently a) where mempty = pure mempty mappend = liftA2 mappend #endif -- ---------------------------------------------------------------------------- -- | 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 :: IO a -> IO ThreadId forkRepeat action = mask $ \restore -> let go = do r <- tryAll (restore action) case r of Left _ -> go _ -> return () in forkIO go catchAll :: IO a -> (SomeException -> IO a) -> IO a catchAll = catch tryAll :: IO a -> IO (Either SomeException a) tryAll = try -- A version of forkIO that does not include the outer exception -- handler: saves a bit of time when we will be installing our own -- exception handler. {-# INLINE rawForkIO #-} rawForkIO :: IO () -> IO ThreadId rawForkIO action = IO $ \ s -> case (fork# action s) of (# s1, tid #) -> (# s1, ThreadId tid #) {-# INLINE rawForkOn #-} rawForkOn :: Int -> IO () -> IO ThreadId rawForkOn (I# cpu) action = IO $ \ s -> case (forkOn# cpu action s) of (# s1, tid #) -> (# s1, ThreadId tid #) async-2.2.2/test/0000755000000000000000000000000013476136253012011 5ustar0000000000000000async-2.2.2/test/test-async.hs0000644000000000000000000002371613476136253014450 0ustar0000000000000000{-# LANGUAGE ScopedTypeVariables,DeriveDataTypeable #-} module Main where import Test.Framework (defaultMain, testGroup) import Test.Framework.Providers.HUnit import Test.HUnit import Control.Concurrent.STM import Control.Concurrent.Async import Control.Exception import Data.IORef import Data.Typeable import Control.Concurrent import Control.Monad import Data.List (sort) import Data.Maybe import Prelude hiding (catch) main = defaultMain tests tests = [ testCase "async_wait" async_wait , testCase "async_waitCatch" async_waitCatch , testCase "async_exwait" async_exwait , testCase "async_exwaitCatch" async_exwaitCatch , testCase "withasync_waitCatch" withasync_waitCatch , testCase "withasync_wait2" withasync_wait2 , testGroup "async_cancel_rep" $ replicate 1000 $ testCase "async_cancel" async_cancel , testCase "async_cancelmany" async_cancelmany , testCase "async_poll" async_poll , testCase "async_poll2" async_poll2 , testCase "withasync_waitCatch_blocked" withasync_waitCatch_blocked , testCase "withasync_wait_blocked" withasync_wait_blocked , testGroup "children surviving too long" [ testCase "concurrently+success" concurrently_success , testCase "concurrently+failure" concurrently_failure , testCase "race+success" race_success , testCase "race+failure" race_failure , testCase "cancel" cancel_survive , testCase "withAsync" withasync_survive ] , testCase "concurrently_" case_concurrently_ , testCase "replicateConcurrently_" case_replicateConcurrently , testCase "replicateConcurrently" case_replicateConcurrently_ , testCase "link1" case_link1 , testCase "link2" case_link2 , testCase "link1_cancel" case_link1cancel , testCase "concurrently_deadlock" case_concurrently_deadlock ] value = 42 :: Int data TestException = TestException deriving (Eq,Show,Typeable) instance Exception TestException async_waitCatch :: Assertion async_waitCatch = do a <- async (return value) r <- waitCatch a case r of Left _ -> assertFailure "" Right e -> e @?= value async_wait :: Assertion async_wait = do a <- async (return value) r <- wait a assertEqual "async_wait" r value async_exwaitCatch :: Assertion async_exwaitCatch = do a <- async (throwIO TestException) r <- waitCatch a case r of Left e -> fromException e @?= Just TestException Right _ -> assertFailure "" async_exwait :: Assertion async_exwait = do a <- async (throwIO TestException) (wait a >> assertFailure "") `catch` \e -> e @?= TestException withasync_waitCatch :: Assertion withasync_waitCatch = do withAsync (return value) $ \a -> do r <- waitCatch a case r of Left _ -> assertFailure "" Right e -> e @?= value withasync_wait2 :: Assertion withasync_wait2 = do a <- withAsync (threadDelay 1000000) $ return r <- waitCatch a case r of Left e -> fromException e @?= Just AsyncCancelled Right _ -> assertFailure "" async_cancel :: Assertion async_cancel = do a <- async (return value) cancelWith a TestException r <- waitCatch a case r of Left e -> fromException e @?= Just TestException Right r -> r @?= value async_cancelmany :: Assertion -- issue 59 async_cancelmany = do r <- newIORef [] a <- async $ forConcurrently_ ['a'..'z'] $ \c -> delay 2 `finally` atomicModifyIORef r (\i -> (c:i,())) delay 1 cancel a v <- readIORef r assertEqual "cancelmany" 26 (length v) where delay sec = threadDelay (sec * 1000000) async_poll :: Assertion async_poll = do a <- async (threadDelay 1000000) r <- poll a when (isJust r) $ assertFailure "" r <- poll a -- poll twice, just to check we don't deadlock when (isJust r) $ assertFailure "" async_poll2 :: Assertion async_poll2 = do a <- async (return value) wait a r <- poll a when (isNothing r) $ assertFailure "" r <- poll a -- poll twice, just to check we don't deadlock when (isNothing r) $ assertFailure "" withasync_waitCatch_blocked :: Assertion withasync_waitCatch_blocked = do r <- withAsync (newEmptyMVar >>= takeMVar) waitCatch case r of Left e -> case fromException e of Just BlockedIndefinitelyOnMVar -> return () Nothing -> assertFailure $ show e Right () -> assertFailure "" withasync_wait_blocked :: Assertion withasync_wait_blocked = do r <- try $ withAsync (newEmptyMVar >>= takeMVar) wait case r of Left e -> case fromException e of Just BlockedIndefinitelyOnMVar -> return () Nothing -> assertFailure $ show e Right () -> assertFailure "" concurrently_success :: Assertion concurrently_success = do finalRes <- newIORef "never filled" baton <- newEmptyMVar let quick = return () slow = threadDelay 10000 `finally` do threadDelay 10000 writeIORef finalRes "slow" putMVar baton () _ <- concurrently quick slow writeIORef finalRes "parent" takeMVar baton res <- readIORef finalRes res @?= "parent" concurrently_failure :: Assertion concurrently_failure = do finalRes <- newIORef "never filled" let quick = error "a quick death" slow = threadDelay 10000 `finally` do threadDelay 10000 writeIORef finalRes "slow" _ :: Either SomeException ((), ()) <- try (concurrently quick slow) writeIORef finalRes "parent" threadDelay 1000000 -- not using the baton, can lead to deadlock detection res <- readIORef finalRes res @?= "parent" race_success :: Assertion race_success = do finalRes <- newIORef "never filled" let quick = return () slow = threadDelay 10000 `finally` do threadDelay 10000 writeIORef finalRes "slow" race_ quick slow writeIORef finalRes "parent" threadDelay 1000000 -- not using the baton, can lead to deadlock detection res <- readIORef finalRes res @?= "parent" race_failure :: Assertion race_failure = do finalRes <- newIORef "never filled" baton <- newEmptyMVar let quick = error "a quick death" slow restore = restore (threadDelay 10000) `finally` do threadDelay 10000 writeIORef finalRes "slow" putMVar baton () _ :: Either SomeException () <- try $ mask $ \restore -> race_ quick (slow restore) writeIORef finalRes "parent" takeMVar baton res <- readIORef finalRes res @?= "parent" cancel_survive :: Assertion cancel_survive = do finalRes <- newIORef "never filled" a <- async $ threadDelay 10000 `finally` do threadDelay 10000 writeIORef finalRes "child" cancel a writeIORef finalRes "parent" threadDelay 1000000 -- not using the baton, can lead to deadlock detection res <- readIORef finalRes res @?= "parent" withasync_survive :: Assertion withasync_survive = do finalRes <- newIORef "never filled" let child = threadDelay 10000 `finally` do threadDelay 10000 writeIORef finalRes "child" withAsync child (\_ -> return ()) writeIORef finalRes "parent" threadDelay 1000000 -- not using the baton, can lead to deadlock detection res <- readIORef finalRes res @?= "parent" case_concurrently_ :: Assertion case_concurrently_ = do ref <- newIORef 0 () <- concurrently_ (atomicModifyIORef ref (\x -> (x + 1, True))) (atomicModifyIORef ref (\x -> (x + 2, 'x'))) res <- readIORef ref res @?= 3 case_replicateConcurrently :: Assertion case_replicateConcurrently = do ref <- newIORef 0 let action = atomicModifyIORef ref (\x -> (x + 1, x + 1)) resList <- replicateConcurrently 100 action resVal <- readIORef ref resVal @?= 100 sort resList @?= [1..100] case_replicateConcurrently_ :: Assertion case_replicateConcurrently_ = do ref <- newIORef 0 let action = atomicModifyIORef ref (\x -> (x + 1, x + 1)) () <- replicateConcurrently_ 100 action resVal <- readIORef ref resVal @?= 100 case_link1 :: Assertion case_link1 = do m1 <- newEmptyMVar m2 <- newEmptyMVar let ex = ErrorCall "oops" a <- async $ do takeMVar m1; throwIO ex; putMVar m2 () link a e <- try $ (do putMVar m1 () takeMVar m2) assertBool "link1" $ case e of Left (ExceptionInLinkedThread a' e') -> compareAsyncs a' a == EQ && case fromException e' of Just (ErrorCall s) -> s == "oops" _otherwise -> False _other -> False case_link2 :: Assertion case_link2 = do let setup = do m1 <- newEmptyMVar m2 <- newEmptyMVar let ex1 = ErrorCall "oops1"; ex2 = ErrorCall "oops2" a <- async $ do takeMVar m1; throwIO ex1 b <- async $ do takeMVar m2; throwIO ex2 link2 a b return (m1,m2,a,b) (m1,m2,a,b) <- setup e <- try $ do putMVar m1 () wait b putMVar m2 () -- ensure the other thread is not deadlocked assertBool "link2a" $ case e of Left (ExceptionInLinkedThread a' e') -> compareAsyncs a' a == EQ && case fromException e' of Just (ErrorCall s) -> s == "oops1" _otherwise -> False _other -> False (m1,m2,a,b) <- setup e <- try $ do putMVar m2 () wait a putMVar m1 () -- ensure the other thread is not deadlocked assertBool "link2b" $ case e of Left (ExceptionInLinkedThread a' e') -> compareAsyncs a' b == EQ && case fromException e' of Just (ErrorCall s) -> s == "oops2" _otherwise -> False _other -> False case_link1cancel :: Assertion case_link1cancel = do m1 <- newEmptyMVar let ex = ErrorCall "oops" a <- async $ do takeMVar m1 link a e <- try $ do cancel a; wait a putMVar m1 () assertBool "link1cancel" $ case e of Left AsyncCancelled -> True -- should not be ExceptionInLinkedThread _other -> False -- See Issue #62 case_concurrently_deadlock :: Assertion case_concurrently_deadlock = do tvar <- newTVarIO False :: IO (TVar Bool) e <- try $ void $ join (concurrently) (atomically $ readTVar tvar >>= check) -- should throw BlockedIndefinitelyOnSTM not BlockedIndefinitelyOnMVar assertBool "concurrently_deadlock" $ case e of Left BlockedIndefinitelyOnSTM{} -> True _other -> False