{-# LANGUAGE DeriveTraversable #-}
{-# LANGUAGE DerivingStrategies #-}
{-# LANGUAGE NumericUnderscores #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE StrictData #-}
{-# LANGUAGE TypeApplications #-}

module Simpoole
  ( Pool
  , mapPool
  , newUnlimitedPool
  , newPool
  , withResource
  , poolMetrics

  , Metrics (..)
  )
where

import qualified Control.Concurrent.Classy as Concurrent
import qualified Control.Concurrent.Classy.Async as Async
import           Control.Monad (forever, unless, void)
import qualified Control.Monad.Catch as Catch
import           Control.Monad.IO.Class (MonadIO (liftIO))
import           Data.Foldable (for_)
import qualified Data.Sequence as Seq
import qualified Data.Time as Time
import           Numeric.Natural (Natural)

-- | Pool of resources
--
-- @since 0.0.0
data Pool m a = Pool
  { Pool m a -> m a
pool_acquire :: m a
  , Pool m a -> a -> m ()
pool_return :: a -> m ()
  , Pool m a -> a -> m ()
pool_destroy :: a -> m ()
  , Pool m a -> m (Metrics Natural)
pool_metrics :: m (Metrics Natural)
  }

-- | Lift a natural transformation @m ~> n@ to @Pool m ~> Pool n@.
--
-- @since 0.0.0
mapPool
  :: (forall x. m x -> n x)
  -> Pool m a
  -> Pool n a
mapPool :: (forall x. m x -> n x) -> Pool m a -> Pool n a
mapPool forall x. m x -> n x
to Pool m a
pool = Pool :: forall (m :: * -> *) a.
m a
-> (a -> m ()) -> (a -> m ()) -> m (Metrics Natural) -> Pool m a
Pool
  { pool_acquire :: n a
pool_acquire = m a -> n a
forall x. m x -> n x
to (m a -> n a) -> m a -> n a
forall a b. (a -> b) -> a -> b
$ Pool m a -> m a
forall (m :: * -> *) a. Pool m a -> m a
pool_acquire Pool m a
pool
  , pool_return :: a -> n ()
pool_return = m () -> n ()
forall x. m x -> n x
to (m () -> n ()) -> (a -> m ()) -> a -> n ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Pool m a -> a -> m ()
forall (m :: * -> *) a. Pool m a -> a -> m ()
pool_return Pool m a
pool
  , pool_destroy :: a -> n ()
pool_destroy = m () -> n ()
forall x. m x -> n x
to (m () -> n ()) -> (a -> m ()) -> a -> n ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Pool m a -> a -> m ()
forall (m :: * -> *) a. Pool m a -> a -> m ()
pool_destroy Pool m a
pool
  , pool_metrics :: n (Metrics Natural)
pool_metrics = m (Metrics Natural) -> n (Metrics Natural)
forall x. m x -> n x
to (m (Metrics Natural) -> n (Metrics Natural))
-> m (Metrics Natural) -> n (Metrics Natural)
forall a b. (a -> b) -> a -> b
$ Pool m a -> m (Metrics Natural)
forall (m :: * -> *) a. Pool m a -> m (Metrics Natural)
pool_metrics Pool m a
pool
  }

{-# INLINE mapPool #-}

-- | Pool resource
data Resource a =
  Resource
    Time.UTCTime
    -- ^ Last use time
    a
    -- ^ The resource itesemf

-- | Create a new pool that has no limit on how many resources it may create and hold.
--
-- @since 0.0.0
newUnlimitedPool
  :: (Concurrent.MonadConc m, MonadIO m)
  => m a
  -- ^ Resource creation
  -> (a -> m ())
  -- ^ Resource destruction
  -> Time.NominalDiffTime
  -- ^ Maximum idle time (+-1s) after which a resource is destroyed
  -> m (Pool m a)
newUnlimitedPool :: m a -> (a -> m ()) -> NominalDiffTime -> m (Pool m a)
newUnlimitedPool m a
create a -> m ()
destroy NominalDiffTime
maxIdleTime = do
  IORef m (Seq (Resource a))
leftOversRef <- String -> Seq (Resource a) -> m (IORef m (Seq (Resource a)))
forall (m :: * -> *) a. MonadConc m => String -> a -> m (IORef m a)
Concurrent.newIORefN String
"leftOvers" Seq (Resource a)
forall a. Seq a
Seq.empty

  Metrics (IORef m Natural)
metricRefs <- m (Metrics (IORef m Natural))
forall (m :: * -> *). MonadConc m => m (Metrics (IORef m Natural))
mkMetricRefs

  let
    wrappedCreate :: m a
wrappedCreate = do
      a
value <- m a
create
      IORef m Natural -> m ()
forall (m :: * -> *) a. (MonadConc m, Enum a) => IORef m a -> m ()
succIORef (Metrics (IORef m Natural) -> IORef m Natural
forall a. Metrics a -> a
metrics_createdResources Metrics (IORef m Natural)
metricRefs)
      a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure a
value

    wrappedDestroy :: a -> m ()
wrappedDestroy a
resource =
      a -> m ()
destroy a
resource m () -> m () -> m ()
forall (m :: * -> *) a b. MonadMask m => m a -> m b -> m a
`Catch.finally` IORef m Natural -> m ()
forall (m :: * -> *) a. (MonadConc m, Enum a) => IORef m a -> m ()
succIORef (Metrics (IORef m Natural) -> IORef m Natural
forall a. Metrics a -> a
metrics_destroyedResources Metrics (IORef m Natural)
metricRefs)

    acquireResource :: m a
acquireResource = do
      Maybe a
mbResource <- IORef m (Seq (Resource a))
-> (Seq (Resource a) -> (Seq (Resource a), Maybe a)) -> m (Maybe a)
forall (m :: * -> *) a b.
MonadConc m =>
IORef m a -> (a -> (a, b)) -> m b
Concurrent.atomicModifyIORef' IORef m (Seq (Resource a))
leftOversRef ((Seq (Resource a) -> (Seq (Resource a), Maybe a)) -> m (Maybe a))
-> (Seq (Resource a) -> (Seq (Resource a), Maybe a)) -> m (Maybe a)
forall a b. (a -> b) -> a -> b
$ \Seq (Resource a)
leftOvers ->
        case Seq (Resource a)
leftOvers of
          Resource UTCTime
_ a
head Seq.:<| Seq (Resource a)
tail -> (Seq (Resource a)
tail, a -> Maybe a
forall a. a -> Maybe a
Just a
head)
          Seq (Resource a)
_empty -> (Seq (Resource a)
leftOvers, Maybe a
forall a. Maybe a
Nothing)
      a
resource <- m a -> (a -> m a) -> Maybe a -> m a
forall b a. b -> (a -> b) -> Maybe a -> b
maybe m a
wrappedCreate a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe a
mbResource

      Natural
numDestroyed <- IORef m Natural -> m Natural
forall (m :: * -> *) a. MonadConc m => IORef m a -> m a
Concurrent.readIORef (Metrics (IORef m Natural) -> IORef m Natural
forall a. Metrics a -> a
metrics_destroyedResources Metrics (IORef m Natural)
metricRefs)
      Natural
numCreated <- IORef m Natural -> m Natural
forall (m :: * -> *) a. MonadConc m => IORef m a -> m a
Concurrent.readIORef (Metrics (IORef m Natural) -> IORef m Natural
forall a. Metrics a -> a
metrics_createdResources Metrics (IORef m Natural)
metricRefs)
      IORef m Natural -> Natural -> m ()
forall (m :: * -> *) a.
(MonadConc m, Ord a) =>
IORef m a -> a -> m ()
maxIORef (Metrics (IORef m Natural) -> IORef m Natural
forall a. Metrics a -> a
metrics_maxLiveResources Metrics (IORef m Natural)
metricRefs) (Natural
numCreated Natural -> Natural -> Natural
forall a. Num a => a -> a -> a
- Natural
numDestroyed)

      a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure a
resource

    returnResource :: a -> m ()
returnResource a
value = do
      UTCTime
now <- IO UTCTime -> m UTCTime
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO UTCTime
Time.getCurrentTime
      IORef m (Seq (Resource a))
-> (Seq (Resource a) -> (Seq (Resource a), ())) -> m ()
forall (m :: * -> *) a b.
MonadConc m =>
IORef m a -> (a -> (a, b)) -> m b
Concurrent.atomicModifyIORef' IORef m (Seq (Resource a))
leftOversRef ((Seq (Resource a) -> (Seq (Resource a), ())) -> m ())
-> (Seq (Resource a) -> (Seq (Resource a), ())) -> m ()
forall a b. (a -> b) -> a -> b
$ \Seq (Resource a)
leftOvers ->
        (Seq (Resource a)
leftOvers Seq (Resource a) -> Resource a -> Seq (Resource a)
forall a. Seq a -> a -> Seq a
Seq.:|> UTCTime -> a -> Resource a
forall a. UTCTime -> a -> Resource a
Resource UTCTime
now a
value, ())

  Async m Any
_reaperThread <- String -> ((forall b. m b -> m b) -> m Any) -> m (Async m Any)
forall (m :: * -> *) a.
MonadConc m =>
String -> ((forall b. m b -> m b) -> m a) -> m (Async m a)
Async.asyncWithUnmaskN String
"reaperThread" (((forall b. m b -> m b) -> m Any) -> m (Async m Any))
-> ((forall b. m b -> m b) -> m Any) -> m (Async m Any)
forall a b. (a -> b) -> a -> b
$ \forall b. m b -> m b
unmask -> m Any -> m Any
forall b. m b -> m b
unmask (m Any -> m Any) -> m Any -> m Any
forall a b. (a -> b) -> a -> b
$ m () -> m Any
forall (f :: * -> *) a b. Applicative f => f a -> f b
forever (m () -> m Any) -> m () -> m Any
forall a b. (a -> b) -> a -> b
$ do
    UTCTime
now <- IO UTCTime -> m UTCTime
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO UTCTime
Time.getCurrentTime

    let isStillGood :: Resource a -> Bool
isStillGood (Resource UTCTime
lastUse a
_) = UTCTime -> UTCTime -> NominalDiffTime
Time.diffUTCTime UTCTime
now UTCTime
lastUse NominalDiffTime -> NominalDiffTime -> Bool
forall a. Ord a => a -> a -> Bool
<= NominalDiffTime
maxIdleTime
    Seq (Resource a)
oldResource <- IORef m (Seq (Resource a))
-> (Seq (Resource a) -> (Seq (Resource a), Seq (Resource a)))
-> m (Seq (Resource a))
forall (m :: * -> *) a b.
MonadConc m =>
IORef m a -> (a -> (a, b)) -> m b
Concurrent.atomicModifyIORef' IORef m (Seq (Resource a))
leftOversRef ((Resource a -> Bool)
-> Seq (Resource a) -> (Seq (Resource a), Seq (Resource a))
forall a. (a -> Bool) -> Seq a -> (Seq a, Seq a)
Seq.partition Resource a -> Bool
forall a. Resource a -> Bool
isStillGood)

    Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (Seq (Resource a) -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null Seq (Resource a)
oldResource) (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$ m (Async m ()) -> m ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (m (Async m ()) -> m ()) -> m (Async m ()) -> m ()
forall a b. (a -> b) -> a -> b
$
      String -> m () -> m (Async m ())
forall (m :: * -> *) a.
MonadConc m =>
String -> m a -> m (Async m a)
Async.asyncN String
"destructionThread" (m () -> m (Async m ())) -> m () -> m (Async m ())
forall a b. (a -> b) -> a -> b
$
        Seq (Resource a)
-> (Resource a -> m (Either SomeException ())) -> m ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
t a -> (a -> f b) -> f ()
for_ Seq (Resource a)
oldResource ((Resource a -> m (Either SomeException ())) -> m ())
-> (Resource a -> m (Either SomeException ())) -> m ()
forall a b. (a -> b) -> a -> b
$ \(Resource UTCTime
_ a
value) ->
          forall a.
(MonadCatch m, Exception SomeException) =>
m a -> m (Either SomeException a)
forall (m :: * -> *) e a.
(MonadCatch m, Exception e) =>
m a -> m (Either e a)
Catch.try @_ @Catch.SomeException (m () -> m (Either SomeException ()))
-> m () -> m (Either SomeException ())
forall a b. (a -> b) -> a -> b
$ a -> m ()
wrappedDestroy a
value

    Int -> m ()
forall (m :: * -> *). MonadConc m => Int -> m ()
Concurrent.threadDelay Int
1_000_000

  Pool m a -> m (Pool m a)
forall (f :: * -> *) a. Applicative f => a -> f a
pure Pool :: forall (m :: * -> *) a.
m a
-> (a -> m ()) -> (a -> m ()) -> m (Metrics Natural) -> Pool m a
Pool
    { pool_acquire :: m a
pool_acquire = m a
acquireResource
    , pool_return :: a -> m ()
pool_return = a -> m ()
returnResource
    , pool_destroy :: a -> m ()
pool_destroy = a -> m ()
wrappedDestroy
    , pool_metrics :: m (Metrics Natural)
pool_metrics = Metrics (IORef m Natural) -> m (Metrics Natural)
forall (m :: * -> *) a.
MonadConc m =>
Metrics (IORef m a) -> m (Metrics a)
readMetricRefs Metrics (IORef m Natural)
metricRefs
    }

-- | Similar to 'newUnlimitedPool' but allows you to limit the number of resources that will exist
-- at the same time. When all resources are currently in use, further resource acquisition will
-- block until one is no longer in use.
--
-- @since 0.0.0
newPool
  :: (Concurrent.MonadConc m, MonadIO m, MonadFail m)
  => m a
  -- ^ Resource creation
  -> (a -> m ())
  -- ^ Resource destruction
  -> Int
  -- ^ Maximum number of resources to exist at the same time
  -> Time.NominalDiffTime
  -- ^ Maximum idle time after which a resource is destroyed
  -> m (Pool m a)
newPool :: m a -> (a -> m ()) -> Int -> NominalDiffTime -> m (Pool m a)
newPool m a
create a -> m ()
destroy Int
maxElems NominalDiffTime
maxIdleTime = do
  Pool m a
basePool <- m a -> (a -> m ()) -> NominalDiffTime -> m (Pool m a)
forall (m :: * -> *) a.
(MonadConc m, MonadIO m) =>
m a -> (a -> m ()) -> NominalDiffTime -> m (Pool m a)
newUnlimitedPool m a
create a -> m ()
destroy NominalDiffTime
maxIdleTime
  QSem m
maxElemBarrier <- Int -> m (QSem m)
forall (m :: * -> *).
(MonadConc m, MonadFail m) =>
Int -> m (QSem m)
Concurrent.newQSem Int
maxElems

  let
    acquireResource :: m a
acquireResource = ((forall a. m a -> m a) -> m a) -> m a
forall (m :: * -> *) b.
MonadMask m =>
((forall a. m a -> m a) -> m b) -> m b
Catch.mask (((forall a. m a -> m a) -> m a) -> m a)
-> ((forall a. m a -> m a) -> m a) -> m a
forall a b. (a -> b) -> a -> b
$ \forall a. m a -> m a
restore -> do
      QSem m -> m ()
forall (m :: * -> *). MonadConc m => QSem m -> m ()
Concurrent.waitQSem QSem m
maxElemBarrier
      m a -> m a
forall a. m a -> m a
restore (Pool m a -> m a
forall (m :: * -> *) a. Pool m a -> m a
pool_acquire Pool m a
basePool)
        m a -> m () -> m a
forall (m :: * -> *) a b. MonadMask m => m a -> m b -> m a
`Catch.onError` QSem m -> m ()
forall (m :: * -> *). MonadConc m => QSem m -> m ()
Concurrent.signalQSem QSem m
maxElemBarrier

    giveBackResource :: (Pool m a -> t -> m b) -> t -> m b
giveBackResource Pool m a -> t -> m b
f t
value = ((forall a. m a -> m a) -> m b) -> m b
forall (m :: * -> *) b.
MonadMask m =>
((forall a. m a -> m a) -> m b) -> m b
Catch.mask (((forall a. m a -> m a) -> m b) -> m b)
-> ((forall a. m a -> m a) -> m b) -> m b
forall a b. (a -> b) -> a -> b
$ \forall a. m a -> m a
restore ->
      m b -> m b
forall a. m a -> m a
restore (Pool m a -> t -> m b
f Pool m a
basePool t
value)
        m b -> m () -> m b
forall (m :: * -> *) a b. MonadMask m => m a -> m b -> m a
`Catch.finally` QSem m -> m ()
forall (m :: * -> *). MonadConc m => QSem m -> m ()
Concurrent.signalQSem QSem m
maxElemBarrier

  Pool m a -> m (Pool m a)
forall (f :: * -> *) a. Applicative f => a -> f a
pure Pool :: forall (m :: * -> *) a.
m a
-> (a -> m ()) -> (a -> m ()) -> m (Metrics Natural) -> Pool m a
Pool
    { pool_acquire :: m a
pool_acquire = m a
acquireResource
    , pool_return :: a -> m ()
pool_return = (Pool m a -> a -> m ()) -> a -> m ()
forall t b. (Pool m a -> t -> m b) -> t -> m b
giveBackResource Pool m a -> a -> m ()
forall (m :: * -> *) a. Pool m a -> a -> m ()
pool_return
    , pool_destroy :: a -> m ()
pool_destroy = (Pool m a -> a -> m ()) -> a -> m ()
forall t b. (Pool m a -> t -> m b) -> t -> m b
giveBackResource Pool m a -> a -> m ()
forall (m :: * -> *) a. Pool m a -> a -> m ()
pool_destroy
    , pool_metrics :: m (Metrics Natural)
pool_metrics = Pool m a -> m (Metrics Natural)
forall (m :: * -> *) a. Pool m a -> m (Metrics Natural)
pool_metrics Pool m a
basePool
    }

-- | Use a resource from the pool.
--
-- @since 0.0.0
withResource :: Catch.MonadMask m => Pool m a -> (a -> m r) -> m r
withResource :: Pool m a -> (a -> m r) -> m r
withResource Pool m a
pool a -> m r
f =
  ((forall a. m a -> m a) -> m r) -> m r
forall (m :: * -> *) b.
MonadMask m =>
((forall a. m a -> m a) -> m b) -> m b
Catch.mask (((forall a. m a -> m a) -> m r) -> m r)
-> ((forall a. m a -> m a) -> m r) -> m r
forall a b. (a -> b) -> a -> b
$ \forall a. m a -> m a
restore -> do
    a
resource <- m a -> m a
forall a. m a -> m a
restore (Pool m a -> m a
forall (m :: * -> *) a. Pool m a -> m a
pool_acquire Pool m a
pool)
    r
result <- m r -> m r
forall a. m a -> m a
restore (a -> m r
f a
resource) m r -> m () -> m r
forall (m :: * -> *) a b. MonadMask m => m a -> m b -> m a
`Catch.onError` Pool m a -> a -> m ()
forall (m :: * -> *) a. Pool m a -> a -> m ()
pool_destroy Pool m a
pool a
resource
    Pool m a -> a -> m ()
forall (m :: * -> *) a. Pool m a -> a -> m ()
pool_return Pool m a
pool a
resource
    r -> m r
forall (f :: * -> *) a. Applicative f => a -> f a
pure r
result

{-# INLINE withResource #-}

-- | Fetch pool metrics.
--
-- @since 0.0.0
poolMetrics :: Pool m a -> m (Metrics Natural)
poolMetrics :: Pool m a -> m (Metrics Natural)
poolMetrics = Pool m a -> m (Metrics Natural)
forall (m :: * -> *) a. Pool m a -> m (Metrics Natural)
pool_metrics

{-# INLINE poolMetrics #-}

---

-- | Pool metrics
--
-- @since 0.0.0
data Metrics a = Metrics
  { Metrics a -> a
metrics_createdResources :: a
  -- ^ Total number of resources created
  --
  -- @since 0.0.0
  , Metrics a -> a
metrics_destroyedResources :: a
  -- ^ Total number of resources destroyed
  --
  -- @since 0.0.0
  , Metrics a -> a
metrics_maxLiveResources :: a
  -- ^ Maximum number of resources that were alive simultaneously
  --
  -- @since 0.0.0
  }
  deriving stock (Int -> Metrics a -> ShowS
[Metrics a] -> ShowS
Metrics a -> String
(Int -> Metrics a -> ShowS)
-> (Metrics a -> String)
-> ([Metrics a] -> ShowS)
-> Show (Metrics a)
forall a. Show a => Int -> Metrics a -> ShowS
forall a. Show a => [Metrics a] -> ShowS
forall a. Show a => Metrics a -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Metrics a] -> ShowS
$cshowList :: forall a. Show a => [Metrics a] -> ShowS
show :: Metrics a -> String
$cshow :: forall a. Show a => Metrics a -> String
showsPrec :: Int -> Metrics a -> ShowS
$cshowsPrec :: forall a. Show a => Int -> Metrics a -> ShowS
Show, ReadPrec [Metrics a]
ReadPrec (Metrics a)
Int -> ReadS (Metrics a)
ReadS [Metrics a]
(Int -> ReadS (Metrics a))
-> ReadS [Metrics a]
-> ReadPrec (Metrics a)
-> ReadPrec [Metrics a]
-> Read (Metrics a)
forall a. Read a => ReadPrec [Metrics a]
forall a. Read a => ReadPrec (Metrics a)
forall a. Read a => Int -> ReadS (Metrics a)
forall a. Read a => ReadS [Metrics a]
forall a.
(Int -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
readListPrec :: ReadPrec [Metrics a]
$creadListPrec :: forall a. Read a => ReadPrec [Metrics a]
readPrec :: ReadPrec (Metrics a)
$creadPrec :: forall a. Read a => ReadPrec (Metrics a)
readList :: ReadS [Metrics a]
$creadList :: forall a. Read a => ReadS [Metrics a]
readsPrec :: Int -> ReadS (Metrics a)
$creadsPrec :: forall a. Read a => Int -> ReadS (Metrics a)
Read, Metrics a -> Metrics a -> Bool
(Metrics a -> Metrics a -> Bool)
-> (Metrics a -> Metrics a -> Bool) -> Eq (Metrics a)
forall a. Eq a => Metrics a -> Metrics a -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Metrics a -> Metrics a -> Bool
$c/= :: forall a. Eq a => Metrics a -> Metrics a -> Bool
== :: Metrics a -> Metrics a -> Bool
$c== :: forall a. Eq a => Metrics a -> Metrics a -> Bool
Eq, Eq (Metrics a)
Eq (Metrics a)
-> (Metrics a -> Metrics a -> Ordering)
-> (Metrics a -> Metrics a -> Bool)
-> (Metrics a -> Metrics a -> Bool)
-> (Metrics a -> Metrics a -> Bool)
-> (Metrics a -> Metrics a -> Bool)
-> (Metrics a -> Metrics a -> Metrics a)
-> (Metrics a -> Metrics a -> Metrics a)
-> Ord (Metrics a)
Metrics a -> Metrics a -> Bool
Metrics a -> Metrics a -> Ordering
Metrics a -> Metrics a -> Metrics a
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
forall a. Ord a => Eq (Metrics a)
forall a. Ord a => Metrics a -> Metrics a -> Bool
forall a. Ord a => Metrics a -> Metrics a -> Ordering
forall a. Ord a => Metrics a -> Metrics a -> Metrics a
min :: Metrics a -> Metrics a -> Metrics a
$cmin :: forall a. Ord a => Metrics a -> Metrics a -> Metrics a
max :: Metrics a -> Metrics a -> Metrics a
$cmax :: forall a. Ord a => Metrics a -> Metrics a -> Metrics a
>= :: Metrics a -> Metrics a -> Bool
$c>= :: forall a. Ord a => Metrics a -> Metrics a -> Bool
> :: Metrics a -> Metrics a -> Bool
$c> :: forall a. Ord a => Metrics a -> Metrics a -> Bool
<= :: Metrics a -> Metrics a -> Bool
$c<= :: forall a. Ord a => Metrics a -> Metrics a -> Bool
< :: Metrics a -> Metrics a -> Bool
$c< :: forall a. Ord a => Metrics a -> Metrics a -> Bool
compare :: Metrics a -> Metrics a -> Ordering
$ccompare :: forall a. Ord a => Metrics a -> Metrics a -> Ordering
$cp1Ord :: forall a. Ord a => Eq (Metrics a)
Ord, a -> Metrics b -> Metrics a
(a -> b) -> Metrics a -> Metrics b
(forall a b. (a -> b) -> Metrics a -> Metrics b)
-> (forall a b. a -> Metrics b -> Metrics a) -> Functor Metrics
forall a b. a -> Metrics b -> Metrics a
forall a b. (a -> b) -> Metrics a -> Metrics b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
<$ :: a -> Metrics b -> Metrics a
$c<$ :: forall a b. a -> Metrics b -> Metrics a
fmap :: (a -> b) -> Metrics a -> Metrics b
$cfmap :: forall a b. (a -> b) -> Metrics a -> Metrics b
Functor, Metrics a -> Bool
(a -> m) -> Metrics a -> m
(a -> b -> b) -> b -> Metrics a -> b
(forall m. Monoid m => Metrics m -> m)
-> (forall m a. Monoid m => (a -> m) -> Metrics a -> m)
-> (forall m a. Monoid m => (a -> m) -> Metrics a -> m)
-> (forall a b. (a -> b -> b) -> b -> Metrics a -> b)
-> (forall a b. (a -> b -> b) -> b -> Metrics a -> b)
-> (forall b a. (b -> a -> b) -> b -> Metrics a -> b)
-> (forall b a. (b -> a -> b) -> b -> Metrics a -> b)
-> (forall a. (a -> a -> a) -> Metrics a -> a)
-> (forall a. (a -> a -> a) -> Metrics a -> a)
-> (forall a. Metrics a -> [a])
-> (forall a. Metrics a -> Bool)
-> (forall a. Metrics a -> Int)
-> (forall a. Eq a => a -> Metrics a -> Bool)
-> (forall a. Ord a => Metrics a -> a)
-> (forall a. Ord a => Metrics a -> a)
-> (forall a. Num a => Metrics a -> a)
-> (forall a. Num a => Metrics a -> a)
-> Foldable Metrics
forall a. Eq a => a -> Metrics a -> Bool
forall a. Num a => Metrics a -> a
forall a. Ord a => Metrics a -> a
forall m. Monoid m => Metrics m -> m
forall a. Metrics a -> Bool
forall a. Metrics a -> Int
forall a. Metrics a -> [a]
forall a. (a -> a -> a) -> Metrics a -> a
forall m a. Monoid m => (a -> m) -> Metrics a -> m
forall b a. (b -> a -> b) -> b -> Metrics a -> b
forall a b. (a -> b -> b) -> b -> Metrics a -> b
forall (t :: * -> *).
(forall m. Monoid m => t m -> m)
-> (forall m a. Monoid m => (a -> m) -> t a -> m)
-> (forall m a. Monoid m => (a -> m) -> t a -> m)
-> (forall a b. (a -> b -> b) -> b -> t a -> b)
-> (forall a b. (a -> b -> b) -> b -> t a -> b)
-> (forall b a. (b -> a -> b) -> b -> t a -> b)
-> (forall b a. (b -> a -> b) -> b -> t a -> b)
-> (forall a. (a -> a -> a) -> t a -> a)
-> (forall a. (a -> a -> a) -> t a -> a)
-> (forall a. t a -> [a])
-> (forall a. t a -> Bool)
-> (forall a. t a -> Int)
-> (forall a. Eq a => a -> t a -> Bool)
-> (forall a. Ord a => t a -> a)
-> (forall a. Ord a => t a -> a)
-> (forall a. Num a => t a -> a)
-> (forall a. Num a => t a -> a)
-> Foldable t
product :: Metrics a -> a
$cproduct :: forall a. Num a => Metrics a -> a
sum :: Metrics a -> a
$csum :: forall a. Num a => Metrics a -> a
minimum :: Metrics a -> a
$cminimum :: forall a. Ord a => Metrics a -> a
maximum :: Metrics a -> a
$cmaximum :: forall a. Ord a => Metrics a -> a
elem :: a -> Metrics a -> Bool
$celem :: forall a. Eq a => a -> Metrics a -> Bool
length :: Metrics a -> Int
$clength :: forall a. Metrics a -> Int
null :: Metrics a -> Bool
$cnull :: forall a. Metrics a -> Bool
toList :: Metrics a -> [a]
$ctoList :: forall a. Metrics a -> [a]
foldl1 :: (a -> a -> a) -> Metrics a -> a
$cfoldl1 :: forall a. (a -> a -> a) -> Metrics a -> a
foldr1 :: (a -> a -> a) -> Metrics a -> a
$cfoldr1 :: forall a. (a -> a -> a) -> Metrics a -> a
foldl' :: (b -> a -> b) -> b -> Metrics a -> b
$cfoldl' :: forall b a. (b -> a -> b) -> b -> Metrics a -> b
foldl :: (b -> a -> b) -> b -> Metrics a -> b
$cfoldl :: forall b a. (b -> a -> b) -> b -> Metrics a -> b
foldr' :: (a -> b -> b) -> b -> Metrics a -> b
$cfoldr' :: forall a b. (a -> b -> b) -> b -> Metrics a -> b
foldr :: (a -> b -> b) -> b -> Metrics a -> b
$cfoldr :: forall a b. (a -> b -> b) -> b -> Metrics a -> b
foldMap' :: (a -> m) -> Metrics a -> m
$cfoldMap' :: forall m a. Monoid m => (a -> m) -> Metrics a -> m
foldMap :: (a -> m) -> Metrics a -> m
$cfoldMap :: forall m a. Monoid m => (a -> m) -> Metrics a -> m
fold :: Metrics m -> m
$cfold :: forall m. Monoid m => Metrics m -> m
Foldable, Functor Metrics
Foldable Metrics
Functor Metrics
-> Foldable Metrics
-> (forall (f :: * -> *) a b.
    Applicative f =>
    (a -> f b) -> Metrics a -> f (Metrics b))
-> (forall (f :: * -> *) a.
    Applicative f =>
    Metrics (f a) -> f (Metrics a))
-> (forall (m :: * -> *) a b.
    Monad m =>
    (a -> m b) -> Metrics a -> m (Metrics b))
-> (forall (m :: * -> *) a.
    Monad m =>
    Metrics (m a) -> m (Metrics a))
-> Traversable Metrics
(a -> f b) -> Metrics a -> f (Metrics b)
forall (t :: * -> *).
Functor t
-> Foldable t
-> (forall (f :: * -> *) a b.
    Applicative f =>
    (a -> f b) -> t a -> f (t b))
-> (forall (f :: * -> *) a. Applicative f => t (f a) -> f (t a))
-> (forall (m :: * -> *) a b.
    Monad m =>
    (a -> m b) -> t a -> m (t b))
-> (forall (m :: * -> *) a. Monad m => t (m a) -> m (t a))
-> Traversable t
forall (m :: * -> *) a. Monad m => Metrics (m a) -> m (Metrics a)
forall (f :: * -> *) a.
Applicative f =>
Metrics (f a) -> f (Metrics a)
forall (m :: * -> *) a b.
Monad m =>
(a -> m b) -> Metrics a -> m (Metrics b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> Metrics a -> f (Metrics b)
sequence :: Metrics (m a) -> m (Metrics a)
$csequence :: forall (m :: * -> *) a. Monad m => Metrics (m a) -> m (Metrics a)
mapM :: (a -> m b) -> Metrics a -> m (Metrics b)
$cmapM :: forall (m :: * -> *) a b.
Monad m =>
(a -> m b) -> Metrics a -> m (Metrics b)
sequenceA :: Metrics (f a) -> f (Metrics a)
$csequenceA :: forall (f :: * -> *) a.
Applicative f =>
Metrics (f a) -> f (Metrics a)
traverse :: (a -> f b) -> Metrics a -> f (Metrics b)
$ctraverse :: forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> Metrics a -> f (Metrics b)
$cp2Traversable :: Foldable Metrics
$cp1Traversable :: Functor Metrics
Traversable)

-- | Create the IORefs which capture the metric values.
mkMetricRefs :: Concurrent.MonadConc m => m (Metrics (Concurrent.IORef m Natural))
mkMetricRefs :: m (Metrics (IORef m Natural))
mkMetricRefs =
  IORef m Natural
-> IORef m Natural -> IORef m Natural -> Metrics (IORef m Natural)
forall a. a -> a -> a -> Metrics a
Metrics
    (IORef m Natural
 -> IORef m Natural -> IORef m Natural -> Metrics (IORef m Natural))
-> m (IORef m Natural)
-> m (IORef m Natural
      -> IORef m Natural -> Metrics (IORef m Natural))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> Natural -> m (IORef m Natural)
forall (m :: * -> *) a. MonadConc m => String -> a -> m (IORef m a)
Concurrent.newIORefN String
"created" Natural
0
    m (IORef m Natural -> IORef m Natural -> Metrics (IORef m Natural))
-> m (IORef m Natural)
-> m (IORef m Natural -> Metrics (IORef m Natural))
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> String -> Natural -> m (IORef m Natural)
forall (m :: * -> *) a. MonadConc m => String -> a -> m (IORef m a)
Concurrent.newIORefN String
"destroyed" Natural
0
    m (IORef m Natural -> Metrics (IORef m Natural))
-> m (IORef m Natural) -> m (Metrics (IORef m Natural))
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> String -> Natural -> m (IORef m Natural)
forall (m :: * -> *) a. MonadConc m => String -> a -> m (IORef m a)
Concurrent.newIORefN String
"maxLive" Natural
0

-- | Read all the metric values.
readMetricRefs :: Concurrent.MonadConc m => Metrics (Concurrent.IORef m a) -> m (Metrics a)
readMetricRefs :: Metrics (IORef m a) -> m (Metrics a)
readMetricRefs = (IORef m a -> m a) -> Metrics (IORef m a) -> m (Metrics a)
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse IORef m a -> m a
forall (m :: * -> *) a. MonadConc m => IORef m a -> m a
Concurrent.readIORef

-- | Increase a value held by an IORef by one.
succIORef :: (Concurrent.MonadConc m, Enum a) => Concurrent.IORef m a -> m ()
succIORef :: IORef m a -> m ()
succIORef IORef m a
ref = IORef m a -> (a -> (a, ())) -> m ()
forall (m :: * -> *) a b.
MonadConc m =>
IORef m a -> (a -> (a, b)) -> m b
Concurrent.atomicModifyIORef' IORef m a
ref (\a
x -> (a -> a
forall a. Enum a => a -> a
succ a
x, ()))

-- | Replace the value in an IORef with the given value if the latter is greater.
maxIORef :: (Concurrent.MonadConc m, Ord a) => Concurrent.IORef m a -> a -> m ()
maxIORef :: IORef m a -> a -> m ()
maxIORef IORef m a
ref a
y = IORef m a -> (a -> (a, ())) -> m ()
forall (m :: * -> *) a b.
MonadConc m =>
IORef m a -> (a -> (a, b)) -> m b
Concurrent.atomicModifyIORef' IORef m a
ref (\a
x -> (a -> a -> a
forall a. Ord a => a -> a -> a
max a
x a
y, ()))