From ea67ee007b2025234fc67d46af5762d10cd02fc3 Mon Sep 17 00:00:00 2001
From: Michael Snoyman <michael@snoyman.com>
Date: Mon, 11 Aug 2014 12:23:42 +0300
Subject: [PATCH] Patch for MVar deadlocking in async

---
 patching/patches/async-2.0.1.5.patch | 40 ++++++++++++++++++++++++++++
 1 file changed, 40 insertions(+)
 create mode 100644 patching/patches/async-2.0.1.5.patch

diff --git a/patching/patches/async-2.0.1.5.patch b/patching/patches/async-2.0.1.5.patch
new file mode 100644
index 00000000..2c301317
--- /dev/null
+++ b/patching/patches/async-2.0.1.5.patch
@@ -0,0 +1,40 @@
+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 ""