#if __GLASGOW_HASKELL__ >= 704
#endif
module Control.Monad.Trans.Resource
(
ResourceT
, ReleaseKey
, runResourceT
, resourceForkIO
, transResourceT
, ExceptionT (..)
, runExceptionT_
, MonadResource (..)
, MonadUnsafeIO (..)
, MonadThrow (..)
, MonadActive (..)
, MonadResourceBase
, InvalidAccess (..)
, 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)
#if __GLASGOW_HASKELL__ >= 704
import Control.Monad.ST.Unsafe (unsafeIOToST)
#else
import Control.Monad.ST (unsafeIOToST)
#endif
#if __GLASGOW_HASKELL__ >= 704
import qualified Control.Monad.ST.Lazy.Unsafe as LazyUnsafe
#else
import qualified Control.Monad.ST.Lazy as LazyUnsafe
#endif
import qualified Control.Monad.ST.Lazy as Lazy
import Data.Functor.Identity (Identity)
newtype ReleaseKey = ReleaseKey Int
deriving Typeable
type RefCount = Word
type NextKey = Int
data ReleaseMap =
ReleaseMap !NextKey !RefCount !(IntMap (IO ()))
| ReleaseMapClosed
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
#if __GLASGOW_HASKELL__ >= 704
(mkTyCon3 "resourcet" "Control.Monad.Trans.Resource" "ResourceT")
#else
(mkTyCon "Control.Monad.Trans.Resource.ResourceT")
#endif
[ typeOf1 m
]
class (MonadThrow m, MonadUnsafeIO m, MonadIO m, Applicative m) => MonadResource m where
register :: IO () -> m ReleaseKey
release :: ReleaseKey -> m ()
allocate :: IO a
-> (a -> IO ())
-> m (ReleaseKey, a)
resourceMask :: ((forall a. ResourceT IO a -> ResourceT IO a) -> ResourceT IO b) -> m b
instance (MonadThrow m, MonadUnsafeIO m, MonadIO m, Applicative 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'"
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 -> key `seq` 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
runResourceT :: MonadBaseControl IO m => ResourceT m a -> m a
runResourceT (ResourceT r) = do
istate <- liftBase $ I.newIORef
$ ReleaseMap maxBound 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)
transResourceT :: (m a -> n b)
-> ResourceT m a
-> ResourceT n b
transResourceT f (ResourceT mx) = ResourceT (\r -> f (mx r))
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
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
newtype ExceptionT m a = ExceptionT { runExceptionT :: m (Either SomeException a) }
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
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
resourceForkIO :: MonadBaseControl IO m => ResourceT m () -> ResourceT m ThreadId
resourceForkIO (ResourceT f) = ResourceT $ \r -> L.mask $ \restore ->
bracket_
(stateAlloc r)
(return ())
(liftBaseDiscard forkIO $ bracket_
(return ())
(stateCleanup r)
(restore $ f r))
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 = LazyUnsafe.unsafeIOToST
instance (MonadTrans t, MonadUnsafeIO m, Monad (t m)) => MonadUnsafeIO (t m) where
unsafeLiftIO = lift . unsafeLiftIO
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
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
#if __GLASGOW_HASKELL__ >= 704
type MonadResourceBase m = (MonadBaseControl IO m, MonadThrow m, MonadUnsafeIO m, MonadIO m, Applicative m)
#else
class (MonadBaseControl IO m, MonadThrow m, MonadUnsafeIO m, MonadIO m, Applicative m) => MonadResourceBase m
instance (MonadBaseControl IO m, MonadThrow m, MonadUnsafeIO m, MonadIO m, Applicative m) => MonadResourceBase m
#endif