@@ -14,13 +14,12 @@ module Control.Monad.Trans.Resource
14import Control.Monad.Trans.Reader (ReaderT, runReaderT, ask)
14import Control.Monad.Trans.Reader (ReaderT, runReaderT, ask)
15import Data.IntMap (IntMap)
15import Data.IntMap (IntMap)
16import qualified Data.IntMap as IntMap
16import qualified Data.IntMap as IntMap
17−import Data.Unique (newUnique, hashUnique)
18import Control.Exception.Lifted (try, finally, SomeException, mask, mask_)
17import Control.Exception.Lifted (try, finally, SomeException, mask, mask_)
19import Control.Monad.Trans.Control (MonadBaseControl)
18import Control.Monad.Trans.Control (MonadBaseControl)
20import qualified Data.IORef as I
19import qualified Data.IORef as I
21import Control.Monad.Base (MonadBase, liftBase)
20import Control.Monad.Base (MonadBase, liftBase)
23−newtype ReleaseMap m = ReleaseMap (IntMap (ResourceT m ()))
22+data ReleaseMap m = ReleaseMap !Int !(IntMap (ResourceT m ()))
24newtype ReleaseKey = ReleaseKey Int
23newtype ReleaseKey = ReleaseKey Int
26type ResourceT m = ReaderT (I.IORef (ReleaseMap m)) m
25type ResourceT m = ReaderT (I.IORef (ReleaseMap m)) m
@@ -34,10 +33,10 @@ with acquire rel = mask_ $ do
34 key <- register $ rel a
33 key <- register $ rel a
35 return (key, a)
34 return (key, a)
37−modify :: MonadBase IO m => (ReleaseMap m -> ReleaseMap m) -> ResourceT m ()
36+modify :: MonadBase IO m => (ReleaseMap m -> (ReleaseMap m, a)) -> ResourceT m a
38modify f = do
37modify f = do
39 istate <- ask
38 istate <- ask
40− liftBase $ I.atomicModifyIORef istate $ \a -> (f a, ())
39+ liftBase $ I.atomicModifyIORef istate $ \a -> f a
42get :: MonadBase IO m => ResourceT m (ReleaseMap m)
41get :: MonadBase IO m => ResourceT m (ReleaseMap m)
43get = ask >>= liftBase . I.readIORef
42get = ask >>= liftBase . I.readIORef
@@ -45,33 +44,32 @@ get = ask >>= liftBase . I.readIORef
45register :: MonadBaseControl IO m
44register :: MonadBaseControl IO m
46 => ResourceT m ()
45 => ResourceT m ()
47 -> ResourceT m ReleaseKey
46 -> ResourceT m ReleaseKey
48−register rel = mask_ $ do
47+register rel = mask_ $
49− key <- liftBase $ fmap hashUnique newUnique
50− modify (insert key rel)
48+ modify $ \(ReleaseMap key m) ->
51− return (ReleaseKey key)
49+ ( ReleaseMap (key + 1) (IntMap.insert key rel m)
52− where
50+ , ReleaseKey key
53− insert k v (ReleaseMap m) = ReleaseMap $ IntMap.insert k v m
51+ )
55release :: MonadBaseControl IO m
53release :: MonadBaseControl IO m
56 => ReleaseKey
54 => ReleaseKey
57 -> ResourceT m ()
55 -> ResourceT m ()
58release (ReleaseKey key) = mask $ \restore -> do
56release (ReleaseKey key) = mask $ \restore -> do
59− ReleaseMap m <- get
57+ ReleaseMap _ m <- get
60 case IntMap.lookup key m of
58 case IntMap.lookup key m of
61 Nothing -> return () -- maybe we should throw an exception?
59 Nothing -> return () -- maybe we should throw an exception?
62 Just r -> modify (delete key) >> restore (try' r >> return ())
60 Just r -> modify (delete key) >> restore (try' r >> return ())
64− delete k (ReleaseMap m) = ReleaseMap $ IntMap.delete k m
62+ delete k (ReleaseMap next m) = (ReleaseMap next $ IntMap.delete k m, ())
66runResourceT :: MonadBaseControl IO m
64runResourceT :: MonadBaseControl IO m
67 => ResourceT m a
65 => ResourceT m a
69runResourceT r = do
67runResourceT r = do
70− istate <- liftBase $ I.newIORef $ ReleaseMap IntMap.empty
68+ istate <- liftBase $ I.newIORef $ ReleaseMap minBound IntMap.empty
71 runReaderT (r `finally` cleanup) istate
69 runReaderT (r `finally` cleanup) istate
73 cleanup = do
71 cleanup = do
74− ReleaseMap m <- get
72+ ReleaseMap _ m <- get
75 if IntMap.null m
73 if IntMap.null m
76 then return ()
74 then return ()