diff --git a/Control/Async.hs b/Control/Async.hs deleted file mode 100644 --- a/Control/Async.hs +++ /dev/null @@ -1,71 +0,0 @@ -{- | - Module : Control.Async - License : BSD3 - Maintainer : simons@cryp.to - Stability : stable - Portability : portable - - An implementation of IO computations that return their value asynchronously. --} - -module Control.Async - ( Async - , forkAsync - , throwToAsync - , killAsync - , isReadyAsync - , waitForAsync - , parIO - ) - where - -import Control.Concurrent -import Control.Exception - -type AsyncMVar a = MVar (Either SomeException a) - --- | @Async a@ represents a value @a@ that is being computed --- asynchronously, i.e. a value that is going to become available at --- some point in the future. -data Async a = Child ThreadId (AsyncMVar a) - -forkAsync' :: IO a -> AsyncMVar a -> IO (Async a) -forkAsync' f mv = fmap (`Child` mv) (mask $ \unmask -> forkIO (try (unmask f) >>= tryPutMVar mv >> return ())) - --- | Start an asynchronous computation. -forkAsync :: IO a -> IO (Async a) -forkAsync f = newEmptyMVar >>= forkAsync' f - --- | Throw an asynchronous exception to the thread that performs the --- computation associated with this value. -throwToAsync :: Exception e => Async a -> e -> IO () -throwToAsync (Child pid _) = throwTo pid - --- | Abort the asynchronous computation associated with this value. -killAsync :: Async a -> IO () -killAsync (Child pid _) = killThread pid - --- | Test whether the asynchronous value has become available. -isReadyAsync :: Async a -> IO Bool -isReadyAsync (Child _ mv) = fmap not (isEmptyMVar mv) - --- | Wait for the asynchronous value to become available, and retrieve --- it. If the computation that generated the value has thrown an --- exception, then that exception will be raised here. -waitForAsync :: Async a -> IO a -waitForAsync (Child _ sync) = fmap (either throw id) (readMVar sync) - --- | Run both computations in parallel and return the @a@ value of the --- computation that terminates first. An exception in either of the two --- computations aborts the entire @parIO@ computation. - -parIO :: IO a -> IO a -> IO a -parIO f g = do - sync <- newEmptyMVar - bracket - (forkAsync' f sync) - killAsync - (\_ -> bracket - (forkAsync' g sync) - killAsync - waitForAsync) diff --git a/Control/Concurrent/Async.hs b/Control/Concurrent/Async.hs new file mode 100644 --- /dev/null +++ b/Control/Concurrent/Async.hs @@ -0,0 +1,489 @@ +{-# LANGUAGE CPP, MagicHash, UnboxedTuples #-} +{-# 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 'cancel') 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) +-- > ... + +----------------------------------------------------------------------------- + +module Control.Concurrent.Async ( + + -- * Asynchronous actions + Async, async, withAsync, asyncThreadId, + wait, poll, waitCatch, cancel, cancelWith, + + -- ** STM operations + waitSTM, pollSTM, waitCatchSTM, + + -- ** Waiting for multiple 'Async's + waitAny, waitAnyCatch, waitAnyCancel, waitAnyCatchCancel, + waitEither, waitEitherCatch, waitEitherCancel, waitEitherCatchCancel, + waitEither_, + waitBoth, + + -- ** Linking + link, link2, + + -- * Convenient utilities + race, race_, concurrently, + ) where + +import Control.Concurrent.STM +import Control.Exception +import Control.Concurrent +import Prelude hiding (catch) +import Control.Monad +import Control.Applicative + +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'. + , _asyncVar :: {-# UNPACK #-} !(TMVar (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 + +-- | Spawn an asynchronous action in a separate thread. +async :: IO a -> IO (Async a) +async action = do + var <- newEmptyTMVarIO + -- t <- forkFinally action (\r -> atomically $ putTMVar var r) + -- slightly faster: + t <- mask $ \restore -> + rawForkIO $ do r <- try (restore action); atomically $ putTMVar var r + return (Async t 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, 'cancel' is called on the @Async@. +-- +-- > withAsync action inner = bracket (async action) cancel inner +-- +-- This is a useful variant of 'async' that ensures an @Async@ is +-- never left running unintentionally. +-- +-- Since 'cancel' may block, 'withAsync' may also block; see 'cancel' +-- for details. +-- +withAsync :: IO a -> (Async a -> IO b) -> IO b +-- The bracket version works, but is slow. We can do better by +-- hand-coding it: +withAsync action inner = do + var <- newEmptyTMVarIO + mask $ \restore -> do + t <- rawForkIO $ try (restore action) >>= \r -> atomically $ putTMVar var r + let a = Async t var + r <- restore (inner a) `catchAll` \e -> do cancel a; throwIO e + cancel 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 = atomically . waitSTM + +-- | 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 = atomically . waitCatchSTM + +-- | 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 (Async _ var) = do + r <- readTMVar var + 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 _ var) = readTMVar var + +-- | A version of 'poll' that can be used inside an STM transaction. +-- +{-# INLINE pollSTM #-} +pollSTM :: Async a -> STM (Maybe (Either SomeException a)) +#if MIN_VERSION_stm(2,3,0) +pollSTM (Async _ var) = tryReadTMVar var +#else +pollSTM (Async _ var) = do + r <- tryTakeTMVar var + case r of + Nothing -> return Nothing + Just x -> do putTMVar var x; return (Just x) +#endif + +-- | Cancel an asynchronous action by throwing the @ThreadKilled@ +-- exception to it. Has no effect if the 'Async' has already +-- completed. +-- +-- > cancel a = throwTo (asyncThreadId a) ThreadKilled +-- +-- Note that 'cancel' is synchronous in the same sense as 'throwTo'. +-- It does not return until the exception has been thrown in the +-- target thread, or the target thread has completed. In particular, +-- if the target thread is making a foreign call, the exception will +-- not be thrown until the foreign call returns, and in this case +-- 'cancel' may block indefinitely. An asynchronous 'cancel' can +-- of course be obtained by wrapping 'cancel' itself in 'async'. +-- +{-# INLINE cancel #-} +cancel :: Async a -> IO () +cancel (Async t _) = throwTo t ThreadKilled + +-- | 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 (Async t _) e = throwTo t e + +-- | 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. +-- +waitAnyCatch :: [Async a] -> IO (Async a, Either SomeException a) +waitAnyCatch asyncs = + atomically $ + 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. +-- +waitAny :: [Async a] -> IO (Async a, a) +waitAny asyncs = + atomically $ + 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. +waitEitherCatch :: Async a -> Async b + -> IO (Either (Either SomeException a) + (Either SomeException b)) +waitEitherCatch left right = + atomically $ + (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'. +-- +waitEither :: Async a -> Async b -> IO (Either a b) +waitEither left right = + atomically $ + (Left <$> waitSTM left) + `orElse` + (Right <$> waitSTM right) + +-- | Like 'waitEither', but the result is ignored. +-- +waitEither_ :: Async a -> Async b -> IO () +waitEither_ left right = + atomically $ + (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'. +-- +waitBoth :: Async a -> Async b -> IO (a,b) +waitBoth left right = + atomically $ do + a <- waitSTM left + `orElse` + (waitSTM right >> retry) + b <- waitSTM right + return (a,b) + + +-- | 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. +-- +link :: Async a -> IO () +link (Async _ var) = do + me <- myThreadId + void $ forkRepeat $ do + r <- atomically $ readTMVar var + case r of + Left e -> throwTo me e + _ -> return () + +-- | Link two @Async@s together, such that if either raises an +-- exception, the same exception is re-thrown in the other @Async@. +-- +link2 :: Async a -> Async b -> IO () +link2 left@(Async tl _) right@(Async tr _) = + void $ forkRepeat $ do + r <- waitEitherCatch left right + case r of + Left (Left e) -> throwTo tr e + Right (Left e) -> throwTo tl e + _ -> return () + + + +-- ----------------------------------------------------------------------------- + +-- | 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 <- takeMVar 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 <- takeMVar m + case e of + Left ex -> throwIO ex + Right r -> collect (r:xs) m + +concurrently' :: IO a -> IO b + -> (MVar (Either SomeException (Either a b)) -> IO r) + -> IO r +concurrently' left right collect = do + done <- newEmptyMVar + mask $ \restore -> do + lid <- forkIO $ restore (left >>= putMVar done . Right . Left) + `catchAll` (putMVar done . Left) + rid <- forkIO $ restore (right >>= putMVar done . Right . Right) + `catchAll` (putMVar done . Left) + let stop = killThread lid >> killThread rid + r <- restore (collect done) `onException` stop + stop + return r + +#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 #) diff --git a/LICENSE b/LICENSE --- a/LICENSE +++ b/LICENSE @@ -1,30 +1,30 @@ -Redistribution and use in source and binary forms, with or -without modification, are permitted provided that the -following conditions are met: +Copyright (c) 2012, Simon Marlow - * Redistributions of source code must retain the above - copyright notice, this list of conditions and the - following disclaimer. +All rights reserved. - * 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. +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are met: - * The names of its contributors may not be used to endorse - or promote products derived from this software without - specific prior written permission. + * Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. -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. + * 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. diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/Setup.lhs b/Setup.lhs deleted file mode 100644 --- a/Setup.lhs +++ /dev/null @@ -1,8 +0,0 @@ -#!/usr/bin/env runhaskell - -> module Main (main) where -> -> import Distribution.Simple -> -> main :: IO () -> main = defaultMain diff --git a/async.cabal b/async.cabal --- a/async.cabal +++ b/async.cabal @@ -1,25 +1,57 @@ -Name: async -Version: 1.4 -Copyright: (c) 2004-2011 Peter Simons -License: BSD3 -License-File: LICENSE -Author: Peter Simons -Maintainer: Peter Simons -Homepage: http://gitorious.org/async/ -Category: Control, Concurrency, Parallelism -Synopsis: Asynchronous Computations -Cabal-Version: >= 1.6 -Build-Type: Simple -Tested-With: GHC == 7.0.4, GHC == 7.2.1 -Description: - An implementation of IO computations that return their value - asynchronously. +name: async +synopsis: Run IO operations asynchronously and wait for their results -Source-Repository head - Type: git - Location: git://gitorious.org/async/mainline.git +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 handle the exception + ('wait') or re-throw it ('waitThrow'); 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'). -Library - Build-Depends: base >= 4.3 && < 5 - Exposed-Modules: Control.Async - Ghc-Options: -Wall +version: 2.0.0.0 +license: BSD3 +license-file: LICENSE +author: Simon Marlow +maintainer: Simon Marlow +copyright: (c) Simon Marlow 2012 +category: Concurrency +build-type: Simple +cabal-version: >=1.8 +homepage: https://github.com/simonmar/async +bug-reports: https://github.com/simonmar/async/issues +tested-with: GHC==7.0.3, GHC==7.2.2, GHC==7.4.1 + +extra-source-files: + bench/race.hs + +source-repository head + type: git + location: https://github.com/simonmar/async.git + +library + exposed-modules: Control.Concurrent.Async + build-depends: base >= 4.3 && < 4.6, stm >= 2.2 && < 2.4 + +test-suite test-async + type: exitcode-stdio-1.0 + hs-source-dirs: test + main-is: test-async.hs + build-depends: base >= 4.3 && < 4.6, + async, + test-framework, + test-framework-hunit, + HUnit diff --git a/bench/race.hs b/bench/race.hs new file mode 100644 --- /dev/null +++ b/bench/race.hs @@ -0,0 +1,8 @@ +import 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) diff --git a/test/test-async.hs b/test/test-async.hs new file mode 100644 --- /dev/null +++ b/test/test-async.hs @@ -0,0 +1,106 @@ +{-# LANGUAGE ScopedTypeVariables,DeriveDataTypeable #-} +module Main where + +import Test.Framework (defaultMain, testGroup) +import Test.Framework.Providers.HUnit + +import Test.HUnit + +import Control.Concurrent.Async +import Control.Exception +import Data.Typeable +import Control.Concurrent +import Control.Monad +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_poll" async_poll + , testCase "async_poll2" async_poll2 + ] + +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 ThreadKilled + 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_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 ""