diff options
Diffstat (limited to 'src/Xmobar/App')
| -rw-r--r-- | src/Xmobar/App/CommandThreads.hs | 2 | ||||
| -rw-r--r-- | src/Xmobar/App/Timer.hs | 221 |
2 files changed, 1 insertions, 222 deletions
diff --git a/src/Xmobar/App/CommandThreads.hs b/src/Xmobar/App/CommandThreads.hs index 931a072..28bf926 100644 --- a/src/Xmobar/App/CommandThreads.hs +++ b/src/Xmobar/App/CommandThreads.hs @@ -34,7 +34,7 @@ import Xmobar.Config.Types import Xmobar.Run.Runnable (Runnable) import Xmobar.Run.Exec (start, trigger, alias) import Xmobar.Run.Template -import Xmobar.App.Timer (withTimer) +import Xmobar.Run.Timer (withTimer) #ifdef DBUS import Xmobar.System.DBus diff --git a/src/Xmobar/App/Timer.hs b/src/Xmobar/App/Timer.hs deleted file mode 100644 index 23c48c0..0000000 --- a/src/Xmobar/App/Timer.hs +++ /dev/null @@ -1,221 +0,0 @@ -{-# LANGUAGE LambdaCase #-} ------------------------------------------------------------------------------- --- | --- Module: Xmobar.App.Timer --- Copyright: (c) 2019, 2020 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 - , 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' |