Hello community, here is the log from the commit of package ghc-resourcet for openSUSE:Factory checked in at 2015-02-27 10:59:10 ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ Comparing /work/SRC/openSUSE:Factory/ghc-resourcet (Old) and /work/SRC/openSUSE:Factory/.ghc-resourcet.new (New) ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
Package is "ghc-resourcet" Changes: -------- --- /work/SRC/openSUSE:Factory/ghc-resourcet/ghc-resourcet.changes 2014-04-02 17:19:12.000000000 +0200 +++ /work/SRC/openSUSE:Factory/.ghc-resourcet.new/ghc-resourcet.changes 2015-02-27 10:59:11.000000000 +0100 @@ -1,0 +2,9 @@ +Sun Feb 1 18:21:18 UTC 2015 - [email protected] + +- Add dependency on ghc-exceptions which is now required +- Update to 1.1.3.3: + + monad-control-1.0 support + + Provide the `withEx` function to interact nicely with the + exceptions package. + +------------------------------------------------------------------- Old: ---- resourcet-0.4.8.tar.gz New: ---- resourcet-1.1.3.3.tar.gz ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ Other differences: ------------------ ++++++ ghc-resourcet.spec ++++++ --- /var/tmp/diff_new_pack.fWNoO7/_old 2015-02-27 10:59:12.000000000 +0100 +++ /var/tmp/diff_new_pack.fWNoO7/_new 2015-02-27 10:59:12.000000000 +0100 @@ -1,7 +1,7 @@ # # spec file for package ghc-resourcet # -# Copyright (c) 2013 SUSE LINUX Products GmbH, Nuernberg, Germany. +# Copyright (c) 2015 SUSE LINUX GmbH, Nuernberg, Germany. # # All modifications and additions to the file contributed by third parties # remain the property of their copyright owners, unless otherwise agreed @@ -19,7 +19,7 @@ %global pkg_name resourcet Name: ghc-resourcet -Version: 0.4.8 +Version: 1.1.3.3 Release: 0 Summary: Deterministic allocation and freeing of scarce resources License: BSD-3-Clause @@ -33,6 +33,7 @@ BuildRequires: ghc-rpm-macros # Begin cabal-rpm deps: BuildRequires: ghc-containers-devel +BuildRequires: ghc-exceptions-devel BuildRequires: ghc-lifted-base-devel BuildRequires: ghc-mmorph-devel BuildRequires: ghc-monad-control-devel ++++++ resourcet-0.4.8.tar.gz -> resourcet-1.1.3.3.tar.gz ++++++ diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/resourcet-0.4.8/ChangeLog.md new/resourcet-1.1.3.3/ChangeLog.md --- old/resourcet-0.4.8/ChangeLog.md 1970-01-01 01:00:00.000000000 +0100 +++ new/resourcet-1.1.3.3/ChangeLog.md 2014-12-17 11:48:49.000000000 +0100 @@ -0,0 +1,7 @@ +## 1.1.3.2 + +monad-control-1.0 support [#191](https://github.com/snoyberg/conduit/pull/191) + +## 1.1.3 + +Provide the `withEx` function to interact nicely with the exceptions package. diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/resourcet-0.4.8/Control/Monad/Trans/Resource/Internal.hs new/resourcet-1.1.3.3/Control/Monad/Trans/Resource/Internal.hs --- old/resourcet-0.4.8/Control/Monad/Trans/Resource/Internal.hs 2013-09-08 07:08:15.000000000 +0200 +++ new/resourcet-1.1.3.3/Control/Monad/Trans/Resource/Internal.hs 2014-12-17 11:48:49.000000000 +0100 @@ -1,30 +1,31 @@ +{-# OPTIONS_HADDOCK not-home #-} {-# LANGUAGE CPP #-} {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE RankNTypes #-} module Control.Monad.Trans.Resource.Internal( - ExceptionT(..) - , InvalidAccess(..) + InvalidAccess(..) , MonadResource(..) - , MonadThrow(..) - , MonadUnsafeIO(..) , ReleaseKey(..) - , ReleaseMap(..)\ + , ReleaseMap(..) , ResIO , ResourceT(..) , stateAlloc , stateCleanup , transResourceT + , register' + , registerType ) where import Control.Exception (throw,Exception,SomeException) import Control.Applicative (Applicative (..)) import Control.Monad.Trans.Control - ( MonadTransControl (..), MonadBaseControl (..) - , ComposeSt, defaultLiftBaseWith, defaultRestoreM) + ( MonadTransControl (..), MonadBaseControl (..) ) import Control.Monad.Base (MonadBase, liftBase) import Control.Monad.Trans.Cont ( ContT ) import Control.Monad.Cont.Class ( MonadCont (..) ) @@ -48,15 +49,24 @@ import qualified Control.Monad.Trans.Writer.Strict as Strict ( WriterT ) import Control.Monad.IO.Class (MonadIO (..)) +#if !(MIN_VERSION_monad_control(1,0,0)) import Control.Monad (liftM) +#endif import qualified Control.Exception as E import Control.Monad.ST (ST) +import Control.Monad.Catch (MonadThrow (..), MonadCatch (..) +#if MIN_VERSION_exceptions(0,6,0) + , MonadMask (..) +#endif + ) import Data.IntMap (IntMap) import qualified Data.IntMap as IntMap import qualified Data.IORef as I import Data.Monoid 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) @@ -85,7 +95,7 @@ -- unwrapped before calling @runResourceT@. -- -- Since 0.3.0 -class (MonadThrow m, MonadUnsafeIO m, MonadIO m, Applicative m) => MonadResource m where +class (MonadThrow m, MonadIO m, Applicative m, MonadBase IO m) => MonadResource m where -- | Lift a @ResourceT IO@ action into the current @Monad@. -- -- Since 0.4.0 @@ -103,7 +113,7 @@ type NextKey = Int data ReleaseMap = - ReleaseMap !NextKey !RefCount !(IntMap (IO ())) + ReleaseMap !NextKey !RefCount !(IntMap (ReleaseType -> IO ())) | ReleaseMapClosed -- | Convenient alias for @ResourceT IO@. @@ -135,43 +145,20 @@ listen = mapResourceT listen pass = mapResourceT pass --- | A @Monad@ which can throw exceptions. Note that this does not work in a --- vanilla @ST@ or @Identity@ monad. Instead, you should use the 'ExceptionT' --- transformer in your stack if you are dealing with a non-@IO@ base monad. --- --- Since 0.3.0 -class Monad m => MonadThrow m where - monadThrow :: E.Exception e => e -> m a - -instance MonadThrow IO where - monadThrow = E.throwIO - -instance MonadThrow Maybe where - monadThrow _ = Nothing -instance MonadThrow (Either SomeException) where - monadThrow = Left . E.toException -instance MonadThrow [] where - monadThrow _ = [] - -#define GO(T) instance (MonadThrow m) => MonadThrow (T m) where monadThrow = lift . monadThrow -#define GOX(X, T) instance (X, MonadThrow m) => MonadThrow (T m) where monadThrow = lift . monadThrow -GO(IdentityT) -GO(ListT) -GO(MaybeT) -GOX(Error e, ErrorT e) -GO(ReaderT r) -GO(ContT r) -GO(ResourceT) -GO(StateT s) -GOX(Monoid w, WriterT w) -GOX(Monoid w, RWST r w s) -GOX(Monoid w, Strict.RWST r w s) -GO(Strict.StateT s) -GOX(Monoid w, Strict.WriterT w) -#undef GO -#undef GOX - -instance (MonadThrow m, MonadUnsafeIO m, MonadIO m, Applicative m) => MonadResource (ResourceT m) where +instance MonadThrow m => MonadThrow (ResourceT m) where + throwM = lift . throwM +instance MonadCatch m => MonadCatch (ResourceT m) where + catch (ResourceT m) c = + ResourceT $ \r -> m r `catch` \e -> unResourceT (c e) r +#if MIN_VERSION_exceptions(0,6,0) +instance MonadMask m => MonadMask (ResourceT m) where +#endif + mask a = ResourceT $ \e -> mask $ \u -> unResourceT (a $ q u) e + where q u (ResourceT b) = ResourceT (u . b) + uninterruptibleMask a = + ResourceT $ \e -> uninterruptibleMask $ \u -> unResourceT (a $ q u) e + where q u (ResourceT b) = ResourceT (u . b) +instance (MonadThrow m, MonadBase IO m, MonadIO m, Applicative m) => MonadResource (ResourceT m) where liftResourceT = transResourceT liftIO -- | Transform the monad a @ResourceT@ lives in. This is most often used to @@ -264,24 +251,32 @@ liftBase = lift . liftBase instance MonadTransControl ResourceT where +#if MIN_VERSION_monad_control(1,0,0) + type StT ResourceT a = a + liftWith f = ResourceT $ \r -> f $ \(ResourceT t) -> t r + restoreT = ResourceT . const +#else newtype StT ResourceT a = StReader {unStReader :: a} liftWith f = ResourceT $ \r -> f $ \(ResourceT t) -> liftM StReader $ t r restoreT = ResourceT . const . liftM unStReader +#endif {-# INLINE liftWith #-} {-# INLINE restoreT #-} instance MonadBaseControl b m => MonadBaseControl b (ResourceT m) where +#if MIN_VERSION_monad_control(1,0,0) + type StM (ResourceT m) a = StM m a + liftBaseWith f = ResourceT $ \reader' -> + liftBaseWith $ \runInBase -> + f $ runInBase . (\(ResourceT r) -> r reader' ) + restoreM = ResourceT . const . restoreM +#else newtype StM (ResourceT m) a = StMT (StM m a) liftBaseWith f = ResourceT $ \reader' -> liftBaseWith $ \runInBase -> f $ liftM StMT . runInBase . (\(ResourceT r) -> r reader' ) restoreM (StMT base) = ResourceT $ const $ restoreM base -instance Monad m => MonadThrow (ExceptionT m) where - monadThrow = ExceptionT . return . Left . E.toException -instance MonadResource m => MonadResource (ExceptionT m) where - liftResourceT = lift . liftResourceT -instance MonadIO m => MonadIO (ExceptionT m) where - liftIO = lift . liftIO +#endif #define GO(T) instance (MonadResource m) => MonadResource (T m) where liftResourceT = lift . liftResourceT #define GOX(X, T) instance (X, MonadResource m) => MonadResource (T m) where liftResourceT = lift . liftResourceT @@ -300,13 +295,6 @@ #undef GO #undef GOX - --- | The express purpose of this transformer is to allow non-@IO@-based monad --- stacks to catch exceptions via the 'MonadThrow' typeclass. --- --- Since 0.3.0 -newtype ExceptionT m a = ExceptionT { runExceptionT :: m (Either SomeException a) } - stateAlloc :: I.IORef ReleaseMap -> IO () stateAlloc istate = do I.atomicModifyIORef istate $ \rm -> @@ -315,8 +303,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 -> @@ -327,94 +315,33 @@ 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) try = E.try - --- | A @Monad@ based on some monad which allows running of some 'IO' actions, --- via unsafe calls. This applies to 'IO' and 'ST', for instance. --- --- Since 0.3.0 -class Monad m => MonadUnsafeIO m where - unsafeLiftIO :: IO a -> m a - -instance MonadUnsafeIO IO where - unsafeLiftIO = id - -instance MonadUnsafeIO (ST s) where - unsafeLiftIO = unsafeIOToST - -instance MonadUnsafeIO (Lazy.ST s) where - unsafeLiftIO = LazyUnsafe.unsafeIOToST - -instance (MonadTrans t, MonadUnsafeIO m, Monad (t m)) => MonadUnsafeIO (t m) where - unsafeLiftIO = lift . unsafeLiftIO - -instance Monad m => Functor (ExceptionT m) where - fmap f = ExceptionT . (liftM . fmap) f . runExceptionT -instance Monad m => Applicative (ExceptionT m) where - pure = ExceptionT . return . Right - ExceptionT mf <*> ExceptionT ma = ExceptionT $ do - ef <- mf - case ef of - Left e -> return (Left e) - Right f -> do - ea <- ma - case ea of - Left e -> return (Left e) - Right x -> return (Right (f x)) -instance Monad m => Monad (ExceptionT m) where - return = pure - ExceptionT ma >>= f = ExceptionT $ do - ea <- ma - case ea of - Left e -> return (Left e) - Right a -> runExceptionT (f a) -instance MonadBase b m => MonadBase b (ExceptionT m) where - liftBase = lift . liftBase -instance MonadTrans ExceptionT where - lift = ExceptionT . liftM Right -instance MonadTransControl ExceptionT where - newtype StT ExceptionT a = StExc { unStExc :: Either SomeException a } - liftWith f = ExceptionT $ liftM return $ f $ liftM StExc . runExceptionT - restoreT = ExceptionT . liftM unStExc -instance MonadBaseControl b m => MonadBaseControl b (ExceptionT m) where - newtype StM (ExceptionT m) a = StE { unStE :: ComposeSt ExceptionT m a } - liftBaseWith = defaultLiftBaseWith StE - restoreM = defaultRestoreM unStE - -instance MonadCont m => MonadCont (ExceptionT m) where - callCC f = ExceptionT $ - callCC $ \c -> - runExceptionT (f (\a -> ExceptionT $ c (Right a))) - -instance MonadError e m => MonadError e (ExceptionT m) where - throwError = lift . throwError - catchError r h = ExceptionT $ runExceptionT r `catchError` (runExceptionT . h) - -instance MonadRWS r w s m => MonadRWS r w s (ExceptionT m) - -instance MonadReader r m => MonadReader r (ExceptionT m) where - ask = lift ask - local = mapExceptionT . local - -mapExceptionT :: (m (Either SomeException a) -> n (Either SomeException b)) -> ExceptionT m a -> ExceptionT n b -mapExceptionT f = ExceptionT . f . runExceptionT - -instance MonadState s m => MonadState s (ExceptionT m) where - get = lift get - put = lift . put - -instance MonadWriter w m => MonadWriter w (ExceptionT m) where - tell = lift . tell - listen = mapExceptionT $ \ m -> do - (a, w) <- listen m - return $! fmap (\ r -> (r, w)) a - pass = mapExceptionT $ \ m -> pass $ do - a <- m - return $! case a of - Left l -> (Left l, id) - Right (r, f) -> (Right r, f) +register' :: I.IORef ReleaseMap + -> 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) + , ReleaseKey istate key + ) + ReleaseMapClosed -> throw $ InvalidAccess "register'" diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/resourcet-0.4.8/Control/Monad/Trans/Resource.hs new/resourcet-1.1.3.3/Control/Monad/Trans/Resource.hs --- old/resourcet-0.4.8/Control/Monad/Trans/Resource.hs 2013-09-08 07:08:15.000000000 +0200 +++ new/resourcet-1.1.3.3/Control/Monad/Trans/Resource.hs 2014-12-17 11:48:49.000000000 +0100 @@ -12,7 +12,7 @@ #endif -- | Allocate resources which are guaranteed to be released. -- --- For more information, see <http://www.yesodweb.com/book/conduits>. +-- For more information, see <https://www.fpcomplete.com/user/snoyberg/library-documentation/resourcet>. -- -- One point to note: all register cleanup actions live in the @IO@ monad, not -- the main monad. This allows both more efficient code, and for monads to be @@ -29,11 +29,6 @@ -- * Monad transformation , transResourceT , joinResourceT - -- * A specific Exception transformer - , ExceptionT (..) - , runExceptionT_ - , runException - , runException_ -- * Registering/releasing , allocate , register @@ -42,9 +37,6 @@ , resourceMask -- * Type class/associated types , MonadResource (..) - , MonadUnsafeIO (..) - , MonadThrow (..) - , MonadActive (..) , MonadResourceBase -- ** Low-level , InvalidAccess (..) @@ -56,6 +48,16 @@ , getInternalState , runInternalState , withInternalState + , createInternalState + , closeInternalState + -- * Backwards compatibility + , ExceptionT (..) + , runExceptionT + , runExceptionT_ + , runException + , runException_ + , MonadThrow (..) + , monadThrow ) where import qualified Data.IntMap as IntMap @@ -92,7 +94,9 @@ import Data.Functor.Identity (Identity, runIdentity) import Control.Monad.Morph - +import Control.Monad.Catch (MonadThrow, throwM) +import Control.Monad.Catch.Pure (CatchT, runCatchT) +import Data.Acquire.Internal (ReleaseType (..)) @@ -159,33 +163,22 @@ go :: (forall a. IO a -> IO a) -> (forall a. ResourceT IO a -> ResourceT IO a) go r (ResourceT g) = ResourceT (\i -> r (g i)) -register' :: I.IORef ReleaseMap - -> IO () - -> IO ReleaseKey -register' istate rel = I.atomicModifyIORef istate $ \rm -> - case rm of - ReleaseMap key rf m -> - ( ReleaseMap (key - 1) rf (IntMap.insert key rel m) - , ReleaseKey istate key - ) - ReleaseMapClosed -> throw $ InvalidAccess "register'" - release' :: I.IORef ReleaseMap -> Int -> (Maybe (IO ()) -> IO a) -> IO a -release' istate key act = E.mask $ \restore -> do +release' istate key act = E.mask_ $ do maction <- I.atomicModifyIORef istate lookupAction - restore (act maction) + act maction where lookupAction rm@(ReleaseMap next rf m) = case IntMap.lookup key m of 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, @@ -204,19 +197,30 @@ -- -- Since 0.3.0 runResourceT :: MonadBaseControl IO m => ResourceT m a -> m a -runResourceT (ResourceT r) = do - istate <- liftBase $ I.newIORef - $ ReleaseMap maxBound minBound IntMap.empty - bracket_ - (stateAlloc istate) - (stateCleanup istate) - (r istate) - -bracket_ :: MonadBaseControl IO m => IO () -> IO () -> m a -> m a -bracket_ alloc cleanup inside = - control $ \run -> E.bracket_ alloc cleanup (run inside) - - +runResourceT (ResourceT r) = control $ \run -> do + istate <- createInternalState + E.mask $ \restore -> do + res <- restore (run (r istate)) `E.onException` + stateCleanup ReleaseException istate + stateCleanup ReleaseNormal istate + return res + +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 = + control $ \run -> E.finally (run action) cleanup -- | This function mirrors @join@ at the transformer level: it will collapse -- two levels of @ResourceT@ into a single @ResourceT@. @@ -226,7 +230,12 @@ -> ResourceT m a joinResourceT (ResourceT f) = ResourceT $ \r -> unResourceT (f r) r +-- | For backwards compatibility. +type ExceptionT = CatchT +-- | For backwards compatibility. +runExceptionT :: ExceptionT m a -> m (Either SomeException a) +runExceptionT = runCatchT -- | Same as 'runExceptionT', but immediately 'E.throw' any exception returned. -- @@ -268,63 +277,21 @@ bracket_ (stateAlloc r) (return ()) + (return ()) (liftBaseDiscard forkIO $ bracket_ (return ()) - (stateCleanup r) + (stateCleanup ReleaseNormal r) + (stateCleanup ReleaseException r) (restore $ f r)) --- | Determine if some monad is still active. This is intended to prevent usage --- of a monadic state after it has been closed. This is necessary for such --- cases as lazy I\/O, where an unevaluated thunk may still refer to a --- closed @ResourceT@. --- --- Since 0.3.0 -class Monad m => MonadActive m where - monadActive :: m Bool - -instance (MonadIO m, MonadActive m) => MonadActive (ResourceT m) where - monadActive = ResourceT $ \rmMap -> do - rm <- liftIO $ I.readIORef rmMap - case rm of - ReleaseMapClosed -> return False - _ -> monadActive -- recurse - -instance MonadActive Identity where - monadActive = return True - -instance MonadActive IO where - monadActive = return True - -instance MonadActive (ST s) where - monadActive = return True - -instance MonadActive (Lazy.ST s) where - monadActive = return True - -#define GO(T) instance MonadActive m => MonadActive (T m) where monadActive = lift monadActive -#define GOX(X, T) instance (X, MonadActive m) => MonadActive (T m) where monadActive = lift monadActive -GO(IdentityT) -GO(ListT) -GO(MaybeT) -GOX(Error e, ErrorT e) -GO(ReaderT r) -GO(StateT s) -GOX(Monoid w, WriterT w) -GOX(Monoid w, RWST r w s) -GOX(Monoid w, Strict.RWST r w s) -GO(Strict.StateT s) -GOX(Monoid w, Strict.WriterT w) -#undef GO -#undef GOX - -- | A @Monad@ which can be used as a base for a @ResourceT@. -- -- A @ResourceT@ has some restrictions on its base monad: -- -- * @runResourceT@ requires an instance of @MonadBaseControl IO@. --- * @MonadResource@ requires an instance of @MonadThrow@, @MonadUnsafeIO@, @MonadIO@, and @Applicative@. +-- * @MonadResource@ requires an instance of @MonadThrow@, @MonadIO@, and @Applicative@. -- -- While any instance of @MonadBaseControl IO@ should be an instance of the -- other classes, this is not guaranteed by the type system (e.g., you may have @@ -340,10 +307,10 @@ -- -- Since 0.3.2 #if __GLASGOW_HASKELL__ >= 704 -type MonadResourceBase m = (MonadBaseControl IO m, MonadThrow m, MonadUnsafeIO m, MonadIO m, Applicative m) +type MonadResourceBase m = (MonadBaseControl IO m, MonadThrow m, MonadBase IO m, MonadIO m, Applicative m) #else -class (MonadBaseControl IO m, MonadThrow m, MonadUnsafeIO m, MonadIO m, Applicative m) => MonadResourceBase m -instance (MonadBaseControl IO m, MonadThrow m, MonadUnsafeIO m, MonadIO m, Applicative m) => MonadResourceBase m +class (MonadBaseControl IO m, MonadThrow m, MonadIO m, Applicative m) => MonadResourceBase m +instance (MonadBaseControl IO m, MonadThrow m, MonadIO m, Applicative m) => MonadResourceBase m #endif -- $internalState @@ -355,6 +322,22 @@ -- instead of wrapping around @ResourceT@ itself. This section provides you the -- means of doing so. +-- | Create a new internal state. This state must be closed with +-- @closeInternalState@. It is your responsibility to ensure exception safety. +-- Caveat emptor! +-- +-- Since 0.4.9 +createInternalState :: MonadBase IO m => m InternalState +createInternalState = liftBase + $ I.newIORef + $ ReleaseMap maxBound (minBound + 1) IntMap.empty + +-- | Close an internal state created by @createInternalState@. +-- +-- Since 0.4.9 +closeInternalState :: MonadBase IO m => InternalState -> m () +closeInternalState = liftBase . stateCleanup ReleaseNormal + -- | Get the internal state of the current @ResourceT@. -- -- Since 0.4.6 @@ -377,3 +360,7 @@ -- Since 0.4.6 withInternalState :: (InternalState -> m a) -> ResourceT m a withInternalState = ResourceT + +-- | Backwards compatibility +monadThrow :: (E.Exception e, MonadThrow m) => e -> m a +monadThrow = throwM diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/resourcet-0.4.8/Data/Acquire/Internal.hs new/resourcet-1.1.3.3/Data/Acquire/Internal.hs --- old/resourcet-0.4.8/Data/Acquire/Internal.hs 1970-01-01 01:00:00.000000000 +0100 +++ new/resourcet-1.1.3.3/Data/Acquire/Internal.hs 2014-12-17 11:48:49.000000000 +0100 @@ -0,0 +1,138 @@ +{-# OPTIONS_HADDOCK not-home #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE FlexibleContexts #-} +module Data.Acquire.Internal + ( Acquire (..) + , Allocated (..) + , with + , withEx + , mkAcquire + , ReleaseType (..) + , mkAcquireType + ) where + +import Control.Applicative (Applicative (..)) +import Control.Monad.Base (MonadBase (..)) +import Control.Monad.IO.Class (MonadIO (..)) +import Control.Monad.Trans.Control (MonadBaseControl, control) +import qualified Control.Exception.Lifted as E +import Data.Typeable (Typeable) +import Control.Monad (liftM, ap) +import qualified Control.Monad.Catch as C +import GHC.IO (unsafeUnmask) + +-- | 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 +-- together. You can allocate these resources using either the @bracket@ +-- pattern (via @with@) or using @ResourceT@ (via @allocateAcquire@). +-- +-- This concept was originally introduced by Gabriel Gonzalez and described at: +-- <http://www.haskellforall.com/2013/06/the-resource-applicative.html>. The +-- implementation in this package is slightly different, due to taking a +-- different approach to async exception safety. +-- +-- Since 1.1.0 +newtype Acquire a = Acquire ((forall b. IO b -> IO b) -> IO (Allocated a)) + deriving Typeable + +instance Functor Acquire where + fmap = liftM +instance Applicative Acquire where + pure = return + (<*>) = ap + +instance Monad Acquire where + 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 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 (const $ return ()) + +instance MonadBase IO Acquire where + liftBase = liftIO + +-- | Create an @Acquire@ value using the given allocate and free functions. +-- +-- Since 1.1.0 +mkAcquire :: IO a -- ^ acquire the resource + -> (a -> IO ()) -- ^ free the resource + -> 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 +-- resource will be freed as soon as the inner block is exited, whether +-- normally or via an exception. This function is similar in function to +-- @bracket@. +-- +-- Since 1.1.0 +with :: MonadBaseControl IO m + => Acquire a + -> (a -> m b) + -> m b +with (Acquire f) g = control $ \run -> E.mask $ \restore -> do + Allocated x free <- f restore + res <- restore (run (g x)) `E.onException` free ReleaseException + free ReleaseNormal + return res + +-- | Same as @with@, but uses the @MonadMask@ typeclass from exceptions instead +-- of @MonadBaseControl@ from exceptions. +-- +-- Since 1.1.3 +#if MIN_VERSION_exceptions(0,6,0) +withEx :: (C.MonadMask m, MonadIO m) +#else +withEx :: (C.MonadCatch m, MonadIO m) +#endif + => Acquire a + -> (a -> m b) + -> m b +withEx (Acquire f) g = do + -- We need to do some funny business, since the restore we get below is + -- specialized to the m from the result, whereas we need a restore function + -- in IO. Checking the current masking state is exactly how mask is + -- implemented in base. + origMS <- liftIO E.getMaskingState + + C.mask $ \restore -> do + Allocated x free <- liftIO $ f $ case origMS of + E.Unmasked -> unsafeUnmask + _ -> id + res <- restore (g x) `C.onException` liftIO (free ReleaseException) + liftIO $ free ReleaseNormal + return res diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/resourcet-0.4.8/Data/Acquire.hs new/resourcet-1.1.3.3/Data/Acquire.hs --- old/resourcet-0.4.8/Data/Acquire.hs 1970-01-01 01:00:00.000000000 +0100 +++ new/resourcet-1.1.3.3/Data/Acquire.hs 2014-12-17 11:48:49.000000000 +0100 @@ -0,0 +1,35 @@ +-- | This was previously known as the Resource monad. However, that term is +-- confusing next to the ResourceT transformer, so it has been renamed. +module Data.Acquire + ( Acquire + , with + , withEx + , mkAcquire + , mkAcquireType + , allocateAcquire + , ReleaseType (..) + ) where + +import Control.Monad.Trans.Resource.Internal +import Control.Monad.Trans.Resource +import Data.Acquire.Internal +import Control.Applicative (Applicative (..)) +import Control.Monad.Base (MonadBase (..)) +import Control.Monad.IO.Class (MonadIO (..)) +import Control.Monad.Trans.Control (MonadBaseControl, control) +import qualified Control.Exception.Lifted as E +import Data.Typeable (Typeable) +import Control.Monad (liftM, ap) + +-- | Allocate a resource and register an action with the @MonadResource@ to +-- free the resource. +-- +-- Since 1.1.0 +allocateAcquire :: MonadResource m => Acquire a -> m (ReleaseKey, a) +allocateAcquire = liftResourceT . allocateAcquireRIO + +allocateAcquireRIO :: Acquire a -> ResourceT IO (ReleaseKey, a) +allocateAcquireRIO (Acquire f) = ResourceT $ \istate -> liftIO $ E.mask $ \restore -> do + Allocated a free <- f restore + key <- registerType istate free + return (key, a) diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/resourcet-0.4.8/README.md new/resourcet-1.1.3.3/README.md --- old/resourcet-0.4.8/README.md 1970-01-01 01:00:00.000000000 +0100 +++ new/resourcet-1.1.3.3/README.md 2014-12-17 11:48:49.000000000 +0100 @@ -0,0 +1,5 @@ +## resourcet + +Please see [the full tutorial on School of Haskell](https://www.fpcomplete.com/user/snoyberg/library-documentation/resourcet). + +This package was originally included with the conduit package, but has existed as a separate package for quite a while. It is fully usable outside of conduit. diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/resourcet-0.4.8/resourcet.cabal new/resourcet-1.1.3.3/resourcet.cabal --- old/resourcet-0.4.8/resourcet.cabal 2013-09-08 07:08:15.000000000 +0200 +++ new/resourcet-1.1.3.3/resourcet.cabal 2014-12-17 11:48:49.000000000 +0100 @@ -1,8 +1,7 @@ Name: resourcet -Version: 0.4.8 +Version: 1.1.3.3 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>. +description: Hackage documentation generation is not reliable. For up to date documentation, please see: <http://www.stackage.org/package/resourcet>. License: BSD3 License-file: LICENSE Author: Michael Snoyman @@ -11,18 +10,22 @@ Build-type: Simple Cabal-version: >=1.8 Homepage: http://github.com/snoyberg/conduit +extra-source-files: ChangeLog.md, README.md Library Exposed-modules: Control.Monad.Trans.Resource Control.Monad.Trans.Resource.Internal + Data.Acquire + Data.Acquire.Internal Build-depends: base >= 4.3 && < 5 , lifted-base >= 0.1 , transformers-base >= 0.4.1 && < 0.5 - , monad-control >= 0.3.1 && < 0.4 + , monad-control >= 0.3.1 && < 1.1 , containers - , transformers >= 0.2.2 && < 0.4 - , mtl >= 2.0 && < 2.2 + , transformers >= 0.2.2 && < 0.5 + , mtl >= 2.0 && < 2.3 , mmorph + , exceptions >= 0.5 ghc-options: -Wall test-suite test diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/resourcet-0.4.8/test/main.hs new/resourcet-1.1.3.3/test/main.hs --- old/resourcet-0.4.8/test/main.hs 2013-09-08 07:08:15.000000000 +0200 +++ new/resourcet-1.1.3.3/test/main.hs 2014-12-17 11:48:49.000000000 +0100 @@ -1,12 +1,18 @@ +{-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE ScopedTypeVariables #-} -import Test.Hspec -import Control.Monad.Trans.Resource -import Data.IORef -import Control.Concurrent -import Control.Monad.IO.Class (liftIO) -import Control.Concurrent.Lifted (fork) -import Control.Exception (handle, SomeException) +import Control.Concurrent +import Control.Concurrent.Lifted (fork) +import Control.Exception (Exception, MaskingState (MaskedInterruptible), + getMaskingState, throwIO, try) +import Control.Exception (SomeException, handle) +import Control.Monad (unless) +import Control.Monad.IO.Class (liftIO) +import Control.Monad.Trans.Resource +import Data.IORef +import Data.Typeable (Typeable) +import Test.Hspec +import Data.Acquire main :: IO () main = hspec $ do @@ -37,6 +43,67 @@ unprotect key y <- readIORef x y `shouldBe` 0 + it "cleanup actions are masked #144" $ do + let checkMasked name = do + ms <- getMaskingState + unless (ms == MaskedInterruptible) $ + error $ show (name, ms) + runResourceT $ do + register (checkMasked "release") >>= release + register (checkMasked "normal") + Left Dummy <- try $ runResourceT $ do + 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) + describe "withEx" $ do + it "normal" $ do + ref <- newIORef Nothing + let acq = mkAcquireType (return ()) $ \() -> writeIORef ref . Just + withEx acq $ const $ return () + readIORef ref >>= (`shouldBe` Just ReleaseNormal) + it "exception" $ do + ref <- newIORef Nothing + let acq = mkAcquireType (return ()) $ \() -> writeIORef ref . Just + Left Dummy <- try $ withEx acq $ const $ throwIO Dummy + readIORef ref >>= (`shouldBe` Just ReleaseException) + +data Dummy = Dummy + deriving (Show, Typeable) +instance Exception Dummy forkHelper s fork' = describe s $ do it "waits for all threads" $ do -- To unsubscribe, e-mail: [email protected] For additional commands, e-mail: [email protected]
