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

module Simpoole
  ( Pool
  , mapPool
  , newPool
  , withResource
  , acquireResource
  , returnResource
  , destroyResource
  , poolMetrics

  , Settings (..)
  , defaultSettings
  , ReturnPolicy (..)

  , 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.Coerce (coerce)
import           Data.Foldable (for_)
import qualified Data.Sequence as Seq
import qualified Data.Time as Time
import           Numeric.Natural (Natural)
import           Simpoole.Internal (FailToIO (..), failToIO)

-- | Strategy to use when returning resources to the pool
--
-- @since 0.1.0
data ReturnPolicy
  = ReturnToFront
  -- ^ Return resources to the front. Resources that have been used recently are more likely to be
  -- reused again quicker.
  --
  -- This strategy is good if you want to scale down the pool more quickly in case resources are not
  -- needed.
  --
  -- @since 0.1.0
  | ReturnToBack
  -- ^ Return resources to the back. Resources that have been used recently are less likely to be
  -- used again quicker.
  --
  -- Use this strategy if you want to keep more resources in the pool fresh, or when maintaining the
  -- pool in order to be ready for burst workloads.
  --
  -- Note: This strategy can lead to no resources ever being destroyed when all resources are
  -- repeatedly used within the idle timeout.
  --
  -- @since 0.1.0
  | ReturnToMiddle
  -- ^ Return resources to the middle. This offers a middleground between 'ReturnToFront' and
  -- 'ReturnToBack'. By ensuring that the starting sub-sequence of resources is reused quicker but
  -- the trailing sub-sequence is not and therefore released more easily.
  --
  -- @since 0.1.0
  deriving stock (Int -> ReturnPolicy -> ShowS
[ReturnPolicy] -> ShowS
ReturnPolicy -> String
(Int -> ReturnPolicy -> ShowS)
-> (ReturnPolicy -> String)
-> ([ReturnPolicy] -> ShowS)
-> Show ReturnPolicy
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [ReturnPolicy] -> ShowS
$cshowList :: [ReturnPolicy] -> ShowS
show :: ReturnPolicy -> String
$cshow :: ReturnPolicy -> String
showsPrec :: Int -> ReturnPolicy -> ShowS
$cshowsPrec :: Int -> ReturnPolicy -> ShowS
Show, ReadPrec [ReturnPolicy]
ReadPrec ReturnPolicy
Int -> ReadS ReturnPolicy
ReadS [ReturnPolicy]
(Int -> ReadS ReturnPolicy)
-> ReadS [ReturnPolicy]
-> ReadPrec ReturnPolicy
-> ReadPrec [ReturnPolicy]
-> Read ReturnPolicy
forall a.
(Int -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
readListPrec :: ReadPrec [ReturnPolicy]
$creadListPrec :: ReadPrec [ReturnPolicy]
readPrec :: ReadPrec ReturnPolicy
$creadPrec :: ReadPrec ReturnPolicy
readList :: ReadS [ReturnPolicy]
$creadList :: ReadS [ReturnPolicy]
readsPrec :: Int -> ReadS ReturnPolicy
$creadsPrec :: Int -> ReadS ReturnPolicy
Read, ReturnPolicy -> ReturnPolicy -> Bool
(ReturnPolicy -> ReturnPolicy -> Bool)
-> (ReturnPolicy -> ReturnPolicy -> Bool) -> Eq ReturnPolicy
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: ReturnPolicy -> ReturnPolicy -> Bool
$c/= :: ReturnPolicy -> ReturnPolicy -> Bool
== :: ReturnPolicy -> ReturnPolicy -> Bool
$c== :: ReturnPolicy -> ReturnPolicy -> Bool
Eq, Eq ReturnPolicy
Eq ReturnPolicy
-> (ReturnPolicy -> ReturnPolicy -> Ordering)
-> (ReturnPolicy -> ReturnPolicy -> Bool)
-> (ReturnPolicy -> ReturnPolicy -> Bool)
-> (ReturnPolicy -> ReturnPolicy -> Bool)
-> (ReturnPolicy -> ReturnPolicy -> Bool)
-> (ReturnPolicy -> ReturnPolicy -> ReturnPolicy)
-> (ReturnPolicy -> ReturnPolicy -> ReturnPolicy)
-> Ord ReturnPolicy
ReturnPolicy -> ReturnPolicy -> Bool
ReturnPolicy -> ReturnPolicy -> Ordering
ReturnPolicy -> ReturnPolicy -> ReturnPolicy
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 :: ReturnPolicy -> ReturnPolicy -> ReturnPolicy
$cmin :: ReturnPolicy -> ReturnPolicy -> ReturnPolicy
max :: ReturnPolicy -> ReturnPolicy -> ReturnPolicy
$cmax :: ReturnPolicy -> ReturnPolicy -> ReturnPolicy
>= :: ReturnPolicy -> ReturnPolicy -> Bool
$c>= :: ReturnPolicy -> ReturnPolicy -> Bool
> :: ReturnPolicy -> ReturnPolicy -> Bool
$c> :: ReturnPolicy -> ReturnPolicy -> Bool
<= :: ReturnPolicy -> ReturnPolicy -> Bool
$c<= :: ReturnPolicy -> ReturnPolicy -> Bool
< :: ReturnPolicy -> ReturnPolicy -> Bool
$c< :: ReturnPolicy -> ReturnPolicy -> Bool
compare :: ReturnPolicy -> ReturnPolicy -> Ordering
$ccompare :: ReturnPolicy -> ReturnPolicy -> Ordering
$cp1Ord :: Eq ReturnPolicy
Ord, Int -> ReturnPolicy
ReturnPolicy -> Int
ReturnPolicy -> [ReturnPolicy]
ReturnPolicy -> ReturnPolicy
ReturnPolicy -> ReturnPolicy -> [ReturnPolicy]
ReturnPolicy -> ReturnPolicy -> ReturnPolicy -> [ReturnPolicy]
(ReturnPolicy -> ReturnPolicy)
-> (ReturnPolicy -> ReturnPolicy)
-> (Int -> ReturnPolicy)
-> (ReturnPolicy -> Int)
-> (ReturnPolicy -> [ReturnPolicy])
-> (ReturnPolicy -> ReturnPolicy -> [ReturnPolicy])
-> (ReturnPolicy -> ReturnPolicy -> [ReturnPolicy])
-> (ReturnPolicy -> ReturnPolicy -> ReturnPolicy -> [ReturnPolicy])
-> Enum ReturnPolicy
forall a.
(a -> a)
-> (a -> a)
-> (Int -> a)
-> (a -> Int)
-> (a -> [a])
-> (a -> a -> [a])
-> (a -> a -> [a])
-> (a -> a -> a -> [a])
-> Enum a
enumFromThenTo :: ReturnPolicy -> ReturnPolicy -> ReturnPolicy -> [ReturnPolicy]
$cenumFromThenTo :: ReturnPolicy -> ReturnPolicy -> ReturnPolicy -> [ReturnPolicy]
enumFromTo :: ReturnPolicy -> ReturnPolicy -> [ReturnPolicy]
$cenumFromTo :: ReturnPolicy -> ReturnPolicy -> [ReturnPolicy]
enumFromThen :: ReturnPolicy -> ReturnPolicy -> [ReturnPolicy]
$cenumFromThen :: ReturnPolicy -> ReturnPolicy -> [ReturnPolicy]
enumFrom :: ReturnPolicy -> [ReturnPolicy]
$cenumFrom :: ReturnPolicy -> [ReturnPolicy]
fromEnum :: ReturnPolicy -> Int
$cfromEnum :: ReturnPolicy -> Int
toEnum :: Int -> ReturnPolicy
$ctoEnum :: Int -> ReturnPolicy
pred :: ReturnPolicy -> ReturnPolicy
$cpred :: ReturnPolicy -> ReturnPolicy
succ :: ReturnPolicy -> ReturnPolicy
$csucc :: ReturnPolicy -> ReturnPolicy
Enum, ReturnPolicy
ReturnPolicy -> ReturnPolicy -> Bounded ReturnPolicy
forall a. a -> a -> Bounded a
maxBound :: ReturnPolicy
$cmaxBound :: ReturnPolicy
minBound :: ReturnPolicy
$cminBound :: ReturnPolicy
Bounded)

-- | Insert a value based on the return policy.
applyReturnPolicy :: ReturnPolicy -> a -> Seq.Seq a -> Seq.Seq a
applyReturnPolicy :: ReturnPolicy -> a -> Seq a -> Seq a
applyReturnPolicy ReturnPolicy
policy a
value Seq a
seq =
  case ReturnPolicy
policy of
    ReturnPolicy
ReturnToFront -> a
value a -> Seq a -> Seq a
forall a. a -> Seq a -> Seq a
Seq.<| Seq a
seq
    ReturnPolicy
ReturnToBack -> Seq a
seq Seq a -> a -> Seq a
forall a. Seq a -> a -> Seq a
Seq.|> a
value
    ReturnPolicy
ReturnToMiddle -> Int -> a -> Seq a -> Seq a
forall a. Int -> a -> Seq a -> Seq a
Seq.insertAt Int
middleIndex a
value Seq a
seq
  where
    middleIndex :: Int
middleIndex
      | Int -> Bool
forall a. Integral a => a -> Bool
even (Seq a -> Int
forall a. Seq a -> Int
Seq.length Seq a
seq) = Int -> Int -> Int
forall a. Integral a => a -> a -> a
div (Seq a -> Int
forall a. Seq a -> Int
Seq.length Seq a
seq) Int
2
      | Bool
otherwise = Int -> Int -> Int
forall a. Integral a => a -> a -> a
div (Seq a -> Int
forall a. Seq a -> Int
Seq.length Seq a
seq) Int
2 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1

-- | Lets you configure certain behaviours of the pool
--
-- @since 0.1.0
data Settings = Settings -- ^ @since 0.2.0
  { Settings -> Maybe NominalDiffTime
settings_idleTimeout :: Maybe Time.NominalDiffTime
  -- ^ Maximum idle time after which a resource is destroyed
  --
  -- Setting it to @Nothing@ means that nothing will ever be destroyed based on idle time.
  --
  -- @since 0.1.0
  , Settings -> ReturnPolicy
settings_returnPolicy :: ReturnPolicy
  -- ^ Read documentation on 'ReturnPolicy' for details.
  --
  -- @since 0.1.0
  , Settings -> Maybe Int
settings_maxLiveLimit :: Maybe Int
  -- ^ Maximum number of resources that may live at the same time.
  --
  -- @Nothing@ means unlimited.
  --
  -- @since 0.2.0
  }

-- | Default pool settings
--
-- @since 0.1.0
defaultSettings :: Settings
defaultSettings :: Settings
defaultSettings = Settings :: Maybe NominalDiffTime -> ReturnPolicy -> Maybe Int -> Settings
Settings
  { settings_idleTimeout :: Maybe NominalDiffTime
settings_idleTimeout = NominalDiffTime -> Maybe NominalDiffTime
forall a. a -> Maybe a
Just NominalDiffTime
60 -- 60 seconds
  , settings_returnPolicy :: ReturnPolicy
settings_returnPolicy = ReturnPolicy
ReturnToMiddle
  , settings_maxLiveLimit :: Maybe Int
settings_maxLiveLimit = Maybe Int
forall a. Maybe a
Nothing
  }

-- | 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 item

-- | Create a new pool that has no limit on how many resources it may create and hold.
newUnlimitedPool
  :: (Concurrent.MonadConc m, MonadIO m)
  => m a
  -- ^ Resource creation
  -> (a -> m ())
  -- ^ Resource destruction
  -> Settings
  -- ^ Pool settings
  -> m (Pool m a)
newUnlimitedPool :: m a -> (a -> m ()) -> Settings -> m (Pool m a)
newUnlimitedPool m a
create a -> m ()
destroy Settings
settings = 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

  IORef m Natural
createdRef <- String -> Natural -> m (IORef m Natural)
forall (m :: * -> *) a. MonadConc m => String -> a -> m (IORef m a)
Concurrent.newIORefN String
"created" Natural
0
  IORef m Natural
destroyedRef <- String -> Natural -> m (IORef m Natural)
forall (m :: * -> *) a. MonadConc m => String -> a -> m (IORef m a)
Concurrent.newIORefN String
"destroyed" Natural
0
  IORef m Natural
maxLiveRef <- String -> Natural -> m (IORef m Natural)
forall (m :: * -> *) a. MonadConc m => String -> a -> m (IORef m a)
Concurrent.newIORefN String
"maxLive" Natural
0

  let
    getMetrics :: m (Metrics Natural)
getMetrics = do
      Natural
created <- IORef m Natural -> m Natural
forall (m :: * -> *) a. MonadConc m => IORef m a -> m a
Concurrent.readIORef IORef m Natural
createdRef
      Natural
destroyed <- IORef m Natural -> m Natural
forall (m :: * -> *) a. MonadConc m => IORef m a -> m a
Concurrent.readIORef IORef m Natural
destroyedRef
      Natural
maxLive <- IORef m Natural -> m Natural
forall (m :: * -> *) a. MonadConc m => IORef m a -> m a
Concurrent.readIORef IORef m Natural
maxLiveRef
      Seq (Resource a)
leftOvers <- IORef m (Seq (Resource a)) -> m (Seq (Resource a))
forall (m :: * -> *) a. MonadConc m => IORef m a -> m a
Concurrent.readIORef IORef m (Seq (Resource a))
leftOversRef

      Metrics Natural -> m (Metrics Natural)
forall (f :: * -> *) a. Applicative f => a -> f a
pure Metrics :: forall a. a -> a -> a -> a -> Metrics a
Metrics
        { metrics_createdResources :: Natural
metrics_createdResources = Natural
created
        , metrics_destroyedResources :: Natural
metrics_destroyedResources = Natural
destroyed
        , metrics_maxLiveResources :: Natural
metrics_maxLiveResources = Natural
maxLive
        , metrics_idleResources :: Natural
metrics_idleResources = Int -> Natural
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Seq (Resource a) -> Int
forall a. Seq a -> Int
Seq.length Seq (Resource a)
leftOvers)
        }

    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 IORef m Natural
createdRef
      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 IORef m Natural
destroyedRef

    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 IORef m Natural
destroyedRef
      Natural
numCreated <- IORef m Natural -> m Natural
forall (m :: * -> *) a. MonadConc m => IORef m a -> m a
Concurrent.readIORef IORef m Natural
createdRef
      IORef m Natural -> Natural -> m ()
forall (m :: * -> *) a.
(MonadConc m, Ord a) =>
IORef m a -> a -> m ()
maxIORef IORef m Natural
maxLiveRef (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 ->
        ( ReturnPolicy -> Resource a -> Seq (Resource a) -> Seq (Resource a)
forall a. ReturnPolicy -> a -> Seq a -> Seq a
applyReturnPolicy (Settings -> ReturnPolicy
settings_returnPolicy Settings
settings) (UTCTime -> a -> Resource a
forall a. UTCTime -> a -> Resource a
Resource UTCTime
now a
value) Seq (Resource a)
leftOvers
        , ()
        )

  Maybe NominalDiffTime -> (NominalDiffTime -> m ()) -> m ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
t a -> (a -> f b) -> f ()
for_ (Settings -> Maybe NominalDiffTime
settings_idleTimeout Settings
settings) ((NominalDiffTime -> m ()) -> m ())
-> (NominalDiffTime -> m ()) -> m ()
forall a b. (a -> b) -> a -> b
$ \NominalDiffTime
idleTimeout -> m (Async m Any) -> m ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (m (Async m Any) -> m ()) -> m (Async m Any) -> m ()
forall a b. (a -> b) -> a -> b
$
    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
idleTimeout

      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 = m (Metrics Natural)
getMetrics
    }

-- | 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.
newLimitedPool
  :: (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
  -> Settings
  -- ^ Pool settings
  -> m (Pool m a)
newLimitedPool :: m a -> (a -> m ()) -> Int -> Settings -> m (Pool m a)
newLimitedPool m a
create a -> m ()
destroy Int
maxElems Settings
settings = do
  Pool m a
basePool <- m a -> (a -> m ()) -> Settings -> m (Pool m a)
forall (m :: * -> *) a.
(MonadConc m, MonadIO m) =>
m a -> (a -> m ()) -> Settings -> m (Pool m a)
newUnlimitedPool m a
create a -> m ()
destroy Settings
settings
  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
    }

-- | Create a new pool.
--
-- @since 0.2.0
newPool
  :: (Concurrent.MonadConc m, MonadIO m)
  => m a
  -- ^ Resource creation
  -> (a -> m ())
  -- ^ Resource destruction
  -> Settings
  -- ^ Pool settings
  -> m (Pool m a)
newPool :: m a -> (a -> m ()) -> Settings -> m (Pool m a)
newPool m a
create a -> m ()
destroy Settings
settings =
  case Settings -> Maybe Int
settings_maxLiveLimit Settings
settings of
    Just Int
maxLive -> FailToIO m (Pool m a) -> m (Pool m a)
forall (m :: * -> *) a. FailToIO m a -> m a
failToIO (FailToIO m (Pool m a) -> m (Pool m a))
-> FailToIO m (Pool m a) -> m (Pool m a)
forall a b. (a -> b) -> a -> b
$ do -- Translate the MonadFail constraint to MonadIO.
      Pool (FailToIO m) a
pool <- FailToIO m a
-> (a -> FailToIO m ())
-> Int
-> Settings
-> FailToIO m (Pool (FailToIO m) a)
forall (m :: * -> *) a.
(MonadConc m, MonadIO m, MonadFail m) =>
m a -> (a -> m ()) -> Int -> Settings -> m (Pool m a)
newLimitedPool (m a -> FailToIO m a
coerce m a
create) ((a -> m ()) -> a -> FailToIO m ()
coerce a -> m ()
destroy) Int
maxLive Settings
settings
      Pool m a -> FailToIO m (Pool m a)
forall (f :: * -> *) a. Applicative f => a -> f a
pure ((forall x. FailToIO m x -> m x) -> Pool (FailToIO m) a -> Pool m a
forall (m :: * -> *) (n :: * -> *) a.
(forall x. m x -> n x) -> Pool m a -> Pool n a
mapPool forall x. FailToIO m x -> m x
coerce Pool (FailToIO m) a
pool)

    Maybe Int
Nothing -> m a -> (a -> m ()) -> Settings -> m (Pool m a)
forall (m :: * -> *) a.
(MonadConc m, MonadIO m) =>
m a -> (a -> m ()) -> Settings -> m (Pool m a)
newUnlimitedPool m a
create a -> m ()
destroy Settings
settings

-- | Use a resource from the pool. Once the continuation returns, the resource will be returned to
-- the pool. If the given continuation throws an error then the acquired resource will be destroyed
-- instead.
--
-- @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 #-}

-- | Acquire a resource.
--
-- @since 0.1.0
acquireResource :: Pool m a -> m a
acquireResource :: Pool m a -> m a
acquireResource = Pool m a -> m a
forall (m :: * -> *) a. Pool m a -> m a
pool_acquire

{-# INLINE acquireResource #-}

-- | Return a resource to the pool.
--
-- @since 0.1.0
returnResource :: Pool m a -> a -> m ()
returnResource :: Pool m a -> a -> m ()
returnResource = Pool m a -> a -> m ()
forall (m :: * -> *) a. Pool m a -> a -> m ()
pool_return

{-# INLINE returnResource #-}

-- | Destroy a resource.
--
-- @since 0.1.0
destroyResource :: Pool m a -> a -> m ()
destroyResource :: Pool m a -> a -> m ()
destroyResource = Pool m a -> a -> m ()
forall (m :: * -> *) a. Pool m a -> a -> m ()
pool_destroy

{-# INLINE destroyResource #-}

-- | 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
  , Metrics a -> a
metrics_idleResources :: a
  -- ^ Number of resources currently idle
  --
  -- @since 0.1.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)

-- | 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, ()))