1 files changed, 130 insertions, 0 deletions
diff --git a/src/Xmobar/App/Timer.hs b/src/Xmobar/App/Timer.hs
new file mode 100644
index 0000000..d67695d
--- /dev/null
+++ b/src/Xmobar/App/Timer.hs
@@ -0,0 +1,130 @@
+------------------------------------------------------------------------------
+-- |
+-- Module: Xmobar.App.Timer
+-- Copyright: (c) 2019 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, withTimer) where
+
+import Control.Concurrent.Async (withAsync)
+import Control.Concurrent.STM
+import Control.Exception (bracket, bracket_)
+import Control.Monad (forever, forM, forM_, guard)
+import Data.IORef
+import Data.Int (Int64)
+import Data.Map (Map)
+import qualified Data.Map as M
+import Data.Time.Clock.POSIX (getPOSIXTime)
+import Data.Unique
+import System.IO.Unsafe (unsafePerformIO)
+
+newtype Timer = Timer (TVar Periods)
+
+type Periods = Map Unique Period
+
+data Period = Period { rate :: Int64, next :: Int64, tick :: TMVar (TMVar ()) }
+
+{-# NOINLINE timer #-}
+timer :: IORef (Maybe Timer)
+timer = unsafePerformIO (newIORef Nothing)
+
+now :: IO Int64
+now = do
+    posix <- getPOSIXTime
+    return $ floor (10 * posix)
+
+newPeriod :: Int64 -> IO (Unique, Period)
+newPeriod r = do
+    u <- newUnique
+    t <- now
+    v <- atomically newEmptyTMVar
+    let t' = t - t `mod` r
+    return (u, Period { rate = r, next = t', tick = v })
+
+-- | 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.
+doEveryTenthSeconds :: Int -> IO () -> IO ()
+doEveryTenthSeconds r action = do
+    Just t <- readIORef timer
+    doEveryTenthSeconds' t r action
+
+doEveryTenthSeconds' :: Timer -> Int -> IO () -> IO ()
+doEveryTenthSeconds' (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)
+    where
+        push u p = atomically $ modifyTVar periodsVar (M.insert u p)
+        pop u = atomically $ modifyTVar periodsVar (M.delete u)
+
+-- | Start the timer coordination thread.
+withTimer :: (IO () -> IO ()) -> IO a -> IO a
+withTimer pauseRefresh action = do
+    periodsVar <- atomically $ newTVar M.empty
+    withAsync (timerLoop pauseRefresh periodsVar) $ \_ ->
+        bracket_
+            (writeIORef timer (Just (Timer periodsVar)))
+            (writeIORef timer Nothing) -- TODO: kill all periods?
+            action
+
+timerLoop :: (IO () -> IO ()) -> TVar Periods -> IO ()
+timerLoop pauseRefresh periodsVar = forever $ do
+    t <- now
+    toFire <- atomically $ do
+        periods <- readTVar periodsVar
+        writeTVar periodsVar (advanceTimers t periods)
+        return (timersToFire t periods)
+    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
+    delayUntilNextFire periodsVar
+
+advanceTimers :: Int64 -> Periods -> Periods
+advanceTimers t = M.map advance
+    where
+        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 ]
+
+nextFireTime :: Periods -> Maybe Int64
+nextFireTime periods
+    | M.null periods = Nothing
+    | otherwise = Just $ minimum [ next p | p <- M.elems periods ]
+
+delayUntilNextFire :: TVar Periods -> IO ()
+delayUntilNextFire periodsVar = do
+    tMaybeNext <- fmap nextFireTime $ readTVarIO periodsVar
+    tNow <- now
+    delayVar <- case tMaybeNext of
+        Just 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 = (maxBound :: Int) `div` 100000
+                delay = (tNext - tNow) `min` fromIntegral maxDelay
+                delayUsec = fromIntegral delay * 100000
+            registerDelay delayUsec
+        Nothing -> atomically $ newTVar False
+    atomically $ do
+        delayOver <- readTVar delayVar
+        tMaybeNext' <- fmap nextFireTime $ readTVar periodsVar
+        -- Return also if a new period is added (it may fire sooner).
+        guard $ delayOver || tMaybeNext /= tMaybeNext'