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

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
$cshowsPrec :: Int -> UnCoalesceException -> ShowS
showsPrec :: Int -> UnCoalesceException -> ShowS
$cshow :: UnCoalesceException -> String
show :: UnCoalesceException -> String
$cshowList :: [UnCoalesceException] -> ShowS
showList :: [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
    posix <- IO POSIXTime
getPOSIXTime
    return $ floor (10 * posix)

newPeriod :: Int64 -> IO (Unique, Period)
newPeriod :: Int64 -> IO (Unique, Period)
newPeriod Int64
r = do
    u <- IO Unique
newUnique
    t <- now
    v <- newEmptyTMVarIO
    let 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
    return (u, Period { rate = r, next = t', 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
    (u, p) <- Int64 -> IO (Unique, Period)
newPeriod (Int -> Int64
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
r)
    bracket_ (push u p) (pop u) $ forever $ bracket (wait p) done $ const 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. (HasCallStack, 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 a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
            Tick TMVar ()
doneVar -> TMVar () -> IO (TMVar ())
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return TMVar ()
doneVar
            Tick
UnCoalesce -> UnCoalesceException -> IO (TMVar ())
forall e a. (HasCallStack, 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 a b. IO a -> IO b -> IO b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Int -> IO ()
tenthSeconds Int
r IO () -> IO b -> IO b
forall a b. IO a -> 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 :: forall a. (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 a b. STM a -> (a -> STM b) -> STM b
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 a. a -> STM a
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
    tNow <- IO Int64
now
    (toFire, tMaybeNext) <- atomically $ do
        periods <- fromJust <$> readTVar periodsVar
        let toFire = Int64 -> Periods -> [(Unique, Period)]
timersToFire Int64
tNow Periods
periods
        let periods' = Int64 -> Periods -> Periods
advanceTimers Int64
tNow Periods
periods
        let tMaybeNext = Periods -> Maybe Int64
nextFireTime Periods
periods'
        writeTVar periodsVar $ Just periods'
        return (toFire, tMaybeNext)
    pauseRefresh $ 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.
        timeoutVar <- registerDelay $ case 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
        fired <- fireTimers toFire
        timeouted <- waitForTimers timeoutVar fired
        unCoalesceTimers timeouted
    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 = t - t `mod` rate p + rate 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 a. Ord a => [a] -> a
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
    doneVar <- STM (TMVar ())
forall a. STM (TMVar a)
newEmptyTMVar
    putTMVar (tick p) (Tick doneVar)
    return (u, 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
    timeoutOver <- TVar Bool -> STM Bool
forall a. TVar a -> STM a
readTVar TVar Bool
timeoutVar
    dones <- forM fired $ \(Unique
u, TMVar ()
doneVar) -> do
        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
        return (u, done)
    guard $ timeoutOver || all snd dones
    return [u | (u, False) <- 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 <- 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' <- foldrM unCoalesceTimer periods timers
    writeTVar periodsVar $ Just 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 a. a -> STM a
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
    _ <- TMVar Tick -> STM (Maybe Tick)
forall a. TMVar a -> STM (Maybe a)
tryTakeTMVar (Period -> TMVar Tick
tick Period
p)
    putTMVar (tick p) UnCoalesce

delayUntilNextFire :: IO ()
delayUntilNextFire :: IO ()
delayUntilNextFire = do
    Just periods <- TVar (Maybe Periods) -> IO (Maybe Periods)
forall a. TVar a -> IO a
readTVarIO TVar (Maybe Periods)
periodsVar
    let tMaybeNext = Periods -> Maybe Int64
nextFireTime Periods
periods
    tNow <- now
    delayVar <- case 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
    atomically $ do
        delayOver <- readTVar delayVar
        periods' <- fromJust <$> readTVar periodsVar
        let tMaybeNext' = Periods -> Maybe Int64
nextFireTime Periods
periods'
        -- Return also if a new period is added (it may fire sooner).
        guard $ delayOver || tMaybeNext /= tMaybeNext'