1 files changed, 96 insertions, 26 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