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]>

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@.

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.

resourcet/Data/Acquire.hs

@@ -65,6 +65,7 @@ module Data.Acquire
     , mkAcquireType
     , allocateAcquire
     , ReleaseType (..)
+    , releaseException
     ) where
 
 import Control.Monad.Trans.Resource.Internal

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,37 @@ 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)
+{-# COMPLETE ReleaseEarly, ReleaseNormal, ReleaseException #-}
+{-# COMPLETE ReleaseEarly, ReleaseNormal, ReleaseException' #-}
+
+-- | 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 +87,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 +146,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

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