@@ -0,0 +1,40 @@
1+diff -ruN orig/Control/Concurrent/Async.hs new/Control/Concurrent/Async.hs
2+--- orig/Control/Concurrent/Async.hs 2014-08-11 12:23:17.688591763 +0300
3++++ new/Control/Concurrent/Async.hs 2014-08-11 12:23:17.000000000 +0300
4+@@ -246,7 +246,10 @@
5+ --
6+ {-# INLINE waitCatch #-}
7+ waitCatch :: Async a -> IO (Either SomeException a)
8+-waitCatch = atomically . waitCatchSTM
9++waitCatch = tryAgain . atomically . waitCatchSTM
10++ where
11++ -- See: https://github.com/simonmar/async/issues/14
12++ tryAgain f = f `catch` \BlockedIndefinitelyOnSTM -> f
13+
14+ -- | Check whether an 'Async' has completed yet. If it has not
15+ -- completed yet, then the result is @Nothing@, otherwise the result
16+diff -ruN orig/test/test-async.hs new/test/test-async.hs
17+--- orig/test/test-async.hs 2014-08-11 12:23:17.688591763 +0300
18++++ new/test/test-async.hs 2014-08-11 12:23:17.000000000 +0300
19+@@ -29,6 +29,7 @@
20+ testCase "async_cancel" async_cancel
21+ , testCase "async_poll" async_poll
22+ , testCase "async_poll2" async_poll2
23++ , testCase "withasync_waitCatch_blocked" withasync_waitCatch_blocked
24+ ]
25+
26+ value = 42 :: Int
27+@@ -104,3 +105,13 @@
28+ when (isNothing r) $ assertFailure ""
29+ r <- poll a -- poll twice, just to check we don't deadlock
30+ when (isNothing r) $ assertFailure ""
31++
32++withasync_waitCatch_blocked :: Assertion
33++withasync_waitCatch_blocked = do
34++ r <- withAsync (newEmptyMVar >>= takeMVar) waitCatch
35++ case r of
36++ Left e ->
37++ case fromException e of
38++ Just BlockedIndefinitelyOnMVar -> return ()
39++ Nothing -> assertFailure $ show e
40++ Right () -> assertFailure ""