summaryrefslogtreecommitdiffhomepage
path: root/src/Xmobar/App
diff options
context:
space:
mode:
Diffstat (limited to 'src/Xmobar/App')
-rw-r--r--src/Xmobar/App/EventLoop.hs43
-rw-r--r--src/Xmobar/App/Main.hs21
-rw-r--r--src/Xmobar/App/Timer.hs130
3 files changed, 176 insertions, 18 deletions
diff --git a/src/Xmobar/App/EventLoop.hs b/src/Xmobar/App/EventLoop.hs
index 3fab3e5..f6ab932 100644
--- a/src/Xmobar/App/EventLoop.hs
+++ b/src/Xmobar/App/EventLoop.hs
@@ -17,7 +17,12 @@
------------------------------------------------------------------------------
-module Xmobar.App.EventLoop (startLoop, startCommand) where
+module Xmobar.App.EventLoop
+ ( startLoop
+ , startCommand
+ , newRefreshLock
+ , refreshLock
+ ) where
import Prelude hiding (lookup)
import Graphics.X11.Xlib hiding (textExtents, textWidth)
@@ -31,7 +36,7 @@ import Control.Monad.Reader
import Control.Concurrent
import Control.Concurrent.Async (Async, async)
import Control.Concurrent.STM
-import Control.Exception (handle, SomeException(..))
+import Control.Exception (bracket_, handle, SomeException(..))
import Data.Bits
import Data.Map hiding (foldr, map, filter)
import Data.Maybe (fromJust, isJust)
@@ -63,15 +68,34 @@ import Xmobar.System.DBus
runX :: XConf -> X () -> IO ()
runX xc f = runReaderT f xc
+newRefreshLock :: IO (TMVar ())
+newRefreshLock = atomically $ newTMVar ()
+
+refreshLock :: TMVar () -> IO a -> IO a
+refreshLock var = bracket_ lock unlock
+ where
+ lock = atomically $ takeTMVar var
+ unlock = atomically $ putTMVar var ()
+
+refreshLockT :: TMVar () -> STM a -> STM a
+refreshLockT var action = do
+ takeTMVar var
+ r <- action
+ putTMVar var ()
+ return r
+
-- | Starts the main event loop and threads
-startLoop :: XConf -> TMVar SignalType -> [[([Async ()], TVar String)]]
- -> IO ()
-startLoop xcfg@(XConf _ _ w _ _ _ _) sig vs = do
+startLoop :: XConf
+ -> TMVar SignalType
+ -> TMVar ()
+ -> [[([Async ()], TVar String)]]
+ -> IO ()
+startLoop xcfg@(XConf _ _ w _ _ _ _) sig pauser vs = do
#ifdef XFT
xftInitFtLibrary
#endif
tv <- atomically $ newTVar []
- _ <- forkIO (handle (handler "checker") (checker tv [] vs sig))
+ _ <- forkIO (handle (handler "checker") (checker tv [] vs sig pauser))
#ifdef THREADED_RUNTIME
_ <- forkOS (handle (handler "eventer") (eventer sig))
#else
@@ -111,15 +135,16 @@ checker :: TVar [String]
-> [String]
-> [[([Async ()], TVar String)]]
-> TMVar SignalType
+ -> TMVar ()
-> IO ()
-checker tvar ov vs signal = do
- nval <- atomically $ do
+checker tvar ov vs signal pauser = do
+ nval <- atomically $ refreshLockT pauser $ do
nv <- mapM concatV vs
guard (nv /= ov)
writeTVar tvar nv
return nv
atomically $ putTMVar signal Wakeup
- checker tvar nval vs signal
+ checker tvar nval vs signal pauser
where
concatV = fmap concat . mapM (readTVar . snd)
diff --git a/src/Xmobar/App/Main.hs b/src/Xmobar/App/Main.hs
index 29504f4..e0b0329 100644
--- a/src/Xmobar/App/Main.hs
+++ b/src/Xmobar/App/Main.hs
@@ -40,9 +40,10 @@ import Xmobar.X11.Types
import Xmobar.X11.Text
import Xmobar.X11.Window
import Xmobar.App.Opts (recompileFlag, verboseFlag, getOpts, doOpts)
-import Xmobar.App.EventLoop (startLoop, startCommand)
+import Xmobar.App.EventLoop (startLoop, startCommand, newRefreshLock, refreshLock)
import Xmobar.App.Compile (recompile, trace)
import Xmobar.App.Config
+import Xmobar.App.Timer (withTimer)
xmobar :: Config -> IO ()
xmobar conf = withDeferSignals $ do
@@ -53,14 +54,16 @@ xmobar conf = withDeferSignals $ do
cls <- mapM (parseTemplate (commands conf) (sepChar conf))
(splitTemplate (alignSep conf) (template conf))
sig <- setupSignalHandler
- bracket (mapM (mapM $ startCommand sig) cls)
- cleanupThreads
- $ \vars -> do
- (r,w) <- createWin d fs conf
- let ic = Map.empty
- to = textOffset conf
- ts = textOffsets conf ++ replicate (length fl) (-1)
- startLoop (XConf d r w (fs:fl) (to:ts) ic conf) sig vars
+ refLock <- newRefreshLock
+ withTimer (refreshLock refLock) $
+ bracket (mapM (mapM $ startCommand sig) cls)
+ cleanupThreads
+ $ \vars -> do
+ (r,w) <- createWin d fs conf
+ let ic = Map.empty
+ to = textOffset conf
+ ts = textOffsets conf ++ replicate (length fl) (-1)
+ startLoop (XConf d r w (fs:fl) (to:ts) ic conf) sig refLock vars
configFromArgs :: Config -> IO Config
configFromArgs cfg = getArgs >>= getOpts >>= doOpts cfg . fst
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'
generated by cgit v1.2.3 (git 2.39.1) at 2024-11-05 00:50:35 +0000