{-# LANGUAGE BlockArguments #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}

-- | This module provides variants of the 'bracket' function that delay the

-- acquisition of the resource until it's used for the first time. If

-- the resource is never used, it will never be acquired.

--

-- A trivial example. This bracket code with a faulty acquisition doesn't throw an exception because the

-- resource is never accessed:

--

-- >>> :{

--  lazyBracket 

--    (throwIO (userError "oops")) 

--    (\_ -> pure ()) 

--    \Resource {} -> do 

--      pure () 

-- :}

-- 

-- But this code does:

--

-- >>> :{

--  lazyBracket 

--    (throwIO (userError "oops")) 

--    (\_ -> pure ()) 

--    \Resource {accessResource} -> do 

--      _ <- accessResource

--      pure () 

-- :}

-- *** Exception: user error (oops)

--

-- To be even more lazy, certain kinds of operations on the resource do not

-- trigger acquisition: instead, they are stashed and applied once the resource

-- has been acquired for other reasons.

--

-- Look at the sequence of ouput messages here:

--

-- >>> :{

--  lazyBracket 

--    (putStrLn "acquired!") 

--    (\() -> putStrLn "released!") 

--    \Resource {accessResource, controlResource} -> do 

--      controlResource \() -> putStrLn "control op 1 - delayed"

--      putStrLn "before acquiring"

--      _ <- accessResource

--      putStrLn "after acquiring"

--      controlResource \() -> putStrLn "control op 2 - immediately executed"

--      pure () 

-- :}

-- before acquiring

-- acquired!

-- control op 1 - delayed

-- after acquiring

-- control op 2 - immediately executed

-- released!

--

-- If we never access the resource, the release function and the stashed

-- operations are not executed:

--

-- >>> :{

--  lazyBracket 

--    (putStrLn "acquired!") 

--    (\() -> putStrLn "released!") 

--    \Resource {accessResource, controlResource} -> do 

--      controlResource \() -> putStrLn "control op 1 - never happens"

--      pure () 

-- :}

--

--

module LazyBracket
  ( -- * Lazy brackets that delay resource acquisition.

    lazyBracket,
    lazyGeneralBracket,
    lazyGeneralBracket_,

    -- * Resource wrapper.

    Resource (..),

    -- * Re-exports.

    ExitCase (..),
  )
where

import Control.Concurrent.MVar
import Control.Monad
import Control.Monad.Catch
import Control.Monad.IO.Class

-- | A wrapper type over resources that delays resource acquisition.

--

-- Because one must be careful with the kinds of functions that are passed to 'controlResource',

-- it might be a good idea to define convenience wrappers over 'Resource' with

-- more restricted interfaces.

data Resource a = Resource
  { -- | Action to get hold of the resource. Will trigger resource acquisition

    -- and apply all stashed control operations the first time it's run.

    Resource a -> IO a
accessResource :: IO a,
    -- | Immediately apply a \"control\" operation to the underlying resource if

    -- the resource has already been acquired, otherwise stash the operation

    -- with the intention of applying it once the resource is eventually acquired.

    -- If the resource is never acquired, stashed operations are discarded.

    --

    -- By \"control\" operations we mean operations that are not essential in and of

    -- themselves, only serve to modify the behaviour of operations that are actually

    -- essential, and can be omitted if no essential operations take place.

    --

    -- Some examples:

    --

    -- For file handle resources, @hSetBuffering@ is a valid control

    -- operation, whereas actually writing bytes to the handle is not.

    --

    -- For database connection resources, beginning a transaction is a valid control

    -- operation, whereas performing an INSERT is not.

    Resource a -> (a -> IO ()) -> IO ()
controlResource :: (a -> IO ()) -> IO ()
  }

-- | A version of 'Contro.Monad.Catch.bracket' for which the resource is not

-- acquired at the beginning, but the first time it's used in the main callback.

-- If the resource is never used, it won't be acquired.

lazyBracket ::
  (MonadIO m, MonadMask m) =>
  -- | Computation to run to acquire the resource.

  IO a ->
  -- | Computation to run to release the resource, in case it was acquired.

  (a -> m c) ->
  -- | Computation to run in-between (might trigger resource acquisition).

  (Resource a -> m b) ->
  -- | Returns the value from the in-between computation

  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

-- | A version of 'Contro.Monad.Catch.generalBracket' for which the resource is not

-- acquired at the beginning, but the first time it's used in the main callback.

-- If the resource is never used, it won't be acquired.

--

lazyGeneralBracket ::
  forall m a b c.
  (MonadIO m, MonadMask m) =>
  -- | Computation to run to acquire the resource

  IO a ->
  -- | Computation to run to release the resource, in case it was acquired

  --

  -- The release function has knowledge of how the main callback was exited: by

  -- normal completion, by a runtime exception, or otherwise aborted.

  -- This can be useful when acquiring resources from resource pools,

  -- to decide whether to return the resource to the pool or to destroy it.

  (a -> ExitCase b -> m c) ->
  -- | Computation to run in-between (might trigger resource acquisition)

  (Resource a -> m b) ->
  -- | Returns the value from the in-between computation, and also of the

  -- release computation, if it took place.

  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 -- no need to perform these inside the mask

        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}
  -- We ignore the 'Resource' argument because we extract the unwrapped

  -- version from the 'MVar'.

  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
          -- we don't mask here, already provided by generalBracket

          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)
        -- If we ran this inside the modifyMVar, an exception during release

        -- would prevent resetting the state to NotYetAcquired. Do we want that?

        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


-- | Slightly simpler version of 'lazyGeneralBracket' that doesn't return the result of the 

-- release computation.

lazyGeneralBracket_ ::
  forall m a b c.
  (MonadIO m, MonadMask m) =>
  -- | computation to run to acquire the resource

  IO a ->
  -- | computation to run to release the resource, in case it was acquired

  (a -> ExitCase b -> m c) ->
  -- | computation to run in-between (might trigger resource acquisition)

  (Resource a -> m b) ->
  -- | returns the value from the in-between computation.

  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

-- $setup

--

-- >>> :set -XBlockArguments

-- >>> :set -XNamedFieldPuns

-- >>> import LazyBracket

-- >>> import Control.Exception