summaryrefslogtreecommitdiffhomepage
path: root/src/Xmobar/Run/Timer.hs
diff options
context:
space:
mode:
Diffstat (limited to 'src/Xmobar/Run/Timer.hs')
-rw-r--r--src/Xmobar/Run/Timer.hs221
1 files changed, 221 insertions, 0 deletions
diff --git a/src/Xmobar/Run/Timer.hs b/src/Xmobar/Run/Timer.hs
new file mode 100644
index 0000000..1df2c23
--- /dev/null
+++ b/src/Xmobar/Run/Timer.hs
@@ -0,0 +1,221 @@
+{-# 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 { rate :: Int64, next :: Int64, tick :: TMVar Tick }
+
+data UnCoalesceException = UnCoalesceException deriving Show
+instance Exception UnCoalesceException
+
+{-# NOINLINE periodsVar #-}
+periodsVar :: TVar (Maybe Periods)
+periodsVar = unsafePerformIO $ newTVarIO 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 <- newEmptyTMVarIO
+ 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 (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 =
+ doEveryTenthSecondsCoalesced r action `catch` \UnCoalesceException ->
+ doEveryTenthSecondsSleeping r 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 r action = do
+ (u, p) <- newPeriod (fromIntegral r)
+ bracket_ (push u p) (pop u) $ forever $ bracket (wait p) done $ const action
+ where
+ push u p = atomically $ modifyTVar' periodsVar $ \case
+ Just periods -> Just $ M.insert u p periods
+ Nothing -> throw UnCoalesceException
+ pop u = atomically $ modifyTVar' periodsVar $ \case
+ Just periods -> Just $ M.delete u periods
+ Nothing -> Nothing
+
+ wait p = atomically (takeTMVar $ tick p) >>= \case
+ Tick doneVar -> return doneVar
+ UnCoalesce -> throwIO UnCoalesceException
+ 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 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 pauseRefresh action =
+ withAsync (timerThread `finally` cleanup) $ const action
+ where
+ timerThread = do
+ atomically $ writeTVar periodsVar $ Just M.empty
+ timerLoop pauseRefresh
+
+ cleanup = atomically $ readTVar periodsVar >>= \case
+ Just periods -> do
+ for_ periods unCoalesceTimer'
+ writeTVar periodsVar Nothing
+ Nothing -> return ()
+
+timerLoop :: (IO () -> IO ()) -> IO ()
+timerLoop pauseRefresh = forever $ do
+ tNow <- now
+ (toFire, tMaybeNext) <- atomically $ do
+ periods <- fromJust <$> readTVar periodsVar
+ let toFire = timersToFire tNow periods
+ let periods' = advanceTimers tNow periods
+ let tMaybeNext = nextFireTime 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 tNext -> fromIntegral ((tNext - tNow) `max` 10) * 100000
+ Nothing -> 1000000
+ fired <- fireTimers toFire
+ timeouted <- waitForTimers timeoutVar fired
+ unCoalesceTimers timeouted
+ delayUntilNextFire
+
+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 -> [(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).
+unCoalesceTimers :: [Unique] -> IO ()
+unCoalesceTimers timers = atomically $ do
+ periods <- fromJust <$> readTVar periodsVar
+ periods' <- foldrM unCoalesceTimer periods timers
+ writeTVar periodsVar $ Just periods'
+
+unCoalesceTimer :: Unique -> Periods -> STM Periods
+unCoalesceTimer u periods = do
+ unCoalesceTimer' (periods M.! u)
+ return $ u `M.delete` periods
+
+unCoalesceTimer' :: Period -> STM ()
+unCoalesceTimer' p = do
+ _ <- tryTakeTMVar (tick p)
+ putTMVar (tick p) UnCoalesce
+
+delayUntilNextFire :: IO ()
+delayUntilNextFire = do
+ Just periods <- readTVarIO periodsVar
+ let tMaybeNext = nextFireTime periods
+ 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 -> newTVarIO False
+ atomically $ do
+ delayOver <- readTVar delayVar
+ periods' <- fromJust <$> readTVar periodsVar
+ let tMaybeNext' = nextFireTime periods'
+ -- Return also if a new period is added (it may fire sooner).
+ guard $ delayOver || tMaybeNext /= tMaybeNext'