packages feed

resourcet 1.1.1 → 1.1.2

raw patch · 6 files changed

+114/−21 lines, 6 files

Files

Control/Monad/Trans/Resource.hs view
@@ -96,7 +96,7 @@ import Control.Monad.Morph import Control.Monad.Catch (MonadThrow, throwM) import Control.Monad.Catch.Pure (CatchT, runCatchT)-+import Data.Acquire.Internal (ReleaseType (..))   @@ -178,7 +178,7 @@             Nothing -> (rm, Nothing)             Just action ->                 ( ReleaseMap next rf $ IntMap.delete key m-                , Just action+                , Just (action ReleaseEarly)                 )     -- We tried to call release, but since the state is already closed, we     -- can assume that the release action was already called. Previously,@@ -197,13 +197,26 @@ -- -- Since 0.3.0 runResourceT :: MonadBaseControl IO m => ResourceT m a -> m a-runResourceT (ResourceT r) = do+runResourceT (ResourceT r) = control $ \run -> do     istate <- createInternalState-    r istate `finally` stateCleanup istate+    E.mask $ \restore -> do+        res <- restore (run (r istate)) `E.onException`+            stateCleanup ReleaseException istate+        stateCleanup ReleaseNormal istate+        return res -bracket_ :: MonadBaseControl IO m => IO () -> IO () -> m a -> m a-bracket_ alloc cleanup inside =-    control $ \run -> E.bracket_ alloc cleanup (run inside)+bracket_ :: MonadBaseControl IO m+         => IO () -- ^ allocate+         -> IO () -- ^ normal cleanup+         -> IO () -- ^ exceptional cleanup+         -> m a+         -> m a+bracket_ alloc cleanupNormal cleanupExc inside =+    control $ \run -> E.mask $ \restore -> do+        alloc+        res <- restore (run inside) `E.onException` cleanupExc+        cleanupNormal+        return res  finally :: MonadBaseControl IO m => m a -> IO () -> m a finally action cleanup =@@ -264,9 +277,11 @@     bracket_         (stateAlloc r)         (return ())+        (return ())         (liftBaseDiscard forkIO $ bracket_             (return ())-            (stateCleanup r)+            (stateCleanup ReleaseNormal r)+            (stateCleanup ReleaseException r)             (restore $ f r))  @@ -321,7 +336,7 @@ -- -- Since 0.4.9 closeInternalState :: MonadBase IO m => InternalState -> m ()-closeInternalState = liftBase . stateCleanup+closeInternalState = liftBase . stateCleanup ReleaseNormal  -- | Get the internal state of the current @ResourceT@. --
Control/Monad/Trans/Resource/Internal.hs view
@@ -19,6 +19,7 @@   , stateCleanup   , transResourceT   , register'+  , registerType ) where  import Control.Exception (throw,Exception,SomeException)@@ -60,6 +61,7 @@ import Data.Typeable import Data.Word(Word) import Prelude hiding (catch)+import Data.Acquire.Internal (ReleaseType (..))  #if __GLASGOW_HASKELL__ >= 704 import Control.Monad.ST.Unsafe (unsafeIOToST)@@ -106,7 +108,7 @@ type NextKey = Int  data ReleaseMap =-    ReleaseMap !NextKey !RefCount !(IntMap (IO ()))+    ReleaseMap !NextKey !RefCount !(IntMap (ReleaseType -> IO ()))   | ReleaseMapClosed  -- | Convenient alias for @ResourceT IO@.@@ -279,8 +281,8 @@                 (ReleaseMap nk (rf + 1) m, ())             ReleaseMapClosed -> throw $ InvalidAccess "stateAlloc" -stateCleanup :: I.IORef ReleaseMap -> IO ()-stateCleanup istate = E.mask_ $ do+stateCleanup :: ReleaseType -> I.IORef ReleaseMap -> IO ()+stateCleanup rtype istate = E.mask_ $ do     mm <- I.atomicModifyIORef istate $ \rm ->         case rm of             ReleaseMap nk rf m ->@@ -291,7 +293,7 @@             ReleaseMapClosed -> throw $ InvalidAccess "stateCleanup"     case mm of         Just m ->-            mapM_ (\x -> try x >> return ()) $ IntMap.elems m+            mapM_ (\x -> try (x rtype) >> return ()) $ IntMap.elems m         Nothing -> return ()   where     try :: IO a -> IO (Either SomeException a)@@ -301,6 +303,20 @@           -> IO ()           -> IO ReleaseKey register' istate rel = I.atomicModifyIORef istate $ \rm ->+    case rm of+        ReleaseMap key rf m ->+            ( ReleaseMap (key - 1) rf (IntMap.insert key (const rel) m)+            , ReleaseKey istate key+            )+        ReleaseMapClosed -> throw $ InvalidAccess "register'"++-- |+--+-- Since 1.1.2+registerType :: I.IORef ReleaseMap+             -> (ReleaseType -> IO ())+             -> IO ReleaseKey+registerType istate rel = I.atomicModifyIORef istate $ \rm ->     case rm of         ReleaseMap key rf m ->             ( ReleaseMap (key - 1) rf (IntMap.insert key rel m)
Data/Acquire.hs view
@@ -4,7 +4,9 @@     ( Acquire     , with     , mkAcquire+    , mkAcquireType     , allocateAcquire+    , ReleaseType (..)     ) where  import Control.Monad.Trans.Resource.Internal@@ -28,5 +30,5 @@ allocateAcquireRIO :: Acquire a -> ResourceT IO (ReleaseKey, a) allocateAcquireRIO (Acquire f) = ResourceT $ \istate -> liftIO $ E.mask $ \restore -> do     Allocated a free <- f restore-    key <- register' istate free+    key <- registerType istate free     return (key, a)
Data/Acquire/Internal.hs view
@@ -8,6 +8,8 @@     , Allocated (..)     , with     , mkAcquire+    , ReleaseType (..)+    , mkAcquireType     ) where  import Control.Applicative (Applicative (..))@@ -18,8 +20,16 @@ import Data.Typeable (Typeable) import Control.Monad (liftM, ap) -data Allocated a = Allocated !a !(IO ())+-- | The way in which a release is called.+--+-- Since 1.1.2+data ReleaseType = ReleaseEarly+                 | ReleaseNormal+                 | ReleaseException+    deriving (Show, Read, Eq, Ord, Enum, Bounded, Typeable) +data Allocated a = Allocated !a !(ReleaseType -> IO ())+ -- | A method for acquiring a scarce resource, providing the means of freeing -- it when no longer needed. This data type provides -- @Functor@/@Applicative@/@Monad@ instances for composing different resources@@ -42,17 +52,17 @@     (<*>) = ap  instance Monad Acquire where-    return a = Acquire (\_ -> return (Allocated a (return ())))+    return a = Acquire (\_ -> return (Allocated a (const $ return ())))     Acquire f >>= g' = Acquire $ \restore -> do         Allocated x free1 <- f restore         let Acquire g = g' x-        Allocated y free2 <- g restore `E.onException` free1-        return $! Allocated y (free2 `E.finally` free1)+        Allocated y free2 <- g restore `E.onException` free1 ReleaseException+        return $! Allocated y (\rt -> free2 rt `E.finally` free1 rt)  instance MonadIO Acquire where     liftIO f = Acquire $ \restore -> do         x <- restore f-        return $! Allocated x (return ())+        return $! Allocated x (const $ return ())  instance MonadBase IO Acquire where     liftBase = liftIO@@ -65,6 +75,19 @@           -> Acquire a mkAcquire create free = Acquire $ \restore -> do     x <- restore create+    return $! Allocated x (const $ free x)++-- | Same as 'mkAcquire', but the cleanup function will be informed of /how/+-- cleanup was initiated. This allows you to distinguish, for example, between+-- normal and exceptional exits.+--+-- Since 1.1.2+mkAcquireType+    :: IO a -- ^ acquire the resource+    -> (a -> ReleaseType -> IO ()) -- ^ free the resource+    -> Acquire a+mkAcquireType create free = Acquire $ \restore -> do+    x <- restore create     return $! Allocated x (free x)  -- | Allocate the given resource and provide it to the provided function. The@@ -79,4 +102,6 @@      -> m b with (Acquire f) g = control $ \run -> E.mask $ \restore -> do     Allocated x free <- f restore-    run (g x) `E.finally` free+    res <- run (g x) `E.onException` free ReleaseException+    free ReleaseNormal+    return res
resourcet.cabal view
@@ -1,5 +1,5 @@ Name:                resourcet-Version:             1.1.1+Version:             1.1.2 Synopsis:            Deterministic allocation and freeing of scarce resources. Description: 	This package was originally included with the conduit package, and has since been split off. For more information, please see <http://www.yesodweb.com/book/conduits>.
test/main.hs view
@@ -12,6 +12,7 @@ import           Data.IORef import           Data.Typeable                (Typeable) import           Test.Hspec+import           Data.Acquire  main :: IO () main = hspec $ do@@ -54,6 +55,40 @@             register (checkMasked "exception")             liftIO $ throwIO Dummy         return ()+    describe "mkAcquireType" $ do+        describe "ResourceT" $ do+            it "early" $ do+                ref <- newIORef Nothing+                let acq = mkAcquireType (return ()) $ \() -> writeIORef ref . Just+                runResourceT $ do+                    (releaseKey, ()) <- allocateAcquire acq+                    release releaseKey+                readIORef ref >>= (`shouldBe` Just ReleaseEarly)+            it "normal" $ do+                ref <- newIORef Nothing+                let acq = mkAcquireType (return ()) $ \() -> writeIORef ref . Just+                runResourceT $ do+                    (_releaseKey, ()) <- allocateAcquire acq+                    return ()+                readIORef ref >>= (`shouldBe` Just ReleaseNormal)+            it "exception" $ do+                ref <- newIORef Nothing+                let acq = mkAcquireType (return ()) $ \() -> writeIORef ref . Just+                Left Dummy <- try $ runResourceT $ do+                    (_releaseKey, ()) <- allocateAcquire acq+                    liftIO $ throwIO Dummy+                readIORef ref >>= (`shouldBe` Just ReleaseException)+        describe "with" $ do+            it "normal" $ do+                ref <- newIORef Nothing+                let acq = mkAcquireType (return ()) $ \() -> writeIORef ref . Just+                with acq $ const $ return ()+                readIORef ref >>= (`shouldBe` Just ReleaseNormal)+            it "exception" $ do+                ref <- newIORef Nothing+                let acq = mkAcquireType (return ()) $ \() -> writeIORef ref . Just+                Left Dummy <- try $ with acq $ const $ throwIO Dummy+                readIORef ref >>= (`shouldBe` Just ReleaseException)  data Dummy = Dummy     deriving (Show, Typeable)