{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE ExplicitForAll #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE ScopedTypeVariables #-}
module System.Wlog.Concurrent
( WaitingDelta (..)
, CanLogInParallel
, logWarningLongAction
, logWarningWaitOnce
, logWarningWaitLinear
, logWarningWaitInf
) where
import Universum
import Control.Concurrent.Async.Lifted (withAsyncWithUnmask)
import Control.Monad.Trans.Control (MonadBaseControl)
import Fmt ((+|), (+||), (|+), (||+))
import GHC.Real ((%))
import Time (RatioNat, Second, Time, threadDelay, timeMul)
import System.Wlog.CanLog (WithLoggerIO, logWarning)
data WaitingDelta
= WaitOnce (Time Second)
| WaitLinear (Time Second)
| WaitGeometric (Time Second) RatioNat
deriving (Show)
type CanLogInParallel m = (MonadBaseControl IO m, WithLoggerIO m)
logWarningLongAction :: forall m a . CanLogInParallel m
=> (Text -> m ()) -> WaitingDelta -> Text -> m a -> m a
logWarningLongAction logFunc delta actionTag action =
withAsyncWithUnmask (\unmask -> unmask $ waitAndWarn delta) (const action)
where
printWarning :: Time Second -> m ()
printWarning t = logFunc $ "Action `"+|actionTag|+"` took more than "+||t||+""
waitAndWarn :: WaitingDelta -> m ()
waitAndWarn (WaitOnce s) = delayAndPrint s s
waitAndWarn (WaitLinear s) =
let waitLoop :: Time Second -> m ()
waitLoop acc = do
delayAndPrint s acc
waitLoop (acc + s)
in waitLoop s
waitAndWarn (WaitGeometric ms k) =
let waitLoop :: Time Second -> Time Second -> m ()
waitLoop acc delayT = do
let newAcc = acc + delayT
let newDelayT = k `timeMul` delayT
delayAndPrint delayT newAcc
waitLoop newAcc newDelayT
in waitLoop 0 ms
delayAndPrint :: Time Second -> Time Second -> m ()
delayAndPrint delayT printT = do
threadDelay delayT
printWarning printT
logWarningWaitOnce :: CanLogInParallel m => Time Second -> Text -> m a -> m a
logWarningWaitOnce = logWarningLongAction logWarning . WaitOnce
logWarningWaitLinear :: CanLogInParallel m => Time Second -> Text -> m a -> m a
logWarningWaitLinear = logWarningLongAction logWarning . WaitLinear
logWarningWaitInf :: CanLogInParallel m => Time Second -> Text -> m a -> m a
logWarningWaitInf = logWarningLongAction logWarning
. (`WaitGeometric` (13 % 10))