summaryrefslogtreecommitdiffhomepage
path: root/src/Xmobar
diff options
context:
space:
mode:
Diffstat (limited to 'src/Xmobar')
-rw-r--r--src/Xmobar/App/Timer.hs122
-rw-r--r--src/Xmobar/Run/Exec.hs12
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