async 1.4 → 2.0.0.0

raw patch · 8 files changed

+686/−128 lines, 8 filesdep +HUnitdep +asyncdep +stmdep ~basesetup-changednew-uploaderPVP ok

version bump matches the API change (PVP)

Dependencies added: HUnit, async, stm, test-framework, test-framework-hunit

Dependency ranges changed: base

API changes (from Hackage documentation)

Files

• Control/Async.hs +0/−71
• Control/Concurrent/Async.hs +489/−0
• LICENSE +26/−26
• Setup.hs +2/−0
• Setup.lhs +0/−8
• async.cabal +55/−23
• bench/race.hs +8/−0
• test/test-async.hs +106/−0

@@ -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)

@@ -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 <marlowsd@gmail.com>+-- 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 #)

@@ -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.

@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain

@@ -1,8 +0,0 @@-#!/usr/bin/env runhaskell--> module Main (main) where->-> import Distribution.Simple->-> main :: IO ()-> main = defaultMain

@@ -1,25 +1,57 @@-Name:                   async-Version:                1.4-Copyright:              (c) 2004-2011 Peter Simons-License:                BSD3-License-File:           LICENSE-Author:                 Peter Simons <simons@cryp.to>-Maintainer:             Peter Simons <simons@cryp.to>-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 <marlowsd@gmail.com>+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

@@ -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)

@@ -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 ""