enclosed-exceptions 1.0.1.1 → 1.0.2

raw patch · 3 files changed

+57/−8 lines, 3 filesdep +stmdep ~basePVP ok

version bump matches the API change (PVP)

Dependencies added: stm

Dependency ranges changed: base

API changes (from Hackage documentation)

Files

• enclosed-exceptions.cabal +2/−2
• src/Control/Exception/Enclosed.hs +39/−6
• test/main.hs +16/−0

@@ -1,5 +1,5 @@ name:                enclosed-exceptions-version:             1.0.1.1+version:             1.0.2 synopsis:            Catching all exceptions from within an enclosed computation description:         Catching all exceptions raised within an enclosed computation,                      while remaining responsive to (external) asynchronous exceptions.@@ -21,7 +21,6 @@                      , transformers                      , lifted-base                   >= 0.2                      , monad-control-                     , async                         >= 2.0                      , deepseq                      , transformers-base   ghc-options:         -Wall -fno-warn-orphans@@ -37,6 +36,7 @@                    , deepseq                    , hspec                         >= 1.3                    , QuickCheck+                   , stm                    , transformers                    , transformers-base     ghc-options:     -Wall

@@ -50,13 +50,16 @@     ) where  import Prelude-import Control.Exception.Lifted+import Control.Concurrent (forkIOWithUnmask)+import Control.Concurrent.MVar (newEmptyMVar, putMVar, readMVar)+import Control.Exception import Control.Monad (liftM) import Control.Monad.Base (liftBase) import Control.Monad.Trans.Control (MonadBaseControl, liftBaseWith, restoreM)-import Control.Concurrent.Async (withAsync, waitCatch) import Control.DeepSeq (NFData, ($!!)) +import qualified Control.Exception.Lifted+ -- | A version of 'catch' which is specialized for any exception. This -- simplifies usage as no explicit type signatures are necessary. --@@ -89,9 +92,39 @@ -- Since 0.5.6 tryAny :: MonadBaseControl IO m => m a -> m (Either SomeException a) tryAny m =-    liftBaseWith (\runInIO -> withAsync (runInIO m) waitCatch) >>=+    liftBaseWith (\runInIO -> tryAnyIO (runInIO m)) >>=     either (return . Left) (liftM Right . restoreM)+  where+    tryAnyIO :: IO a -> IO (Either SomeException a)+    tryAnyIO action = do+        result <- newEmptyMVar+        bracket+            (forkIOWithUnmask (\restore -> try (restore action) >>= putMVar result))+            (\t -> throwTo t ThreadKilled)+            (\_ -> retryCount 10 (readMVar result)) +    -- If the action supplied by the user ends up blocking on an MVar+    -- or STM action, all threads currently blocked on such an action will+    -- receive an exception. In general, this is a good thing from the GHC+    -- RTS, but it is counter-productive for our purposes, where we know that+    -- when the user action receives such an exception, our code above will+    -- unblock and our main thread will not deadlock.+    --+    -- Workaround: we retry the readMVar action if we received a+    -- BlockedIndefinitelyOnMVar. To remain on the safe side and avoid+    -- deadlock, we cap this at an arbitrary number (10) above so that, if+    -- there's a bug in this function, the runtime system can still recover.+    --+    -- For previous discussion of this topic, see:+    -- https://github.com/simonmar/async/pull/15+    retryCount :: Int -> IO a -> IO a+    retryCount cnt0 action =+        loop cnt0+      where+        loop 0 = action+        loop cnt = action `catch`+            \BlockedIndefinitelyOnMVar -> loop (cnt - 1)+ -- | An extension to @catch@ which ensures that the return value is fully -- evaluated. See @tryAny@. --@@ -120,7 +153,7 @@ tryDeep :: (Exception e, NFData a, MonadBaseControl IO m)         => m a         -> m (Either e a)-tryDeep m = try $ do+tryDeep m = Control.Exception.Lifted.try $ do     x <- m     liftBase $ evaluate $!! x @@ -149,14 +182,14 @@ -- -- Since 0.5.6 handleIO :: MonadBaseControl IO m => (IOException -> m a) -> m a -> m a-handleIO = handle+handleIO = Control.Exception.Lifted.handle  -- | A version of 'try' which is specialized for IO exceptions. -- This simplifies usage as no explicit type signatures are necessary. -- -- Since 0.5.6 tryIO :: MonadBaseControl IO m => m a -> m (Either IOException a)-tryIO = try+tryIO = Control.Exception.Lifted.try  -- | --

@@ -11,6 +11,7 @@ import Control.Concurrent (threadDelay) import Control.Concurrent.Async (async, cancelWith, waitCatch) import Control.Concurrent.MVar+import Control.Concurrent.STM import Control.Exception.Enclosed import Control.Monad (forever) @@ -76,6 +77,21 @@                 tryAny `trierCatchesOutside` False             it "doesn't catch exceptions lazily thrown in its pure result" $ do                 tryAny `trierCatchesDeep` False++            let shouldBeShow :: Show a => a -> a -> IO ()+                shouldBeShow x y = show x `shouldBe` show y++            it "isn't fooled by BlockedIndefinitelyOnMVar" $ do+                res <- tryAny $ do+                    var <- newEmptyMVar+                    takeMVar (var :: MVar ())+                res `shouldBeShow` Left (toException BlockedIndefinitelyOnMVar)++            it "isn't fooled by BlockedIndefinitelyOnTVar" $ do+                res <- tryAny $ do+                    var <- atomically newEmptyTMVar+                    atomically $ takeTMVar (var :: TMVar ())+                res `shouldBeShow` Left (toException BlockedIndefinitelyOnSTM)          describe "tryDeep" $ do             it "catches exceptions thrown from the inside" $ do