Timer coalescing: gracefully uncoalesce slow timers

The first implementation assumed all timers (monitors) are fast and
frequent (which happens to be the case in my configuration). This meant
that a single on-line weather monitor could block the entire xmobar
instance for a long time due to the refresh pausing (meant to reduce
power consumption).

This commit attempts to fix that by limiting the refresh pause time and
using the old periodic sleep method for these slow timers (monitors).

2 files changed, 97 insertions, 37 deletions

diff --git a/src/Xmobar/App/Timer.hs b/src/Xmobar/App/Timer.hs
index d67695d..8464fb7 100644
--- a/src/Xmobar/App/Timer.hs
+++ b/src/Xmobar/App/Timer.hs
@@ -1,3 +1,4 @@
+{-# LANGUAGE LambdaCase #-}
 ------------------------------------------------------------------------------
 -- |
 -- Module: Xmobar.App.Timer
@@ -11,16 +12,23 @@
 --
 ------------------------------------------------------------------------------
 
-module Xmobar.App.Timer (doEveryTenthSeconds, withTimer) where
+module Xmobar.App.Timer
+    ( doEveryTenthSeconds
+    , tenthSeconds
+    , withTimer
+    ) where
 
+import Control.Concurrent (threadDelay)
 import Control.Concurrent.Async (withAsync)
 import Control.Concurrent.STM
-import Control.Exception (bracket, bracket_)
-import Control.Monad (forever, forM, forM_, guard)
+import Control.Exception
+import Control.Monad (forever, forM, guard)
+import Data.Foldable (foldrM)
 import Data.IORef
 import Data.Int (Int64)
 import Data.Map (Map)
 import qualified Data.Map as M
+import Data.Maybe (isJust)
 import Data.Time.Clock.POSIX (getPOSIXTime)
 import Data.Unique
 import System.IO.Unsafe (unsafePerformIO)
@@ -29,7 +37,12 @@ newtype Timer = Timer (TVar Periods)
 
 type Periods = Map Unique Period
 
-data Period = Period { rate :: Int64, next :: Int64, tick :: TMVar (TMVar ()) }
+data Tick = Tick (TMVar ()) | TimeOut
+
+data Period = Period { rate :: Int64, next :: Int64, tick :: TMVar Tick }
+
+data TimeOutException = TimeOutException deriving Show
+instance Exception TimeOutException
 
 {-# NOINLINE timer #-}
 timer :: IORef (Maybe Timer)
@@ -50,24 +63,48 @@ newPeriod r = do
 
 -- | Perform a given action every N tenths of a second.
 --
--- The timer is aligned with other timers to minimize the number of wakeups
--- and unnecessary redraws.
+-- 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 r action = do
     Just t <- readIORef timer
-    doEveryTenthSeconds' t r action
+    doEveryTenthSecondsCoalesced t r action `catch` \TimeOutException ->
+        doEveryTenthSecondsSleeping r action
 
-doEveryTenthSeconds' :: Timer -> Int -> IO () -> IO ()
-doEveryTenthSeconds' (Timer periodsVar) r action = do
+-- | Perform a given action every N tenths of a second,
+-- coalesce with other timers using a given Timer instance.
+doEveryTenthSecondsCoalesced :: Timer -> Int -> IO () -> IO ()
+doEveryTenthSecondsCoalesced (Timer periodsVar) r action = do
     (u, p) <- newPeriod (fromIntegral r)
-    bracket_ (push u p) (pop u) $ forever $
-        bracket (atomically $ takeTMVar $ tick p)
-                (\doneVar -> atomically $ putTMVar doneVar ())
-                (const action)
+    bracket_ (push u p) (pop u) $ forever $ bracket (wait p) done $ const action
     where
         push u p = atomically $ modifyTVar periodsVar (M.insert u p)
         pop u = atomically $ modifyTVar periodsVar (M.delete u)
 
+        wait p = atomically (takeTMVar $ tick p) >>= \case
+            Tick doneVar -> return doneVar
+            TimeOut -> throwIO TimeOutException
+        done doneVar = atomically $ putTMVar doneVar ()
+
+-- | Perform a given action every N tenths of a second,
+-- making no attempt to synchronize with other timers.
+doEveryTenthSecondsSleeping :: Int -> IO () -> IO ()
+doEveryTenthSecondsSleeping r action = go
+    where go = action >> tenthSeconds r >> 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 s | s >= x = do threadDelay (x * 100000)
+                             tenthSeconds (s - x)
+               | otherwise = threadDelay (s * 100000)
+               where x = (maxBound :: Int) `div` 100000
+
 -- | Start the timer coordination thread.
 withTimer :: (IO () -> IO ()) -> IO a -> IO a
 withTimer pauseRefresh action = do
@@ -80,19 +117,25 @@ withTimer pauseRefresh action = do
 
 timerLoop :: (IO () -> IO ()) -> TVar Periods -> IO ()
 timerLoop pauseRefresh periodsVar = forever $ do
-    t <- now
-    toFire <- atomically $ do
+    tNow <- now
+    (toFire, tMaybeNext) <- atomically $ do
         periods <- readTVar periodsVar
-        writeTVar periodsVar (advanceTimers t periods)
-        return (timersToFire t periods)
+        let toFire = timersToFire tNow periods
+        let periods' = advanceTimers tNow periods
+        let tMaybeNext = nextFireTime periods'
+        writeTVar periodsVar periods'
+        return (toFire, tMaybeNext)
     pauseRefresh $ do
-        -- Fire timers ...
-        doneVars <- atomically $ forM toFire $ \p -> do
-            doneVar <- newEmptyTMVar
-            putTMVar (tick p) doneVar
-            return doneVar
-        -- ... and wait for them to avoid unnecessary redraws.
-        atomically $ forM_ doneVars takeTMVar
+        -- 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 tNext -> fromIntegral ((tNext - tNow) `max` 10) * 100000
+            Nothing -> 1000000
+        fired <- fireTimers toFire
+        timeouted <- waitForTimers timeoutVar fired
+        timeoutTimers timeouted periodsVar
     delayUntilNextFire periodsVar
 
 advanceTimers :: Int64 -> Periods -> Periods
@@ -101,14 +144,41 @@ advanceTimers t = M.map advance
         advance p | next p <= t = p { next = t - t `mod` rate p + rate p }
                   | otherwise = p
 
-timersToFire :: Int64 -> Periods -> [Period]
-timersToFire t periods = [ p | p <- M.elems periods, next p <= t ]
+timersToFire :: Int64 -> Periods -> [(Unique, Period)]
+timersToFire t periods = [ (u, p) | (u, p) <- M.toList periods, next p <= t ]
 
 nextFireTime :: Periods -> Maybe Int64
 nextFireTime periods
     | M.null periods = Nothing
     | otherwise = Just $ minimum [ next p | p <- M.elems periods ]
 
+fireTimers :: [(Unique, Period)] -> IO [(Unique, TMVar ())]
+fireTimers toFire = atomically $ forM toFire $ \(u, p) -> do
+    doneVar <- newEmptyTMVar
+    putTMVar (tick p) (Tick doneVar)
+    return (u, doneVar)
+
+waitForTimers :: TVar Bool -> [(Unique, TMVar ())] -> IO [Unique]
+waitForTimers timeoutVar fired = atomically $ do
+    timeoutOver <- readTVar timeoutVar
+    dones <- forM fired $ \(u, doneVar) -> do
+        done <- isJust <$> tryReadTMVar doneVar
+        return (u, done)
+    guard $ timeoutOver || all snd dones
+    return [u | (u, False) <- dones]
+
+-- | Handle slow timers (drop and signal them to stop coalescing).
+timeoutTimers :: [Unique] -> TVar Periods -> IO ()
+timeoutTimers timers periodsVar = atomically $ do
+    periods <- readTVar periodsVar
+    periods' <- foldrM timeoutTimer periods timers
+    writeTVar periodsVar periods'
+
+timeoutTimer :: Unique -> Periods -> STM Periods
+timeoutTimer u periods = do
+    putTMVar (tick (periods M.! u)) TimeOut
+    return $ u `M.delete` periods
+
 delayUntilNextFire :: TVar Periods -> IO ()
 delayUntilNextFire periodsVar = do
     tMaybeNext <- fmap nextFireTime $ readTVarIO periodsVar
diff --git a/src/Xmobar/Run/Exec.hs b/src/Xmobar/Run/Exec.hs
index ad68232..d8cf81a 100644
--- a/src/Xmobar/Run/Exec.hs
+++ b/src/Xmobar/Run/Exec.hs
@@ -21,20 +21,10 @@ module Xmobar.Run.Exec (Exec (..), tenthSeconds, doEveryTenthSeconds) where
 
 import Prelude
 import Data.Char
-import Control.Concurrent
 
-import Xmobar.App.Timer (doEveryTenthSeconds)
+import Xmobar.App.Timer (doEveryTenthSeconds, tenthSeconds)
 import Xmobar.System.Signal
 
--- | Work around to 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 s | s >= x = do threadDelay (x * 100000)
-                             tenthSeconds (s - x)
-               | otherwise = threadDelay (s * 100000)
-               where x = (maxBound :: Int) `div` 100000
-
 class Show e => Exec e where
     alias   :: e -> String
     alias   e    = takeWhile (not . isSpace) $ show e