resource-simple (empty) → 0.1

raw patch · 5 files changed

+341/−0 lines, 5 filesdep +basedep +containersdep +monad-controlsetup-changed

Dependencies added: base, containers, monad-control, monad-fork, mtl, transformers, transformers-base

Files

CONTRIBUTORS +2/−0
LICENSE +30/−0
Setup.hs +2/−0
resource-simple.cabal +48/−0
src/Control/Monad/Resource.hs +259/−0

+ CONTRIBUTORS view

@@ -0,0 +1,2 @@+Michael Snoyman <michael@snoyman.com>+Robin Banks <anarchomorphism@seomraspraoi.org>

+ LICENSE view

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

+ Setup.hs view

@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain

+ resource-simple.cabal view

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

+ src/Control/Monad/Resource.hs view

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