{-|
Module      : Z.IO.Resource
Description : The Resource monad
Copyright   : (c) Dong Han, 2017
License     : BSD
Maintainer  : winterland1989@gmail.com
Stability   : experimental
Portability : non-portable

This module also implements Gabriel Gonzalez'd idea on 'Resource' applicative:
<http://www.haskellforall.com/2013/06/the-resource-applicative.html>. The 'Applicative' and 'Monad' instance is
especially useful when you want safely combine multiple resources.

A high performance resource pool based on STM is also provided.

-}

module Z.IO.Resource (
    -- * Resource management
    Resource(..)
  , initResource
  , initResource_
  , withResource
  , withResource'
    -- * Resource pool
  , Pool
  , PoolState(..)
  , initPool
  , withResourceInPool
  , poolStat, poolInUse
  -- * Re-export
  , liftIO
) where

import           Control.Concurrent.STM
import           Control.Monad
import qualified Control.Monad.Catch as MonadCatch
import           Control.Monad.IO.Class
import           Z.Data.PrimRef.PrimIORef
import           Z.IO.LowResTimer
import           Z.IO.Exception

--------------------------------------------------------------------------------

-- | A 'Resource' is an 'IO' action which acquires some resource of type a and
-- also returns a finalizer of type IO () that releases the resource.
--
-- The only safe way to use a 'Resource' is 'withResource' and 'withResource'',
-- You should not use the 'acquire' field directly, unless you want to implement your own
-- resource management. In the later case, you should 'mask_' 'acquire' since
-- some resource initializations may assume async exceptions are masked.
--
-- 'MonadIO' instance is provided so that you can lift 'IO' computation inside
-- 'Resource', this is convenient for propagating 'Resource' around since many
-- 'IO' computations carry finalizers.
--
-- A convention in Z-IO is that functions returning a 'Resource' should be
-- named in @initXXX@ format, users are strongly recommended to follow this convention.
--
-- There're two additional guarantees we made in Z-IO:
--
--   * All resources in Z-IO can track its own liveness, throw 'ResourceVanished'
--     exception using 'throwECLOSED' or 'throwECLOSEDSTM' when used after resource
--     is closed.
--
--   * All resources' clean up action in Z-IO is idempotent.
--
-- Library authors providing 'initXXX' are also encouraged to provide these guarantees.
--
newtype Resource a = Resource { Resource a -> IO (a, IO ())
acquire :: IO (a, IO ()) }

-- | Create 'Resource' from create and release action.
--
-- Note, 'resource' doesn't open resource itself, resource is created when you use
-- 'with' \/ 'with''.
--
initResource :: IO a -> (a -> IO ()) -> Resource a
{-# INLINE initResource #-}
initResource :: IO a -> (a -> IO ()) -> Resource a
initResource IO a
create a -> IO ()
release = IO (a, IO ()) -> Resource a
forall a. IO (a, IO ()) -> Resource a
Resource (IO (a, IO ()) -> Resource a) -> IO (a, IO ()) -> Resource a
forall a b. (a -> b) -> a -> b
$ do
    a
r <- IO a
create
    (a, IO ()) -> IO (a, IO ())
forall (m :: * -> *) a. Monad m => a -> m a
return ((a, IO ()) -> IO (a, IO ())) -> (a, IO ()) -> IO (a, IO ())
forall a b. (a -> b) -> a -> b
$ (a
r, a -> IO ()
release a
r)

-- | Create 'Resource' from create and release action.
--
-- This function is useful when you want to add some initialization and clean up action
-- inside 'Resource' monad.
--
initResource_ :: IO () -> IO () -> Resource ()
{-# INLINE initResource_ #-}
initResource_ :: IO () -> IO () -> Resource ()
initResource_ IO ()
create IO ()
release = IO ((), IO ()) -> Resource ()
forall a. IO (a, IO ()) -> Resource a
Resource (IO ((), IO ()) -> Resource ()) -> IO ((), IO ()) -> Resource ()
forall a b. (a -> b) -> a -> b
$ do
    ()
r <- IO ()
create
    ((), IO ()) -> IO ((), IO ())
forall (m :: * -> *) a. Monad m => a -> m a
return (((), IO ()) -> IO ((), IO ())) -> ((), IO ()) -> IO ((), IO ())
forall a b. (a -> b) -> a -> b
$ (()
r, IO ()
release)

instance Functor Resource where
    {-# INLINE fmap #-}
    fmap :: (a -> b) -> Resource a -> Resource b
fmap a -> b
f Resource a
resource = IO (b, IO ()) -> Resource b
forall a. IO (a, IO ()) -> Resource a
Resource (IO (b, IO ()) -> Resource b) -> IO (b, IO ()) -> Resource b
forall a b. (a -> b) -> a -> b
$ do
        (a
a, IO ()
release) <- Resource a -> IO (a, IO ())
forall a. Resource a -> IO (a, IO ())
acquire Resource a
resource
        (b, IO ()) -> IO (b, IO ())
forall (m :: * -> *) a. Monad m => a -> m a
return (a -> b
f a
a, IO ()
release)

instance Applicative Resource where
    {-# INLINE pure #-}
    pure :: a -> Resource a
pure a
a = IO (a, IO ()) -> Resource a
forall a. IO (a, IO ()) -> Resource a
Resource ((a, IO ()) -> IO (a, IO ())
forall (f :: * -> *) a. Applicative f => a -> f a
pure (a
a, () -> IO ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()))
    {-# INLINE (<*>) #-}
    Resource (a -> b)
resource1 <*> :: Resource (a -> b) -> Resource a -> Resource b
<*> Resource a
resource2 = IO (b, IO ()) -> Resource b
forall a. IO (a, IO ()) -> Resource a
Resource (IO (b, IO ()) -> Resource b) -> IO (b, IO ()) -> Resource b
forall a b. (a -> b) -> a -> b
$ do
        (a -> b
f, IO ()
release1) <- Resource (a -> b) -> IO (a -> b, IO ())
forall a. Resource a -> IO (a, IO ())
acquire Resource (a -> b)
resource1
        (a
x, IO ()
release2) <- Resource a -> IO (a, IO ())
forall a. Resource a -> IO (a, IO ())
acquire Resource a
resource2 IO (a, IO ()) -> IO () -> IO (a, IO ())
forall a b. IO a -> IO b -> IO a
`onException` IO ()
release1
        (b, IO ()) -> IO (b, IO ())
forall (m :: * -> *) a. Monad m => a -> m a
return (a -> b
f a
x, IO ()
release2 IO () -> IO () -> IO ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> IO ()
release1)

instance Monad Resource where
    {-# INLINE return #-}
    return :: a -> Resource a
return = a -> Resource a
forall (f :: * -> *) a. Applicative f => a -> f a
pure
    {-# INLINE (>>=) #-}
    Resource a
m >>= :: Resource a -> (a -> Resource b) -> Resource b
>>= a -> Resource b
f = IO (b, IO ()) -> Resource b
forall a. IO (a, IO ()) -> Resource a
Resource (IO (b, IO ()) -> Resource b) -> IO (b, IO ()) -> Resource b
forall a b. (a -> b) -> a -> b
$ do
        (a
m', IO ()
release1) <- Resource a -> IO (a, IO ())
forall a. Resource a -> IO (a, IO ())
acquire Resource a
m
        (b
x , IO ()
release2) <- Resource b -> IO (b, IO ())
forall a. Resource a -> IO (a, IO ())
acquire (a -> Resource b
f a
m') IO (b, IO ()) -> IO () -> IO (b, IO ())
forall a b. IO a -> IO b -> IO a
`onException` IO ()
release1
        (b, IO ()) -> IO (b, IO ())
forall (m :: * -> *) a. Monad m => a -> m a
return (b
x, IO ()
release2 IO () -> IO () -> IO ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> IO ()
release1)

instance MonadIO Resource where
    {-# INLINE liftIO #-}
    liftIO :: IO a -> Resource a
liftIO IO a
f = IO (a, IO ()) -> Resource a
forall a. IO (a, IO ()) -> Resource a
Resource (IO (a, IO ()) -> Resource a) -> IO (a, IO ()) -> Resource a
forall a b. (a -> b) -> a -> b
$ (a -> (a, IO ())) -> IO a -> IO (a, IO ())
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\ a
a -> (a
a, IO ()
dummyRelease)) IO a
f
        where dummyRelease :: IO ()
dummyRelease = () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()

-- | Create a new resource and run some computation, resource is guarantee to
-- be closed.
--
-- Be care don't leak the resource through computation return value, because
-- after the computation finishes, the resource is closed already.
--
withResource :: (MonadCatch.MonadMask m, MonadIO m, HasCallStack)
             => Resource a -> (a -> m b) -> m b
{-# INLINABLE withResource #-}
withResource :: Resource a -> (a -> m b) -> m b
withResource Resource a
resource a -> m b
k = m (a, IO ()) -> ((a, IO ()) -> m ()) -> ((a, IO ()) -> m b) -> m b
forall (m :: * -> *) a c b.
MonadMask m =>
m a -> (a -> m c) -> (a -> m b) -> m b
MonadCatch.bracket
    (IO (a, IO ()) -> m (a, IO ())
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (Resource a -> IO (a, IO ())
forall a. Resource a -> IO (a, IO ())
acquire Resource a
resource))
    (\(a
_, IO ()
release) -> IO () -> m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO ()
release)
    (\(a
a, IO ()
_) -> a -> m b
k a
a)

-- | Create a new resource and run some computation, resource is guarantee to
-- be closed.
--
-- The difference from 'with' is that the computation will receive an extra
-- close action, which can be used to close the resource early before the whole
-- computation finished, the close action can be called multiple times,
-- only the first call will clean up the resource.
--
withResource' :: (MonadCatch.MonadMask m, MonadIO m, HasCallStack)
              => Resource a -> (a -> m () -> m b) -> m b
{-# INLINABLE withResource' #-}
withResource' :: Resource a -> (a -> m () -> m b) -> m b
withResource' Resource a
resource a -> m () -> m b
k = do
    Counter
c <- IO Counter -> m Counter
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (Int -> IO Counter
newCounter Int
0)
    m (a, IO ()) -> ((a, IO ()) -> m ()) -> ((a, IO ()) -> m b) -> m b
forall (m :: * -> *) a c b.
MonadMask m =>
m a -> (a -> m c) -> (a -> m b) -> m b
MonadCatch.bracket
        (IO (a, IO ()) -> m (a, IO ())
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (a, IO ()) -> m (a, IO ())) -> IO (a, IO ()) -> m (a, IO ())
forall a b. (a -> b) -> a -> b
$ do
            (a
a, IO ()
release) <- (Resource a -> IO (a, IO ())
forall a. Resource a -> IO (a, IO ())
acquire Resource a
resource)
            let release' :: IO ()
release' = do
                    Int
c' <- Counter -> Int -> IO Int
atomicOrCounter Counter
c Int
1
                    Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Int
c' Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
0) IO ()
release
            (a, IO ()) -> IO (a, IO ())
forall (m :: * -> *) a. Monad m => a -> m a
return (a
a, IO ()
release'))
        (\(a
_, IO ()
release) -> IO () -> m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO ()
release)
        (\(a
a, IO ()
release) -> a -> m () -> m b
k a
a (IO () -> m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO ()
release))

--------------------------------------------------------------------------------

-- | A single resource pool entry.
data Entry a = Entry
    (a, IO ())             -- the resource and clean up action
    {-# UNPACK #-} !Int    -- the life remaining

data PoolState = PoolClosed | PoolScanning | PoolEmpty deriving (PoolState -> PoolState -> Bool
(PoolState -> PoolState -> Bool)
-> (PoolState -> PoolState -> Bool) -> Eq PoolState
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: PoolState -> PoolState -> Bool
$c/= :: PoolState -> PoolState -> Bool
== :: PoolState -> PoolState -> Bool
$c== :: PoolState -> PoolState -> Bool
Eq, Int -> PoolState -> ShowS
[PoolState] -> ShowS
PoolState -> String
(Int -> PoolState -> ShowS)
-> (PoolState -> String)
-> ([PoolState] -> ShowS)
-> Show PoolState
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [PoolState] -> ShowS
$cshowList :: [PoolState] -> ShowS
show :: PoolState -> String
$cshow :: PoolState -> String
showsPrec :: Int -> PoolState -> ShowS
$cshowsPrec :: Int -> PoolState -> ShowS
Show)

-- | A high performance resource pool based on STM.
--
-- We choose to not divide pool into strips due to the difficults in resource balancing. If there
-- is a high contention on resource (see 'statPool'), just increase the maximum number of resources
-- can be opened.
--
data Pool a = Pool
    { Pool a -> Resource a
_poolResource :: Resource a
    , Pool a -> Int
_poolLimit :: Int
    , Pool a -> Int
_poolIdleTime :: Int
    , Pool a -> TVar [Entry a]
_poolEntries :: TVar [Entry a]
    , Pool a -> TVar Int
_poolInUse :: TVar Int
    , Pool a -> TVar PoolState
_poolState :: TVar PoolState
    }

-- | Initialize a resource pool with given 'Resource'
--
-- Like other initXXX functions, this function won't open a resource pool until you use 'withResource'.
-- And this resource pool follow the same resource management pattern like other resources.
--
initPool :: Resource a
         -> Int     -- ^ maximum number of resources can be opened
         -> Int     -- ^ amount of time after which an unused resource can be released (in seconds).
         -> Resource (Pool a)
initPool :: Resource a -> Int -> Int -> Resource (Pool a)
initPool Resource a
res Int
limit Int
itime = IO (Pool a) -> (Pool a -> IO ()) -> Resource (Pool a)
forall a. IO a -> (a -> IO ()) -> Resource a
initResource IO (Pool a)
createPool Pool a -> IO ()
forall a. Pool a -> IO ()
closePool
  where
    createPool :: IO (Pool a)
createPool = do
        TVar [Entry a]
entries <- [Entry a] -> IO (TVar [Entry a])
forall a. a -> IO (TVar a)
newTVarIO []
        TVar Int
inuse <- Int -> IO (TVar Int)
forall a. a -> IO (TVar a)
newTVarIO Int
0
        TVar PoolState
state <- PoolState -> IO (TVar PoolState)
forall a. a -> IO (TVar a)
newTVarIO PoolState
PoolEmpty
        Pool a -> IO (Pool a)
forall (m :: * -> *) a. Monad m => a -> m a
return (Resource a
-> Int
-> Int
-> TVar [Entry a]
-> TVar Int
-> TVar PoolState
-> Pool a
forall a.
Resource a
-> Int
-> Int
-> TVar [Entry a]
-> TVar Int
-> TVar PoolState
-> Pool a
Pool Resource a
res Int
limit Int
itime TVar [Entry a]
entries TVar Int
inuse TVar PoolState
state)

    closePool :: Pool a -> IO ()
closePool (Pool Resource a
_ Int
_ Int
_ TVar [Entry a]
entries TVar Int
_ TVar PoolState
state) = IO (IO ()) -> IO ()
forall (m :: * -> *) a. Monad m => m (m a) -> m a
join (IO (IO ()) -> IO ())
-> (STM (IO ()) -> IO (IO ())) -> STM (IO ()) -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. STM (IO ()) -> IO (IO ())
forall a. STM a -> IO a
atomically (STM (IO ()) -> IO ()) -> STM (IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ do
        PoolState
c <- TVar PoolState -> STM PoolState
forall a. TVar a -> STM a
readTVar TVar PoolState
state
        if PoolState
c PoolState -> PoolState -> Bool
forall a. Eq a => a -> a -> Bool
== PoolState
PoolClosed
        then IO () -> STM (IO ())
forall (m :: * -> *) a. Monad m => a -> m a
return (() -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ())
        else do
            TVar PoolState -> PoolState -> STM ()
forall a. TVar a -> a -> STM ()
writeTVar TVar PoolState
state PoolState
PoolClosed
            IO () -> STM (IO ())
forall (m :: * -> *) a. Monad m => a -> m a
return (do
                [Entry a]
es <- TVar [Entry a] -> IO [Entry a]
forall a. TVar a -> IO a
readTVarIO TVar [Entry a]
entries
                [Entry a] -> (Entry a -> IO ()) -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [Entry a]
es ((Entry a -> IO ()) -> IO ()) -> (Entry a -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \ (Entry (a
_, IO ()
close) Int
_) ->
                    (SomeException -> IO ()) -> IO () -> IO ()
forall (m :: * -> *) a.
MonadCatch m =>
(SomeException -> m a) -> m a -> m a
MonadCatch.handleAll (\ SomeException
_ -> () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()) IO ()
close)

-- | Get a resource pool's 'PoolState'
--
-- This function is useful when debug, under load lots of 'PoolEmpty' may indicate
-- contention on resources, i.e. the limit on maximum number of resources can be opened
-- should be adjusted to a higher number. On the otherhand, lots of 'PoolScanning'
-- may indicate there're too much free resources.
--
poolStat :: Pool a -> IO PoolState
poolStat :: Pool a -> IO PoolState
poolStat Pool a
pool = TVar PoolState -> IO PoolState
forall a. TVar a -> IO a
readTVarIO (Pool a -> TVar PoolState
forall a. Pool a -> TVar PoolState
_poolState Pool a
pool)

-- | Get how many resource is being used within a resource pool.
--
-- This function is useful when debug, under load in use number alway reaches limit may indicate
-- contention on resources, i.e. the limit on maximum number of resources can be opened
-- should be adjusted to a higher number.
--
poolInUse :: Pool a -> IO Int
poolInUse :: Pool a -> IO Int
poolInUse Pool a
pool = TVar Int -> IO Int
forall a. TVar a -> IO a
readTVarIO (Pool a -> TVar Int
forall a. Pool a -> TVar Int
_poolInUse Pool a
pool)

-- | Open resource inside a given resource pool and do some computation.
--
-- This function is thread safe, concurrently usage will be guaranteed
-- to get different resource. If exception happens,
-- resource will be closed(not return to pool).
withResourceInPool :: (MonadCatch.MonadMask m, MonadIO m, HasCallStack)
                   => Pool a -> (a -> m b) -> m b
withResourceInPool :: Pool a -> (a -> m b) -> m b
withResourceInPool (Pool Resource a
res Int
limit Int
itime TVar [Entry a]
entries TVar Int
inuse TVar PoolState
state) a -> m b
k =
    (b, ()) -> b
forall a b. (a, b) -> a
fst ((b, ()) -> b) -> m (b, ()) -> m b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> m (a, IO ())
-> ((a, IO ()) -> ExitCase b -> m ())
-> ((a, IO ()) -> m b)
-> m (b, ())
forall (m :: * -> *) a b c.
MonadMask m =>
m a -> (a -> ExitCase b -> m c) -> (a -> m b) -> m (b, c)
MonadCatch.generalBracket
        (IO (a, IO ()) -> m (a, IO ())
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO (a, IO ())
takeFromPool)
        (\ r :: (a, IO ())
r@(a
_, IO ()
close) ExitCase b
exit ->
            case ExitCase b
exit of
                MonadCatch.ExitCaseSuccess b
_ -> IO () -> m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO ((a, IO ()) -> IO ()
returnToPool (a, IO ())
r)
                ExitCase b
_ -> IO () -> m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ do
                    STM () -> IO ()
forall a. STM a -> IO a
atomically (STM () -> IO ()) -> STM () -> IO ()
forall a b. (a -> b) -> a -> b
$ TVar Int -> (Int -> Int) -> STM ()
forall a. TVar a -> (a -> a) -> STM ()
modifyTVar' TVar Int
inuse (Int -> Int -> Int
forall a. Num a => a -> a -> a
subtract Int
1)
                    IO ()
close)
        (\ (a
a, IO ()
_) -> a -> m b
k a
a)
  where
    takeFromPool :: IO (a, IO ())
takeFromPool = IO (IO (a, IO ())) -> IO (a, IO ())
forall (m :: * -> *) a. Monad m => m (m a) -> m a
join (IO (IO (a, IO ())) -> IO (a, IO ()))
-> (STM (IO (a, IO ())) -> IO (IO (a, IO ())))
-> STM (IO (a, IO ()))
-> IO (a, IO ())
forall b c a. (b -> c) -> (a -> b) -> a -> c
. STM (IO (a, IO ())) -> IO (IO (a, IO ()))
forall a. STM a -> IO a
atomically (STM (IO (a, IO ())) -> IO (a, IO ()))
-> STM (IO (a, IO ())) -> IO (a, IO ())
forall a b. (a -> b) -> a -> b
$ do
        PoolState
c <- TVar PoolState -> STM PoolState
forall a. TVar a -> STM a
readTVar TVar PoolState
state
        if PoolState
c PoolState -> PoolState -> Bool
forall a. Eq a => a -> a -> Bool
== PoolState
PoolClosed
        then STM (IO (a, IO ()))
forall a. HasCallStack => STM a
throwECLOSEDSTM
        else do
            [Entry a]
es <- TVar [Entry a] -> STM [Entry a]
forall a. TVar a -> STM a
readTVar TVar [Entry a]
entries
            case [Entry a]
es of
                ((Entry (a, IO ())
a Int
_):[Entry a]
es') -> do
                    TVar [Entry a] -> [Entry a] -> STM ()
forall a. TVar a -> a -> STM ()
writeTVar TVar [Entry a]
entries [Entry a]
es'
                    IO (a, IO ()) -> STM (IO (a, IO ()))
forall (m :: * -> *) a. Monad m => a -> m a
return ((a, IO ()) -> IO (a, IO ())
forall (m :: * -> *) a. Monad m => a -> m a
return (a, IO ())
a)
                [Entry a]
_ -> do
                    Int
i <- TVar Int -> STM Int
forall a. TVar a -> STM a
readTVar TVar Int
inuse
                    Bool -> STM () -> STM ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Int
i Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
limit) STM ()
forall a. STM a
retry
                    TVar Int -> (Int -> Int) -> STM ()
forall a. TVar a -> (a -> a) -> STM ()
modifyTVar' TVar Int
inuse (Int -> Int -> Int
forall a. Num a => a -> a -> a
+Int
1)
                    IO (a, IO ()) -> STM (IO (a, IO ()))
forall (m :: * -> *) a. Monad m => a -> m a
return (Resource a -> IO (a, IO ())
forall a. Resource a -> IO (a, IO ())
acquire Resource a
res IO (a, IO ()) -> IO () -> IO (a, IO ())
forall a b. IO a -> IO b -> IO a
`onException`
                         STM () -> IO ()
forall a. STM a -> IO a
atomically (TVar Int -> (Int -> Int) -> STM ()
forall a. TVar a -> (a -> a) -> STM ()
modifyTVar' TVar Int
inuse (Int -> Int -> Int
forall a. Num a => a -> a -> a
subtract Int
1)))

    returnToPool :: (a, IO ()) -> IO ()
returnToPool (a, IO ())
a = IO (IO ()) -> IO ()
forall (m :: * -> *) a. Monad m => m (m a) -> m a
join (IO (IO ()) -> IO ())
-> (STM (IO ()) -> IO (IO ())) -> STM (IO ()) -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. STM (IO ()) -> IO (IO ())
forall a. STM a -> IO a
atomically (STM (IO ()) -> IO ()) -> STM (IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ do
        PoolState
c <- TVar PoolState -> STM PoolState
forall a. TVar a -> STM a
readTVar TVar PoolState
state
        case PoolState
c of
            PoolState
PoolClosed -> IO () -> STM (IO ())
forall (m :: * -> *) a. Monad m => a -> m a
return ((a, IO ()) -> IO ()
forall a b. (a, b) -> b
snd (a, IO ())
a)
            PoolState
PoolEmpty -> do
                TVar [Entry a] -> ([Entry a] -> [Entry a]) -> STM ()
forall a. TVar a -> (a -> a) -> STM ()
modifyTVar' TVar [Entry a]
entries ((a, IO ()) -> Int -> Entry a
forall a. (a, IO ()) -> Int -> Entry a
Entry (a, IO ())
a Int
itimeEntry a -> [Entry a] -> [Entry a]
forall a. a -> [a] -> [a]
:)
                TVar PoolState -> PoolState -> STM ()
forall a. TVar a -> a -> STM ()
writeTVar TVar PoolState
state PoolState
PoolScanning
                IO () -> STM (IO ())
forall (m :: * -> *) a. Monad m => a -> m a
return (IO LowResTimer -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO LowResTimer -> IO ()) -> IO LowResTimer -> IO ()
forall a b. (a -> b) -> a -> b
$ Int -> IO () -> IO LowResTimer
registerLowResTimer Int
10 IO ()
scanPool)
            PoolState
_ -> do
                TVar [Entry a] -> ([Entry a] -> [Entry a]) -> STM ()
forall a. TVar a -> (a -> a) -> STM ()
modifyTVar' TVar [Entry a]
entries ((a, IO ()) -> Int -> Entry a
forall a. (a, IO ()) -> Int -> Entry a
Entry (a, IO ())
a Int
itimeEntry a -> [Entry a] -> [Entry a]
forall a. a -> [a] -> [a]
:)
                IO () -> STM (IO ())
forall (m :: * -> *) a. Monad m => a -> m a
return (() -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ())

    scanPool :: IO ()
scanPool = do
         IO (IO ()) -> IO ()
forall (m :: * -> *) a. Monad m => m (m a) -> m a
join (IO (IO ()) -> IO ())
-> (STM (IO ()) -> IO (IO ())) -> STM (IO ()) -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. STM (IO ()) -> IO (IO ())
forall a. STM a -> IO a
atomically (STM (IO ()) -> IO ()) -> STM (IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ do
            PoolState
c <- TVar PoolState -> STM PoolState
forall a. TVar a -> STM a
readTVar TVar PoolState
state
            if PoolState
c PoolState -> PoolState -> Bool
forall a. Eq a => a -> a -> Bool
== PoolState
PoolClosed
            then IO () -> STM (IO ())
forall (m :: * -> *) a. Monad m => a -> m a
return (() -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ())
            else do
                [Entry a]
es <- TVar [Entry a] -> STM [Entry a]
forall a. TVar a -> STM a
readTVar TVar [Entry a]
entries
                if ([Entry a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Entry a]
es)
                then do
                    TVar PoolState -> PoolState -> STM ()
forall a. TVar a -> a -> STM ()
writeTVar TVar PoolState
state PoolState
PoolEmpty
                    IO () -> STM (IO ())
forall (m :: * -> *) a. Monad m => a -> m a
return (() -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ())
                else do
                    let (Int
deadNum, [(a, IO ())]
dead, [Entry a]
living) = [Entry a]
-> Int
-> [(a, IO ())]
-> [Entry a]
-> (Int, [(a, IO ())], [Entry a])
forall a a.
Num a =>
[Entry a]
-> a -> [(a, IO ())] -> [Entry a] -> (a, [(a, IO ())], [Entry a])
age [Entry a]
es Int
0 [] []
                    TVar [Entry a] -> [Entry a] -> STM ()
forall a. TVar a -> a -> STM ()
writeTVar TVar [Entry a]
entries [Entry a]
living
                    TVar Int -> (Int -> Int) -> STM ()
forall a. TVar a -> (a -> a) -> STM ()
modifyTVar' TVar Int
inuse (Int -> Int -> Int
forall a. Num a => a -> a -> a
subtract Int
deadNum)
                    IO () -> STM (IO ())
forall (m :: * -> *) a. Monad m => a -> m a
return (do
                        [(a, IO ())] -> ((a, IO ()) -> IO ()) -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [(a, IO ())]
dead (((a, IO ()) -> IO ()) -> IO ()) -> ((a, IO ()) -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \ (a
_, IO ()
close) ->
                            (SomeException -> IO ()) -> IO () -> IO ()
forall (m :: * -> *) a.
MonadCatch m =>
(SomeException -> m a) -> m a -> m a
MonadCatch.handleAll (\ SomeException
_ -> () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()) IO ()
close
                        IO LowResTimer -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO LowResTimer -> IO ()) -> IO LowResTimer -> IO ()
forall a b. (a -> b) -> a -> b
$ Int -> IO () -> IO LowResTimer
registerLowResTimer Int
10 IO ()
scanPool)

    age :: [Entry a]
-> a -> [(a, IO ())] -> [Entry a] -> (a, [(a, IO ())], [Entry a])
age ((Entry (a, IO ())
a Int
life):[Entry a]
es) !a
deadNum [(a, IO ())]
dead [Entry a]
living
        | Int
life Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
1  = [Entry a]
-> a -> [(a, IO ())] -> [Entry a] -> (a, [(a, IO ())], [Entry a])
age [Entry a]
es a
deadNum     [(a, IO ())]
dead     ((a, IO ()) -> Int -> Entry a
forall a. (a, IO ()) -> Int -> Entry a
Entry (a, IO ())
a (Int
lifeInt -> Int -> Int
forall a. Num a => a -> a -> a
-Int
1)Entry a -> [Entry a] -> [Entry a]
forall a. a -> [a] -> [a]
:[Entry a]
living)
        | Bool
otherwise = [Entry a]
-> a -> [(a, IO ())] -> [Entry a] -> (a, [(a, IO ())], [Entry a])
age [Entry a]
es (a
deadNuma -> a -> a
forall a. Num a => a -> a -> a
+a
1) ((a, IO ())
a(a, IO ()) -> [(a, IO ())] -> [(a, IO ())]
forall a. a -> [a] -> [a]
:[(a, IO ())]
dead) [Entry a]
living
    age [Entry a]
_ !a
deadNum [(a, IO ())]
dead [Entry a]
living = (a
deadNum, [(a, IO ())]
dead, [Entry a]
living)