From 57e8e23ec7b81b0a680dd9decc70bbf98892abab Mon Sep 17 00:00:00 2001 From: jao Date: Fri, 4 Feb 2022 03:34:48 +0000 Subject: Refactoring: event loop handling simplifications --- src/Xmobar/App/Main.hs | 6 +-- src/Xmobar/Run/Loop.hs | 14 +++---- src/Xmobar/Text/Loop.hs | 35 ++++++---------- src/Xmobar/X11/Loop.hs | 103 +++++++++++++++++++++++------------------------- 4 files changed, 69 insertions(+), 89 deletions(-) diff --git a/src/Xmobar/App/Main.hs b/src/Xmobar/App/Main.hs index 52cdca5..489bcd0 100644 --- a/src/Xmobar/App/Main.hs +++ b/src/Xmobar/App/Main.hs @@ -29,13 +29,13 @@ import Control.Monad (unless) import Xmobar.App.Config import Xmobar.Config.Types import Xmobar.Config.Parse -import qualified Xmobar.X11.Loop as X11 -import qualified Xmobar.Text.Loop as Text +import Xmobar.X11.Loop (x11Loop) +import Xmobar.Text.Loop (textLoop) import Xmobar.App.Opts (recompileFlag, verboseFlag, getOpts, doOpts) import Xmobar.App.Compile (recompile, trace) xmobar :: Config -> IO () -xmobar cfg = if textOutput cfg then Text.loop cfg else X11.loop cfg +xmobar cfg = if textOutput cfg then textLoop cfg else x11Loop cfg configFromArgs :: Config -> IO Config configFromArgs cfg = getArgs >>= getOpts >>= doOpts cfg . fst diff --git a/src/Xmobar/Run/Loop.hs b/src/Xmobar/Run/Loop.hs index 30ee112..bda41ff 100644 --- a/src/Xmobar/Run/Loop.hs +++ b/src/Xmobar/Run/Loop.hs @@ -16,7 +16,7 @@ -- ------------------------------------------------------------------------------ -module Xmobar.Run.Loop (initLoop, loop) where +module Xmobar.Run.Loop (LoopFunction, loop) where import Control.Concurrent (forkIO) import Control.Exception (bracket_, bracket, handle, SomeException(..)) @@ -53,13 +53,10 @@ refreshLockT var action = do putTMVar var () return r -type StartFunction = TMVar SignalType - -> TMVar () - -> [[([Async ()], TVar String)]] - -> IO () +type LoopFunction = TMVar SignalType -> TVar [String] -> IO () -loop :: Config -> StartFunction -> IO () -loop conf starter = withDeferSignals $ do +loop :: Config -> LoopFunction -> IO () +loop conf looper = withDeferSignals $ do cls <- mapM (parseTemplate (commands conf) (sepChar conf)) (splitTemplate (alignSep conf) (template conf)) let confSig = unSignalChan (signal conf) @@ -70,7 +67,8 @@ loop conf starter = withDeferSignals $ do bracket (mapM (mapM $ startCommand sig) cls) cleanupThreads $ \vars -> do - starter sig refLock vars + tv <- initLoop sig refLock vars + looper sig tv cleanupThreads :: [[([Async ()], a)]] -> IO () cleanupThreads vars = diff --git a/src/Xmobar/Text/Loop.hs b/src/Xmobar/Text/Loop.hs index 42c8700..2903aa9 100644 --- a/src/Xmobar/Text/Loop.hs +++ b/src/Xmobar/Text/Loop.hs @@ -14,48 +14,35 @@ -- ------------------------------------------------------------------------------ -module Xmobar.Text.Loop (loop) where +module Xmobar.Text.Loop (textLoop) where import Prelude hiding (lookup) import System.IO import Control.Monad.Reader -import Control.Concurrent.Async (Async) import Control.Concurrent.STM import Xmobar.System.Signal - import Xmobar.Config.Types (Config) - -import qualified Xmobar.Run.Loop as Loop - +import Xmobar.Run.Loop (loop) import Xmobar.Run.Parsers (parseString) - import Xmobar.Text.Output (formatSegment) -- | Starts the main event loop and threads -loop :: Config -> IO () -loop conf = Loop.loop conf (startTextLoop' conf) - -startTextLoop' :: Config - -> TMVar SignalType - -> TMVar () - -> [[([Async ()], TVar String)]] - -> IO () -startTextLoop' cfg sig pauser vs = do - hSetBuffering stdin LineBuffering - hSetBuffering stdout LineBuffering - tv <- Loop.initLoop sig pauser vs - eventLoop cfg tv sig +textLoop :: Config -> IO () +textLoop conf = do + hSetBuffering stdin LineBuffering + hSetBuffering stdout LineBuffering + loop conf (eventLoop conf) -- | Continuously wait for a signal from a thread or a interrupt handler -eventLoop :: Config -> TVar [String] -> TMVar SignalType -> IO () -eventLoop cfg tv signal = do +eventLoop :: Config -> TMVar SignalType -> TVar [String] -> IO () +eventLoop cfg signal tv = do typ <- atomically $ takeTMVar signal case typ of - Wakeup -> updateString cfg tv >>= putStrLn >> eventLoop cfg tv signal - _ -> eventLoop cfg tv signal + Wakeup -> updateString cfg tv >>= putStrLn >> eventLoop cfg signal tv + _ -> eventLoop cfg signal tv updateString :: Config -> TVar [String] -> IO String updateString conf v = do diff --git a/src/Xmobar/X11/Loop.hs b/src/Xmobar/X11/Loop.hs index 840c16e..c74ae57 100644 --- a/src/Xmobar/X11/Loop.hs +++ b/src/Xmobar/X11/Loop.hs @@ -16,7 +16,7 @@ -- ------------------------------------------------------------------------------ -module Xmobar.X11.Loop (loop) where +module Xmobar.X11.Loop (x11Loop) where import Prelude hiding (lookup) import Graphics.X11.Xlib hiding (textExtents, textWidth, Segment) @@ -27,7 +27,6 @@ import Graphics.X11.Xrandr import Control.Arrow ((&&&)) import Control.Monad.Reader import Control.Concurrent -import Control.Concurrent.Async (Async) import Control.Concurrent.STM import Control.Exception (handle, SomeException(..)) import Data.Bits @@ -59,7 +58,7 @@ import Xmobar.X11.Bitmap as Bitmap import Xmobar.X11.Types import Xmobar.System.Utils (safeIndex) -import qualified Xmobar.Run.Loop as Loop +import Xmobar.Run.Loop (loop) #ifndef THREADED_RUNTIME import Xmobar.X11.Events(nextEvent') @@ -73,8 +72,8 @@ runX :: XConf -> X () -> IO () runX xc f = runReaderT f xc -- | Starts the main event loop and threads -loop :: Config -> IO () -loop conf = do +x11Loop :: Config -> IO () +x11Loop conf = do initThreads d <- openDisplay "" fs <- initFont d (font conf) @@ -82,58 +81,54 @@ loop conf = do let ic = Map.empty to = textOffset conf ts = textOffsets conf ++ replicate (length fl) (-1) - Loop.loop conf $ \sig lock vars -> do - (r,w) <- createWin d fs conf - startLoop (XConf d r w (fs :| fl) (to :| ts) ic conf) sig lock vars + (r,w) <- createWin d fs conf + loop conf (startLoop (XConf d r w (fs :| fl) (to :| ts) ic conf)) -startLoop :: XConf - -> TMVar SignalType - -> TMVar () - -> [[([Async ()], TVar String)]] - -> IO () -startLoop xcfg@(XConf _ _ w _ _ _ _) sig pauser vs = do +startLoop :: XConf -> TMVar SignalType -> TVar [String] -> IO () +startLoop xcfg@(XConf _ _ w _ _ _ _) sig tv = do #ifdef XFT xftInitFtLibrary #endif - tv <- Loop.initLoop sig pauser vs #ifdef THREADED_RUNTIME - _ <- forkOS (handle (handler "eventer") (eventer sig)) + _ <- forkOS (handle (handler "X event handler") (handleXEvent w sig)) #else - _ <- forkIO (handle (handler "eventer") (eventer sig)) + _ <- forkIO (handle (handler "X event handler") (handleXEvent w sig)) #endif - eventLoop tv xcfg [] sig + eventLoop xcfg [] sig tv where handler thing (SomeException e) = void $ putStrLn ("Thread " ++ thing ++ " failed: " ++ show e) - -- Reacts on events from X - eventer signal = - allocaXEvent $ \e -> do - dpy <- openDisplay "" - xrrSelectInput dpy (defaultRootWindow dpy) rrScreenChangeNotifyMask - selectInput dpy w (exposureMask .|. structureNotifyMask .|. buttonPressMask) - - forever $ do + +-- | Translates X11 events received by w to signals handled by eventLoop +handleXEvent :: Window -> TMVar SignalType -> IO () +handleXEvent w signal = + allocaXEvent $ \e -> do + dpy <- openDisplay "" + xrrSelectInput dpy (defaultRootWindow dpy) rrScreenChangeNotifyMask + selectInput dpy w (exposureMask .|. structureNotifyMask .|. buttonPressMask) + + forever $ do #ifdef THREADED_RUNTIME - nextEvent dpy e + nextEvent dpy e #else - nextEvent' dpy e + nextEvent' dpy e #endif - ev <- getEvent e - case ev of - ConfigureEvent {} -> atomically $ putTMVar signal Reposition - ExposeEvent {} -> atomically $ putTMVar signal Wakeup - RRScreenChangeNotifyEvent {} -> atomically $ putTMVar signal Reposition - ButtonEvent {} -> atomically $ - putTMVar signal (Action (ev_button ev) (fi $ ev_x ev)) - _ -> return () - --- | Continuously wait for a signal from a thread or a interrupt handler -eventLoop :: TVar [String] - -> XConf - -> [([Action], Position, Position)] - -> TMVar SignalType - -> IO () -eventLoop tv xc@(XConf d r w fs vos is cfg) as signal = do + ev <- getEvent e + case ev of + ConfigureEvent {} -> atomically $ putTMVar signal Reposition + ExposeEvent {} -> atomically $ putTMVar signal Wakeup + RRScreenChangeNotifyEvent {} -> atomically $ putTMVar signal Reposition + ButtonEvent {} -> atomically $ + putTMVar signal (Action (ev_button ev) (fi $ ev_x ev)) + _ -> return () + +-- | Continuously wait for a signal from a thread or an interrupt handler +eventLoop :: XConf + -> [([Action], Position, Position)] + -> TMVar SignalType + -> TVar [String] + -> IO () +eventLoop xc@(XConf d r w fs vos is cfg) as signal tv = do typ <- atomically $ takeTMVar signal case typ of Wakeup -> do @@ -142,7 +137,7 @@ eventLoop tv xc@(XConf d r w fs vos is cfg) as signal = do \c -> return xc { iconS = c } as' <- updateActions xc r str runX xc' $ drawInWin r str - eventLoop tv xc' as' signal + eventLoop xc' as' signal tv Reposition -> reposWindow cfg @@ -156,38 +151,38 @@ eventLoop tv xc@(XConf d r w fs vos is cfg) as signal = do Toggle t -> toggle t TogglePersistent -> eventLoop - tv xc { config = cfg { persistent = not $ persistent cfg } } as signal + xc { config = cfg { persistent = not $ persistent cfg } } as signal tv Action but x -> action but x where isPersistent = not $ persistent cfg - + loopOn = eventLoop xc as signal tv hide t | t == 0 = - when isPersistent (hideWindow d w) >> eventLoop tv xc as signal + when isPersistent (hideWindow d w) >> loopOn | otherwise = do void $ forkIO $ threadDelay t >> atomically (putTMVar signal $ Hide 0) - eventLoop tv xc as signal + loopOn reveal t | t == 0 = do when isPersistent (showWindow r cfg d w) - eventLoop tv xc as signal + loopOn | otherwise = do void $ forkIO $ threadDelay t >> atomically (putTMVar signal $ Reveal 0) - eventLoop tv xc as signal + loopOn toggle t = do ismapped <- isMapped d w atomically (putTMVar signal $ if ismapped then Hide t else Reveal t) - eventLoop tv xc as signal + loopOn reposWindow rcfg = do r' <- repositionWin d w (NE.head fs) rcfg - eventLoop tv (XConf d r' w fs vos is rcfg) as signal + eventLoop (XConf d r' w fs vos is rcfg) as signal tv updateConfigPosition ocfg = case position ocfg of @@ -205,7 +200,7 @@ eventLoop tv xc@(XConf d r w fs vos is cfg) as signal = do filter (\(Spawn b _) -> button `elem` b) $ concatMap (\(a,_,_) -> a) $ filter (\(_, from, to) -> x >= from && x <= to) as - eventLoop tv xc as signal + loopOn updateString :: Config -> TVar [String] -> IO [[Segment]] updateString conf v = do -- cgit v1.2.3