diff options
| -rw-r--r-- | src/Xmobar/App/Timer.hs | 122 | ||||
| -rw-r--r-- | src/Xmobar/Run/Exec.hs | 12 |
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 |