resourcet (empty) → 0.3.0

raw patch · 4 files changed

+560/−0 lines, 4 filesdep +basedep +containersdep +lifted-basesetup-changed

Dependencies added: base, containers, lifted-base, monad-control, transformers, transformers-base

Files

• Control/Monad/Trans/Resource.hs +496/−0
• LICENSE +30/−0
• Setup.lhs +7/−0
• resourcet.cabal +27/−0

@@ -0,0 +1,496 @@+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE UndecidableInstances #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE CPP #-}+{-# LANGUAGE DeriveDataTypeable #-}+-- | Allocate resources which are guaranteed to be released.+--+-- For more information, see <http://www.yesodweb.com/book/conduits>.+--+-- 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+-- transformed.+module Control.Monad.Trans.Resource+    ( -- * Data types+      ResourceT+    , ReleaseKey+      -- * Unwrap+    , runResourceT+      -- * Special actions+    , resourceForkIO+      -- * Monad transformation+    , transResourceT+      -- * A specific Exception transformer+    , ExceptionT (..)+    , runExceptionT_+      -- * Type class/associated types+    , MonadResource (..)+    , MonadUnsafeIO (..)+    , MonadThrow (..)+    , MonadActive (..)+      -- ** Low-level+    , InvalidAccess (..)+      -- * Re-exports+    , MonadBaseControl+    ) where++import Data.Typeable+import Data.IntMap (IntMap)+import qualified Data.IntMap as IntMap+import Control.Exception (SomeException, throw, Exception)+import Control.Monad.Trans.Control+    ( MonadTransControl (..), MonadBaseControl (..)+    , ComposeSt, defaultLiftBaseWith, defaultRestoreM+    , liftBaseDiscard, control+    )+import qualified Data.IORef as I+import Control.Monad.Base (MonadBase, liftBase)+import Control.Applicative (Applicative (..))+import Control.Monad.Trans.Class (MonadTrans (..))+import Control.Monad.IO.Class (MonadIO (..))+import Control.Monad (liftM)+import qualified Control.Exception as E+import Data.Monoid (Monoid)+import qualified Control.Exception.Lifted as L++import Control.Monad.Trans.Identity ( IdentityT)+import Control.Monad.Trans.List     ( ListT    )+import Control.Monad.Trans.Maybe    ( MaybeT   )+import Control.Monad.Trans.Error    ( ErrorT, Error)+import Control.Monad.Trans.Reader   ( ReaderT  )+import Control.Monad.Trans.Cont     ( ContT  )+import Control.Monad.Trans.State    ( StateT   )+import Control.Monad.Trans.Writer   ( WriterT  )+import Control.Monad.Trans.RWS      ( RWST     )++import Data.Word (Word)++import qualified Control.Monad.Trans.RWS.Strict    as Strict ( RWST   )+import qualified Control.Monad.Trans.State.Strict  as Strict ( StateT )+import qualified Control.Monad.Trans.Writer.Strict as Strict ( WriterT )+import Control.Concurrent (ThreadId, forkIO)++import Control.Monad.ST (ST, unsafeIOToST)+import qualified Control.Monad.ST.Lazy as Lazy+import Data.Functor.Identity (Identity)++-- | A lookup key for a specific release action. This value is returned by+-- 'register' and 'allocate', and is passed to 'release'.+--+-- Since 0.3.0+newtype ReleaseKey = ReleaseKey Int+    deriving Typeable++type RefCount = Word+type NextKey = Int++data ReleaseMap =+    ReleaseMap !NextKey !RefCount !(IntMap (IO ()))+  | ReleaseMapClosed++-- | 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+-- 'allocate'. @allocate@ 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.+--+-- Since 0.3.0+newtype ResourceT m a = ResourceT (I.IORef ReleaseMap -> m a)++instance Typeable1 m => Typeable1 (ResourceT m) where+    typeOf1 = goType undefined+      where+        goType :: Typeable1 m => m a -> ResourceT m a -> TypeRep+        goType m _ =+            mkTyConApp+                (mkTyCon "Control.Monad.Trans.Resource.ResourceT")+                [ typeOf1 m+                ]++-- | A @Monad@ which allows for safe resource allocation. In theory, any monad+-- transformer stack included a @ResourceT@ can be an instance of+-- @MonadResource@.+--+-- Note: @runResourceT@ has a requirement for a @MonadBaseControl IO m@ monad,+-- which allows control operations to be lifted. A @MonadResource@ does not+-- have this requirement. This means that transformers such as @ContT@ can be+-- an instance of @MonadResource@. However, the @ContT@ wrapper will need to be+-- unwrapped before calling @runResourceT@.+--+-- Since 0.3.0+class (MonadThrow m, MonadUnsafeIO m, MonadIO m) => MonadResource m where+    -- | Register some action that will be called precisely once, either when+    -- 'runResourceT' is called, or when the 'ReleaseKey' is passed to 'release'.+    --+    -- Since 0.3.0+    register :: IO () -> m ReleaseKey++    -- | Call a release action early, and deregister it from the list of cleanup+    -- actions to be performed.+    --+    -- Since 0.3.0+    release :: ReleaseKey -> m ()++    -- | Perform some allocation, and automatically register a cleanup action.+    --+    -- This is almost identical to calling the allocation and then+    -- @register@ing the release action, but this properly handles masking of+    -- asynchronous exceptions.+    --+    -- Since 0.3.0+    allocate :: IO a -- ^ allocate+             -> (a -> IO ()) -- ^ free resource+             -> m (ReleaseKey, a)++    -- | Perform asynchronous exception masking.+    --+    -- This is more general then @Control.Exception.mask@, yet more efficient+    -- than @Control.Exception.Lifted.mask@.+    --+    -- Since 0.3.0+    resourceMask :: ((forall a. ResourceT IO a -> ResourceT IO a) -> ResourceT IO b) -> m b++instance (MonadThrow m, MonadUnsafeIO m, MonadIO m) => MonadResource (ResourceT m) where+    allocate acquire rel = ResourceT $ \istate -> liftIO $ E.mask $ \restore -> do+        a <- restore acquire+        key <- register' istate $ rel a+        return (key, a)++    register rel = ResourceT $ \istate -> liftIO $ register' istate rel++    release rk = ResourceT $ \istate -> liftIO $ release' istate rk++    resourceMask f = ResourceT $ \istate -> liftIO $ E.mask $ \restore ->+        let ResourceT f' = f (go restore)+         in f' istate+      where+        go :: (forall a. IO a -> IO a) -> (forall a. ResourceT IO a -> ResourceT IO a)+        go r (ResourceT g) = ResourceT (\i -> r (g i))++#define GO(T) instance (MonadResource m) => MonadResource (T m) where allocate a = lift . allocate a; register = lift . register; release = lift . release; resourceMask = lift . resourceMask+#define GOX(X, T) instance (X, MonadResource m) => MonadResource (T m) where allocate a = lift . allocate a; register = lift . register; release = lift . release; resourceMask = lift . resourceMask+GO(IdentityT)+GO(ListT)+GO(MaybeT)+GOX(Error e, ErrorT e)+GO(ReaderT r)+GO(ContT 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++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 key+            )+        ReleaseMapClosed -> throw $ InvalidAccess "register'"++-- | Indicates either an error in the library, or misuse of it (e.g., a+-- @ResourceT@'s state is accessed after being released).+--+-- Since 0.3.0+data InvalidAccess = InvalidAccess { functionName :: String }+    deriving Typeable++instance Show InvalidAccess where+    show (InvalidAccess f) = concat+        [ "Control.Monad.Trans.Resource."+        , f+        , ": The mutable state is being accessed after cleanup. Please contact the maintainers."+        ]++instance Exception InvalidAccess++release' :: I.IORef ReleaseMap+         -> ReleaseKey+         -> IO ()+release' istate (ReleaseKey key) = E.mask $ \restore -> do+    maction <- I.atomicModifyIORef istate lookupAction+    maybe (return ()) restore 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+                )+    lookupAction ReleaseMapClosed = throw $ InvalidAccess "release'"++stateAlloc :: I.IORef ReleaseMap -> IO ()+stateAlloc istate = do+    I.atomicModifyIORef istate $ \rm ->+        case rm of+            ReleaseMap nk rf m ->+                (ReleaseMap nk (rf + 1) m, ())+            ReleaseMapClosed -> throw $ InvalidAccess "stateAlloc"++stateCleanup :: I.IORef ReleaseMap -> IO ()+stateCleanup istate = E.mask_ $ do+    mm <- I.atomicModifyIORef istate $ \rm ->+        case rm of+            ReleaseMap nk rf m ->+                let rf' = rf - 1+                 in if rf' == minBound+                        then (ReleaseMapClosed, Just m)+                        else (ReleaseMap nk rf' m, Nothing)+            ReleaseMapClosed -> throw $ InvalidAccess "stateCleanup"+    case mm of+        Just m ->+            mapM_ (\x -> try x >> return ()) $ IntMap.elems m+        Nothing -> return ()+  where+    try :: IO a -> IO (Either SomeException a)+    try = E.try++-- | Unwrap a 'ResourceT' transformer, and call all registered release actions.+--+-- Note that there is some reference counting involved due to 'resourceForkIO'.+-- If multiple threads are sharing the same collection of resources, only the+-- last call to @runResourceT@ will deallocate the resources.+--+-- Since 0.3.0+runResourceT :: MonadBaseControl IO m => ResourceT m a -> m a+runResourceT (ResourceT r) = do+    istate <- liftBase $ I.newIORef+        $ ReleaseMap minBound 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)++-- | 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@.+--+-- Since 0.3.0+transResourceT :: (m a -> n b)+               -> ResourceT m a+               -> ResourceT n b+transResourceT f (ResourceT mx) = ResourceT (\r -> f (mx r))++-------- All of our monad et al instances+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 ma >>= f = ResourceT $ \r -> do+        a <- ma r+        let ResourceT f' = f a+        f' r++instance MonadTrans ResourceT where+    lift = ResourceT . const++instance MonadIO m => MonadIO (ResourceT m) where+    liftIO = lift . liftIO++instance MonadBase b m => MonadBase b (ResourceT m) where+    liftBase = lift . liftBase++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+    {-# INLINE liftWith #-}+    {-# INLINE restoreT #-}++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 Monad m => MonadThrow (ExceptionT m) where+    monadThrow = ExceptionT . return . Left . E.toException+++-- | 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) }++-- | Same as 'runExceptionT', but immediately 'E.throw' any exception returned.+--+-- Since 0.3.0+runExceptionT_ :: Monad m => ExceptionT m a -> m a+runExceptionT_ = liftM (either E.throw id) . runExceptionT++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++-- | 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++#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++-- | Introduce a reference-counting scheme to allow a resource context to be+-- shared by multiple threads. Once the last thread exits, all remaining+-- resources will be released.+--+-- Note that abuse of this function will greatly delay the deallocation of+-- registered resources. This function should be used with care. A general+-- guideline:+--+-- If you are allocating a resource that should be shared by multiple threads,+-- and will be held for a long time, you should allocate it at the beginning of+-- a new @ResourceT@ block and then call @resourceForkIO@ from there.+--+-- Since 0.3.0+resourceForkIO :: MonadBaseControl IO m => ResourceT m () -> ResourceT m ThreadId+resourceForkIO (ResourceT f) = ResourceT $ \r -> L.mask $ \restore ->+    -- We need to make sure the counter is incremented before this call+    -- returns. Otherwise, the parent thread may call runResourceT before+    -- the child thread increments, and all resources will be freed+    -- before the child gets called.+    bracket_+        (stateAlloc r)+        (return ())+        (liftBaseDiscard forkIO $ bracket_+            (return ())+            (stateCleanup r)+            (restore $ f r))++-- | 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 = Lazy.unsafeIOToST++instance (MonadTrans t, MonadUnsafeIO m, Monad (t m)) => MonadUnsafeIO (t m) where+    unsafeLiftIO = lift . unsafeLiftIO++-- | 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

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

@@ -0,0 +1,7 @@+#!/usr/bin/env runhaskell++> module Main where+> import Distribution.Simple++> main :: IO ()+> main = defaultMain

@@ -0,0 +1,27 @@+Name:                resourcet+Version:             0.3.0+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>.+License:             BSD3+License-file:        LICENSE+Author:              Michael Snoyman+Maintainer:          michael@snoyman.com+Category:            Data, Conduit+Build-type:          Simple+Cabal-version:       >=1.8+Homepage:            http://github.com/snoyberg/conduit++Library+  Exposed-modules:     Control.Monad.Trans.Resource+  Build-depends:       base                     >= 4.3          && < 5+                     , lifted-base              >= 0.1          && < 0.2+                     , transformers-base        >= 0.4.1        && < 0.5+                     , monad-control            >= 0.3.1        && < 0.4+                     , containers+                     , transformers             >= 0.2.2        && < 0.3+  ghc-options:     -Wall++source-repository head+  type:     git+  location: git://github.com/snoyberg/conduit.git