{-# LANGUAGE LambdaCase #-}
------------------------------------------------------------------------------
-- |
-- Module: Xmobar.App.Timer
-- Copyright: (c) 2019, 2020 Tomáš Janoušek
-- License: BSD3-style (see LICENSE)
--
-- Maintainer: Tomáš Janoušek <tomi@nomi.cz>
-- Stability: unstable
--
-- Timer coalescing for recurring actions.
--
------------------------------------------------------------------------------

module Xmobar.App.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 })

-- | Perform a given action every N tenths of a second.
--
-- The timer is aligned (coalesced) with other timers to minimize the number
-- of wakeups and unnecessary redraws. If the action takes too long (one
-- second or when the next timer is due), coalescing is disabled for it and it
-- falls back to periodic sleep.
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

-- | Perform a given action every N tenths of a second,
-- coalesce with other timers using a given Timer instance.
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 ()

-- | Perform a given action every N tenths of a second,
-- making no attempt to synchronize with other timers.
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

-- | Sleep for a given amount of tenths of a second.
--
-- (Work around the Int max bound: since threadDelay takes an Int, it
-- is not possible to set a thread delay grater than about 45 minutes.
-- With a little recursion we solve the problem.)
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

-- | Start the timer coordination thread and perform a given IO action (this
-- is meant to surround the entire xmobar execution), terminating the timer
-- thread afterwards.
--
-- Additionally, if the timer thread fails, individual
-- 'doEveryTenthSecondsCoalesced' invocations that are waiting to be
-- coordinated by it are notified to fall back to periodic sleeping.
--
-- The timer thread _will_ fail immediately when running in a non-threaded
-- RTS.
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
        -- To avoid multiple refreshes, pause refreshing for up to 1 second,
        -- fire timers and wait for them to finish (update their text).
        -- Those that need more time (e.g. weather monitors) will be dropped
        -- from timer coalescing and will fall back to periodic sleep.
        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]

-- | Handle slow timers (drop and signal them to stop coalescing).
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
            -- Work around the Int max bound: threadDelay takes an Int, we can
            -- only sleep for so long, which is okay, we'll just check timers
            -- sooner and sleep again.
            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'
        -- Return also if a new period is added (it may fire sooner).
        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'