diff --git a/CONTRIBUTORS b/CONTRIBUTORS new file mode 100644 --- /dev/null +++ b/CONTRIBUTORS @@ -0,0 +1,2 @@ +Michael Snoyman +Robin Banks diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,30 @@ +Copyright (c)2011, Michael Snoyman + +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + + * Redistributions in binary form must reproduce the above + copyright notice, this list of conditions and the following + disclaimer in the documentation and/or other materials provided + with the distribution. + + * Neither the name of Michael Snoyman nor the names of other + contributors may be used to endorse or promote products derived + from this software without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/resource-simple.cabal b/resource-simple.cabal new file mode 100644 --- /dev/null +++ b/resource-simple.cabal @@ -0,0 +1,48 @@ +name: resource-simple +version: 0.1 +synopsis: Allocate resources which are guaranteed to be released. +license: BSD3 +license-file: LICENSE +author: Robin Banks +maintainer: anarchomorphism@seomraspraoi.org +stability: Experimental +category: Control +cabal-version: >= 1.2 +build-type: Simple +description: + This is a simplified, standalone version of the @ResourceT@ transformer that + was originally developed as part of the @conduit@ package. That version of + @ResourceT@ was supported by a complicated hierarchy of type classes, the + main purpose of which was to enable the usage of @ResourceT@ on top of the + @ST@ monad. However, this doesn't really make much sense conceptually, and + the reason it was done is because conduits are very closely tied to + @ResourceT@, and an instance for @ST@ would enable the usage of @ResourceT@ + in pure code. + . + This package completely does away with the supporting type class hierarchy, + and as such, this version of @ResourceT@ can only be used with @IO@ or + @IO@-like monads. + . + This package is motivated by a belief that the iteratee problem and the + resource finalization problem are orthogonal. This package is ideal for + usage with the @pipes@ library. + +extra-source-files: + CONTRIBUTORS, + LICENSE + +Library + hs-source-dirs: + src + + exposed-modules: + Control.Monad.Resource + + build-depends: + base > 4 && < 5, + containers < 1, + monad-control > 0.3 && < 0.4, + monad-fork < 0.2, + mtl > 2 && < 3, + transformers > 0.2 && < 0.3, + transformers-base < 0.5 diff --git a/src/Control/Monad/Resource.hs b/src/Control/Monad/Resource.hs new file mode 100644 --- /dev/null +++ b/src/Control/Monad/Resource.hs @@ -0,0 +1,259 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE UndecidableInstances #-} + +{-| + +Allocate resources which are guaranteed to be released. + +One point to note: all register cleanup actions live in IO, not the main +monad. This allows both more efficient code, and for monads to be transformed. + +-} + +module Control.Monad.Resource + ( -- * Data types + ResourceT + , ReleaseKey + -- * Run + , runResourceT + -- * Resource allocation + , with + , register + , release + -- * Monad transformation + , transResourceT + ) +where + +import Data.IntMap (IntMap) +import qualified Data.IntMap as IntMap +import Data.IORef + ( IORef + , newIORef + , readIORef + , writeIORef + , atomicModifyIORef + ) +import Data.Word (Word) +import Control.Applicative (Applicative (..)) +import Control.Exception (SomeException, mask, mask_, try, finally) +import Control.Monad (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.Trans.Class (MonadTrans (..)) +import Control.Monad.Trans.Control + ( MonadBaseControl (..) + , MonadTransControl (..) + , control + ) + + +------------------------------------------------------------------------------ +-- | A lookup key for a specific release action. This value is returned by +-- 'register' and 'with' and is passed to 'release'. +newtype ReleaseKey = ReleaseKey Int + + +------------------------------------------------------------------------------ +data ReleaseMap = ReleaseMap !Int !Word !(IntMap (IO ())) + + +------------------------------------------------------------------------------ +-- | 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@. +-- +-- 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. +newtype ResourceT m a = ResourceT (IORef ReleaseMap -> m a) + + +------------------------------------------------------------------------------ +instance MonadTrans ResourceT where + lift = ResourceT . const + + +------------------------------------------------------------------------------ +instance MonadTransControl ResourceT where + newtype StT ResourceT a = StReader {unStReader :: a} + liftWith f = ResourceT $ \r -> f $ \(ResourceT t) -> liftM StReader $ t r + restoreT = ResourceT . const . liftM unStReader + + +------------------------------------------------------------------------------ +instance Functor m => Functor (ResourceT m) where + fmap f (ResourceT m) = ResourceT $ \r -> fmap f (m r) + + +------------------------------------------------------------------------------ +instance Applicative m => Applicative (ResourceT m) where + pure = ResourceT . const . pure + ResourceT mf <*> ResourceT ma = ResourceT $ \r -> mf r <*> ma r + + +------------------------------------------------------------------------------ +instance Monad m => Monad (ResourceT m) where + return = ResourceT . const . return + ResourceT m >>= f = ResourceT $ \r -> m r >>= \a -> + let ResourceT m' = f a in m' r + + +------------------------------------------------------------------------------ +instance MonadIO m => MonadIO (ResourceT m) where + liftIO = lift . liftIO + + +------------------------------------------------------------------------------ +instance MonadBase b m => MonadBase b (ResourceT m) where + liftBase = lift . liftBase + + +------------------------------------------------------------------------------ +instance MonadBaseControl b m => MonadBaseControl b (ResourceT m) where + 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 (MonadFork m, MonadBaseControl IO m) => MonadFork (ResourceT m) where + fork (ResourceT f) = ResourceT $ \istate -> + control $ \run -> mask $ \unmask -> do + stateAlloc istate + run . fork $ control $ \run' -> do + unmask (run' $ f istate) `finally` stateCleanup istate + + +------------------------------------------------------------------------------ +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) + + +------------------------------------------------------------------------------ +instance MonadState s m => MonadState s (ResourceT m) where + get = lift get + put s = lift $ put s + + +------------------------------------------------------------------------------ +instance MonadWriter w m => MonadWriter w (ResourceT m) where + tell w = lift $ tell w + listen = transResourceT listen + pass = transResourceT pass + + +------------------------------------------------------------------------------ +-- | 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) + + +------------------------------------------------------------------------------ +-- | 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' istate (ReleaseKey key) = mask $ \unmask -> do + atomicModifyIORef istate lookupAction >>= maybe (return ()) unmask + where + lookupAction rm@(ReleaseMap key' ref im) = + case IntMap.lookup key im of + Nothing -> (rm, Nothing) + Just m -> (ReleaseMap key' ref $ IntMap.delete key im, Just 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@. +transResourceT :: (m a -> n b) -> ResourceT m a -> ResourceT n b +transResourceT f (ResourceT mx) = ResourceT (\r -> f (mx r)) + + +------------------------------------------------------------------------------ +-- | 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 + + +------------------------------------------------------------------------------ +stateAlloc :: IORef ReleaseMap -> IO () +stateAlloc istate = atomicModifyIORef istate $ \(ReleaseMap key ref im) -> + (ReleaseMap key (ref + 1) im, ()) + + +------------------------------------------------------------------------------ +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)