mirror of
https://github.com/commercialhaskell/stackage.git
synced 2026-01-12 23:38:29 +01:00
41 lines
1.6 KiB
Diff
41 lines
1.6 KiB
Diff
diff -ruN orig/Control/Concurrent/Async.hs new/Control/Concurrent/Async.hs
|
|
--- orig/Control/Concurrent/Async.hs 2014-08-11 12:23:17.688591763 +0300
|
|
+++ new/Control/Concurrent/Async.hs 2014-08-11 12:23:17.000000000 +0300
|
|
@@ -246,7 +246,10 @@
|
|
--
|
|
{-# INLINE waitCatch #-}
|
|
waitCatch :: Async a -> IO (Either SomeException a)
|
|
-waitCatch = atomically . waitCatchSTM
|
|
+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
|
|
diff -ruN orig/test/test-async.hs new/test/test-async.hs
|
|
--- orig/test/test-async.hs 2014-08-11 12:23:17.688591763 +0300
|
|
+++ new/test/test-async.hs 2014-08-11 12:23:17.000000000 +0300
|
|
@@ -29,6 +29,7 @@
|
|
testCase "async_cancel" async_cancel
|
|
, testCase "async_poll" async_poll
|
|
, testCase "async_poll2" async_poll2
|
|
+ , testCase "withasync_waitCatch_blocked" withasync_waitCatch_blocked
|
|
]
|
|
|
|
value = 42 :: Int
|
|
@@ -104,3 +105,13 @@
|
|
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 ""
|