{-# LANGUAGE BlockArguments #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}
module LazyBracket
(
lazyBracket,
lazyGeneralBracket,
lazyGeneralBracket_,
Resource (..),
ExitCase (..),
)
where
import Control.Concurrent.MVar
import Control.Monad
import Control.Monad.Catch
import Control.Monad.IO.Class
data Resource a = Resource
{
Resource a -> IO a
accessResource :: IO a,
Resource a -> (a -> IO ()) -> IO ()
controlResource :: (a -> IO ()) -> IO ()
}
lazyBracket ::
(MonadIO m, MonadMask m) =>
IO a ->
(a -> m c) ->
(Resource a -> m b) ->
m b
lazyBracket :: IO a -> (a -> m c) -> (Resource a -> m b) -> m b
lazyBracket IO a
acquire a -> m c
release Resource a -> m b
action = do
IO a -> (a -> ExitCase b -> m c) -> (Resource a -> m b) -> m b
forall (m :: * -> *) a b c.
(MonadIO m, MonadMask m) =>
IO a -> (a -> ExitCase b -> m c) -> (Resource a -> m b) -> m b
lazyGeneralBracket_
IO a
acquire
(\a
a ExitCase b
_ -> a -> m c
release a
a)
Resource a -> m b
action
data ResourceState a
= NotYetAcquired (a -> IO ())
| AlreadyAcquired a
lazyGeneralBracket ::
forall m a b c.
(MonadIO m, MonadMask m) =>
IO a ->
(a -> ExitCase b -> m c) ->
(Resource a -> m b) ->
m (b, Maybe c)
lazyGeneralBracket :: IO a
-> (a -> ExitCase b -> m c)
-> (Resource a -> m b)
-> m (b, Maybe c)
lazyGeneralBracket IO a
acquire a -> ExitCase b -> m c
release Resource a -> m b
action = do
MVar (ResourceState a)
ref <- IO (MVar (ResourceState a)) -> m (MVar (ResourceState a))
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (MVar (ResourceState a)) -> m (MVar (ResourceState a)))
-> IO (MVar (ResourceState a)) -> m (MVar (ResourceState a))
forall a b. (a -> b) -> a -> b
$ ResourceState a -> IO (MVar (ResourceState a))
forall a. a -> IO (MVar a)
newMVar @(ResourceState a) ((a -> IO ()) -> ResourceState a
forall a. (a -> IO ()) -> ResourceState a
NotYetAcquired a -> IO ()
forall a. Monoid a => a
mempty)
let accessResource :: IO a
accessResource = do
(a
resource, a -> IO ()
pendingOperations) <- do
MVar (ResourceState a)
-> (ResourceState a -> IO (ResourceState a, (a, a -> IO ())))
-> IO (a, a -> IO ())
forall a b. MVar a -> (a -> IO (a, b)) -> IO b
modifyMVarMasked MVar (ResourceState a)
ref \case
NotYetAcquired a -> IO ()
pendingOperations -> do
a
resource <- IO a
acquire
(ResourceState a, (a, a -> IO ()))
-> IO (ResourceState a, (a, a -> IO ()))
forall (f :: * -> *) a. Applicative f => a -> f a
pure (a -> ResourceState a
forall a. a -> ResourceState a
AlreadyAcquired a
resource, (a
resource, a -> IO ()
pendingOperations))
resourceState :: ResourceState a
resourceState@(AlreadyAcquired a
a) -> do
(ResourceState a, (a, a -> IO ()))
-> IO (ResourceState a, (a, a -> IO ()))
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ResourceState a
resourceState, (a
a, a -> IO ()
forall a. Monoid a => a
mempty))
a -> IO ()
pendingOperations a
resource
a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure a
resource
let controlResource :: (a -> IO ()) -> IO ()
controlResource a -> IO ()
operation = do
IO ()
runNow <- do
MVar (ResourceState a)
-> (ResourceState a -> IO (ResourceState a, IO ())) -> IO (IO ())
forall a b. MVar a -> (a -> IO (a, b)) -> IO b
modifyMVarMasked MVar (ResourceState a)
ref \case
NotYetAcquired a -> IO ()
pendingOperations -> do
(ResourceState a, IO ()) -> IO (ResourceState a, IO ())
forall (f :: * -> *) a. Applicative f => a -> f a
pure ((a -> IO ()) -> ResourceState a
forall a. (a -> IO ()) -> ResourceState a
NotYetAcquired (a -> IO ()
pendingOperations (a -> IO ()) -> (a -> IO ()) -> a -> IO ()
forall a. Semigroup a => a -> a -> a
<> a -> IO ()
operation), IO ()
forall a. Monoid a => a
mempty)
resourceState :: ResourceState a
resourceState@(AlreadyAcquired a
a) -> do
(ResourceState a, IO ()) -> IO (ResourceState a, IO ())
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ResourceState a
resourceState, a -> IO ()
operation a
a)
IO ()
runNow
let lazyResource :: Resource a
lazyResource = Resource :: forall a. IO a -> ((a -> IO ()) -> IO ()) -> Resource a
Resource {IO a
accessResource :: IO a
accessResource :: IO a
accessResource, (a -> IO ()) -> IO ()
controlResource :: (a -> IO ()) -> IO ()
controlResource :: (a -> IO ()) -> IO ()
controlResource}
let lazyRelease :: Resource a -> ExitCase b -> m (Maybe c)
lazyRelease (Resource a
_ :: Resource a) ExitCase b
exitCase = do
ExitCase b -> m (Maybe c)
action <- IO (ExitCase b -> m (Maybe c)) -> m (ExitCase b -> m (Maybe c))
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (ExitCase b -> m (Maybe c)) -> m (ExitCase b -> m (Maybe c)))
-> IO (ExitCase b -> m (Maybe c)) -> m (ExitCase b -> m (Maybe c))
forall a b. (a -> b) -> a -> b
$ do
MVar (ResourceState a)
-> (ResourceState a
-> IO (ResourceState a, ExitCase b -> m (Maybe c)))
-> IO (ExitCase b -> m (Maybe c))
forall a b. MVar a -> (a -> IO (a, b)) -> IO b
modifyMVar MVar (ResourceState a)
ref \case
NotYetAcquired a -> IO ()
_ -> do
(ResourceState a, ExitCase b -> m (Maybe c))
-> IO (ResourceState a, ExitCase b -> m (Maybe c))
forall (f :: * -> *) a. Applicative f => a -> f a
pure ((a -> IO ()) -> ResourceState a
forall a. (a -> IO ()) -> ResourceState a
NotYetAcquired a -> IO ()
forall a. Monoid a => a
mempty, \ExitCase b
_ -> Maybe c -> m (Maybe c)
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe c
forall a. Maybe a
Nothing)
AlreadyAcquired a
a -> do
(ResourceState a, ExitCase b -> m (Maybe c))
-> IO (ResourceState a, ExitCase b -> m (Maybe c))
forall (f :: * -> *) a. Applicative f => a -> f a
pure ((a -> IO ()) -> ResourceState a
forall a. (a -> IO ()) -> ResourceState a
NotYetAcquired a -> IO ()
forall a. Monoid a => a
mempty, (c -> Maybe c) -> m c -> m (Maybe c)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap c -> Maybe c
forall a. a -> Maybe a
Just (m c -> m (Maybe c))
-> (ExitCase b -> m c) -> ExitCase b -> m (Maybe c)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> a -> ExitCase b -> m c
release a
a)
ExitCase b -> m (Maybe c)
action ExitCase b
exitCase
m (Resource a)
-> (Resource a -> ExitCase b -> m (Maybe c))
-> (Resource a -> m b)
-> m (b, Maybe c)
forall (m :: * -> *) a b c.
MonadMask m =>
m a -> (a -> ExitCase b -> m c) -> (a -> m b) -> m (b, c)
generalBracket (Resource a -> m (Resource a)
forall (f :: * -> *) a. Applicative f => a -> f a
pure Resource a
lazyResource) Resource a -> ExitCase b -> m (Maybe c)
lazyRelease Resource a -> m b
action
lazyGeneralBracket_ ::
forall m a b c.
(MonadIO m, MonadMask m) =>
IO a ->
(a -> ExitCase b -> m c) ->
(Resource a -> m b) ->
m b
lazyGeneralBracket_ :: IO a -> (a -> ExitCase b -> m c) -> (Resource a -> m b) -> m b
lazyGeneralBracket_ IO a
acquire a -> ExitCase b -> m c
release Resource a -> m b
action = do
(b
b, Maybe c
_) <-
IO a
-> (a -> ExitCase b -> m c)
-> (Resource a -> m b)
-> m (b, Maybe c)
forall (m :: * -> *) a b c.
(MonadIO m, MonadMask m) =>
IO a
-> (a -> ExitCase b -> m c)
-> (Resource a -> m b)
-> m (b, Maybe c)
lazyGeneralBracket
IO a
acquire
a -> ExitCase b -> m c
release
Resource a -> m b
action
b -> m b
forall (f :: * -> *) a. Applicative f => a -> f a
pure b
b