diff --git a/resourcet/Control/Monad/Trans/Resource.hs b/resourcet/Control/Monad/Trans/Resource.hs index e9203b461..87259c23c 100644 --- a/resourcet/Control/Monad/Trans/Resource.hs +++ b/resourcet/Control/Monad/Trans/Resource.hs @@ -206,13 +206,13 @@ runResourceTChecked = runResourceT bracket_ :: MonadUnliftIO m => IO () -- ^ allocate -> IO () -- ^ normal cleanup - -> IO () -- ^ exceptional cleanup + -> (E.SomeException -> IO ()) -- ^ exceptional cleanup -> m a -> m a bracket_ alloc cleanupNormal cleanupExc inside = withRunInIO $ \run -> E.mask $ \restore -> do alloc - res <- restore (run inside) `E.onException` cleanupExc + res <- restore (run inside) `E.catch` (\e -> cleanupExc e >> E.throwIO e) cleanupNormal return res @@ -254,11 +254,11 @@ resourceForkWith g (ResourceT f) = bracket_ (stateAlloc r) (return ()) - (return ()) + (const $ return ()) (g $ bracket_ (return ()) (stateCleanup ReleaseNormal r) - (stateCleanup ReleaseException r) + (\e -> stateCleanup (ReleaseException' e) r) (restore $ run $ f r)) -- | Launch a new reference counted resource context using @forkIO@. diff --git a/resourcet/Control/Monad/Trans/Resource/Internal.hs b/resourcet/Control/Monad/Trans/Resource/Internal.hs index f9b4434f2..5fa6312a6 100644 --- a/resourcet/Control/Monad/Trans/Resource/Internal.hs +++ b/resourcet/Control/Monad/Trans/Resource/Internal.hs @@ -387,7 +387,7 @@ stateCleanupChecked morig istate = E.mask_ $ do try :: IO () -> IO (Maybe SomeException) try io = fmap (either Just (\() -> Nothing)) (E.try io) - rtype = maybe ReleaseNormal (const ReleaseException) morig + rtype = maybe ReleaseNormal ReleaseException' morig -- Note that this returns values in reverse order, which is what we -- want in the specific case of this function. diff --git a/resourcet/Data/Acquire.hs b/resourcet/Data/Acquire.hs index b1ee75c41..ec78a3202 100644 --- a/resourcet/Data/Acquire.hs +++ b/resourcet/Data/Acquire.hs @@ -65,6 +65,7 @@ module Data.Acquire , mkAcquireType , allocateAcquire , ReleaseType (..) + , DeprecatedReleaseExceptionPlaceholder ) where import Control.Monad.Trans.Resource.Internal diff --git a/resourcet/Data/Acquire/Internal.hs b/resourcet/Data/Acquire/Internal.hs index 6c7f46bf4..f9ed4eb51 100644 --- a/resourcet/Data/Acquire/Internal.hs +++ b/resourcet/Data/Acquire/Internal.hs @@ -4,19 +4,21 @@ {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE PatternSynonyms #-} module Data.Acquire.Internal ( Acquire (..) , Allocated (..) , with , mkAcquire - , ReleaseType (..) + , ReleaseType (.., ReleaseException) , mkAcquireType + , DeprecatedReleaseExceptionPlaceholder ) where import Control.Applicative (Applicative (..)) import Control.Monad.IO.Unlift (MonadIO (..), MonadUnliftIO, withRunInIO) import qualified Control.Exception as E -import Data.Typeable (Typeable) +import Data.Typeable (Typeable, typeOf) import Control.Monad (liftM, ap) import qualified Control.Monad.Catch as C () @@ -25,8 +27,34 @@ import qualified Control.Monad.Catch as C () -- @since 1.1.2 data ReleaseType = ReleaseEarly | ReleaseNormal - | ReleaseException - deriving (Show, Read, Eq, Ord, Enum, Bounded, Typeable) + | ReleaseException' E.SomeException + deriving (Show, Typeable) + +-- | Treats 'E.SomeException's as equal when they wrap the same type and 'show' the same. +instance Eq ReleaseType where + ReleaseEarly == ReleaseEarly = True + ReleaseNormal == ReleaseNormal = True + ReleaseException' (E.SomeException e0) == ReleaseException' (E.SomeException e1) = + case typeOf e0 == typeOf e1 of + True -> + show e0 == show e1 + False -> + False + _ == _ = + False + +-- | Fake 'E.Exception' to use with the deprecated 'ReleaseException' pattern. +data DeprecatedReleaseExceptionPlaceholder = DeprecatedReleaseExceptionPlaceholder + deriving (Show) + +instance E.Exception DeprecatedReleaseExceptionPlaceholder + +{-# COMPLETE ReleaseEarly, ReleaseNormal, ReleaseException #-} +{-# DEPRECATED ReleaseException "Use ReleaseException'" #-} +pattern ReleaseException :: ReleaseType +pattern ReleaseException <- ReleaseException' _ + where + ReleaseException = ReleaseException' (E.toException DeprecatedReleaseExceptionPlaceholder) data Allocated a = Allocated !a !(ReleaseType -> IO ()) @@ -56,7 +84,7 @@ instance Monad Acquire where Acquire f >>= g' = Acquire $ \restore -> do Allocated x free1 <- f restore let Acquire g = g' x - Allocated y free2 <- g restore `E.onException` free1 ReleaseException + Allocated y free2 <- g restore `E.catch` (\e -> free1 (ReleaseException' e) >> E.throwIO e) return $! Allocated y (\rt -> free2 rt `E.finally` free1 rt) instance MonadIO Acquire where @@ -115,6 +143,6 @@ with :: MonadUnliftIO m -> m b with (Acquire f) g = withRunInIO $ \run -> E.mask $ \restore -> do Allocated x free <- f restore - res <- restore (run (g x)) `E.onException` free ReleaseException + res <- restore (run (g x)) `E.catch` (\e -> free (ReleaseException' e) >> E.throwIO e) free ReleaseNormal return res diff --git a/resourcet/test/main.hs b/resourcet/test/main.hs index 14a61ba8d..d767091d9 100644 --- a/resourcet/test/main.hs +++ b/resourcet/test/main.hs @@ -4,7 +4,7 @@ import Control.Concurrent import Control.Exception (Exception, MaskingState (MaskedInterruptible), getMaskingState, throwIO, try, fromException) -import Control.Exception (SomeException, handle) +import Control.Exception (SomeException, handle, toException) import Control.Monad (unless, void) import qualified Control.Monad.Catch import Control.Monad.IO.Class (liftIO) @@ -102,7 +102,7 @@ main = hspec $ do Left Dummy <- try $ runResourceT $ do (_releaseKey, ()) <- allocateAcquire acq liftIO $ throwIO Dummy - readIORef ref >>= (`shouldBe` Just ReleaseException) + readIORef ref >>= (`shouldBe` Just (ReleaseException' (toException Dummy))) describe "with" $ do it "normal" $ do ref <- newIORef Nothing @@ -113,7 +113,7 @@ main = hspec $ do ref <- newIORef Nothing let acq = mkAcquireType (return ()) $ \() -> writeIORef ref . Just Left Dummy <- try $ with acq $ const $ throwIO Dummy - readIORef ref >>= (`shouldBe` Just ReleaseException) + readIORef ref >>= (`shouldBe` Just (ReleaseException' (toException Dummy))) describe "runResourceTChecked" $ do it "catches exceptions" $ do eres <- try $ runResourceTChecked $ void $ register $ throwIO Dummy