{-# LANGUAGE LambdaCase #-}
module Xmobar.Run.Timer
( doEveryTenthSeconds
, tenthSeconds
, withTimer
) where
import Control.Concurrent (threadDelay)
import Control.Concurrent.Async (withAsync)
import Control.Concurrent.STM
import Control.Exception
import Control.Monad (forever, forM, guard)
import Data.Foldable (foldrM, for_)
import Data.Int (Int64)
import Data.Map (Map)
import qualified Data.Map as M
import Data.Maybe (isJust, fromJust)
import Data.Time.Clock.POSIX (getPOSIXTime)
import Data.Unique
import System.IO.Unsafe (unsafePerformIO)
type Periods = Map Unique Period
data Tick = Tick (TMVar ()) | UnCoalesce
data Period = Period { Period -> Int64
rate :: Int64, Period -> Int64
next :: Int64, Period -> TMVar Tick
tick :: TMVar Tick }
data UnCoalesceException = UnCoalesceException deriving Int -> UnCoalesceException -> ShowS
[UnCoalesceException] -> ShowS
UnCoalesceException -> String
(Int -> UnCoalesceException -> ShowS)
-> (UnCoalesceException -> String)
-> ([UnCoalesceException] -> ShowS)
-> Show UnCoalesceException
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [UnCoalesceException] -> ShowS
$cshowList :: [UnCoalesceException] -> ShowS
show :: UnCoalesceException -> String
$cshow :: UnCoalesceException -> String
showsPrec :: Int -> UnCoalesceException -> ShowS
$cshowsPrec :: Int -> UnCoalesceException -> ShowS
Show
instance Exception UnCoalesceException
{-# NOINLINE periodsVar #-}
periodsVar :: TVar (Maybe Periods)
periodsVar :: TVar (Maybe Periods)
periodsVar = IO (TVar (Maybe Periods)) -> TVar (Maybe Periods)
forall a. IO a -> a
unsafePerformIO (IO (TVar (Maybe Periods)) -> TVar (Maybe Periods))
-> IO (TVar (Maybe Periods)) -> TVar (Maybe Periods)
forall a b. (a -> b) -> a -> b
$ Maybe Periods -> IO (TVar (Maybe Periods))
forall a. a -> IO (TVar a)
newTVarIO Maybe Periods
forall a. Maybe a
Nothing
now :: IO Int64
now :: IO Int64
now = do
POSIXTime
posix <- IO POSIXTime
getPOSIXTime
Int64 -> IO Int64
forall (m :: * -> *) a. Monad m => a -> m a
return (Int64 -> IO Int64) -> Int64 -> IO Int64
forall a b. (a -> b) -> a -> b
$ POSIXTime -> Int64
forall a b. (RealFrac a, Integral b) => a -> b
floor (POSIXTime
10 POSIXTime -> POSIXTime -> POSIXTime
forall a. Num a => a -> a -> a
* POSIXTime
posix)
newPeriod :: Int64 -> IO (Unique, Period)
newPeriod :: Int64 -> IO (Unique, Period)
newPeriod Int64
r = do
Unique
u <- IO Unique
newUnique
Int64
t <- IO Int64
now
TMVar Tick
v <- IO (TMVar Tick)
forall a. IO (TMVar a)
newEmptyTMVarIO
let t' :: Int64
t' = Int64
t Int64 -> Int64 -> Int64
forall a. Num a => a -> a -> a
- Int64
t Int64 -> Int64 -> Int64
forall a. Integral a => a -> a -> a
`mod` Int64
r
(Unique, Period) -> IO (Unique, Period)
forall (m :: * -> *) a. Monad m => a -> m a
return (Unique
u, Period :: Int64 -> Int64 -> TMVar Tick -> Period
Period { rate :: Int64
rate = Int64
r, next :: Int64
next = Int64
t', tick :: TMVar Tick
tick = TMVar Tick
v })
doEveryTenthSeconds :: Int -> IO () -> IO ()
doEveryTenthSeconds :: Int -> IO () -> IO ()
doEveryTenthSeconds Int
r IO ()
action =
Int -> IO () -> IO ()
doEveryTenthSecondsCoalesced Int
r IO ()
action IO () -> (UnCoalesceException -> IO ()) -> IO ()
forall e a. Exception e => IO a -> (e -> IO a) -> IO a
`catch` \UnCoalesceException
UnCoalesceException ->
Int -> IO () -> IO ()
doEveryTenthSecondsSleeping Int
r IO ()
action
doEveryTenthSecondsCoalesced :: Int -> IO () -> IO ()
doEveryTenthSecondsCoalesced :: Int -> IO () -> IO ()
doEveryTenthSecondsCoalesced Int
r IO ()
action = do
(Unique
u, Period
p) <- Int64 -> IO (Unique, Period)
newPeriod (Int -> Int64
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
r)
IO () -> IO () -> IO () -> IO ()
forall a b c. IO a -> IO b -> IO c -> IO c
bracket_ (Unique -> Period -> IO ()
push Unique
u Period
p) (Unique -> IO ()
pop Unique
u) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ IO () -> IO ()
forall (f :: * -> *) a b. Applicative f => f a -> f b
forever (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ IO (TMVar ())
-> (TMVar () -> IO ()) -> (TMVar () -> IO ()) -> IO ()
forall a b c. IO a -> (a -> IO b) -> (a -> IO c) -> IO c
bracket (Period -> IO (TMVar ())
wait Period
p) TMVar () -> IO ()
done ((TMVar () -> IO ()) -> IO ()) -> (TMVar () -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ IO () -> TMVar () -> IO ()
forall a b. a -> b -> a
const IO ()
action
where
push :: Unique -> Period -> IO ()
push Unique
u Period
p = STM () -> IO ()
forall a. STM a -> IO a
atomically (STM () -> IO ()) -> STM () -> IO ()
forall a b. (a -> b) -> a -> b
$ TVar (Maybe Periods) -> (Maybe Periods -> Maybe Periods) -> STM ()
forall a. TVar a -> (a -> a) -> STM ()
modifyTVar' TVar (Maybe Periods)
periodsVar ((Maybe Periods -> Maybe Periods) -> STM ())
-> (Maybe Periods -> Maybe Periods) -> STM ()
forall a b. (a -> b) -> a -> b
$ \case
Just Periods
periods -> Periods -> Maybe Periods
forall a. a -> Maybe a
Just (Periods -> Maybe Periods) -> Periods -> Maybe Periods
forall a b. (a -> b) -> a -> b
$ Unique -> Period -> Periods -> Periods
forall k a. Ord k => k -> a -> Map k a -> Map k a
M.insert Unique
u Period
p Periods
periods
Maybe Periods
Nothing -> UnCoalesceException -> Maybe Periods
forall a e. Exception e => e -> a
throw UnCoalesceException
UnCoalesceException
pop :: Unique -> IO ()
pop Unique
u = STM () -> IO ()
forall a. STM a -> IO a
atomically (STM () -> IO ()) -> STM () -> IO ()
forall a b. (a -> b) -> a -> b
$ TVar (Maybe Periods) -> (Maybe Periods -> Maybe Periods) -> STM ()
forall a. TVar a -> (a -> a) -> STM ()
modifyTVar' TVar (Maybe Periods)
periodsVar ((Maybe Periods -> Maybe Periods) -> STM ())
-> (Maybe Periods -> Maybe Periods) -> STM ()
forall a b. (a -> b) -> a -> b
$ \case
Just Periods
periods -> Periods -> Maybe Periods
forall a. a -> Maybe a
Just (Periods -> Maybe Periods) -> Periods -> Maybe Periods
forall a b. (a -> b) -> a -> b
$ Unique -> Periods -> Periods
forall k a. Ord k => k -> Map k a -> Map k a
M.delete Unique
u Periods
periods
Maybe Periods
Nothing -> Maybe Periods
forall a. Maybe a
Nothing
wait :: Period -> IO (TMVar ())
wait Period
p = STM Tick -> IO Tick
forall a. STM a -> IO a
atomically (TMVar Tick -> STM Tick
forall a. TMVar a -> STM a
takeTMVar (TMVar Tick -> STM Tick) -> TMVar Tick -> STM Tick
forall a b. (a -> b) -> a -> b
$ Period -> TMVar Tick
tick Period
p) IO Tick -> (Tick -> IO (TMVar ())) -> IO (TMVar ())
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
Tick TMVar ()
doneVar -> TMVar () -> IO (TMVar ())
forall (m :: * -> *) a. Monad m => a -> m a
return TMVar ()
doneVar
Tick
UnCoalesce -> UnCoalesceException -> IO (TMVar ())
forall e a. Exception e => e -> IO a
throwIO UnCoalesceException
UnCoalesceException
done :: TMVar () -> IO ()
done TMVar ()
doneVar = STM () -> IO ()
forall a. STM a -> IO a
atomically (STM () -> IO ()) -> STM () -> IO ()
forall a b. (a -> b) -> a -> b
$ TMVar () -> () -> STM ()
forall a. TMVar a -> a -> STM ()
putTMVar TMVar ()
doneVar ()
doEveryTenthSecondsSleeping :: Int -> IO () -> IO ()
doEveryTenthSecondsSleeping :: Int -> IO () -> IO ()
doEveryTenthSecondsSleeping Int
r IO ()
action = IO ()
forall b. IO b
go
where go :: IO b
go = IO ()
action IO () -> IO () -> IO ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Int -> IO ()
tenthSeconds Int
r IO () -> IO b -> IO b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> IO b
go
tenthSeconds :: Int -> IO ()
tenthSeconds :: Int -> IO ()
tenthSeconds Int
s | Int
s Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
x = do Int -> IO ()
threadDelay (Int
x Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
100000)
Int -> IO ()
tenthSeconds (Int
s Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
x)
| Bool
otherwise = Int -> IO ()
threadDelay (Int
s Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
100000)
where x :: Int
x = (Int
forall a. Bounded a => a
maxBound :: Int) Int -> Int -> Int
forall a. Integral a => a -> a -> a
`div` Int
100000
withTimer :: (IO () -> IO ()) -> IO a -> IO a
withTimer :: (IO () -> IO ()) -> IO a -> IO a
withTimer IO () -> IO ()
pauseRefresh IO a
action =
IO () -> (Async () -> IO a) -> IO a
forall a b. IO a -> (Async a -> IO b) -> IO b
withAsync (IO ()
timerThread IO () -> IO () -> IO ()
forall a b. IO a -> IO b -> IO a
`finally` IO ()
cleanup) ((Async () -> IO a) -> IO a) -> (Async () -> IO a) -> IO a
forall a b. (a -> b) -> a -> b
$ IO a -> Async () -> IO a
forall a b. a -> b -> a
const IO a
action
where
timerThread :: IO ()
timerThread = do
STM () -> IO ()
forall a. STM a -> IO a
atomically (STM () -> IO ()) -> STM () -> IO ()
forall a b. (a -> b) -> a -> b
$ TVar (Maybe Periods) -> Maybe Periods -> STM ()
forall a. TVar a -> a -> STM ()
writeTVar TVar (Maybe Periods)
periodsVar (Maybe Periods -> STM ()) -> Maybe Periods -> STM ()
forall a b. (a -> b) -> a -> b
$ Periods -> Maybe Periods
forall a. a -> Maybe a
Just Periods
forall k a. Map k a
M.empty
(IO () -> IO ()) -> IO ()
timerLoop IO () -> IO ()
pauseRefresh
cleanup :: IO ()
cleanup = STM () -> IO ()
forall a. STM a -> IO a
atomically (STM () -> IO ()) -> STM () -> IO ()
forall a b. (a -> b) -> a -> b
$ TVar (Maybe Periods) -> STM (Maybe Periods)
forall a. TVar a -> STM a
readTVar TVar (Maybe Periods)
periodsVar STM (Maybe Periods) -> (Maybe Periods -> STM ()) -> STM ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
Just Periods
periods -> do
Periods -> (Period -> STM ()) -> STM ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
t a -> (a -> f b) -> f ()
for_ Periods
periods Period -> STM ()
unCoalesceTimer'
TVar (Maybe Periods) -> Maybe Periods -> STM ()
forall a. TVar a -> a -> STM ()
writeTVar TVar (Maybe Periods)
periodsVar Maybe Periods
forall a. Maybe a
Nothing
Maybe Periods
Nothing -> () -> STM ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
timerLoop :: (IO () -> IO ()) -> IO ()
timerLoop :: (IO () -> IO ()) -> IO ()
timerLoop IO () -> IO ()
pauseRefresh = IO () -> IO ()
forall (f :: * -> *) a b. Applicative f => f a -> f b
forever (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
Int64
tNow <- IO Int64
now
([(Unique, Period)]
toFire, Maybe Int64
tMaybeNext) <- STM ([(Unique, Period)], Maybe Int64)
-> IO ([(Unique, Period)], Maybe Int64)
forall a. STM a -> IO a
atomically (STM ([(Unique, Period)], Maybe Int64)
-> IO ([(Unique, Period)], Maybe Int64))
-> STM ([(Unique, Period)], Maybe Int64)
-> IO ([(Unique, Period)], Maybe Int64)
forall a b. (a -> b) -> a -> b
$ do
Periods
periods <- Maybe Periods -> Periods
forall a. HasCallStack => Maybe a -> a
fromJust (Maybe Periods -> Periods) -> STM (Maybe Periods) -> STM Periods
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> TVar (Maybe Periods) -> STM (Maybe Periods)
forall a. TVar a -> STM a
readTVar TVar (Maybe Periods)
periodsVar
let toFire :: [(Unique, Period)]
toFire = Int64 -> Periods -> [(Unique, Period)]
timersToFire Int64
tNow Periods
periods
let periods' :: Periods
periods' = Int64 -> Periods -> Periods
advanceTimers Int64
tNow Periods
periods
let tMaybeNext :: Maybe Int64
tMaybeNext = Periods -> Maybe Int64
nextFireTime Periods
periods'
TVar (Maybe Periods) -> Maybe Periods -> STM ()
forall a. TVar a -> a -> STM ()
writeTVar TVar (Maybe Periods)
periodsVar (Maybe Periods -> STM ()) -> Maybe Periods -> STM ()
forall a b. (a -> b) -> a -> b
$ Periods -> Maybe Periods
forall a. a -> Maybe a
Just Periods
periods'
([(Unique, Period)], Maybe Int64)
-> STM ([(Unique, Period)], Maybe Int64)
forall (m :: * -> *) a. Monad m => a -> m a
return ([(Unique, Period)]
toFire, Maybe Int64
tMaybeNext)
IO () -> IO ()
pauseRefresh (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
TVar Bool
timeoutVar <- Int -> IO (TVar Bool)
registerDelay (Int -> IO (TVar Bool)) -> Int -> IO (TVar Bool)
forall a b. (a -> b) -> a -> b
$ case Maybe Int64
tMaybeNext of
Just Int64
tNext -> Int64 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral ((Int64
tNext Int64 -> Int64 -> Int64
forall a. Num a => a -> a -> a
- Int64
tNow) Int64 -> Int64 -> Int64
forall a. Ord a => a -> a -> a
`max` Int64
10) Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
100000
Maybe Int64
Nothing -> Int
1000000
[(Unique, TMVar ())]
fired <- [(Unique, Period)] -> IO [(Unique, TMVar ())]
fireTimers [(Unique, Period)]
toFire
[Unique]
timeouted <- TVar Bool -> [(Unique, TMVar ())] -> IO [Unique]
waitForTimers TVar Bool
timeoutVar [(Unique, TMVar ())]
fired
[Unique] -> IO ()
unCoalesceTimers [Unique]
timeouted
IO ()
delayUntilNextFire
advanceTimers :: Int64 -> Periods -> Periods
advanceTimers :: Int64 -> Periods -> Periods
advanceTimers Int64
t = (Period -> Period) -> Periods -> Periods
forall a b k. (a -> b) -> Map k a -> Map k b
M.map Period -> Period
advance
where
advance :: Period -> Period
advance Period
p | Period -> Int64
next Period
p Int64 -> Int64 -> Bool
forall a. Ord a => a -> a -> Bool
<= Int64
t = Period
p { next :: Int64
next = Int64
t Int64 -> Int64 -> Int64
forall a. Num a => a -> a -> a
- Int64
t Int64 -> Int64 -> Int64
forall a. Integral a => a -> a -> a
`mod` Period -> Int64
rate Period
p Int64 -> Int64 -> Int64
forall a. Num a => a -> a -> a
+ Period -> Int64
rate Period
p }
| Bool
otherwise = Period
p
timersToFire :: Int64 -> Periods -> [(Unique, Period)]
timersToFire :: Int64 -> Periods -> [(Unique, Period)]
timersToFire Int64
t Periods
periods = [ (Unique
u, Period
p) | (Unique
u, Period
p) <- Periods -> [(Unique, Period)]
forall k a. Map k a -> [(k, a)]
M.toList Periods
periods, Period -> Int64
next Period
p Int64 -> Int64 -> Bool
forall a. Ord a => a -> a -> Bool
<= Int64
t ]
nextFireTime :: Periods -> Maybe Int64
nextFireTime :: Periods -> Maybe Int64
nextFireTime Periods
periods
| Periods -> Bool
forall k a. Map k a -> Bool
M.null Periods
periods = Maybe Int64
forall a. Maybe a
Nothing
| Bool
otherwise = Int64 -> Maybe Int64
forall a. a -> Maybe a
Just (Int64 -> Maybe Int64) -> Int64 -> Maybe Int64
forall a b. (a -> b) -> a -> b
$ [Int64] -> Int64
forall (t :: * -> *) a. (Foldable t, Ord a) => t a -> a
minimum [ Period -> Int64
next Period
p | Period
p <- Periods -> [Period]
forall k a. Map k a -> [a]
M.elems Periods
periods ]
fireTimers :: [(Unique, Period)] -> IO [(Unique, TMVar ())]
fireTimers :: [(Unique, Period)] -> IO [(Unique, TMVar ())]
fireTimers [(Unique, Period)]
toFire = STM [(Unique, TMVar ())] -> IO [(Unique, TMVar ())]
forall a. STM a -> IO a
atomically (STM [(Unique, TMVar ())] -> IO [(Unique, TMVar ())])
-> STM [(Unique, TMVar ())] -> IO [(Unique, TMVar ())]
forall a b. (a -> b) -> a -> b
$ [(Unique, Period)]
-> ((Unique, Period) -> STM (Unique, TMVar ()))
-> STM [(Unique, TMVar ())]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [(Unique, Period)]
toFire (((Unique, Period) -> STM (Unique, TMVar ()))
-> STM [(Unique, TMVar ())])
-> ((Unique, Period) -> STM (Unique, TMVar ()))
-> STM [(Unique, TMVar ())]
forall a b. (a -> b) -> a -> b
$ \(Unique
u, Period
p) -> do
TMVar ()
doneVar <- STM (TMVar ())
forall a. STM (TMVar a)
newEmptyTMVar
TMVar Tick -> Tick -> STM ()
forall a. TMVar a -> a -> STM ()
putTMVar (Period -> TMVar Tick
tick Period
p) (TMVar () -> Tick
Tick TMVar ()
doneVar)
(Unique, TMVar ()) -> STM (Unique, TMVar ())
forall (m :: * -> *) a. Monad m => a -> m a
return (Unique
u, TMVar ()
doneVar)
waitForTimers :: TVar Bool -> [(Unique, TMVar ())] -> IO [Unique]
waitForTimers :: TVar Bool -> [(Unique, TMVar ())] -> IO [Unique]
waitForTimers TVar Bool
timeoutVar [(Unique, TMVar ())]
fired = STM [Unique] -> IO [Unique]
forall a. STM a -> IO a
atomically (STM [Unique] -> IO [Unique]) -> STM [Unique] -> IO [Unique]
forall a b. (a -> b) -> a -> b
$ do
Bool
timeoutOver <- TVar Bool -> STM Bool
forall a. TVar a -> STM a
readTVar TVar Bool
timeoutVar
[(Unique, Bool)]
dones <- [(Unique, TMVar ())]
-> ((Unique, TMVar ()) -> STM (Unique, Bool))
-> STM [(Unique, Bool)]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [(Unique, TMVar ())]
fired (((Unique, TMVar ()) -> STM (Unique, Bool))
-> STM [(Unique, Bool)])
-> ((Unique, TMVar ()) -> STM (Unique, Bool))
-> STM [(Unique, Bool)]
forall a b. (a -> b) -> a -> b
$ \(Unique
u, TMVar ()
doneVar) -> do
Bool
done <- Maybe () -> Bool
forall a. Maybe a -> Bool
isJust (Maybe () -> Bool) -> STM (Maybe ()) -> STM Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> TMVar () -> STM (Maybe ())
forall a. TMVar a -> STM (Maybe a)
tryReadTMVar TMVar ()
doneVar
(Unique, Bool) -> STM (Unique, Bool)
forall (m :: * -> *) a. Monad m => a -> m a
return (Unique
u, Bool
done)
Bool -> STM ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (Bool -> STM ()) -> Bool -> STM ()
forall a b. (a -> b) -> a -> b
$ Bool
timeoutOver Bool -> Bool -> Bool
|| ((Unique, Bool) -> Bool) -> [(Unique, Bool)] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all (Unique, Bool) -> Bool
forall a b. (a, b) -> b
snd [(Unique, Bool)]
dones
[Unique] -> STM [Unique]
forall (m :: * -> *) a. Monad m => a -> m a
return [Unique
u | (Unique
u, Bool
False) <- [(Unique, Bool)]
dones]
unCoalesceTimers :: [Unique] -> IO ()
unCoalesceTimers :: [Unique] -> IO ()
unCoalesceTimers [Unique]
timers = STM () -> IO ()
forall a. STM a -> IO a
atomically (STM () -> IO ()) -> STM () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
Periods
periods <- Maybe Periods -> Periods
forall a. HasCallStack => Maybe a -> a
fromJust (Maybe Periods -> Periods) -> STM (Maybe Periods) -> STM Periods
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> TVar (Maybe Periods) -> STM (Maybe Periods)
forall a. TVar a -> STM a
readTVar TVar (Maybe Periods)
periodsVar
Periods
periods' <- (Unique -> Periods -> STM Periods)
-> Periods -> [Unique] -> STM Periods
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> b -> m b) -> b -> t a -> m b
foldrM Unique -> Periods -> STM Periods
unCoalesceTimer Periods
periods [Unique]
timers
TVar (Maybe Periods) -> Maybe Periods -> STM ()
forall a. TVar a -> a -> STM ()
writeTVar TVar (Maybe Periods)
periodsVar (Maybe Periods -> STM ()) -> Maybe Periods -> STM ()
forall a b. (a -> b) -> a -> b
$ Periods -> Maybe Periods
forall a. a -> Maybe a
Just Periods
periods'
unCoalesceTimer :: Unique -> Periods -> STM Periods
unCoalesceTimer :: Unique -> Periods -> STM Periods
unCoalesceTimer Unique
u Periods
periods = do
Period -> STM ()
unCoalesceTimer' (Periods
periods Periods -> Unique -> Period
forall k a. Ord k => Map k a -> k -> a
M.! Unique
u)
Periods -> STM Periods
forall (m :: * -> *) a. Monad m => a -> m a
return (Periods -> STM Periods) -> Periods -> STM Periods
forall a b. (a -> b) -> a -> b
$ Unique
u Unique -> Periods -> Periods
forall k a. Ord k => k -> Map k a -> Map k a
`M.delete` Periods
periods
unCoalesceTimer' :: Period -> STM ()
unCoalesceTimer' :: Period -> STM ()
unCoalesceTimer' Period
p = do
Maybe Tick
_ <- TMVar Tick -> STM (Maybe Tick)
forall a. TMVar a -> STM (Maybe a)
tryTakeTMVar (Period -> TMVar Tick
tick Period
p)
TMVar Tick -> Tick -> STM ()
forall a. TMVar a -> a -> STM ()
putTMVar (Period -> TMVar Tick
tick Period
p) Tick
UnCoalesce
delayUntilNextFire :: IO ()
delayUntilNextFire :: IO ()
delayUntilNextFire = do
Just Periods
periods <- TVar (Maybe Periods) -> IO (Maybe Periods)
forall a. TVar a -> IO a
readTVarIO TVar (Maybe Periods)
periodsVar
let tMaybeNext :: Maybe Int64
tMaybeNext = Periods -> Maybe Int64
nextFireTime Periods
periods
Int64
tNow <- IO Int64
now
TVar Bool
delayVar <- case Maybe Int64
tMaybeNext of
Just Int64
tNext -> do
let maxDelay :: Int
maxDelay = (Int
forall a. Bounded a => a
maxBound :: Int) Int -> Int -> Int
forall a. Integral a => a -> a -> a
`div` Int
100000
delay :: Int64
delay = (Int64
tNext Int64 -> Int64 -> Int64
forall a. Num a => a -> a -> a
- Int64
tNow) Int64 -> Int64 -> Int64
forall a. Ord a => a -> a -> a
`min` Int -> Int64
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
maxDelay
delayUsec :: Int
delayUsec = Int64 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int64
delay Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
100000
Int -> IO (TVar Bool)
registerDelay Int
delayUsec
Maybe Int64
Nothing -> Bool -> IO (TVar Bool)
forall a. a -> IO (TVar a)
newTVarIO Bool
False
STM () -> IO ()
forall a. STM a -> IO a
atomically (STM () -> IO ()) -> STM () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
Bool
delayOver <- TVar Bool -> STM Bool
forall a. TVar a -> STM a
readTVar TVar Bool
delayVar
Periods
periods' <- Maybe Periods -> Periods
forall a. HasCallStack => Maybe a -> a
fromJust (Maybe Periods -> Periods) -> STM (Maybe Periods) -> STM Periods
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> TVar (Maybe Periods) -> STM (Maybe Periods)
forall a. TVar a -> STM a
readTVar TVar (Maybe Periods)
periodsVar
let tMaybeNext' :: Maybe Int64
tMaybeNext' = Periods -> Maybe Int64
nextFireTime Periods
periods'
Bool -> STM ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (Bool -> STM ()) -> Bool -> STM ()
forall a b. (a -> b) -> a -> b
$ Bool
delayOver Bool -> Bool -> Bool
|| Maybe Int64
tMaybeNext Maybe Int64 -> Maybe Int64 -> Bool
forall a. Eq a => a -> a -> Bool
/= Maybe Int64
tMaybeNext'