{-# LANGUAGE DeriveFunctor              #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE LambdaCase                 #-}
{-# LANGUAGE NamedFieldPuns             #-}
-- | Module: Lifetimes
-- Description: Flexible resource management using first class lifetimes.
--
-- This package is centered around a couple types:
--
-- * 'Acquire' is a monadic context in which resources can be acquired.
--   These can be executed using 'acquire', or for simpler cases 'withAcquire'
--   or 'acquireValue'.
-- * 'Resource' is a handle to a resource. The value for the resource can
--   be read from this, and the 'Resource' can also be used to manipulate
--   the resource's lifetime.
-- * 'Liftime' is the type of first-class liftimes; resources are attached
--   to these and can be moved between them.
module Lifetimes
    (
    -- * Lifetimes
      Lifetime
    , newLifetime
    , withLifetime

    -- * Acquiring resources
    , Acquire
    , mkAcquire
    , withAcquire
    , acquire
    , acquireValue
    , currentLifetime

    -- * Using resources
    , Resource
    , getResource
    , mustGetResource

    -- * Releasing resources
    , releaseEarly
    , detach

    -- * Move semantics
    , moveTo

    -- * Errors
    , ResourceExpired(..)
    ) where

import           Control.Concurrent.STM
import           Control.Exception          (Exception, bracket, finally)
import           Control.Monad.STM.Class
import           Control.Monad.Trans.Reader (ReaderT, ask, runReaderT)
import           Data.Foldable              (fold)
import qualified Data.Map.Strict            as M
import           Data.Maybe                 (fromJust)
import           Zhp

-- | Error thrown when an attempt is made to use an expired
-- resource or lifetime.
data ResourceExpired = ResourceExpired
    deriving(Int -> ResourceExpired -> ShowS
[ResourceExpired] -> ShowS
ResourceExpired -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [ResourceExpired] -> ShowS
$cshowList :: [ResourceExpired] -> ShowS
show :: ResourceExpired -> String
$cshow :: ResourceExpired -> String
showsPrec :: Int -> ResourceExpired -> ShowS
$cshowsPrec :: Int -> ResourceExpired -> ShowS
Show, ReadPrec [ResourceExpired]
ReadPrec ResourceExpired
Int -> ReadS ResourceExpired
ReadS [ResourceExpired]
forall a.
(Int -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
readListPrec :: ReadPrec [ResourceExpired]
$creadListPrec :: ReadPrec [ResourceExpired]
readPrec :: ReadPrec ResourceExpired
$creadPrec :: ReadPrec ResourceExpired
readList :: ReadS [ResourceExpired]
$creadList :: ReadS [ResourceExpired]
readsPrec :: Int -> ReadS ResourceExpired
$creadsPrec :: Int -> ReadS ResourceExpired
Read, Eq ResourceExpired
ResourceExpired -> ResourceExpired -> Bool
ResourceExpired -> ResourceExpired -> Ordering
ResourceExpired -> ResourceExpired -> ResourceExpired
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: ResourceExpired -> ResourceExpired -> ResourceExpired
$cmin :: ResourceExpired -> ResourceExpired -> ResourceExpired
max :: ResourceExpired -> ResourceExpired -> ResourceExpired
$cmax :: ResourceExpired -> ResourceExpired -> ResourceExpired
>= :: ResourceExpired -> ResourceExpired -> Bool
$c>= :: ResourceExpired -> ResourceExpired -> Bool
> :: ResourceExpired -> ResourceExpired -> Bool
$c> :: ResourceExpired -> ResourceExpired -> Bool
<= :: ResourceExpired -> ResourceExpired -> Bool
$c<= :: ResourceExpired -> ResourceExpired -> Bool
< :: ResourceExpired -> ResourceExpired -> Bool
$c< :: ResourceExpired -> ResourceExpired -> Bool
compare :: ResourceExpired -> ResourceExpired -> Ordering
$ccompare :: ResourceExpired -> ResourceExpired -> Ordering
Ord, ResourceExpired -> ResourceExpired -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: ResourceExpired -> ResourceExpired -> Bool
$c/= :: ResourceExpired -> ResourceExpired -> Bool
== :: ResourceExpired -> ResourceExpired -> Bool
$c== :: ResourceExpired -> ResourceExpired -> Bool
Eq)
instance Exception ResourceExpired

newtype ReleaseKey = ReleaseKey Word64
    deriving(Int -> ReleaseKey -> ShowS
[ReleaseKey] -> ShowS
ReleaseKey -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [ReleaseKey] -> ShowS
$cshowList :: [ReleaseKey] -> ShowS
show :: ReleaseKey -> String
$cshow :: ReleaseKey -> String
showsPrec :: Int -> ReleaseKey -> ShowS
$cshowsPrec :: Int -> ReleaseKey -> ShowS
Show, ReadPrec [ReleaseKey]
ReadPrec ReleaseKey
Int -> ReadS ReleaseKey
ReadS [ReleaseKey]
forall a.
(Int -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
readListPrec :: ReadPrec [ReleaseKey]
$creadListPrec :: ReadPrec [ReleaseKey]
readPrec :: ReadPrec ReleaseKey
$creadPrec :: ReadPrec ReleaseKey
readList :: ReadS [ReleaseKey]
$creadList :: ReadS [ReleaseKey]
readsPrec :: Int -> ReadS ReleaseKey
$creadsPrec :: Int -> ReadS ReleaseKey
Read, Eq ReleaseKey
ReleaseKey -> ReleaseKey -> Bool
ReleaseKey -> ReleaseKey -> Ordering
ReleaseKey -> ReleaseKey -> ReleaseKey
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: ReleaseKey -> ReleaseKey -> ReleaseKey
$cmin :: ReleaseKey -> ReleaseKey -> ReleaseKey
max :: ReleaseKey -> ReleaseKey -> ReleaseKey
$cmax :: ReleaseKey -> ReleaseKey -> ReleaseKey
>= :: ReleaseKey -> ReleaseKey -> Bool
$c>= :: ReleaseKey -> ReleaseKey -> Bool
> :: ReleaseKey -> ReleaseKey -> Bool
$c> :: ReleaseKey -> ReleaseKey -> Bool
<= :: ReleaseKey -> ReleaseKey -> Bool
$c<= :: ReleaseKey -> ReleaseKey -> Bool
< :: ReleaseKey -> ReleaseKey -> Bool
$c< :: ReleaseKey -> ReleaseKey -> Bool
compare :: ReleaseKey -> ReleaseKey -> Ordering
$ccompare :: ReleaseKey -> ReleaseKey -> Ordering
Ord, ReleaseKey -> ReleaseKey -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: ReleaseKey -> ReleaseKey -> Bool
$c/= :: ReleaseKey -> ReleaseKey -> Bool
== :: ReleaseKey -> ReleaseKey -> Bool
$c== :: ReleaseKey -> ReleaseKey -> Bool
Eq, ReleaseKey
forall a. a -> a -> Bounded a
maxBound :: ReleaseKey
$cmaxBound :: ReleaseKey
minBound :: ReleaseKey
$cminBound :: ReleaseKey
Bounded)

instance Enum ReleaseKey where
    toEnum :: Int -> ReleaseKey
toEnum Int
n = Word64 -> ReleaseKey
ReleaseKey (forall a. Enum a => Int -> a
toEnum Int
n)
    fromEnum :: ReleaseKey -> Int
fromEnum (ReleaseKey Word64
n) = forall a. Enum a => a -> Int
fromEnum Word64
n

newtype Cleanup = Cleanup { Cleanup -> IO ()
runCleanup :: IO () }

instance Semigroup Cleanup where
    -- We want resources to be released in the opposite order from their
    -- acquisition, so x <> y releases y and then x.
    Cleanup IO ()
x <> :: Cleanup -> Cleanup -> Cleanup
<> Cleanup IO ()
y = IO () -> Cleanup
Cleanup forall a b. (a -> b) -> a -> b
$ IO ()
y forall a b. IO a -> IO b -> IO a
`finally` IO ()
x

instance Monoid Cleanup where
    mempty :: Cleanup
mempty = IO () -> Cleanup
Cleanup forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) a. Applicative f => a -> f a
pure ()

-- | A 'Lifetime' is a represents the scope in which a 'Resource' is valid;
-- resources are attached to a lifetime when they are acquired, and will
-- be released when the lifetime ends.
data Lifetime = Lifetime
    { Lifetime -> TVar (Maybe (Map ReleaseKey Cleanup))
resources      :: TVar (Maybe (M.Map ReleaseKey Cleanup))
    , Lifetime -> TVar ReleaseKey
nextReleaseKey :: TVar ReleaseKey
    }

-- | Represents a resource with type @a@, which has a lifetime and an
-- associated cleanup handler.
data Resource a = Resource
    { forall a. Resource a -> TVar ReleaseKey
releaseKey :: TVar ReleaseKey
    , forall a. Resource a -> TVar Lifetime
lifetime   :: TVar Lifetime
    , forall a. Resource a -> TVar (Maybe a)
valueCell  :: TVar (Maybe a)
    }

-- | An 'Acquire' is a monadic action that acquires some number of resources,
-- and registers cleanup handlers to be executed when their lifetime expires.
newtype Acquire a = Acquire (ReaderT Lifetime IO a)
    deriving(forall a b. a -> Acquire b -> Acquire a
forall a b. (a -> b) -> Acquire a -> Acquire b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
<$ :: forall a b. a -> Acquire b -> Acquire a
$c<$ :: forall a b. a -> Acquire b -> Acquire a
fmap :: forall a b. (a -> b) -> Acquire a -> Acquire b
$cfmap :: forall a b. (a -> b) -> Acquire a -> Acquire b
Functor, Functor Acquire
forall a. a -> Acquire a
forall a b. Acquire a -> Acquire b -> Acquire a
forall a b. Acquire a -> Acquire b -> Acquire b
forall a b. Acquire (a -> b) -> Acquire a -> Acquire b
forall a b c. (a -> b -> c) -> Acquire a -> Acquire b -> Acquire 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 a b. Acquire a -> Acquire b -> Acquire a
$c<* :: forall a b. Acquire a -> Acquire b -> Acquire a
*> :: forall a b. Acquire a -> Acquire b -> Acquire b
$c*> :: forall a b. Acquire a -> Acquire b -> Acquire b
liftA2 :: forall a b c. (a -> b -> c) -> Acquire a -> Acquire b -> Acquire c
$cliftA2 :: forall a b c. (a -> b -> c) -> Acquire a -> Acquire b -> Acquire c
<*> :: forall a b. Acquire (a -> b) -> Acquire a -> Acquire b
$c<*> :: forall a b. Acquire (a -> b) -> Acquire a -> Acquire b
pure :: forall a. a -> Acquire a
$cpure :: forall a. a -> Acquire a
Applicative, Applicative Acquire
forall a. a -> Acquire a
forall a b. Acquire a -> Acquire b -> Acquire b
forall a b. Acquire a -> (a -> Acquire b) -> Acquire 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
return :: forall a. a -> Acquire a
$creturn :: forall a. a -> Acquire a
>> :: forall a b. Acquire a -> Acquire b -> Acquire b
$c>> :: forall a b. Acquire a -> Acquire b -> Acquire b
>>= :: forall a b. Acquire a -> (a -> Acquire b) -> Acquire b
$c>>= :: forall a b. Acquire a -> (a -> Acquire b) -> Acquire b
Monad, Monad Acquire
forall a. IO a -> Acquire a
forall (m :: * -> *).
Monad m -> (forall a. IO a -> m a) -> MonadIO m
liftIO :: forall a. IO a -> Acquire a
$cliftIO :: forall a. IO a -> Acquire a
MonadIO)

newReleaseKey :: Lifetime -> STM ReleaseKey
newReleaseKey :: Lifetime -> STM ReleaseKey
newReleaseKey Lifetime{TVar ReleaseKey
nextReleaseKey :: TVar ReleaseKey
nextReleaseKey :: Lifetime -> TVar ReleaseKey
nextReleaseKey} = do
    ReleaseKey
key <- forall a. TVar a -> STM a
readTVar TVar ReleaseKey
nextReleaseKey
    forall a. TVar a -> a -> STM ()
writeTVar TVar ReleaseKey
nextReleaseKey forall a b. (a -> b) -> a -> b
$! forall a. Enum a => a -> a
succ ReleaseKey
key
    forall (f :: * -> *) a. Applicative f => a -> f a
pure ReleaseKey
key

addCleanup :: Lifetime -> Cleanup -> STM ReleaseKey
addCleanup :: Lifetime -> Cleanup -> STM ReleaseKey
addCleanup Lifetime
lt Cleanup
clean = do
    ReleaseKey
key <- Lifetime -> STM ReleaseKey
newReleaseKey Lifetime
lt
    forall a. TVar (Maybe a) -> (a -> a) -> STM ()
modifyMaybeTVar (Lifetime -> TVar (Maybe (Map ReleaseKey Cleanup))
resources Lifetime
lt) forall a b. (a -> b) -> a -> b
$ forall k a. Ord k => k -> a -> Map k a -> Map k a
M.insert ReleaseKey
key Cleanup
clean
    forall (f :: * -> *) a. Applicative f => a -> f a
pure ReleaseKey
key

acquire1 :: Lifetime -> IO a -> (a -> IO ()) -> IO (a, Resource a)
acquire1 :: forall a. Lifetime -> IO a -> (a -> IO ()) -> IO (a, Resource a)
acquire1 Lifetime
lt IO a
get a -> IO ()
clean = do
    forall a b c. IO a -> (a -> IO b) -> (a -> IO c) -> IO c
bracket
        (IO a
get forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall a. a -> IO (TVar a)
newTVarIO forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. forall a. a -> Maybe a
Just)
        (\TVar (Maybe a)
var -> forall a. STM a -> IO a
atomically (forall a. TVar a -> STM a
readTVar TVar (Maybe a)
var) forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
(a -> f b) -> t a -> f ()
traverse_ a -> IO ()
clean)
        (\TVar (Maybe a)
var -> forall a. STM a -> IO a
atomically forall a b. (a -> b) -> a -> b
$ do
            a
value <- forall a. HasCallStack => Maybe a -> a
fromJust forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. TVar a -> STM a
readTVar TVar (Maybe a)
var
            ReleaseKey
key <- Lifetime -> Cleanup -> STM ReleaseKey
addCleanup Lifetime
lt forall a b. (a -> b) -> a -> b
$ IO () -> Cleanup
Cleanup (a -> IO ()
clean a
value)
            forall a. TVar a -> a -> STM ()
writeTVar TVar (Maybe a)
var forall a. Maybe a
Nothing
            TVar Lifetime
lifetime <- forall a. a -> STM (TVar a)
newTVar Lifetime
lt
            TVar ReleaseKey
releaseKey <- forall a. a -> STM (TVar a)
newTVar ReleaseKey
key
            TVar (Maybe a)
valueCell <- forall a. a -> STM (TVar a)
newTVar forall a b. (a -> b) -> a -> b
$ forall a. a -> Maybe a
Just a
value
            forall (f :: * -> *) a. Applicative f => a -> f a
pure
                ( a
value
                , Resource
                    { TVar ReleaseKey
releaseKey :: TVar ReleaseKey
releaseKey :: TVar ReleaseKey
releaseKey
                    , TVar Lifetime
lifetime :: TVar Lifetime
lifetime :: TVar Lifetime
lifetime
                    , TVar (Maybe a)
valueCell :: TVar (Maybe a)
valueCell :: TVar (Maybe a)
valueCell
                    }
                )
        )

-- | Get the lifetime for the resources being acquired.
currentLifetime :: Acquire Lifetime
currentLifetime :: Acquire Lifetime
currentLifetime = forall a. ReaderT Lifetime IO a -> Acquire a
Acquire forall (m :: * -> *) r. Monad m => ReaderT r m r
ask

-- | @'mkAcquire' get cleanup@ acquires a resource with @get@, which will
-- be released by calling @cleanup@ when its lifetime ends.
mkAcquire :: IO a -> (a -> IO ()) -> Acquire a
mkAcquire :: forall a. IO a -> (a -> IO ()) -> Acquire a
mkAcquire IO a
get a -> IO ()
cleanup = forall a. ReaderT Lifetime IO a -> Acquire a
Acquire forall a b. (a -> b) -> a -> b
$ do
    Lifetime
lt <- forall (m :: * -> *) r. Monad m => ReaderT r m r
ask
    forall a b. (a, b) -> a
fst forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (forall a. Lifetime -> IO a -> (a -> IO ()) -> IO (a, Resource a)
acquire1 Lifetime
lt IO a
get a -> IO ()
cleanup)

-- | Acquire a new lifetime, as its own resource. This allows creating
-- sub-groups of resources, which can be later moved as a unit.
newLifetime :: Acquire Lifetime
newLifetime :: Acquire Lifetime
newLifetime = forall a. IO a -> (a -> IO ()) -> Acquire a
mkAcquire IO Lifetime
createLifetime Lifetime -> IO ()
destroyLifetime

createLifetime :: IO Lifetime
createLifetime :: IO Lifetime
createLifetime = TVar (Maybe (Map ReleaseKey Cleanup))
-> TVar ReleaseKey -> Lifetime
Lifetime
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. a -> IO (TVar a)
newTVarIO (forall a. a -> Maybe a
Just forall k a. Map k a
M.empty)
    forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall a. a -> IO (TVar a)
newTVarIO forall a. Bounded a => a
minBound

modifyMaybeTVar :: TVar (Maybe a) -> (a -> a) -> STM ()
modifyMaybeTVar :: forall a. TVar (Maybe a) -> (a -> a) -> STM ()
modifyMaybeTVar TVar (Maybe a)
tvar a -> a
f = do
    Maybe a
content <- forall a. TVar a -> STM a
readTVar TVar (Maybe a)
tvar
    case Maybe a
content of
        Just a
v  -> forall a. TVar a -> a -> STM ()
writeTVar TVar (Maybe a)
tvar forall a b. (a -> b) -> a -> b
$ forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$! a -> a
f a
v
        Maybe a
Nothing -> forall e a. Exception e => e -> STM a
throwSTM ResourceExpired
ResourceExpired

getResourceMap :: Lifetime -> STM (M.Map ReleaseKey Cleanup)
getResourceMap :: Lifetime -> STM (Map ReleaseKey Cleanup)
getResourceMap Lifetime
lt =
    forall a. TVar a -> STM a
readTVar (Lifetime -> TVar (Maybe (Map ReleaseKey Cleanup))
resources Lifetime
lt) forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
        Just Map ReleaseKey Cleanup
m  -> forall (f :: * -> *) a. Applicative f => a -> f a
pure Map ReleaseKey Cleanup
m
        Maybe (Map ReleaseKey Cleanup)
Nothing -> forall e a. Exception e => e -> STM a
throwSTM ResourceExpired
ResourceExpired

destroyLifetime :: Lifetime -> IO ()
destroyLifetime :: Lifetime -> IO ()
destroyLifetime Lifetime
lt =
    forall (m :: * -> *) a. Monad m => m (m a) -> m a
join forall a b. (a -> b) -> a -> b
$ forall a. STM a -> IO a
atomically forall a b. (a -> b) -> a -> b
$ do
        Cleanup
clean <- forall (t :: * -> *) m. (Foldable t, Monoid m) => t m -> m
fold forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Lifetime -> STM (Map ReleaseKey Cleanup)
getResourceMap Lifetime
lt
        forall a. TVar a -> a -> STM ()
writeTVar (Lifetime -> TVar (Maybe (Map ReleaseKey Cleanup))
resources Lifetime
lt) forall a. Maybe a
Nothing
        forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ Cleanup -> IO ()
runCleanup Cleanup
clean

-- | 'withAcquire' acuires a resource, uses it, and then releases it.
-- @'withAcquire' ('mkAcquire' get cleanup)@ is equivalent to
-- @'bracket' get cleanup@.
withAcquire :: Acquire a -> (a -> IO b) -> IO b
withAcquire :: forall a b. Acquire a -> (a -> IO b) -> IO b
withAcquire Acquire a
acq a -> IO b
use = forall a. (Lifetime -> IO a) -> IO a
withLifetime forall a b. (a -> b) -> a -> b
$ \Lifetime
lt -> do
    Resource a
res <- forall a. Lifetime -> Acquire a -> IO (Resource a)
acquire Lifetime
lt Acquire a
acq
    a
value <- forall a. HasCallStack => Maybe a -> a
fromJust forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. STM a -> IO a
atomically (forall (m :: * -> *) a. MonadSTM m => Resource a -> m (Maybe a)
getResource Resource a
res)
    a -> IO b
use a
value

-- | Execute an IO action within the scope of a newly allocated lifetime,
-- which ends when the IO action completes.
withLifetime :: (Lifetime -> IO a) -> IO a
withLifetime :: forall a. (Lifetime -> IO a) -> IO a
withLifetime = forall a b c. IO a -> (a -> IO b) -> (a -> IO c) -> IO c
bracket IO Lifetime
createLifetime Lifetime -> IO ()
destroyLifetime

-- | Acquire a resource, attaching it to the supplied lifetime.
acquire :: Lifetime -> Acquire a -> IO (Resource a)
acquire :: forall a. Lifetime -> Acquire a -> IO (Resource a)
acquire Lifetime
lt (Acquire ReaderT Lifetime IO a
acq) = do
    (Lifetime
lt', Resource Lifetime
res) <- forall a. Lifetime -> IO a -> (a -> IO ()) -> IO (a, Resource a)
acquire1 Lifetime
lt IO Lifetime
createLifetime Lifetime -> IO ()
destroyLifetime
    a
value' <- forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
runReaderT ReaderT Lifetime IO a
acq Lifetime
lt'
    TVar (Maybe a)
valueCell <- forall a. STM a -> IO a
atomically forall a b. (a -> b) -> a -> b
$ forall a. a -> STM (TVar a)
newTVar forall a b. (a -> b) -> a -> b
$ forall a. a -> Maybe a
Just a
value'
    forall (f :: * -> *) a. Applicative f => a -> f a
pure Resource Lifetime
res { TVar (Maybe a)
valueCell :: TVar (Maybe a)
valueCell :: TVar (Maybe a)
valueCell }

-- | Like 'acquire', but returns the value, rather than a 'Resource' wrapper.
-- conveinent when you don't need to move the resource or release it before
-- the lifetime expires.
acquireValue :: Lifetime -> Acquire a -> IO a
acquireValue :: forall a. Lifetime -> Acquire a -> IO a
acquireValue Lifetime
lt Acquire a
acq = do
    Resource a
res <- forall a. Lifetime -> Acquire a -> IO (Resource a)
acquire Lifetime
lt Acquire a
acq
    forall a. HasCallStack => Maybe a -> a
fromJust forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. STM a -> IO a
atomically (forall (m :: * -> *) a. MonadSTM m => Resource a -> m (Maybe a)
getResource Resource a
res)

-- | Move a resource to another lifetime. The resource will be detached from
-- its existing lifetime, and so may live past it, but will be released when
-- the new lifetime expires.
moveTo :: MonadSTM m => Resource a -> Lifetime -> m ()
moveTo :: forall (m :: * -> *) a.
MonadSTM m =>
Resource a -> Lifetime -> m ()
moveTo Resource a
r Lifetime
newLt = forall (m :: * -> *) a. MonadSTM m => STM a -> m a
liftSTM forall a b. (a -> b) -> a -> b
$ do
    ReleaseKey
oldKey <- forall a. TVar a -> STM a
readTVar forall a b. (a -> b) -> a -> b
$ forall a. Resource a -> TVar ReleaseKey
releaseKey Resource a
r
    Lifetime
oldLt <- forall a. TVar a -> STM a
readTVar forall a b. (a -> b) -> a -> b
$ forall a. Resource a -> TVar Lifetime
lifetime Resource a
r
    Map ReleaseKey Cleanup
oldMap <- Lifetime -> STM (Map ReleaseKey Cleanup)
getResourceMap Lifetime
oldLt
    case forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup ReleaseKey
oldKey Map ReleaseKey Cleanup
oldMap of
        Maybe Cleanup
Nothing -> forall (f :: * -> *) a. Applicative f => a -> f a
pure () -- already freed.
        Just Cleanup
clean -> do
            forall a. TVar (Maybe a) -> (a -> a) -> STM ()
modifyMaybeTVar (Lifetime -> TVar (Maybe (Map ReleaseKey Cleanup))
resources Lifetime
oldLt) forall a b. (a -> b) -> a -> b
$ forall k a. Ord k => k -> Map k a -> Map k a
M.delete ReleaseKey
oldKey
            ReleaseKey
newKey <- Lifetime -> STM ReleaseKey
newReleaseKey Lifetime
newLt
            forall a. TVar a -> a -> STM ()
writeTVar (forall a. Resource a -> TVar ReleaseKey
releaseKey Resource a
r) forall a b. (a -> b) -> a -> b
$! ReleaseKey
newKey
            forall a. TVar (Maybe a) -> (a -> a) -> STM ()
modifyMaybeTVar (Lifetime -> TVar (Maybe (Map ReleaseKey Cleanup))
resources Lifetime
newLt) forall a b. (a -> b) -> a -> b
$ forall k a. Ord k => k -> a -> Map k a -> Map k a
M.insert ReleaseKey
newKey Cleanup
clean

-- | Release a resource early, before its lifetime would otherwise end.
releaseEarly :: Resource a -> IO ()
releaseEarly :: forall a. Resource a -> IO ()
releaseEarly Resource a
r =
    forall a b c. IO a -> (a -> IO b) -> (a -> IO c) -> IO c
bracket
        (forall a. STM a -> IO a
atomically STM (Maybe a)
takeValue)
        forall {t :: * -> *} {a}. Foldable t => t a -> IO ()
releaseValue
        (\Maybe a
_ -> forall (f :: * -> *) a. Applicative f => a -> f a
pure ())
  where
    takeValue :: STM (Maybe a)
takeValue = do
        Maybe a
v <- forall (m :: * -> *) a. MonadSTM m => Resource a -> m (Maybe a)
getResource Resource a
r
        forall a. TVar a -> a -> STM ()
writeTVar (forall a. Resource a -> TVar (Maybe a)
valueCell Resource a
r) forall a. Maybe a
Nothing
        forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe a
v
    releaseValue :: t a -> IO ()
releaseValue t a
v =
        forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
t a -> (a -> f b) -> f ()
for_ t a
v forall a b. (a -> b) -> a -> b
$ \a
_ ->
            forall (m :: * -> *) a. Monad m => m (m a) -> m a
join forall a b. (a -> b) -> a -> b
$ forall a. STM a -> IO a
atomically (forall (m :: * -> *) a. MonadSTM m => Resource a -> m (IO ())
detach Resource a
r)

-- | Get the value associated with a resource, returning 'Nothing' if the
-- resource's lifetime is expired.
getResource :: MonadSTM m => Resource a -> m (Maybe a)
getResource :: forall (m :: * -> *) a. MonadSTM m => Resource a -> m (Maybe a)
getResource Resource a
r = forall (m :: * -> *) a. MonadSTM m => STM a -> m a
liftSTM forall a b. (a -> b) -> a -> b
$ forall a. TVar a -> STM a
readTVar (forall a. Resource a -> TVar (Maybe a)
valueCell Resource a
r)

-- | Like 'getResource', but throws a 'ResourceExpired' exception instead
-- of returning a 'Maybe'.
mustGetResource :: MonadSTM m => Resource a -> m a
mustGetResource :: forall (m :: * -> *) a. MonadSTM m => Resource a -> m a
mustGetResource Resource a
r = forall (m :: * -> *) a. MonadSTM m => STM a -> m a
liftSTM forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a. MonadSTM m => Resource a -> m (Maybe a)
getResource Resource a
r forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
    Maybe a
Nothing -> forall e a. Exception e => e -> STM a
throwSTM ResourceExpired
ResourceExpired
    Just a
v  -> forall (f :: * -> *) a. Applicative f => a -> f a
pure a
v

-- | Detach the resource from its lifetime, returning the cleanup handler.
-- NOTE: if the caller does not otherwise arrange to run the cleanup handler,
-- it will *not* be executed.
detach :: MonadSTM m => Resource a -> m (IO ())
detach :: forall (m :: * -> *) a. MonadSTM m => Resource a -> m (IO ())
detach Resource a
r = forall (m :: * -> *) a. MonadSTM m => STM a -> m a
liftSTM forall a b. (a -> b) -> a -> b
$ do
    ReleaseKey
key <- forall a. TVar a -> STM a
readTVar forall a b. (a -> b) -> a -> b
$ forall a. Resource a -> TVar ReleaseKey
releaseKey Resource a
r
    Lifetime
lt <- forall a. TVar a -> STM a
readTVar forall a b. (a -> b) -> a -> b
$ forall a. Resource a -> TVar Lifetime
lifetime Resource a
r
    Map ReleaseKey Cleanup
ltMap <- Lifetime -> STM (Map ReleaseKey Cleanup)
getResourceMap Lifetime
lt
    let result :: Maybe Cleanup
result = forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup ReleaseKey
key Map ReleaseKey Cleanup
ltMap
    forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
t a -> (a -> f b) -> f ()
for_ Maybe Cleanup
result forall a b. (a -> b) -> a -> b
$ \Cleanup
_ ->
        forall a. TVar (Maybe a) -> (a -> a) -> STM ()
modifyMaybeTVar (Lifetime -> TVar (Maybe (Map ReleaseKey Cleanup))
resources Lifetime
lt) forall a b. (a -> b) -> a -> b
$ forall k a. Ord k => k -> Map k a -> Map k a
M.delete ReleaseKey
key
    forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
(a -> f b) -> t a -> f ()
traverse_ Cleanup -> IO ()
runCleanup Maybe Cleanup
result