{-# LANGUAGE TemplateHaskell #-}
module Control.Effect.Managed
(
Managed'(..)
, Managed
, manage
, Bracket
, runManaged'
, runManaged
, tagManaged'
, retagManaged'
, untagManaged'
) where
import qualified Control.Exception as IO
import Data.IORef (IORef, atomicModifyIORef', newIORef, readIORef)
import Control.Monad.Trans.Reader (ReaderT(ReaderT), runReaderT)
import Control.Effect.Machinery
class MonadIO m => Managed' tag m where
manage' :: m a
-> (a -> m b)
-> m a
makeTaggedEffect ''Managed'
newtype Bracket n m a = Bracket { Bracket n m a -> ReaderT (IORef [n ()]) m a
runBracket :: ReaderT (IORef [n ()]) m a }
deriving (Functor (Bracket n m)
a -> Bracket n m a
Functor (Bracket n m)
-> (forall a. a -> Bracket n m a)
-> (forall a b.
Bracket n m (a -> b) -> Bracket n m a -> Bracket n m b)
-> (forall a b c.
(a -> b -> c) -> Bracket n m a -> Bracket n m b -> Bracket n m c)
-> (forall a b. Bracket n m a -> Bracket n m b -> Bracket n m b)
-> (forall a b. Bracket n m a -> Bracket n m b -> Bracket n m a)
-> Applicative (Bracket n m)
Bracket n m a -> Bracket n m b -> Bracket n m b
Bracket n m a -> Bracket n m b -> Bracket n m a
Bracket n m (a -> b) -> Bracket n m a -> Bracket n m b
(a -> b -> c) -> Bracket n m a -> Bracket n m b -> Bracket n m c
forall a. a -> Bracket n m a
forall a b. Bracket n m a -> Bracket n m b -> Bracket n m a
forall a b. Bracket n m a -> Bracket n m b -> Bracket n m b
forall a b. Bracket n m (a -> b) -> Bracket n m a -> Bracket n m b
forall a b c.
(a -> b -> c) -> Bracket n m a -> Bracket n m b -> Bracket n m c
forall (f :: * -> *).
Functor f
-> (forall a. a -> f a)
-> (forall a b. f (a -> b) -> f a -> f b)
-> (forall a b c. (a -> b -> c) -> f a -> f b -> f c)
-> (forall a b. f a -> f b -> f b)
-> (forall a b. f a -> f b -> f a)
-> Applicative f
forall (n :: * -> *) (m :: * -> *).
Applicative m =>
Functor (Bracket n m)
forall (n :: * -> *) (m :: * -> *) a.
Applicative m =>
a -> Bracket n m a
forall (n :: * -> *) (m :: * -> *) a b.
Applicative m =>
Bracket n m a -> Bracket n m b -> Bracket n m a
forall (n :: * -> *) (m :: * -> *) a b.
Applicative m =>
Bracket n m a -> Bracket n m b -> Bracket n m b
forall (n :: * -> *) (m :: * -> *) a b.
Applicative m =>
Bracket n m (a -> b) -> Bracket n m a -> Bracket n m b
forall (n :: * -> *) (m :: * -> *) a b c.
Applicative m =>
(a -> b -> c) -> Bracket n m a -> Bracket n m b -> Bracket n m c
<* :: Bracket n m a -> Bracket n m b -> Bracket n m a
$c<* :: forall (n :: * -> *) (m :: * -> *) a b.
Applicative m =>
Bracket n m a -> Bracket n m b -> Bracket n m a
*> :: Bracket n m a -> Bracket n m b -> Bracket n m b
$c*> :: forall (n :: * -> *) (m :: * -> *) a b.
Applicative m =>
Bracket n m a -> Bracket n m b -> Bracket n m b
liftA2 :: (a -> b -> c) -> Bracket n m a -> Bracket n m b -> Bracket n m c
$cliftA2 :: forall (n :: * -> *) (m :: * -> *) a b c.
Applicative m =>
(a -> b -> c) -> Bracket n m a -> Bracket n m b -> Bracket n m c
<*> :: Bracket n m (a -> b) -> Bracket n m a -> Bracket n m b
$c<*> :: forall (n :: * -> *) (m :: * -> *) a b.
Applicative m =>
Bracket n m (a -> b) -> Bracket n m a -> Bracket n m b
pure :: a -> Bracket n m a
$cpure :: forall (n :: * -> *) (m :: * -> *) a.
Applicative m =>
a -> Bracket n m a
$cp1Applicative :: forall (n :: * -> *) (m :: * -> *).
Applicative m =>
Functor (Bracket n m)
Applicative, a -> Bracket n m b -> Bracket n m a
(a -> b) -> Bracket n m a -> Bracket n m b
(forall a b. (a -> b) -> Bracket n m a -> Bracket n m b)
-> (forall a b. a -> Bracket n m b -> Bracket n m a)
-> Functor (Bracket n m)
forall a b. a -> Bracket n m b -> Bracket n m a
forall a b. (a -> b) -> Bracket n m a -> Bracket n m b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
forall (n :: * -> *) (m :: * -> *) a b.
Functor m =>
a -> Bracket n m b -> Bracket n m a
forall (n :: * -> *) (m :: * -> *) a b.
Functor m =>
(a -> b) -> Bracket n m a -> Bracket n m b
<$ :: a -> Bracket n m b -> Bracket n m a
$c<$ :: forall (n :: * -> *) (m :: * -> *) a b.
Functor m =>
a -> Bracket n m b -> Bracket n m a
fmap :: (a -> b) -> Bracket n m a -> Bracket n m b
$cfmap :: forall (n :: * -> *) (m :: * -> *) a b.
Functor m =>
(a -> b) -> Bracket n m a -> Bracket n m b
Functor, Applicative (Bracket n m)
a -> Bracket n m a
Applicative (Bracket n m)
-> (forall a b.
Bracket n m a -> (a -> Bracket n m b) -> Bracket n m b)
-> (forall a b. Bracket n m a -> Bracket n m b -> Bracket n m b)
-> (forall a. a -> Bracket n m a)
-> Monad (Bracket n m)
Bracket n m a -> (a -> Bracket n m b) -> Bracket n m b
Bracket n m a -> Bracket n m b -> Bracket n m b
forall a. a -> Bracket n m a
forall a b. Bracket n m a -> Bracket n m b -> Bracket n m b
forall a b. Bracket n m a -> (a -> Bracket n m b) -> Bracket n m b
forall (m :: * -> *).
Applicative m
-> (forall a b. m a -> (a -> m b) -> m b)
-> (forall a b. m a -> m b -> m b)
-> (forall a. a -> m a)
-> Monad m
forall (n :: * -> *) (m :: * -> *).
Monad m =>
Applicative (Bracket n m)
forall (n :: * -> *) (m :: * -> *) a. Monad m => a -> Bracket n m a
forall (n :: * -> *) (m :: * -> *) a b.
Monad m =>
Bracket n m a -> Bracket n m b -> Bracket n m b
forall (n :: * -> *) (m :: * -> *) a b.
Monad m =>
Bracket n m a -> (a -> Bracket n m b) -> Bracket n m b
return :: a -> Bracket n m a
$creturn :: forall (n :: * -> *) (m :: * -> *) a. Monad m => a -> Bracket n m a
>> :: Bracket n m a -> Bracket n m b -> Bracket n m b
$c>> :: forall (n :: * -> *) (m :: * -> *) a b.
Monad m =>
Bracket n m a -> Bracket n m b -> Bracket n m b
>>= :: Bracket n m a -> (a -> Bracket n m b) -> Bracket n m b
$c>>= :: forall (n :: * -> *) (m :: * -> *) a b.
Monad m =>
Bracket n m a -> (a -> Bracket n m b) -> Bracket n m b
$cp1Monad :: forall (n :: * -> *) (m :: * -> *).
Monad m =>
Applicative (Bracket n m)
Monad, Monad (Bracket n m)
Monad (Bracket n m)
-> (forall a. IO a -> Bracket n m a) -> MonadIO (Bracket n m)
IO a -> Bracket n m a
forall a. IO a -> Bracket n m a
forall (m :: * -> *).
Monad m -> (forall a. IO a -> m a) -> MonadIO m
forall (n :: * -> *) (m :: * -> *).
MonadIO m =>
Monad (Bracket n m)
forall (n :: * -> *) (m :: * -> *) a.
MonadIO m =>
IO a -> Bracket n m a
liftIO :: IO a -> Bracket n m a
$cliftIO :: forall (n :: * -> *) (m :: * -> *) a.
MonadIO m =>
IO a -> Bracket n m a
$cp1MonadIO :: forall (n :: * -> *) (m :: * -> *).
MonadIO m =>
Monad (Bracket n m)
MonadIO)
deriving (m a -> Bracket n m a
(forall (m :: * -> *) a. Monad m => m a -> Bracket n m a)
-> MonadTrans (Bracket n)
forall (m :: * -> *) a. Monad m => m a -> Bracket n m a
forall (n :: * -> *) (m :: * -> *) a.
Monad m =>
m a -> Bracket n m a
forall (t :: Transformer).
(forall (m :: * -> *) a. Monad m => m a -> t m a) -> MonadTrans t
lift :: m a -> Bracket n m a
$clift :: forall (n :: * -> *) (m :: * -> *) a.
Monad m =>
m a -> Bracket n m a
MonadTrans, MonadTrans (Bracket n)
m (StT (Bracket n) a) -> Bracket n m a
MonadTrans (Bracket n)
-> (forall (m :: * -> *) a.
Monad m =>
(Run (Bracket n) -> m a) -> Bracket n m a)
-> (forall (m :: * -> *) a.
Monad m =>
m (StT (Bracket n) a) -> Bracket n m a)
-> MonadTransControl (Bracket n)
(Run (Bracket n) -> m a) -> Bracket n m a
forall (n :: * -> *). MonadTrans (Bracket n)
forall (m :: * -> *) a.
Monad m =>
m (StT (Bracket n) a) -> Bracket n m a
forall (m :: * -> *) a.
Monad m =>
(Run (Bracket n) -> m a) -> Bracket n m a
forall (n :: * -> *) (m :: * -> *) a.
Monad m =>
m (StT (Bracket n) a) -> Bracket n m a
forall (n :: * -> *) (m :: * -> *) a.
Monad m =>
(Run (Bracket n) -> m a) -> Bracket n m a
forall (t :: Transformer).
MonadTrans t
-> (forall (m :: * -> *) a. Monad m => (Run t -> m a) -> t m a)
-> (forall (m :: * -> *) a. Monad m => m (StT t a) -> t m a)
-> MonadTransControl t
restoreT :: m (StT (Bracket n) a) -> Bracket n m a
$crestoreT :: forall (n :: * -> *) (m :: * -> *) a.
Monad m =>
m (StT (Bracket n) a) -> Bracket n m a
liftWith :: (Run (Bracket n) -> m a) -> Bracket n m a
$cliftWith :: forall (n :: * -> *) (m :: * -> *) a.
Monad m =>
(Run (Bracket n) -> m a) -> Bracket n m a
$cp1MonadTransControl :: forall (n :: * -> *). MonadTrans (Bracket n)
MonadTransControl)
deriving (MonadBase b, MonadBaseControl b)
instance (MonadBase IO m, MonadIO m) => Managed' tag (Bracket m m) where
manage' :: Bracket m m a -> (a -> Bracket m m b) -> Bracket m m a
manage' Bracket m m a
alloc a -> Bracket m m b
free = ReaderT (IORef [m ()]) m a -> Bracket m m a
forall (n :: * -> *) (m :: * -> *) a.
ReaderT (IORef [n ()]) m a -> Bracket n m a
Bracket (ReaderT (IORef [m ()]) m a -> Bracket m m a)
-> ((IORef [m ()] -> m a) -> ReaderT (IORef [m ()]) m a)
-> (IORef [m ()] -> m a)
-> Bracket m m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (IORef [m ()] -> m a) -> ReaderT (IORef [m ()]) m a
forall r (m :: * -> *) a. (r -> m a) -> ReaderT r m a
ReaderT ((IORef [m ()] -> m a) -> Bracket m m a)
-> (IORef [m ()] -> m a) -> Bracket m m a
forall a b. (a -> b) -> a -> b
$
\IORef [m ()]
ref -> do
a
a <- ReaderT (IORef [m ()]) m a -> IORef [m ()] -> m a
forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
runReaderT (Bracket m m a -> ReaderT (IORef [m ()]) m a
forall (n :: * -> *) (m :: * -> *) a.
Bracket n m a -> ReaderT (IORef [n ()]) m a
runBracket Bracket m m a
alloc) IORef [m ()]
ref
IO () -> m ()
forall (b :: * -> *) (m :: * -> *) α. MonadBase b m => b α -> m α
liftBase (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$
IORef [m ()] -> ([m ()] -> ([m ()], ())) -> IO ()
forall a b. IORef a -> (a -> (a, b)) -> IO b
atomicModifyIORef' IORef [m ()]
ref (([m ()] -> ([m ()], ())) -> IO ())
-> ([m ()] -> ([m ()], ())) -> IO ()
forall a b. (a -> b) -> a -> b
$
\[m ()]
frees -> (ReaderT (IORef [m ()]) m () -> IORef [m ()] -> m ()
forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
runReaderT (Bracket m m () -> ReaderT (IORef [m ()]) m ()
forall (n :: * -> *) (m :: * -> *) a.
Bracket n m a -> ReaderT (IORef [n ()]) m a
runBracket (a -> Bracket m m b
free a
a Bracket m m b -> Bracket m m () -> Bracket m m ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> () -> Bracket m m ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ())) IORef [m ()]
ref m () -> [m ()] -> [m ()]
forall a. a -> [a] -> [a]
: [m ()]
frees, ())
a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure a
a
{-# INLINE manage' #-}
runManaged' :: forall tag m a. MonadBaseControl IO m => (Managed' tag `Via` Bracket m) m a -> m a
runManaged' :: Via (Managed' tag) (Bracket m) m a -> m a
runManaged' Via (Managed' tag) (Bracket m) m a
program =
m (IORef [m ()])
-> (IORef [m ()] -> m ()) -> (IORef [m ()] -> m a) -> m a
forall (n :: * -> *) b c d.
MonadBaseControl IO n =>
n b -> (b -> n c) -> (b -> n d) -> n d
liftedBracket
( m (IORef [m ()])
forall (n :: * -> *). MonadBase IO n => n (IORef [n ()])
allocRef )
( IORef [m ()] -> m ()
forall (n :: * -> *). MonadBase IO n => IORef [n ()] -> n ()
freeRef )
( ReaderT (IORef [m ()]) m a -> IORef [m ()] -> m a
forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
runReaderT (Bracket m m a -> ReaderT (IORef [m ()]) m a
forall (n :: * -> *) (m :: * -> *) a.
Bracket n m a -> ReaderT (IORef [n ()]) m a
runBracket (Via (Managed' tag) (Bracket m) m a -> Bracket m m a
forall (effs :: [Effect]) (t :: Transformer) (m :: * -> *) a.
EachVia effs t m a -> t m a
runVia Via (Managed' tag) (Bracket m) m a
program)) )
where
allocRef :: forall n. MonadBase IO n => n (IORef [n ()])
allocRef :: n (IORef [n ()])
allocRef = IO (IORef [n ()]) -> n (IORef [n ()])
forall (b :: * -> *) (m :: * -> *) α. MonadBase b m => b α -> m α
liftBase (IO (IORef [n ()]) -> n (IORef [n ()]))
-> IO (IORef [n ()]) -> n (IORef [n ()])
forall a b. (a -> b) -> a -> b
$ [n ()] -> IO (IORef [n ()])
forall a. a -> IO (IORef a)
newIORef []
freeRef :: forall n. MonadBase IO n => IORef [n ()] -> n ()
freeRef :: IORef [n ()] -> n ()
freeRef = ([n ()] -> n ()
forall (t :: * -> *) (m :: * -> *) a.
(Foldable t, Monad m) =>
t (m a) -> m ()
sequence_ ([n ()] -> n ()) -> n [n ()] -> n ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<<) (n [n ()] -> n ())
-> (IORef [n ()] -> n [n ()]) -> IORef [n ()] -> n ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IO [n ()] -> n [n ()]
forall (b :: * -> *) (m :: * -> *) α. MonadBase b m => b α -> m α
liftBase (IO [n ()] -> n [n ()])
-> (IORef [n ()] -> IO [n ()]) -> IORef [n ()] -> n [n ()]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IORef [n ()] -> IO [n ()]
forall a. IORef a -> IO a
readIORef
liftedBracket :: forall n b c d. MonadBaseControl IO n => n b -> (b -> n c) -> (b -> n d) -> n d
liftedBracket :: n b -> (b -> n c) -> (b -> n d) -> n d
liftedBracket n b
alloc b -> n c
free b -> n d
use =
(RunInBase n IO -> IO (StM n d)) -> n d
forall (b :: * -> *) (m :: * -> *) a.
MonadBaseControl b m =>
(RunInBase m b -> b (StM m a)) -> m a
control ((RunInBase n IO -> IO (StM n d)) -> n d)
-> (RunInBase n IO -> IO (StM n d)) -> n d
forall a b. (a -> b) -> a -> b
$ \RunInBase n IO
run ->
IO (StM n b)
-> (StM n b -> IO (StM n c))
-> (StM n b -> IO (StM n d))
-> IO (StM n d)
forall a b c. IO a -> (a -> IO b) -> (a -> IO c) -> IO c
IO.bracket
( n b -> IO (StM n b)
RunInBase n IO
run n b
alloc )
( \StM n b
a -> n c -> IO (StM n c)
RunInBase n IO
run (StM n b -> n b
forall (b :: * -> *) (m :: * -> *) a.
MonadBaseControl b m =>
StM m a -> m a
restoreM StM n b
a n b -> (b -> n c) -> n c
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= b -> n c
free) )
( \StM n b
a -> n d -> IO (StM n d)
RunInBase n IO
run (StM n b -> n b
forall (b :: * -> *) (m :: * -> *) a.
MonadBaseControl b m =>
StM m a -> m a
restoreM StM n b
a n b -> (b -> n d) -> n d
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= b -> n d
use) )
{-# INLINE runManaged' #-}
makeUntagged ['runManaged']