packages feed

async-dejafu (empty) → 0.1.0.0

raw patch · 5 files changed

+723/−0 lines, 5 filesdep +HUnitdep +async-dejafudep +basesetup-changed

Dependencies added: HUnit, async-dejafu, base, dejafu, exceptions, hunit-dejafu

Files

+ Control/Concurrent/Async.hs view
@@ -0,0 +1,539 @@+{-# LANGUAGE CPP        #-}+{-# LANGUAGE RankNTypes #-}++-- | This module is a version of the+-- <https://hackage.haskell.org/package/async async> package using the+-- <https://hackage.haskell.org/package/dejafu dejafu> concurrency+-- abstraction. It provides a set of operations for running+-- @MonadConc@ operations asynchronously and waiting for their+-- results.+--+-- For example, assuming a suitable @getURL@ function, we can fetch+-- the contents of two web pages at the same time:+--+-- > withAsync (getURL url1) $ \a1 -> do+-- > withAsync (getURL url2) $ \a2 -> do+-- > page1 <- wait a1+-- > page2 <- wait a2+-- > ...+--+-- The 'withAsync' function starts an operation in a separate thread,+-- and kills it if the inner action finishes before it completes.+--+-- There are a few deviations from the regular async package:+--+--   * 'asyncBound' and 'withAsyncBound' are missing as dejafu does+--   not support bound threads.+--+--   * The @Alternative@ instance for 'Concurrently' uses @forever+--   yield@ in the definition of @empty@, rather than @forever+--   (threadDelay maxBound)@.+module Control.Concurrent.Async+  ( -- * Asynchronous actions+    Async++  -- * Spawning+  , async+  , asyncOn+  , asyncWithUnmask+  , asyncOnWithUnmask++  -- * Spawning with automatic 'cancel'ation+  , withAsync+  , withAsyncOn+  , withAsyncWithUnmask+  , withAsyncOnWithUnmask++  -- * Querying 'Async's+  , wait, waitSTM+  , poll, pollSTM+  , waitCatch, waitCatchSTM+  , cancel+  , cancelWith+  , asyncThreadId++  -- * Waiting for multiple 'Async's+  , waitAny, waitAnySTM+  , waitAnyCatch, waitAnyCatchSTM+  , waitAnyCancel+  , waitAnyCatchCancel+  , waitEither, waitEitherSTM+  , waitEitherCatch, waitEitherCatchSTM+  , waitEitherCancel+  , waitEitherCatchCancel+  , waitEither_, waitEitherSTM_+  , waitBoth, waitBothSTM++  -- * Linking+  , link+  , link2++  -- * Convenient utilities+  , race+  , race_+  , concurrently+  , mapConcurrently+  , forConcurrently+  , Concurrently(..)+  ) where++import Control.Applicative+import Control.Exception (AsyncException(ThreadKilled), BlockedIndefinitelyOnSTM(..), Exception, SomeException)+import Control.Monad+import Control.Monad.Catch (finally, try, onException)+import Control.Monad.Conc.Class+import Control.Monad.STM.Class+import Control.Concurrent.STM.CTMVar (newEmptyCTMVar, putCTMVar, readCTMVar)++#if !MIN_VERSION_base(4,8,0)+import Data.Traversable+#endif+++-----------------------------------------------------------------------------------------+-- Asynchronous and Concurrent Actions++-- | An asynchronous action spawned by 'async' or+-- 'withAsync'. Asynchronous actions are executed in a separate+-- thread, and operations are provided for waiting for asynchronous+-- actions to complete and obtaining their results (see e.g. 'wait').+--+-- Note that, unlike the \"async\" package, 'Async' here does not have+-- an 'Ord' instance. This is because 'MonadConc' 'ThreadId's do not+-- necessarily have one.+data Async m a = Async+  { asyncThreadId :: !(ThreadId m)+  , _asyncWait :: STMLike m (Either SomeException a)+  }++instance MonadConc m => Eq (Async m a) where+  Async t1 _ == Async t2 _ = t1 == t2++instance MonadConc m => Functor (Async m) where+  fmap f (Async t w) = Async t $ fmap f <$> w++-- | A value of type @Concurrently m a@ is a @MonadConc@ operation+-- that can be composed with other @Concurrently@ values, using the+-- @Applicative@ and @Alternative@ instances.+--+-- Calling @runConcurrently@ on a value of type @Concurrently m a@+-- will execute the @MonadConc@ operations it contains concurrently,+-- before delivering the result of type @a@.+--+-- For example+--+-- > (page1, page2, page3)+-- >   <- runConcurrently $ (,,)+-- >   <$> Concurrently (getURL "url1")+-- >   <*> Concurrently (getURL "url2")+-- >   <*> Concurrently (getURL "url3")+newtype Concurrently m a = Concurrently { runConcurrently :: m a }++instance MonadConc m => Functor (Concurrently m) where+  fmap f (Concurrently a) = Concurrently $ f <$> a++instance MonadConc m => Applicative (Concurrently m) where+  pure = Concurrently . return++  Concurrently fs <*> Concurrently as =+    Concurrently $ (\(f, a) -> f a) <$> concurrently fs as++instance MonadConc m => Alternative (Concurrently m) where+  empty = Concurrently $ forever yield++  Concurrently as <|> Concurrently bs =+    Concurrently $ either id id <$> race as bs+++-------------------------------------------------------------------------------+-- Spawning++-- | Spawn an asynchronous action in a separate thread.+async :: MonadConc m => m a -> m (Async m a)+async = asyncUsing fork++-- | Like 'async' but using 'forkOn' internally.+asyncOn :: MonadConc m => Int -> m a -> m (Async m a)+asyncOn = asyncUsing . forkOn++-- | Like 'async' but using 'forkWithUnmask' internally.+asyncWithUnmask :: MonadConc m => ((forall b. m b -> m b) -> m a) -> m (Async m a)+asyncWithUnmask = asyncUnmaskUsing forkWithUnmask++-- | Like 'asyncOn' but using 'forkOnWithUnmask' internally.+asyncOnWithUnmask :: MonadConc m => Int -> ((forall b. m b -> m b) -> m a) -> m (Async m a)+asyncOnWithUnmask i = asyncUnmaskUsing (forkOnWithUnmask i)++-- | Fork a thread with the given forking function+asyncUsing :: MonadConc m => (m () -> m (ThreadId m)) -> m a -> m (Async m a)+asyncUsing doFork action = do+  var <- atomically newEmptyCTMVar+  tid <- mask $ \restore -> doFork $ try (restore action) >>= atomically . putCTMVar var++  return $ Async tid (readCTMVar var)++-- | Fork a thread with the given forking function and give it an+-- action to unmask exceptions+asyncUnmaskUsing :: MonadConc m => (((forall b. m b -> m b) -> m ()) -> m (ThreadId m)) -> ((forall b. m b -> m b) -> m a) -> m (Async m a)+asyncUnmaskUsing doFork action = do+  var <- atomically newEmptyCTMVar+  tid <- doFork $ \restore -> try (action restore) >>= atomically . putCTMVar var++  return $ Async tid (readCTMVar 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 :: MonadConc m => m a -> (Async m a -> m b) -> m b+withAsync = withAsyncUsing fork++-- | Like 'withAsync' but uses 'forkOn' internally.+withAsyncOn :: MonadConc m => Int -> m a -> (Async m a -> m b) -> m b+withAsyncOn = withAsyncUsing . forkOn++-- | Like 'withAsync' bit uses 'forkWithUnmask' internally.+withAsyncWithUnmask :: MonadConc m => ((forall x. m x -> m x) -> m a) -> (Async m a -> m b) -> m b+withAsyncWithUnmask = withAsyncUnmaskUsing forkWithUnmask++-- | Like 'withAsyncOn' bit uses 'forkOnWithUnmask' internally.+withAsyncOnWithUnmask :: MonadConc m => Int -> ((forall x. m x -> m x) -> m a) -> (Async m a -> m b) -> m b+withAsyncOnWithUnmask i = withAsyncUnmaskUsing (forkOnWithUnmask i)++-- | Fork a thread with the given forking function and kill it when+-- the inner action completes.+--+-- The 'bracket' version appears to hang, even with just IO stuff and+-- using the normal async package. Curious.+withAsyncUsing :: MonadConc m => (m () -> m (ThreadId m)) -> m a -> (Async m a -> m b) -> m b+withAsyncUsing doFork action inner = do+  var <- atomically newEmptyCTMVar+  tid <- mask $ \restore -> doFork $ try (restore action) >>= atomically . putCTMVar var++  let a = Async tid (readCTMVar var)++  res <- inner a `catchAll` (\e -> cancel a >> throw e)+  cancel a++  return res++-- | Fork a thread with the given forking function, give it an action+-- to unmask exceptions, and kill it when the inner action completed.+withAsyncUnmaskUsing :: MonadConc m => (((forall x. m x -> m x) -> m ()) -> m (ThreadId m)) -> ((forall x. m x -> m x) -> m a) -> (Async m a -> m b) -> m b+withAsyncUnmaskUsing doFork action inner = do+  var <- atomically newEmptyCTMVar+  tid <- doFork $ \restore -> try (action restore) >>= atomically . putCTMVar var++  let a = Async tid (readCTMVar var)++  res <- inner a `catchAll` (\e -> cancel a >> throw e)+  cancel a++  return res++catchAll :: MonadConc m => m a -> (SomeException -> m a) -> m a+catchAll = catch++-------------------------------------------------------------------------------+-- Querying++-- | Wait for an asynchronous action to complete, and return its+-- value. If the asynchronous value threw an exception, then the+-- exception is re-thrown by 'wait'.+--+-- > wait = atomically . waitSTM+wait :: MonadConc m => Async m a -> m a+wait = atomically . waitSTM++-- | A version of 'wait' that can be used inside a @MonadSTM@ transaction.+waitSTM :: MonadConc m => Async m a -> STMLike m a+waitSTM a = do+ r <- waitCatchSTM a+ either throwSTM return r++-- | Check whether an 'Async' has completed yet. If it has not+-- completed yet, then the result is @Nothing@, otherwise the result+-- is @Just e@ where @e@ is @Left x@ if the @Async@ raised an+-- exception @x@, or @Right a@ if it returned a value @a@.+--+-- > poll = atomically . pollSTM+poll :: MonadConc m => Async m a -> m (Maybe (Either SomeException a))+poll = atomically . pollSTM++-- | A version of 'poll' that can be used inside a @MonadSTM@ transaction.+pollSTM :: MonadConc m => Async m a -> STMLike m (Maybe (Either SomeException a))+pollSTM (Async _ w) = (Just <$> w) `orElse` return Nothing++-- | Wait for an asynchronous action to complete, and return either+-- @Left e@ if the action raised an exception @e@, or @Right a@ if it+-- returned a value @a@.+waitCatch :: MonadConc m => Async m a -> m (Either SomeException a)+waitCatch = tryAgain . atomically . waitCatchSTM where+  -- See: https://github.com/simonmar/async/issues/14+  tryAgain f = f `catch` \BlockedIndefinitelyOnSTM -> f++-- | A version of 'waitCatch' that can be used inside a @MonadSTM@ transaction.+waitCatchSTM :: MonadConc m => Async m a -> STMLike m (Either SomeException a)+waitCatchSTM (Async _ w) = w++-- | 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. An asynchronous+-- 'cancel' can of course be obtained by wrapping 'cancel' itself in+-- 'async'.+cancel :: MonadConc m => Async m a -> m ()+cancel (Async tid _) = throwTo tid ThreadKilled++-- | Cancel an asynchronous action by throwing the supplied exception+-- to it.+--+-- > cancelWith a e = throwTo (asyncThreadId a) e+--+-- The notes about the synchronous nature of 'cancel' also apply to+-- 'cancelWith'.+cancelWith :: (MonadConc m, Exception e) => Async m a -> e -> m ()+cancelWith (Async tid _) = throwTo tid+++-------------------------------------------------------------------------------+-- Waiting for multiple 'Async's++-- | Wait for any of the supplied 'Async's to complete.  If the first+-- to complete throws an exception, then that exception is re-thrown+-- by 'waitAny'.+--+-- If multiple 'Async's complete or have completed, then the value+-- returned corresponds to the first completed 'Async' in the list.+waitAny :: MonadConc m => [Async m a] -> m (Async m a, a)+waitAny = atomically . waitAnySTM++-- | A version of 'waitAny' that can be used inside a @MonadSTM@+-- transaction.+waitAnySTM :: MonadConc m => [Async m a] -> STMLike m (Async m a, a)+waitAnySTM = foldr (orElse . (\a -> do r <- waitSTM a; return (a, r))) retry++-- | Wait for any of the supplied asynchronous operations to complete.+-- The value returned is a pair of the 'Async' that completed, and the+-- result that would be returned by 'wait' on that 'Async'.+--+-- If multiple 'Async's complete or have completed, then the value+-- returned corresponds to the first completed 'Async' in the list.+waitAnyCatch :: MonadConc m => [Async m a] -> m (Async m a, Either SomeException a)+waitAnyCatch = atomically . waitAnyCatchSTM++-- | A version of 'waitAnyCatch' that can be used inside a @MonadSTM@+-- transaction.+waitAnyCatchSTM :: MonadConc m => [Async m a] -> STMLike m (Async m a, Either SomeException a)+waitAnyCatchSTM = foldr (orElse . (\a -> do r <- waitCatchSTM a; return (a, r))) retry++-- | Like 'waitAny', but also cancels the other asynchronous+-- operations as soon as one has completed.+waitAnyCancel :: MonadConc m => [Async m a] -> m (Async m a, a)+waitAnyCancel asyncs = waitAny asyncs `finally` mapM_ cancel asyncs++-- | Like 'waitAnyCatch', but also cancels the other asynchronous+-- operations as soon as one has completed.+waitAnyCatchCancel :: MonadConc m => [Async m a] -> m (Async m a, Either SomeException a)+waitAnyCatchCancel asyncs = waitAnyCatch asyncs `finally` mapM_ cancel asyncs++-- | Wait for the first of two @Async@s to finish.  If the @Async@+-- that finished first raised an exception, then the exception is+-- re-thrown by 'waitEither'.+waitEither :: MonadConc m => Async m a -> Async m b -> m (Either a b)+waitEither left right = atomically $ waitEitherSTM left right++-- | A version of 'waitEither' that can be used inside a @MonadSTM@+-- transaction.+waitEitherSTM :: MonadConc m => Async m a -> Async m b -> STMLike m (Either a b)+waitEitherSTM left right =+  (Left <$> waitSTM left) `orElse` (Right <$> waitSTM right)++-- | Wait for the first of two @Async@s to finish.+waitEitherCatch :: MonadConc m => Async m a -> Async m b+  -> m (Either (Either SomeException a) (Either SomeException b))+waitEitherCatch left right = atomically $ waitEitherCatchSTM left right++-- | A version of 'waitEitherCatch' that can be used inside a+-- @MonadSTM@ transaction.+waitEitherCatchSTM :: MonadConc m => Async m a -> Async m b+  -> STMLike m (Either (Either SomeException a) (Either SomeException b))+waitEitherCatchSTM left right =+  (Left <$> waitCatchSTM left) `orElse` (Right <$> waitCatchSTM right)++-- | Like 'waitEither', but also 'cancel's both @Async@s before+-- returning.+waitEitherCancel :: MonadConc m => Async m a -> Async m b -> m (Either a b)+waitEitherCancel left right =+  waitEither left right `finally` (cancel left >> cancel right)++-- | Like 'waitEitherCatch', but also 'cancel's both @Async@s before+-- returning.+waitEitherCatchCancel :: MonadConc m => Async m a -> Async m b+  -> m (Either (Either SomeException a) (Either SomeException b))+waitEitherCatchCancel left right =+  waitEitherCatch left right `finally` (cancel left >> cancel right)++-- | Like 'waitEither', but the result is ignored.+waitEither_ :: MonadConc m => Async m a -> Async m b -> m ()+waitEither_ left right = atomically $ waitEitherSTM_ left right++-- | A version of 'waitEither_' that can be used inside a @MonadSTM@+-- transaction.+waitEitherSTM_:: MonadConc m => Async m a -> Async m b -> STMLike m ()+waitEitherSTM_ left right = void $ waitEitherSTM left 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 :: MonadConc m => Async m a -> Async m b -> m (a, b)+waitBoth left right = atomically $ waitBothSTM left right++-- | A version of 'waitBoth' that can be used inside a @MonadSTM@+-- transaction.+waitBothSTM :: MonadConc m => Async m a -> Async m b -> STMLike m (a, b)+waitBothSTM left right = do+  a <- waitSTM left `orElse` (waitSTM right >> retry)+  b <- waitSTM right+  return (a, b)+++-------------------------------------------------------------------------------+-- Linking++-- | Link the given @Async@ to the current thread, such that if the+-- @Async@ raises an exception, that exception will be re-thrown in+-- the current thread.+--+link :: MonadConc m => Async m a -> m ()+link (Async _ w) = do+  me <- myThreadId+  void $ forkRepeat $ do+    r <- atomically w+    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 :: MonadConc m => Async m a -> Async m b -> m ()+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 ()++-- | Fork a thread that runs the supplied action, and if it raises an+-- exception, re-runs the action.  The thread terminates only when the+-- action runs to completion without raising an exception.+forkRepeat :: MonadConc m => m a -> m (ThreadId m)+forkRepeat action = mask $ \restore ->+  let go = do+        r <- (try :: MonadConc m => m a -> m (Either SomeException a)) $ restore action+        case r of+          Left _ -> go+          _      -> return ()+  in fork go+++-------------------------------------------------------------------------------+-- Convenient Utilities++-- | Run two @MonadConc@ actions concurrently, and return the first to+-- finish. The loser of the race is 'cancel'led.+--+-- > race left right =+-- >   withAsync left $ \a ->+-- >   withAsync right $ \b ->+-- >   waitEither a b+--+race :: MonadConc m => m a -> m b -> m (Either a b)+race left right = concurrently' left right collect where+  collect m = do+    e <- takeCVar m+    case e of+      Left ex -> throw ex+      Right r -> return r++-- | Like 'race', but the result is ignored.+--+-- > race_ left right =+-- >   withAsync left $ \a ->+-- >   withAsync right $ \b ->+-- >   waitEither_ a b+race_ :: MonadConc m => m a -> m b -> m ()+race_ a b = void $ race a b++-- | Run two @MonadConc@ actions concurrently, and return both+-- results. If either action throws an exception at any time, then the+-- other action is 'cancel'led, and the exception is re-thrown by+-- 'concurrently'.+--+-- > concurrently left right =+-- >   withAsync left $ \a ->+-- >   withAsync right $ \b ->+-- >   waitBoth a b+concurrently :: MonadConc m => m a -> m b -> m (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 <- takeCVar m+    case e of+      Left ex -> throw ex+      Right r -> collect (r:xs) m++-- Run two things concurrently. Faster than the 'Async' version.+concurrently' :: MonadConc m => m a -> m b+  -> (CVar m (Either SomeException (Either a b)) -> m r)+  -> m r+concurrently' left right collect = do+  done <- newEmptyCVar+  mask $ \restore -> do+    lid <- fork $ restore (left >>= putCVar done . Right . Left)+          `catch` (putCVar done . Left)++    rid <- fork $ restore (right >>= putCVar done . Right . Right)+          `catch` (putCVar done . Left)++    -- See: https://github.com/simonmar/async/issues/27+    let stop = killThread rid >> killThread lid++    r <- restore (collect done) `onException` stop++    stop++    return r++-- | Maps a @MonadConc@-performing function over any @Traversable@+-- data type, performing all the @MonadConc@ actions concurrently, and+-- returning the original data structure with the arguments replaced+-- by the results.+--+-- For example, @mapConcurrently@ works with lists:+--+-- > pages <- mapConcurrently getURL ["url1", "url2", "url3"]+--+mapConcurrently :: (Traversable t, MonadConc m) => (a -> m b) -> t a -> m (t b)+mapConcurrently f = runConcurrently . traverse (Concurrently . f)++-- | `forConcurrently` is `mapConcurrently` with its arguments flipped+--+-- > pages <- forConcurrently ["url1", "url2", "url3"] $ \url -> getURL url+--+forConcurrently :: (Traversable t, MonadConc m) => t a -> (a -> m b)-> m (t b)+forConcurrently = flip mapConcurrently
+ LICENSE view
@@ -0,0 +1,30 @@+Copyright (c) 2012, Michael Walker++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 Michael Walker 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.
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ async-dejafu.cabal view
@@ -0,0 +1,49 @@+-- Initial async-dejafu.cabal generated by cabal init.  For further +-- documentation, see http://haskell.org/cabal/users-guide/++name:                async-dejafu+version:             0.1.0.0+synopsis:            Run MonadConc operations asynchronously and wait for their results.++description:+  The <https://hackage.haskell.org/package/async async> library+  provides a higher-level interface over threads, allowing users to+  conveniently run IO operations asynchronously and wait for their+  results. This package is a reimplementation of async using the+  @MonadConc@ abstraction from+  <https://hackage.haskell.org/package/dejafu dejafu>, providing+  easy-to-use asynchronous operaitons within an easily-testable+  framework.+  .+  When these functions are used in an IO context, the behaviour should+  appear identical to the original async package.+++homepage:            https://github.com/barrucadu/dejafu+license:             BSD3+license-file:        LICENSE+author:              Michael Walker+maintainer:          mike@barrucadu.co.uk+-- copyright:           +category:            Concurrency+build-type:          Simple+-- extra-source-files:  +cabal-version:       >=1.10++library+  exposed-modules:     Control.Concurrent.Async+  -- other-modules:       +  -- other-extensions:    +  build-depends:       base >=4.5 && <5+                     , dejafu >= 0.1+                     , exceptions+  -- hs-source-dirs:      +  default-language:    Haskell2010+  ghc-options: -Wall++test-suite tests+  hs-source-dirs:      tests+  type:                exitcode-stdio-1.0+  main-is:             Main.hs+  build-depends:       base, async-dejafu, dejafu, HUnit, hunit-dejafu+  default-language:    Haskell2010
+ tests/Main.hs view
@@ -0,0 +1,103 @@+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE LambdaCase         #-}++module Main where++import Control.Concurrent.Async+import Control.Exception (AsyncException(..), BlockedIndefinitelyOnMVar(..), Exception, SomeException(..), fromException)+import Control.Monad (forever)+import Control.Monad.Conc.Class+import Data.Functor (void)+import Data.Typeable (Typeable, cast)+import Test.DejaFu hiding (MemType(..))+import Test.HUnit (Test(..), runTestTT, test)+import Test.HUnit.DejaFu++main :: IO ()+main = void . runTestTT $ TestList+  [ TestLabel "async" $ test+    [ testDejafu async_wait        "async_wait"        $ alwaysTrue (==Right value)+    , testDejafu async_waitCatch   "async_waitCatch"   $ alwaysTrue (\case Right (Right v) -> v == value; _ -> False)+    , testDejafu async_exwait      "async_exwait"      $ alwaysTrue (==Right (Just TestException))+    , testDejafu async_exwaitCatch "async_exwaitCatch" $ alwaysTrue (==Right (Just TestException))+    , testDejafu async_cancel      "async_cancel"      $ gives' [Left (Just TestException), Right value]+    , testDejafu async_poll        "async_poll"        $ alwaysTrue (\case Right Nothing -> True; _ -> False)+    , testDejafu async_poll2       "async_poll2"       $ alwaysTrue (\case Right (Just (Right v)) -> v == value; _ -> False)+    ]++  , TestLabel "withAsync" $ test+    [ testDejafu withasync_waitCatch "withasync_waitCatch" $ alwaysTrue (\case Right (Right v) -> v == value; _ -> False)+    , testDejafu withasync_wait2     "withasync_wait2"     $ alwaysTrue (\case Right (Left (Just ThreadKilled)) -> True; _ -> False)++    -- this fails because dejafu doesn't throw 'BlockedIndefinitelyOnMVar' in testing yet+    -- , testDejafu withasync_waitCatch_blocked "withasync_waitCatch_blocked" $ alwaysTrue (\case Right (Just BlockedIndefinitelyOnMVar) -> True; _ -> False)+    ]+  ]++value :: Int+value = 42++data TestException = TestException deriving (Eq,Show,Typeable)+instance Exception TestException++async_wait :: MonadConc m => m Int+async_wait = do+  a <- async $ return value+  wait a++async_waitCatch :: MonadConc m => m (Either SomeException Int)+async_waitCatch = do+  a <- async $ return value+  waitCatch a++async_exwait :: MonadConc m => m (Maybe TestException)+async_exwait = do+  a <- async $ throw TestException+  (wait a >> return Nothing) `catch` (return . Just)++async_exwaitCatch :: MonadConc m => m (Maybe TestException)+async_exwaitCatch = do+  a <- async $ throw TestException+  r <- waitCatch a+  return $ case r of+    Left  e -> fromException e+    Right _ -> Nothing++async_cancel :: MonadConc m => m (Either (Maybe TestException) Int)+async_cancel = do+  a <- async $ return value+  cancelWith a TestException+  r <- waitCatch a+  return $ case r of+    Left  e -> Left $ fromException e+    Right v -> Right v++async_poll :: MonadConc m => m (Maybe (Either SomeException Int))+async_poll = do+  a <- async $ forever yield+  poll a++async_poll2 :: MonadConc m => m (Maybe (Either SomeException Int))+async_poll2 = do+  a <- async $ return value+  wait a+  poll a++withasync_waitCatch :: MonadConc m => m (Either SomeException Int)+withasync_waitCatch = withAsync (return value) waitCatch++withasync_wait2 :: MonadConc m => m (Either (Maybe AsyncException) ())+withasync_wait2 = do+  a <- withAsync (forever yield) return+  r <- waitCatch a+  return $ case r of+    Left (SomeException e) -> Left $ cast e+    Right x -> Right x++withasync_waitCatch_blocked :: MonadConc m => m (Maybe BlockedIndefinitelyOnMVar)+withasync_waitCatch_blocked = do+  _concAllKnown+  r <- withAsync (_concAllKnown >> newEmptyCVar >>= takeCVar) waitCatch+  return $ case r of+    Left e -> fromException e+    _      -> Nothing