{-# 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
(Int -> ResourceExpired -> ShowS)
-> (ResourceExpired -> String)
-> ([ResourceExpired] -> ShowS)
-> Show ResourceExpired
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]
(Int -> ReadS ResourceExpired)
-> ReadS [ResourceExpired]
-> ReadPrec ResourceExpired
-> ReadPrec [ResourceExpired]
-> Read 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
Eq ResourceExpired
-> (ResourceExpired -> ResourceExpired -> Ordering)
-> (ResourceExpired -> ResourceExpired -> Bool)
-> (ResourceExpired -> ResourceExpired -> Bool)
-> (ResourceExpired -> ResourceExpired -> Bool)
-> (ResourceExpired -> ResourceExpired -> Bool)
-> (ResourceExpired -> ResourceExpired -> ResourceExpired)
-> (ResourceExpired -> ResourceExpired -> ResourceExpired)
-> Ord 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
$cp1Ord :: Eq ResourceExpired
Ord, ResourceExpired -> ResourceExpired -> Bool
(ResourceExpired -> ResourceExpired -> Bool)
-> (ResourceExpired -> ResourceExpired -> Bool)
-> Eq ResourceExpired
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
(Int -> ReleaseKey -> ShowS)
-> (ReleaseKey -> String)
-> ([ReleaseKey] -> ShowS)
-> Show ReleaseKey
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]
(Int -> ReadS ReleaseKey)
-> ReadS [ReleaseKey]
-> ReadPrec ReleaseKey
-> ReadPrec [ReleaseKey]
-> Read 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
Eq ReleaseKey
-> (ReleaseKey -> ReleaseKey -> Ordering)
-> (ReleaseKey -> ReleaseKey -> Bool)
-> (ReleaseKey -> ReleaseKey -> Bool)
-> (ReleaseKey -> ReleaseKey -> Bool)
-> (ReleaseKey -> ReleaseKey -> Bool)
-> (ReleaseKey -> ReleaseKey -> ReleaseKey)
-> (ReleaseKey -> ReleaseKey -> ReleaseKey)
-> Ord 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
$cp1Ord :: Eq ReleaseKey
Ord, ReleaseKey -> ReleaseKey -> Bool
(ReleaseKey -> ReleaseKey -> Bool)
-> (ReleaseKey -> ReleaseKey -> Bool) -> Eq ReleaseKey
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
ReleaseKey -> ReleaseKey -> Bounded 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 (Int -> Word64
forall a. Enum a => Int -> a
toEnum Int
n)
    fromEnum :: ReleaseKey -> Int
fromEnum (ReleaseKey Word64
n) = Word64 -> Int
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 (IO () -> Cleanup) -> IO () -> Cleanup
forall a b. (a -> b) -> a -> b
$ IO ()
y IO () -> IO () -> IO ()
forall a b. IO a -> IO b -> IO a
`finally` IO ()
x

instance Monoid Cleanup where
    mempty :: Cleanup
mempty = IO () -> Cleanup
Cleanup (IO () -> Cleanup) -> IO () -> Cleanup
forall a b. (a -> b) -> a -> b
$ () -> IO ()
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
    { Resource a -> TVar ReleaseKey
releaseKey :: TVar ReleaseKey
    , Resource a -> TVar Lifetime
lifetime   :: TVar Lifetime
    , 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(a -> Acquire b -> Acquire a
(a -> b) -> Acquire a -> Acquire b
(forall a b. (a -> b) -> Acquire a -> Acquire b)
-> (forall a b. a -> Acquire b -> Acquire a) -> Functor Acquire
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
<$ :: a -> Acquire b -> Acquire a
$c<$ :: forall a b. a -> Acquire b -> Acquire a
fmap :: (a -> b) -> Acquire a -> Acquire b
$cfmap :: forall a b. (a -> b) -> Acquire a -> Acquire b
Functor, Functor Acquire
a -> Acquire a
Functor Acquire
-> (forall a. a -> Acquire a)
-> (forall a b. Acquire (a -> b) -> Acquire a -> Acquire b)
-> (forall a b c.
    (a -> b -> c) -> Acquire a -> Acquire b -> Acquire c)
-> (forall a b. Acquire a -> Acquire b -> Acquire b)
-> (forall a b. Acquire a -> Acquire b -> Acquire a)
-> Applicative Acquire
Acquire a -> Acquire b -> Acquire b
Acquire a -> Acquire b -> Acquire a
Acquire (a -> b) -> Acquire a -> Acquire b
(a -> b -> c) -> Acquire a -> Acquire b -> Acquire c
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
<* :: Acquire a -> Acquire b -> Acquire a
$c<* :: forall a b. Acquire a -> Acquire b -> Acquire a
*> :: Acquire a -> Acquire b -> Acquire b
$c*> :: forall a b. Acquire a -> Acquire b -> Acquire b
liftA2 :: (a -> b -> c) -> Acquire a -> Acquire b -> Acquire c
$cliftA2 :: forall a b c. (a -> b -> c) -> Acquire a -> Acquire b -> Acquire c
<*> :: Acquire (a -> b) -> Acquire a -> Acquire b
$c<*> :: forall a b. Acquire (a -> b) -> Acquire a -> Acquire b
pure :: a -> Acquire a
$cpure :: forall a. a -> Acquire a
$cp1Applicative :: Functor Acquire
Applicative, Applicative Acquire
a -> Acquire a
Applicative Acquire
-> (forall a b. Acquire a -> (a -> Acquire b) -> Acquire b)
-> (forall a b. Acquire a -> Acquire b -> Acquire b)
-> (forall a. a -> Acquire a)
-> Monad Acquire
Acquire a -> (a -> Acquire b) -> Acquire b
Acquire a -> Acquire b -> Acquire b
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 :: a -> Acquire a
$creturn :: forall a. a -> Acquire a
>> :: Acquire a -> Acquire b -> Acquire b
$c>> :: forall a b. Acquire a -> Acquire b -> Acquire b
>>= :: Acquire a -> (a -> Acquire b) -> Acquire b
$c>>= :: forall a b. Acquire a -> (a -> Acquire b) -> Acquire b
$cp1Monad :: Applicative Acquire
Monad, Monad Acquire
Monad Acquire -> (forall a. IO a -> Acquire a) -> MonadIO Acquire
IO a -> Acquire a
forall a. IO a -> Acquire a
forall (m :: * -> *).
Monad m -> (forall a. IO a -> m a) -> MonadIO m
liftIO :: IO a -> Acquire a
$cliftIO :: forall a. IO a -> Acquire a
$cp1MonadIO :: Monad Acquire
MonadIO)

newReleaseKey :: Lifetime -> STM ReleaseKey
newReleaseKey :: Lifetime -> STM ReleaseKey
newReleaseKey Lifetime{TVar ReleaseKey
nextReleaseKey :: TVar ReleaseKey
nextReleaseKey :: Lifetime -> TVar ReleaseKey
nextReleaseKey} = do
    ReleaseKey
key <- TVar ReleaseKey -> STM ReleaseKey
forall a. TVar a -> STM a
readTVar TVar ReleaseKey
nextReleaseKey
    TVar ReleaseKey -> ReleaseKey -> STM ()
forall a. TVar a -> a -> STM ()
writeTVar TVar ReleaseKey
nextReleaseKey (ReleaseKey -> STM ()) -> ReleaseKey -> STM ()
forall a b. (a -> b) -> a -> b
$! ReleaseKey -> ReleaseKey
forall a. Enum a => a -> a
succ ReleaseKey
key
    ReleaseKey -> STM ReleaseKey
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
    TVar (Maybe (Map ReleaseKey Cleanup))
-> (Map ReleaseKey Cleanup -> Map ReleaseKey Cleanup) -> STM ()
forall a. TVar (Maybe a) -> (a -> a) -> STM ()
modifyMaybeTVar (Lifetime -> TVar (Maybe (Map ReleaseKey Cleanup))
resources Lifetime
lt) ((Map ReleaseKey Cleanup -> Map ReleaseKey Cleanup) -> STM ())
-> (Map ReleaseKey Cleanup -> Map ReleaseKey Cleanup) -> STM ()
forall a b. (a -> b) -> a -> b
$ ReleaseKey
-> Cleanup -> Map ReleaseKey Cleanup -> Map ReleaseKey Cleanup
forall k a. Ord k => k -> a -> Map k a -> Map k a
M.insert ReleaseKey
key Cleanup
clean
    ReleaseKey -> STM ReleaseKey
forall (f :: * -> *) a. Applicative f => a -> f a
pure ReleaseKey
key

acquire1 :: Lifetime -> IO a -> (a -> IO ()) -> IO (a, Resource a)
acquire1 :: Lifetime -> IO a -> (a -> IO ()) -> IO (a, Resource a)
acquire1 Lifetime
lt IO a
get a -> IO ()
clean = do
    IO (TVar (Maybe a))
-> (TVar (Maybe a) -> IO ())
-> (TVar (Maybe a) -> IO (a, Resource a))
-> IO (a, Resource a)
forall a b c. IO a -> (a -> IO b) -> (a -> IO c) -> IO c
bracket
        (IO a
get IO a -> (a -> IO (TVar (Maybe a))) -> IO (TVar (Maybe a))
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Maybe a -> IO (TVar (Maybe a))
forall a. a -> IO (TVar a)
newTVarIO (Maybe a -> IO (TVar (Maybe a)))
-> (a -> Maybe a) -> a -> IO (TVar (Maybe a))
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. a -> Maybe a
forall a. a -> Maybe a
Just)
        (\TVar (Maybe a)
var -> STM (Maybe a) -> IO (Maybe a)
forall a. STM a -> IO a
atomically (TVar (Maybe a) -> STM (Maybe a)
forall a. TVar a -> STM a
readTVar TVar (Maybe a)
var) IO (Maybe a) -> (Maybe a -> IO ()) -> IO ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (a -> IO ()) -> Maybe a -> IO ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
(a -> f b) -> t a -> f ()
traverse_ a -> IO ()
clean)
        (\TVar (Maybe a)
var -> STM (a, Resource a) -> IO (a, Resource a)
forall a. STM a -> IO a
atomically (STM (a, Resource a) -> IO (a, Resource a))
-> STM (a, Resource a) -> IO (a, Resource a)
forall a b. (a -> b) -> a -> b
$ do
            a
value <- Maybe a -> a
forall a. HasCallStack => Maybe a -> a
fromJust (Maybe a -> a) -> STM (Maybe a) -> STM a
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> TVar (Maybe a) -> STM (Maybe a)
forall a. TVar a -> STM a
readTVar TVar (Maybe a)
var
            ReleaseKey
key <- Lifetime -> Cleanup -> STM ReleaseKey
addCleanup Lifetime
lt (Cleanup -> STM ReleaseKey) -> Cleanup -> STM ReleaseKey
forall a b. (a -> b) -> a -> b
$ IO () -> Cleanup
Cleanup (a -> IO ()
clean a
value)
            TVar (Maybe a) -> Maybe a -> STM ()
forall a. TVar a -> a -> STM ()
writeTVar TVar (Maybe a)
var Maybe a
forall a. Maybe a
Nothing
            TVar Lifetime
lifetime <- Lifetime -> STM (TVar Lifetime)
forall a. a -> STM (TVar a)
newTVar Lifetime
lt
            TVar ReleaseKey
releaseKey <- ReleaseKey -> STM (TVar ReleaseKey)
forall a. a -> STM (TVar a)
newTVar ReleaseKey
key
            TVar (Maybe a)
valueCell <- Maybe a -> STM (TVar (Maybe a))
forall a. a -> STM (TVar a)
newTVar (Maybe a -> STM (TVar (Maybe a)))
-> Maybe a -> STM (TVar (Maybe a))
forall a b. (a -> b) -> a -> b
$ a -> Maybe a
forall a. a -> Maybe a
Just a
value
            (a, Resource a) -> STM (a, Resource a)
forall (f :: * -> *) a. Applicative f => a -> f a
pure
                ( a
value
                , Resource :: forall a.
TVar ReleaseKey -> TVar Lifetime -> TVar (Maybe a) -> Resource a
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 = ReaderT Lifetime IO Lifetime -> Acquire Lifetime
forall a. ReaderT Lifetime IO a -> Acquire a
Acquire ReaderT Lifetime IO Lifetime
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 :: IO a -> (a -> IO ()) -> Acquire a
mkAcquire IO a
get a -> IO ()
cleanup = ReaderT Lifetime IO a -> Acquire a
forall a. ReaderT Lifetime IO a -> Acquire a
Acquire (ReaderT Lifetime IO a -> Acquire a)
-> ReaderT Lifetime IO a -> Acquire a
forall a b. (a -> b) -> a -> b
$ do
    Lifetime
lt <- ReaderT Lifetime IO Lifetime
forall (m :: * -> *) r. Monad m => ReaderT r m r
ask
    (a, Resource a) -> a
forall a b. (a, b) -> a
fst ((a, Resource a) -> a)
-> ReaderT Lifetime IO (a, Resource a) -> ReaderT Lifetime IO a
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO (a, Resource a) -> ReaderT Lifetime IO (a, Resource a)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (Lifetime -> IO a -> (a -> IO ()) -> IO (a, Resource a)
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 = IO Lifetime -> (Lifetime -> IO ()) -> Acquire Lifetime
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
    (TVar (Maybe (Map ReleaseKey Cleanup))
 -> TVar ReleaseKey -> Lifetime)
-> IO (TVar (Maybe (Map ReleaseKey Cleanup)))
-> IO (TVar ReleaseKey -> Lifetime)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe (Map ReleaseKey Cleanup)
-> IO (TVar (Maybe (Map ReleaseKey Cleanup)))
forall a. a -> IO (TVar a)
newTVarIO (Map ReleaseKey Cleanup -> Maybe (Map ReleaseKey Cleanup)
forall a. a -> Maybe a
Just Map ReleaseKey Cleanup
forall k a. Map k a
M.empty)
    IO (TVar ReleaseKey -> Lifetime)
-> IO (TVar ReleaseKey) -> IO Lifetime
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> ReleaseKey -> IO (TVar ReleaseKey)
forall a. a -> IO (TVar a)
newTVarIO ReleaseKey
forall a. Bounded a => a
minBound

modifyMaybeTVar :: TVar (Maybe a) -> (a -> a) -> STM ()
modifyMaybeTVar :: TVar (Maybe a) -> (a -> a) -> STM ()
modifyMaybeTVar TVar (Maybe a)
tvar a -> a
f = do
    Maybe a
content <- TVar (Maybe a) -> STM (Maybe a)
forall a. TVar a -> STM a
readTVar TVar (Maybe a)
tvar
    case Maybe a
content of
        Just a
v  -> TVar (Maybe a) -> Maybe a -> STM ()
forall a. TVar a -> a -> STM ()
writeTVar TVar (Maybe a)
tvar (Maybe a -> STM ()) -> Maybe a -> STM ()
forall a b. (a -> b) -> a -> b
$ a -> Maybe a
forall a. a -> Maybe a
Just (a -> Maybe a) -> a -> Maybe a
forall a b. (a -> b) -> a -> b
$! a -> a
f a
v
        Maybe a
Nothing -> ResourceExpired -> STM ()
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 =
    TVar (Maybe (Map ReleaseKey Cleanup))
-> STM (Maybe (Map ReleaseKey Cleanup))
forall a. TVar a -> STM a
readTVar (Lifetime -> TVar (Maybe (Map ReleaseKey Cleanup))
resources Lifetime
lt) STM (Maybe (Map ReleaseKey Cleanup))
-> (Maybe (Map ReleaseKey Cleanup) -> STM (Map ReleaseKey Cleanup))
-> STM (Map ReleaseKey Cleanup)
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
        Just Map ReleaseKey Cleanup
m  -> Map ReleaseKey Cleanup -> STM (Map ReleaseKey Cleanup)
forall (f :: * -> *) a. Applicative f => a -> f a
pure Map ReleaseKey Cleanup
m
        Maybe (Map ReleaseKey Cleanup)
Nothing -> ResourceExpired -> STM (Map ReleaseKey Cleanup)
forall e a. Exception e => e -> STM a
throwSTM ResourceExpired
ResourceExpired

destroyLifetime :: Lifetime -> IO ()
destroyLifetime :: Lifetime -> IO ()
destroyLifetime Lifetime
lt =
    IO (IO ()) -> IO ()
forall (m :: * -> *) a. Monad m => m (m a) -> m a
join (IO (IO ()) -> IO ()) -> IO (IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ STM (IO ()) -> IO (IO ())
forall a. STM a -> IO a
atomically (STM (IO ()) -> IO (IO ())) -> STM (IO ()) -> IO (IO ())
forall a b. (a -> b) -> a -> b
$ do
        Cleanup
clean <- Map ReleaseKey Cleanup -> Cleanup
forall (t :: * -> *) m. (Foldable t, Monoid m) => t m -> m
fold (Map ReleaseKey Cleanup -> Cleanup)
-> STM (Map ReleaseKey Cleanup) -> STM Cleanup
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Lifetime -> STM (Map ReleaseKey Cleanup)
getResourceMap Lifetime
lt
        TVar (Maybe (Map ReleaseKey Cleanup))
-> Maybe (Map ReleaseKey Cleanup) -> STM ()
forall a. TVar a -> a -> STM ()
writeTVar (Lifetime -> TVar (Maybe (Map ReleaseKey Cleanup))
resources Lifetime
lt) Maybe (Map ReleaseKey Cleanup)
forall a. Maybe a
Nothing
        IO () -> STM (IO ())
forall (f :: * -> *) a. Applicative f => a -> f a
pure (IO () -> STM (IO ())) -> IO () -> STM (IO ())
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 :: Acquire a -> (a -> IO b) -> IO b
withAcquire Acquire a
acq a -> IO b
use = (Lifetime -> IO b) -> IO b
forall a. (Lifetime -> IO a) -> IO a
withLifetime ((Lifetime -> IO b) -> IO b) -> (Lifetime -> IO b) -> IO b
forall a b. (a -> b) -> a -> b
$ \Lifetime
lt -> do
    Resource a
res <- Lifetime -> Acquire a -> IO (Resource a)
forall a. Lifetime -> Acquire a -> IO (Resource a)
acquire Lifetime
lt Acquire a
acq
    a
value <- Maybe a -> a
forall a. HasCallStack => Maybe a -> a
fromJust (Maybe a -> a) -> IO (Maybe a) -> IO a
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> STM (Maybe a) -> IO (Maybe a)
forall a. STM a -> IO a
atomically (Resource a -> STM (Maybe a)
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 :: (Lifetime -> IO a) -> IO a
withLifetime = IO Lifetime -> (Lifetime -> IO ()) -> (Lifetime -> IO a) -> IO a
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 :: Lifetime -> Acquire a -> IO (Resource a)
acquire Lifetime
lt (Acquire ReaderT Lifetime IO a
acq) = do
    (Lifetime
lt', Resource Lifetime
res) <- Lifetime
-> IO Lifetime
-> (Lifetime -> IO ())
-> IO (Lifetime, Resource Lifetime)
forall a. Lifetime -> IO a -> (a -> IO ()) -> IO (a, Resource a)
acquire1 Lifetime
lt IO Lifetime
createLifetime Lifetime -> IO ()
destroyLifetime
    a
value' <- ReaderT Lifetime IO a -> Lifetime -> IO a
forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
runReaderT ReaderT Lifetime IO a
acq Lifetime
lt'
    TVar (Maybe a)
valueCell <- STM (TVar (Maybe a)) -> IO (TVar (Maybe a))
forall a. STM a -> IO a
atomically (STM (TVar (Maybe a)) -> IO (TVar (Maybe a)))
-> STM (TVar (Maybe a)) -> IO (TVar (Maybe a))
forall a b. (a -> b) -> a -> b
$ Maybe a -> STM (TVar (Maybe a))
forall a. a -> STM (TVar a)
newTVar (Maybe a -> STM (TVar (Maybe a)))
-> Maybe a -> STM (TVar (Maybe a))
forall a b. (a -> b) -> a -> b
$ a -> Maybe a
forall a. a -> Maybe a
Just a
value'
    Resource a -> IO (Resource a)
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 :: Lifetime -> Acquire a -> IO a
acquireValue Lifetime
lt Acquire a
acq = do
    Resource a
res <- Lifetime -> Acquire a -> IO (Resource a)
forall a. Lifetime -> Acquire a -> IO (Resource a)
acquire Lifetime
lt Acquire a
acq
    Maybe a -> a
forall a. HasCallStack => Maybe a -> a
fromJust (Maybe a -> a) -> IO (Maybe a) -> IO a
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> STM (Maybe a) -> IO (Maybe a)
forall a. STM a -> IO a
atomically (Resource a -> STM (Maybe a)
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 :: Resource a -> Lifetime -> m ()
moveTo Resource a
r Lifetime
newLt = STM () -> m ()
forall (m :: * -> *) a. MonadSTM m => STM a -> m a
liftSTM (STM () -> m ()) -> STM () -> m ()
forall a b. (a -> b) -> a -> b
$ do
    ReleaseKey
oldKey <- TVar ReleaseKey -> STM ReleaseKey
forall a. TVar a -> STM a
readTVar (TVar ReleaseKey -> STM ReleaseKey)
-> TVar ReleaseKey -> STM ReleaseKey
forall a b. (a -> b) -> a -> b
$ Resource a -> TVar ReleaseKey
forall a. Resource a -> TVar ReleaseKey
releaseKey Resource a
r
    Lifetime
oldLt <- TVar Lifetime -> STM Lifetime
forall a. TVar a -> STM a
readTVar (TVar Lifetime -> STM Lifetime) -> TVar Lifetime -> STM Lifetime
forall a b. (a -> b) -> a -> b
$ Resource a -> TVar Lifetime
forall a. Resource a -> TVar Lifetime
lifetime Resource a
r
    Map ReleaseKey Cleanup
oldMap <- Lifetime -> STM (Map ReleaseKey Cleanup)
getResourceMap Lifetime
oldLt
    case ReleaseKey -> Map ReleaseKey Cleanup -> Maybe Cleanup
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup ReleaseKey
oldKey Map ReleaseKey Cleanup
oldMap of
        Maybe Cleanup
Nothing -> () -> STM ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure () -- already freed.
        Just Cleanup
clean -> do
            TVar (Maybe (Map ReleaseKey Cleanup))
-> (Map ReleaseKey Cleanup -> Map ReleaseKey Cleanup) -> STM ()
forall a. TVar (Maybe a) -> (a -> a) -> STM ()
modifyMaybeTVar (Lifetime -> TVar (Maybe (Map ReleaseKey Cleanup))
resources Lifetime
oldLt) ((Map ReleaseKey Cleanup -> Map ReleaseKey Cleanup) -> STM ())
-> (Map ReleaseKey Cleanup -> Map ReleaseKey Cleanup) -> STM ()
forall a b. (a -> b) -> a -> b
$ ReleaseKey -> Map ReleaseKey Cleanup -> Map ReleaseKey Cleanup
forall k a. Ord k => k -> Map k a -> Map k a
M.delete ReleaseKey
oldKey
            ReleaseKey
newKey <- Lifetime -> STM ReleaseKey
newReleaseKey Lifetime
newLt
            TVar ReleaseKey -> ReleaseKey -> STM ()
forall a. TVar a -> a -> STM ()
writeTVar (Resource a -> TVar ReleaseKey
forall a. Resource a -> TVar ReleaseKey
releaseKey Resource a
r) (ReleaseKey -> STM ()) -> ReleaseKey -> STM ()
forall a b. (a -> b) -> a -> b
$! ReleaseKey
newKey
            TVar (Maybe (Map ReleaseKey Cleanup))
-> (Map ReleaseKey Cleanup -> Map ReleaseKey Cleanup) -> STM ()
forall a. TVar (Maybe a) -> (a -> a) -> STM ()
modifyMaybeTVar (Lifetime -> TVar (Maybe (Map ReleaseKey Cleanup))
resources Lifetime
newLt) ((Map ReleaseKey Cleanup -> Map ReleaseKey Cleanup) -> STM ())
-> (Map ReleaseKey Cleanup -> Map ReleaseKey Cleanup) -> STM ()
forall a b. (a -> b) -> a -> b
$ ReleaseKey
-> Cleanup -> Map ReleaseKey Cleanup -> Map ReleaseKey Cleanup
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 :: Resource a -> IO ()
releaseEarly Resource a
r =
    IO (Maybe a) -> (Maybe a -> IO ()) -> (Maybe a -> IO ()) -> IO ()
forall a b c. IO a -> (a -> IO b) -> (a -> IO c) -> IO c
bracket
        (STM (Maybe a) -> IO (Maybe a)
forall a. STM a -> IO a
atomically STM (Maybe a)
takeValue)
        Maybe a -> IO ()
forall (t :: * -> *) a. Foldable t => t a -> IO ()
releaseValue
        (\Maybe a
_ -> () -> IO ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ())
  where
    takeValue :: STM (Maybe a)
takeValue = do
        Maybe a
v <- Resource a -> STM (Maybe a)
forall (m :: * -> *) a. MonadSTM m => Resource a -> m (Maybe a)
getResource Resource a
r
        TVar (Maybe a) -> Maybe a -> STM ()
forall a. TVar a -> a -> STM ()
writeTVar (Resource a -> TVar (Maybe a)
forall a. Resource a -> TVar (Maybe a)
valueCell Resource a
r) Maybe a
forall a. Maybe a
Nothing
        Maybe a -> STM (Maybe a)
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe a
v
    releaseValue :: t a -> IO ()
releaseValue t a
v =
        t a -> (a -> IO ()) -> IO ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
t a -> (a -> f b) -> f ()
for_ t a
v ((a -> IO ()) -> IO ()) -> (a -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \a
_ ->
            IO (IO ()) -> IO ()
forall (m :: * -> *) a. Monad m => m (m a) -> m a
join (IO (IO ()) -> IO ()) -> IO (IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ STM (IO ()) -> IO (IO ())
forall a. STM a -> IO a
atomically (Resource a -> STM (IO ())
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 :: Resource a -> m (Maybe a)
getResource Resource a
r = STM (Maybe a) -> m (Maybe a)
forall (m :: * -> *) a. MonadSTM m => STM a -> m a
liftSTM (STM (Maybe a) -> m (Maybe a)) -> STM (Maybe a) -> m (Maybe a)
forall a b. (a -> b) -> a -> b
$ TVar (Maybe a) -> STM (Maybe a)
forall a. TVar a -> STM a
readTVar (Resource a -> TVar (Maybe a)
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 :: Resource a -> m a
mustGetResource Resource a
r = STM a -> m a
forall (m :: * -> *) a. MonadSTM m => STM a -> m a
liftSTM (STM a -> m a) -> STM a -> m a
forall a b. (a -> b) -> a -> b
$ Resource a -> STM (Maybe a)
forall (m :: * -> *) a. MonadSTM m => Resource a -> m (Maybe a)
getResource Resource a
r STM (Maybe a) -> (Maybe a -> STM a) -> STM a
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
    Maybe a
Nothing -> ResourceExpired -> STM a
forall e a. Exception e => e -> STM a
throwSTM ResourceExpired
ResourceExpired
    Just a
v  -> a -> STM a
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 :: Resource a -> m (IO ())
detach Resource a
r = STM (IO ()) -> m (IO ())
forall (m :: * -> *) a. MonadSTM m => STM a -> m a
liftSTM (STM (IO ()) -> m (IO ())) -> STM (IO ()) -> m (IO ())
forall a b. (a -> b) -> a -> b
$ do
    ReleaseKey
key <- TVar ReleaseKey -> STM ReleaseKey
forall a. TVar a -> STM a
readTVar (TVar ReleaseKey -> STM ReleaseKey)
-> TVar ReleaseKey -> STM ReleaseKey
forall a b. (a -> b) -> a -> b
$ Resource a -> TVar ReleaseKey
forall a. Resource a -> TVar ReleaseKey
releaseKey Resource a
r
    Lifetime
lt <- TVar Lifetime -> STM Lifetime
forall a. TVar a -> STM a
readTVar (TVar Lifetime -> STM Lifetime) -> TVar Lifetime -> STM Lifetime
forall a b. (a -> b) -> a -> b
$ Resource a -> TVar Lifetime
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 = ReleaseKey -> Map ReleaseKey Cleanup -> Maybe Cleanup
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup ReleaseKey
key Map ReleaseKey Cleanup
ltMap
    Maybe Cleanup -> (Cleanup -> STM ()) -> STM ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
t a -> (a -> f b) -> f ()
for_ Maybe Cleanup
result ((Cleanup -> STM ()) -> STM ()) -> (Cleanup -> STM ()) -> STM ()
forall a b. (a -> b) -> a -> b
$ \Cleanup
_ ->
        TVar (Maybe (Map ReleaseKey Cleanup))
-> (Map ReleaseKey Cleanup -> Map ReleaseKey Cleanup) -> STM ()
forall a. TVar (Maybe a) -> (a -> a) -> STM ()
modifyMaybeTVar (Lifetime -> TVar (Maybe (Map ReleaseKey Cleanup))
resources Lifetime
lt) ((Map ReleaseKey Cleanup -> Map ReleaseKey Cleanup) -> STM ())
-> (Map ReleaseKey Cleanup -> Map ReleaseKey Cleanup) -> STM ()
forall a b. (a -> b) -> a -> b
$ ReleaseKey -> Map ReleaseKey Cleanup -> Map ReleaseKey Cleanup
forall k a. Ord k => k -> Map k a -> Map k a
M.delete ReleaseKey
key
    IO () -> STM (IO ())
forall (f :: * -> *) a. Applicative f => a -> f a
pure (IO () -> STM (IO ())) -> IO () -> STM (IO ())
forall a b. (a -> b) -> a -> b
$ (Cleanup -> IO ()) -> Maybe Cleanup -> IO ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
(a -> f b) -> t a -> f ()
traverse_ Cleanup -> IO ()
runCleanup Maybe Cleanup
result