Include the exception in ReleaseTypes indicating exceptional exit.

Supercedes and resolves snoyberg#461. Fixes snoyberg#460. Co-authored-by: Shea Levy <[email protected]> Co-authored-by: parsonsmatt <[email protected]>
shlevy · Oct 7, 2022 · 24e4af5 · 24e4af5
1 parent 28fac5e
commit 24e4af5
Show file tree

Hide file tree

Showing 4 changed files with 42 additions and 14 deletions.
diff --git 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
@@ -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/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
@@ -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