From d067fd532aaf98fbeb1824c9577b90290b8306b8 Mon Sep 17 00:00:00 2001 From: Shea Levy Date: Thu, 6 Oct 2022 14:26:28 -0400 Subject: [PATCH] Include the exception in ReleaseTypes indicating exceptional exit. Supercedes and resolves #461. Fixes #460. Co-authored-by: Shea Levy Co-authored-by: parsonsmatt --- resourcet/Control/Monad/Trans/Resource.hs | 10 ++--- .../Control/Monad/Trans/Resource/Internal.hs | 4 +- resourcet/Data/Acquire.hs | 1 + resourcet/Data/Acquire/Internal.hs | 41 ++++++++++++++++--- resourcet/test/main.hs | 6 +-- 5 files changed, 46 insertions(+), 16 deletions(-) diff --git a/resourcet/Control/Monad/Trans/Resource.hs b/resourcet/Control/Monad/Trans/Resource.hs index e9203b461..2317eb996 100644 --- a/resourcet/Control/Monad/Trans/Resource.hs +++ b/resourcet/Control/Monad/Trans/Resource.hs @@ -66,7 +66,7 @@ import Control.Monad.Trans.Resource.Internal import Control.Concurrent (ThreadId, forkIO) import Control.Monad.Catch (MonadThrow, throwM) -import Data.Acquire.Internal (ReleaseType (..)) +import Data.Acquire.Internal (ReleaseType (..), releaseException) @@ -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..ebd8a6ab5 100644 --- a/resourcet/Control/Monad/Trans/Resource/Internal.hs +++ b/resourcet/Control/Monad/Trans/Resource/Internal.hs @@ -65,7 +65,7 @@ import qualified Data.IntMap as IntMap import qualified Data.IORef as I import Data.Typeable import Data.Word(Word) -import Data.Acquire.Internal (ReleaseType (..)) +import Data.Acquire.Internal (ReleaseType (..), releaseException) -- | A @Monad@ which allows for safe resource allocation. In theory, any monad -- transformer stack which includes a @ResourceT@ can be an instance of @@ -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..c475947c9 100644 --- a/resourcet/Data/Acquire.hs +++ b/resourcet/Data/Acquire.hs @@ -65,6 +65,7 @@ module Data.Acquire , mkAcquireType , allocateAcquire , ReleaseType (..) + , releaseException ) where import Control.Monad.Trans.Resource.Internal diff --git a/resourcet/Data/Acquire/Internal.hs b/resourcet/Data/Acquire/Internal.hs index 6c7f46bf4..855b8cab0 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 (ReleaseEarly, ReleaseNormal, ReleaseException', ReleaseException) + , releaseException , mkAcquireType ) 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,35 @@ import qualified Control.Monad.Catch as C () -- @since 1.1.2 data ReleaseType = ReleaseEarly | ReleaseNormal - | ReleaseException - deriving (Show, Read, Eq, Ord, Enum, Bounded, Typeable) + | ReleaseExceptionInternal (Maybe E.SomeException) + deriving (Show, Typeable) + +-- | Only 'Nothing' when constructed via the deprecated 'ReleaseException' pattern. +pattern ReleaseException' :: Maybe E.SomeException -> ReleaseType +pattern ReleaseException' e <- ReleaseExceptionInternal e + +releaseException :: E.SomeException -> ReleaseType +releaseException = ReleaseExceptionInternal . Just + +{-# DEPRECATED ReleaseException "Use ReleaseException' to match, releaseException to construct" #-} +pattern ReleaseException :: ReleaseType +pattern ReleaseException <- ReleaseExceptionInternal _ + where + ReleaseException = ReleaseExceptionInternal Nothing + +-- | 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 + ReleaseExceptionInternal Nothing == ReleaseExceptionInternal Nothing = True + ReleaseExceptionInternal (Just (E.SomeException e0)) == ReleaseExceptionInternal (Just (E.SomeException e1)) = + case typeOf e0 == typeOf e1 of + True -> + show e0 == show e1 + False -> + False + _ == _ = + False data Allocated a = Allocated !a !(ReleaseType -> IO ()) @@ -56,7 +85,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 +144,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..65c97dbfd 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