diff --git a/CONTRIBUTORS b/CONTRIBUTORS --- a/CONTRIBUTORS +++ b/CONTRIBUTORS @@ -1,2 +1,2 @@ Michael Snoyman -Robin Banks +Shane O'Brien diff --git a/resource-simple.cabal b/resource-simple.cabal --- a/resource-simple.cabal +++ b/resource-simple.cabal @@ -1,13 +1,13 @@ name: resource-simple -version: 0.1 +version: 0.2 synopsis: Allocate resources which are guaranteed to be released. license: BSD3 license-file: LICENSE -author: Robin Banks -maintainer: anarchomorphism@seomraspraoi.org +author: Shane O'Brien +maintainer: shane@duairc.com stability: Experimental category: Control -cabal-version: >= 1.2 +cabal-version: >= 1.6 build-type: Simple description: This is a simplified, standalone version of the @ResourceT@ transformer that @@ -43,6 +43,10 @@ containers < 1, monad-control > 0.3 && < 0.4, monad-fork < 0.2, - mtl > 2 && < 3, + mtl-evil-instances < 0.2, transformers > 0.2 && < 0.3, transformers-base < 0.5 + +source-repository head + type: git + location: git://github.com/duairc/resource-simple.git diff --git a/src/Control/Monad/Resource.hs b/src/Control/Monad/Resource.hs --- a/src/Control/Monad/Resource.hs +++ b/src/Control/Monad/Resource.hs @@ -1,6 +1,7 @@ {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE OverlappingInstances #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE UndecidableInstances #-} @@ -14,42 +15,29 @@ -} module Control.Monad.Resource - ( -- * Data types + ( -- * The @ResourceT@ monad transformer ResourceT - , ReleaseKey - -- * Run + -- ** Running , runResourceT - -- * Resource allocation - , with - , register - , release - -- * Monad transformation - , transResourceT + -- ** Monad transformation + , mapResourceT + -- * The @MonadResource@ type class + , MonadResource (..) + , ReleaseKey ) where import Data.IntMap (IntMap) import qualified Data.IntMap as IntMap -import Data.IORef - ( IORef - , newIORef - , readIORef - , writeIORef - , atomicModifyIORef - ) +import Data.IORef (IORef, newIORef, writeIORef, atomicModifyIORef) import Data.Word (Word) -import Control.Applicative (Applicative (..)) +import Control.Applicative (Applicative (..), Alternative (..)) import Control.Exception (SomeException, mask, mask_, try, finally) -import Control.Monad (liftM, when) +import Control.Monad (MonadPlus (..), ap, liftM, when) import Control.Monad.Base (MonadBase (..)) -import Control.Monad.Cont.Class (MonadCont(..)) -import Control.Monad.Error.Class (MonadError (..)) import Control.Monad.Fork.Class (MonadFork (..)) -import Control.Monad.IO.Class (MonadIO (..)) -import Control.Monad.Reader.Class (MonadReader (..)) -import Control.Monad.RWS.Class (MonadRWS (..)) -import Control.Monad.State.Class (MonadState (..)) -import Control.Monad.Writer.Class (MonadWriter (..)) +import Control.Monad.Instances.Evil () +import Control.Monad.IO.Class (MonadIO) import Control.Monad.Trans.Class (MonadTrans (..)) import Control.Monad.Trans.Control ( MonadBaseControl (..) @@ -72,12 +60,16 @@ -- | The Resource transformer. This transformer keeps track of all registered -- actions, and calls them upon exit (via 'runResourceT'). Actions may be -- registered via 'register', or resources may be allocated atomically via --- 'with'. The with function corresponds closely to @bracket@. +-- 'with'. The 'with' function corresponds closely to @bracket@. These +-- functions are provided by 'ResourceT'\'s 'MonadResource' instance. -- -- Releasing may be performed before exit via the 'release' function. This is -- a highly recommended optimization, as it will ensure that scarce resources -- are freed early. Note that calling @release@ will deregister the action, so -- that a release action will only ever be called once. +-- +-- Pass-through instances for the @mtl@ type classes are provided +-- automatically by the @mtl-evil-instances@ package. newtype ResourceT m a = ResourceT (IORef ReleaseMap -> m a) @@ -94,17 +86,23 @@ ------------------------------------------------------------------------------ -instance Functor m => Functor (ResourceT m) where - fmap f (ResourceT m) = ResourceT $ \r -> fmap f (m r) +instance Monad m => Functor (ResourceT m) where + fmap = liftM ------------------------------------------------------------------------------ -instance Applicative m => Applicative (ResourceT m) where - pure = ResourceT . const . pure - ResourceT mf <*> ResourceT ma = ResourceT $ \r -> mf r <*> ma r +instance Monad m => Applicative (ResourceT m) where + pure = return + (<*>) = ap ------------------------------------------------------------------------------ +instance MonadPlus m => Alternative (ResourceT m) where + empty = mzero + (<|>) = mplus + + +------------------------------------------------------------------------------ instance Monad m => Monad (ResourceT m) where return = ResourceT . const . return ResourceT m >>= f = ResourceT $ \r -> m r >>= \a -> @@ -112,13 +110,9 @@ ------------------------------------------------------------------------------ -instance MonadIO m => MonadIO (ResourceT m) where - liftIO = lift . liftIO - - ------------------------------------------------------------------------------- -instance MonadBase b m => MonadBase b (ResourceT m) where - liftBase = lift . liftBase +instance MonadPlus m => MonadPlus (ResourceT m) where + mzero = ResourceT $ const mzero + mplus (ResourceT m) (ResourceT m') = ResourceT $ \r -> mplus (m r) (m' r) ------------------------------------------------------------------------------ @@ -140,74 +134,56 @@ ------------------------------------------------------------------------------ -instance MonadCont m => MonadCont (ResourceT m) where - callCC = liftCallCC callCC - where - liftCallCC ccc f = ResourceT $ \r -> ccc $ \ c -> - let ResourceT m = f (ResourceT . const . c) in m r - - ------------------------------------------------------------------------------- -instance MonadError e m => MonadError e (ResourceT m) where - throwError = lift . throwError - catchError = liftCatch catchError - where - liftCatch f (ResourceT m) h = ResourceT $ \r -> - f (m r) (\e -> let ResourceT m' = h e in m' r) - - ------------------------------------------------------------------------------- -instance MonadReader r m => MonadReader r (ResourceT m) where - ask = lift ask - local f (ResourceT m) = ResourceT $ local f . m - - ------------------------------------------------------------------------------- -instance MonadRWS r w s m => MonadRWS r w s (ResourceT m) +-- | Transform the monad a @ResourceT@ lives in. This is most often used to +-- strip or add new transformers to a stack, e.g. to run a @ReaderT@. +mapResourceT :: (m a -> n b) -> ResourceT m a -> ResourceT n b +mapResourceT f (ResourceT m) = ResourceT $ f . m ------------------------------------------------------------------------------ -instance MonadState s m => MonadState s (ResourceT m) where - get = lift get - put s = lift $ put s +-- | Unwrap a 'ResourceT' transformer, and call all registered release +-- actions. +-- +-- Note that there is some reference counting involved due to the +-- implementation of 'fork' used in the 'MonadFork' instance. If multiple +-- threads are sharing the same collection of resources, only the last call +-- to @runResourceT@ will deallocate the resources. +runResourceT :: MonadBaseControl IO m => ResourceT m a -> m a +runResourceT (ResourceT r) = do + istate <- liftBase $ newIORef $ ReleaseMap 0 0 IntMap.empty + control $ \run -> mask $ \unmask -> do + stateAlloc istate + unmask (run $ r istate) `finally` stateCleanup istate ------------------------------------------------------------------------------ -instance MonadWriter w m => MonadWriter w (ResourceT m) where - tell w = lift $ tell w - listen = transResourceT listen - pass = transResourceT pass +stateAlloc :: IORef ReleaseMap -> IO () +stateAlloc istate = atomicModifyIORef istate $ \(ReleaseMap key ref im) -> + (ReleaseMap key (ref + 1) im, ()) ------------------------------------------------------------------------------ --- | Perform some allocation, and automatically register a cleanup action. -with :: MonadBase IO m - => IO a -- ^ allocate - -> (a -> IO ()) -- ^ free resource - -> ResourceT m (ReleaseKey, a) -with acquire m = ResourceT $ \istate -> liftBase $ mask $ \unmask -> do - a <- unmask acquire - key <- register' istate $ m a - return (key, a) +stateCleanup :: IORef ReleaseMap -> IO () +stateCleanup istate = mask_ $ do + (ref, im) <- atomicModifyIORef istate $ \(ReleaseMap key ref im) -> + (ReleaseMap key (ref - 1) im, (ref - 1, im)) + when (ref == 0) $ do + mapM_ (\x -> try' x >> return ()) $ IntMap.elems im + writeIORef istate $ error "Control.Monad.Resource.stateCleanup: There\ + \ is a bug in the implementation. The mutable state is being\ + \ accessed after cleanup. Please contact the maintainers." + where + try' = try :: IO a -> IO (Either SomeException a) ------------------------------------------------------------------------------ --- | Register some action that will be called precisely once, either when --- 'runResourceT' is called, or when the 'ReleaseKey' is passed to 'release'. -register :: MonadBase IO m => IO () -> ResourceT m ReleaseKey -register m = ResourceT $ \istate -> liftBase $ register' istate m - register' :: IORef ReleaseMap -> IO () -> IO ReleaseKey register' istate m = atomicModifyIORef istate $ \(ReleaseMap key ref im) -> (ReleaseMap (key + 1) ref (IntMap.insert key m im), ReleaseKey key) ------------------------------------------------------------------------------ --- | Call a release action early, and deregister it from the list of cleanup --- actions to be performed. -release :: MonadBase IO m => ReleaseKey -> ResourceT m () -release key = ResourceT $ \istate -> liftBase $ release' istate key - +release' :: IORef ReleaseMap -> ReleaseKey -> IO () release' istate (ReleaseKey key) = mask $ \unmask -> do atomicModifyIORef istate lookupAction >>= maybe (return ()) unmask where @@ -218,42 +194,48 @@ ------------------------------------------------------------------------------ --- | Transform the monad a @ResourceT@ lives in. This is most often used to --- strip or add new transformers to a stack, e.g. to run a @ReaderT@. -transResourceT :: (m a -> n b) -> ResourceT m a -> ResourceT n b -transResourceT f (ResourceT mx) = ResourceT (\r -> f (mx r)) +-- | The 'MonadResource' type class. This provides the 'with', 'register' and +-- 'release' functions, which are the main functionality of this package. The +-- main instance of this class is 'ResourceT'. +-- +-- The others instances are overlapping instances (in the spirit of +-- @mtl-evil-instances@), which provide automatic pass-through instances for +-- 'MonadResource' for every monad transformer. This means that you don't have +-- to provide a pass-through instance of 'MonadResource' for every monad +-- transformer you write. +class MonadIO m => MonadResource m where + -- | Perform some allocation, and automatically register a cleanup action. + with :: IO a -> (a -> IO ()) -> m (ReleaseKey, a) + -- | Register some action that will be run precisely once, either when + -- 'runResourceT' is called, or when the 'ReleaseKey' is passed to + -- 'release'. + register :: IO () -> m ReleaseKey + -- | Call a release action early, and deregister it from the list of + -- cleanup actions to be performed. + release :: ReleaseKey -> m () + + ------------------------------------------------------------------------------ --- | Unwrap a 'ResourceT' transformer, and call all registered release --- actions. --- --- Note that there is some reference counting involved due to the 'MonadFork' --- instance. If multiple threads are sharing the same collection of resources, --- only the last call to @runResourceT@ will deallocate the resources. -runResourceT :: MonadBaseControl IO m => ResourceT m a -> m a -runResourceT (ResourceT r) = do - istate <- liftBase $ newIORef $ ReleaseMap 0 0 IntMap.empty - control $ \run -> mask $ \unmask -> do - stateAlloc istate - unmask (run $ r istate) `finally` stateCleanup istate +instance MonadBaseControl IO m => MonadResource (ResourceT m) where + with acquire m = ResourceT $ \istate -> liftBase . mask $ \unmask -> do + a <- unmask acquire + key <- register' istate $ m a + return (key, a) + register m = ResourceT $ \istate -> liftBase $ register' istate m + release key = ResourceT $ \istate -> liftBase $ release' istate key ------------------------------------------------------------------------------ -stateAlloc :: IORef ReleaseMap -> IO () -stateAlloc istate = atomicModifyIORef istate $ \(ReleaseMap key ref im) -> - (ReleaseMap key (ref + 1) im, ()) +instance (MonadTrans t, Monad (t m), MonadResource m) => MonadResource (t m) where + with = (lift .) . with + register = lift . register + release = lift . release ------------------------------------------------------------------------------ -stateCleanup :: IORef ReleaseMap -> IO () -stateCleanup istate = mask_ $ do - (ref, im) <- atomicModifyIORef istate $ \(ReleaseMap key ref im) -> - (ReleaseMap key (ref - 1) im, (ref - 1, im)) - when (ref == 0) $ do - mapM_ (\x -> try' x >> return ()) $ IntMap.elems im - writeIORef istate $ error "Control.Monad.Resource.Trans.stateCleanup:\ - \ There is a bug in the implementation. The mutable state is\ - \ being accessed after cleanup. Please contact the maintainers." - where - try' = try :: IO a -> IO (Either SomeException a) +instance (MonadBase b m, MonadResource b) => MonadResource m where + with = (liftBase .) . with + register = liftBase . register + release = liftBase . release