From 4fe99635e87c4f2262a27bf91c1ab6c7e3ee0988 Mon Sep 17 00:00:00 2001 From: Martin Perner Date: Wed, 31 Aug 2011 13:39:01 +0200 Subject: Working version The last commit removed the exposure event which turned out to be a big problem. Although the bug still exists that not all xrandr events are received when normal events are enabled. To work around this problem a second display is created on which only the xrandr events are enabled. On an exposure event the eventqueue for this display is processed. The results are very good, in the worst case an exposure event must be triggered by the user on xmobar to update its position. --- src/Main.hs | 4 +++- 1 file changed, 3 insertions(+), 1 deletion(-) (limited to 'src/Main.hs') diff --git a/src/Main.hs b/src/Main.hs index 18e05e2..941a844 100644 --- a/src/Main.hs +++ b/src/Main.hs @@ -42,6 +42,7 @@ import Control.Monad (unless) main :: IO () main = do d <- openDisplay "" + d' <- openDisplay "" args <- getArgs (o,file) <- getOpts args (c,defaultings) <- case file of @@ -60,7 +61,8 @@ main = do cls <- mapM (parseTemplate conf) (splitTemplate conf) vars <- mapM (mapM startCommand) cls (r,w) <- createWin d fs conf - eventLoop (XConf d r w fs conf) vars + _ <- enableXRandrEventListen d' + eventLoop (XConf d d' r w fs conf) vars -- | Splits the template in its parts splitTemplate :: Config -> [String] -- cgit v1.2.3 From dbf4ea77dc318f5d3b68651eabc562cd6cefec51 Mon Sep 17 00:00:00 2001 From: Martin Perner Date: Wed, 7 Sep 2011 13:09:52 +0200 Subject: complete reword of the eventLoop *) replaced window destroy and create with a reposition *) replaced the exception for redraw with an MVar *) put nextEvent into an own thread, communication over the MVar *) signal handlers for repositioning and screen swap Notes: *) getScreenInfo is a parameter of eventLoop because it blocks when there is an nextEvent waiting for an new event --- src/Main.hs | 12 ++--- src/XUtil.hsc | 10 +++- src/Xmobar.hs | 143 +++++++++++++++++++++++++++++++++++++++------------------- xmobar.cabal | 2 +- 4 files changed, 110 insertions(+), 57 deletions(-) (limited to 'src/Main.hs') diff --git a/src/Main.hs b/src/Main.hs index 941a844..34a298d 100644 --- a/src/Main.hs +++ b/src/Main.hs @@ -41,8 +41,8 @@ import Control.Monad (unless) -- | The main entry point main :: IO () main = do + initThreads d <- openDisplay "" - d' <- openDisplay "" args <- getArgs (o,file) <- getOpts args (c,defaultings) <- case file of @@ -52,17 +52,13 @@ main = do unless (null defaultings) $ putStrLn $ "Fields missing from config defaulted: " ++ intercalate "," defaultings - -- listen for ConfigureEvents on the root window, for xrandr support: - rootw <- rootWindow d (defaultScreen d) - selectInput d rootw structureNotifyMask - conf <- doOpts c o fs <- initFont d (font conf) cls <- mapM (parseTemplate conf) (splitTemplate conf) vars <- mapM (mapM startCommand) cls - (r,w) <- createWin d fs conf - _ <- enableXRandrEventListen d' - eventLoop (XConf d d' r w fs conf) vars + (r,w, srs) <- createWin d fs conf + sig <- setupSignalHandler + eventLoop (XConf d r w fs conf) vars sig srs -- | Splits the template in its parts splitTemplate :: Config -> [String] diff --git a/src/XUtil.hsc b/src/XUtil.hsc index 6511b10..cb0c89a 100644 --- a/src/XUtil.hsc +++ b/src/XUtil.hsc @@ -1,4 +1,4 @@ -{-# OPTIONS -fglasgow-exts #-} +{-# LANGUAGE ForeignFunctionInterface #-} ----------------------------------------------------------------------------- -- | -- Module : XUtil @@ -28,13 +28,15 @@ module XUtil , fi , withColors , DynPixel(..) - , xrrSelectInput + , xrrSelectInput + , xrrQueryExtension ) where import Control.Concurrent import Control.Monad.Trans import Data.IORef import Foreign +import Foreign.C.Types import Graphics.X11.Xlib hiding (textExtents, textWidth) import qualified Graphics.X11.Xlib as Xlib (textExtents, textWidth) import Graphics.X11.Xlib.Extras @@ -263,3 +265,7 @@ setupLocale = return () #include foreign import ccall unsafe "X11/extensions/Xrandr.h XRRSelectInput" xrrSelectInput :: Display -> Window -> EventMask -> IO () + +-- XRRQueryExtension +foreign import ccall unsafe "X11/extensions/Xrandr.h XRRQueryExtension" + xrrQueryExtension :: Display -> Ptr CInt -> Ptr CInt -> IO (Bool) diff --git a/src/Xmobar.hs b/src/Xmobar.hs index 97d6990..e41c2b7 100644 --- a/src/Xmobar.hs +++ b/src/Xmobar.hs @@ -18,12 +18,13 @@ module Xmobar -- $main X , XConf (..), runX , eventLoop + , setupSignalHandler -- * Program Execution -- $command , startCommand -- * Window Management -- $window - , createWin, updateWin, enableXRandrEventListen + , createWin, updateWin -- * Printing -- $print , drawInWin, printStrings @@ -42,7 +43,9 @@ import Control.Exception hiding (handle) import Data.Bits import Data.Maybe(fromMaybe) import Data.Typeable (Typeable) +import Foreign import System.Posix.Process (getProcessID) +import System.Posix.Signals import Config import Parsers @@ -60,7 +63,6 @@ type X = ReaderT XConf IO -- | The ReaderT inner component data XConf = XConf { display :: Display - , xrrDspy :: Display -- display used for XRandr events , rect :: Rectangle , window :: Window , fontS :: XFont @@ -74,52 +76,97 @@ runX xc f = runReaderT f xc data WakeUp = WakeUp deriving (Show,Typeable) instance Exception WakeUp +data SignalType = Wakeup | Reposition | ChangeScreen + -- | The event loop -eventLoop :: XConf -> [[(Maybe ThreadId, TVar String)]] -> IO () -eventLoop xc@(XConf d xrrD _ w fs c) vs = block $ do +eventLoop :: XConf -> [[(Maybe ThreadId, TVar String)]] -> MVar SignalType -> [Rectangle] -> IO () +eventLoop xcfg@(XConf d _ w fs _) vs signal screeninfo = do tv <- atomically $ newTVar [] - t <- myThreadId - ct <- forkIO (checker t tv [] `catch` \(SomeException _) -> return ()) - go tv ct - where + tsrs <- atomically $ newTVar screeninfo + _ <- forkIO (checker tv [] `catch` \(SomeException _) -> putStrLn "Oh Noez checker" >> return ()) + _ <- forkOS (eventer tsrs `catch` \(SomeException _) -> putStrLn "Oh Noez eventer" >>return ()) + go tv xcfg tsrs + where -- interrupt the drawing thread every time a var is updated - checker t tvar ov = do + checker tvar ov = do nval <- atomically $ do nv <- mapM concatV vs guard (nv /= ov) writeTVar tvar nv return nv - throwTo t WakeUp - checker t tvar nval + putMVar signal Wakeup + checker tvar nval concatV = fmap concat . mapM (readTVar . snd) + eventer tsrs = + alloca $ \ptrEventBase -> + alloca $ \ptrErrorBase -> + allocaXEvent $ \e -> do + _ <- xrrQueryExtension d ptrEventBase ptrErrorBase + xrrEventBase <- peek ptrEventBase + forever $ do + nextEvent d e + ev <- getEvent e + case ev of + ConfigureEvent {} -> sendRepos + ExposeEvent {} -> putMVar signal Wakeup + _ -> + -- keyPressMask is the same value as RRScreenChangeNotify + when ( (fromIntegral (ev_event_type ev) - xrrEventBase) == fromIntegral keyPressMask) sendRepos + where + sendRepos = do + srs <- getScreenInfo d + atomically $ writeTVar tsrs srs + putMVar signal Reposition + + -- Continuously wait for a timer interrupt or an expose event - go tv ct = do - catch (unblock $ allocaXEvent $ \e -> - handle tv ct =<< (nextEvent' d e >> getEvent e)) - (\WakeUp -> runX xc (updateWin tv) >> return ()) - go tv ct - - -- event hanlder - handle _ ct (ConfigureEvent {}) = recreateWindow ct - - handle tvar ct (ExposeEvent {}) = block $ do - -- check if there are XRandr events pending - num <- pending xrrD - if num == 0 then - -- if no pending events, make a update - runX xc (updateWin tvar) - else - recreateWindow ct - - handle _ _ _ = return () - - recreateWindow ct = do - killThread ct - destroyWindow d w - (r',w') <- createWin d fs c - eventLoop (XConf d xrrD r' w' fs c) vs + go tv xc@(XConf _ _ _ _ cfg) tsrs = do + typ <- takeMVar signal + case typ of + Wakeup -> do + runX xc (updateWin tv) + go tv xc tsrs + Reposition -> do + ncfg <- reposWindow cfg + go tv ncfg tsrs + ChangeScreen -> + case position cfg of + OnScreen n o -> do + srs <- readTVarIO tsrs + if n == length srs then do + ncfg <- reposWindow (cfg {position = OnScreen 1 o}) + go tv ncfg tsrs + else do + ncfg <- reposWindow (cfg {position = OnScreen (n+1) o}) + go tv ncfg tsrs + o -> do + ncfg <- reposWindow (cfg {position = OnScreen 1 o}) + go tv ncfg tsrs + where + reposWindow rcfg = do + srs <- readTVarIO tsrs + r' <- repositionWin d w fs rcfg srs + return (XConf d r' w fs rcfg) + +-- | Signal handling +setupSignalHandler :: IO (MVar SignalType) +setupSignalHandler = do + tid <- newEmptyMVar + installHandler sigUSR1 (Catch $ updatePosHandler tid) Nothing + installHandler sigHUP (Catch $ changeScreenHandler tid) Nothing + return tid + +updatePosHandler :: MVar SignalType -> IO () +updatePosHandler sig = do + putMVar sig Reposition + return () + +changeScreenHandler :: MVar SignalType -> IO () +changeScreenHandler sig = do + putMVar sig ChangeScreen + return () -- $command @@ -138,16 +185,8 @@ startCommand (com,s,ss) -- $window --- | The function to enable notifications from XRandr -enableXRandrEventListen :: Display -> IO () -enableXRandrEventListen d = do - let dflt = defaultScreen d - rootw <- rootWindow d dflt - -- RRScreenChangeNotifyMask has the same value as keyPressMask - xrrSelectInput d rootw keyPressMask - -- | The function to create the initial window -createWin :: Display -> XFont -> Config -> IO (Rectangle,Window) +createWin :: Display -> XFont -> Config -> IO (Rectangle,Window,[Rectangle]) createWin d fs c = do let dflt = defaultScreen d srs <- getScreenInfo d @@ -156,11 +195,23 @@ createWin d fs c = do let ht = as + ds + 4 (r,o) = setPosition (position c) srs (fi ht) win <- newWindow d (defaultScreenOfDisplay d) rootw r o + -- keyPressMask is the same value as RRScreenChangeNotify + xrrSelectInput d rootw keyPressMask selectInput d win (exposureMask .|. structureNotifyMask) setProperties r c d win srs when (lowerOnStart c) (lowerWindow d win) mapWindow d win - return (r,win) + return (r,win, srs) + +-- | Updates the size and position of the window +repositionWin :: Display -> Window -> XFont -> Config -> [Rectangle] -> IO (Rectangle) +repositionWin d win fs c srs = do + (as,ds) <- textExtents fs "0" + let ht = as + ds + 4 + (r,_) = setPosition (position c) srs (fi ht) + moveResizeWindow d win (rect_x r) (rect_y r) (rect_width r) (rect_height r) + setProperties r c d win srs + return r setPosition :: XPosition -> [Rectangle] -> Dimension -> (Rectangle,Bool) setPosition p rs ht = diff --git a/xmobar.cabal b/xmobar.cabal index bb46101..e40494f 100644 --- a/xmobar.cabal +++ b/xmobar.cabal @@ -81,7 +81,7 @@ executable xmobar ghc-prof-options: -prof -auto-all if true - ghc-options: -funbox-strict-fields -Wall + ghc-options: -funbox-strict-fields -Wall -threaded extra-libraries: Xrandr if impl (ghc == 6.10.1) && arch (x86_64) -- cgit v1.2.3 From 735e4098b7d54dc248721a74873317e920b86d2b Mon Sep 17 00:00:00 2001 From: Martin Perner Date: Sat, 10 Sep 2011 16:02:49 +0200 Subject: removed threading problem with Xlib The output just stopped at some point until a new XEvent was received As XLockDisplay is in theory a good idea, with XNextEvent blocking its not usable. As it turned out, a window can be shared between display connections. Now the eventloop has its own display connection (which also removes the need for the lock introduced before). Additionally the screeninfo doesn't need to be fetched into a TVar in the eventerloop anymore. Also this was needed for the signalHandlers to work correctly again. --- src/Main.hs | 4 ++-- src/Xmobar.hs | 69 +++++++++++++++++++++++++++-------------------------------- 2 files changed, 33 insertions(+), 40 deletions(-) (limited to 'src/Main.hs') diff --git a/src/Main.hs b/src/Main.hs index 34a298d..0d4c113 100644 --- a/src/Main.hs +++ b/src/Main.hs @@ -56,9 +56,9 @@ main = do fs <- initFont d (font conf) cls <- mapM (parseTemplate conf) (splitTemplate conf) vars <- mapM (mapM startCommand) cls - (r,w, srs) <- createWin d fs conf + (r,w) <- createWin d fs conf sig <- setupSignalHandler - eventLoop (XConf d r w fs conf) vars sig srs + eventLoop (XConf d r w fs conf) vars sig -- | Splits the template in its parts splitTemplate :: Config -> [String] diff --git a/src/Xmobar.hs b/src/Xmobar.hs index e41c2b7..abf6ab3 100644 --- a/src/Xmobar.hs +++ b/src/Xmobar.hs @@ -79,13 +79,12 @@ instance Exception WakeUp data SignalType = Wakeup | Reposition | ChangeScreen -- | The event loop -eventLoop :: XConf -> [[(Maybe ThreadId, TVar String)]] -> MVar SignalType -> [Rectangle] -> IO () -eventLoop xcfg@(XConf d _ w fs _) vs signal screeninfo = do +eventLoop :: XConf -> [[(Maybe ThreadId, TVar String)]] -> MVar SignalType -> IO () +eventLoop xcfg@(XConf d _ w fs _) vs signal = do tv <- atomically $ newTVar [] - tsrs <- atomically $ newTVar screeninfo _ <- forkIO (checker tv [] `catch` \(SomeException _) -> putStrLn "Oh Noez checker" >> return ()) - _ <- forkOS (eventer tsrs `catch` \(SomeException _) -> putStrLn "Oh Noez eventer" >>return ()) - go tv xcfg tsrs + _ <- forkOS (eventer `catch` \(SomeException _) -> putStrLn "Oh Noez eventer" >>return ()) + go tv xcfg where -- interrupt the drawing thread every time a var is updated checker tvar ov = do @@ -99,56 +98,52 @@ eventLoop xcfg@(XConf d _ w fs _) vs signal screeninfo = do concatV = fmap concat . mapM (readTVar . snd) - eventer tsrs = + eventer = alloca $ \ptrEventBase -> alloca $ \ptrErrorBase -> allocaXEvent $ \e -> do _ <- xrrQueryExtension d ptrEventBase ptrErrorBase xrrEventBase <- peek ptrEventBase + + dpy <- openDisplay "" + -- keyPressMask is the same value as RRScreenChangeNotify + xrrSelectInput dpy (defaultRootWindow dpy) keyPressMask + selectInput dpy w (exposureMask .|. structureNotifyMask) + forever $ do - nextEvent d e + nextEvent dpy e ev <- getEvent e case ev of - ConfigureEvent {} -> sendRepos + ConfigureEvent {} -> putMVar signal Reposition ExposeEvent {} -> putMVar signal Wakeup _ -> -- keyPressMask is the same value as RRScreenChangeNotify - when ( (fromIntegral (ev_event_type ev) - xrrEventBase) == fromIntegral keyPressMask) sendRepos - where - sendRepos = do - srs <- getScreenInfo d - atomically $ writeTVar tsrs srs - putMVar signal Reposition + when ( (fromIntegral (ev_event_type ev) - xrrEventBase) == fromIntegral keyPressMask) + $ putMVar signal Reposition -- Continuously wait for a timer interrupt or an expose event - go tv xc@(XConf _ _ _ _ cfg) tsrs = do + go tv xc@(XConf _ _ _ _ cfg) = do typ <- takeMVar signal case typ of Wakeup -> do runX xc (updateWin tv) - go tv xc tsrs - Reposition -> do - ncfg <- reposWindow cfg - go tv ncfg tsrs + go tv xc + Reposition -> reposWindow cfg ChangeScreen -> case position cfg of OnScreen n o -> do - srs <- readTVarIO tsrs + srs <- getScreenInfo d if n == length srs then do - ncfg <- reposWindow (cfg {position = OnScreen 1 o}) - go tv ncfg tsrs - else do - ncfg <- reposWindow (cfg {position = OnScreen (n+1) o}) - go tv ncfg tsrs - o -> do - ncfg <- reposWindow (cfg {position = OnScreen 1 o}) - go tv ncfg tsrs + reposWindow (cfg {position = OnScreen 1 o}) + else + reposWindow (cfg {position = OnScreen (n+1) o}) + o -> + reposWindow (cfg {position = OnScreen 1 o}) where reposWindow rcfg = do - srs <- readTVarIO tsrs - r' <- repositionWin d w fs rcfg srs - return (XConf d r' w fs rcfg) + r' <- repositionWin d w fs rcfg + go tv (XConf d r' w fs rcfg) -- | Signal handling setupSignalHandler :: IO (MVar SignalType) @@ -186,7 +181,7 @@ startCommand (com,s,ss) -- $window -- | The function to create the initial window -createWin :: Display -> XFont -> Config -> IO (Rectangle,Window,[Rectangle]) +createWin :: Display -> XFont -> Config -> IO (Rectangle,Window) createWin d fs c = do let dflt = defaultScreen d srs <- getScreenInfo d @@ -195,17 +190,15 @@ createWin d fs c = do let ht = as + ds + 4 (r,o) = setPosition (position c) srs (fi ht) win <- newWindow d (defaultScreenOfDisplay d) rootw r o - -- keyPressMask is the same value as RRScreenChangeNotify - xrrSelectInput d rootw keyPressMask - selectInput d win (exposureMask .|. structureNotifyMask) setProperties r c d win srs when (lowerOnStart c) (lowerWindow d win) mapWindow d win - return (r,win, srs) + return (r,win) -- | Updates the size and position of the window -repositionWin :: Display -> Window -> XFont -> Config -> [Rectangle] -> IO (Rectangle) -repositionWin d win fs c srs = do +repositionWin :: Display -> Window -> XFont -> Config -> IO (Rectangle) +repositionWin d win fs c = do + srs <- getScreenInfo d (as,ds) <- textExtents fs "0" let ht = as + ds + 4 (r,_) = setPosition (position c) srs (fi ht) -- cgit v1.2.3 From b2601191cf84efdd6d0e144385c82e9d3a45cd27 Mon Sep 17 00:00:00 2001 From: Martin Perner Date: Sat, 10 Sep 2011 17:01:10 +0200 Subject: moved signal handler setup into eventloop --- src/Main.hs | 3 +-- src/Xmobar.hs | 24 ++++++++++++------------ 2 files changed, 13 insertions(+), 14 deletions(-) (limited to 'src/Main.hs') diff --git a/src/Main.hs b/src/Main.hs index 0d4c113..e8efd61 100644 --- a/src/Main.hs +++ b/src/Main.hs @@ -57,8 +57,7 @@ main = do cls <- mapM (parseTemplate conf) (splitTemplate conf) vars <- mapM (mapM startCommand) cls (r,w) <- createWin d fs conf - sig <- setupSignalHandler - eventLoop (XConf d r w fs conf) vars sig + eventLoop (XConf d r w fs conf) vars -- | Splits the template in its parts splitTemplate :: Config -> [String] diff --git a/src/Xmobar.hs b/src/Xmobar.hs index abf6ab3..c5613a6 100644 --- a/src/Xmobar.hs +++ b/src/Xmobar.hs @@ -18,7 +18,6 @@ module Xmobar -- $main X , XConf (..), runX , eventLoop - , setupSignalHandler -- * Program Execution -- $command , startCommand @@ -79,26 +78,27 @@ instance Exception WakeUp data SignalType = Wakeup | Reposition | ChangeScreen -- | The event loop -eventLoop :: XConf -> [[(Maybe ThreadId, TVar String)]] -> MVar SignalType -> IO () -eventLoop xcfg@(XConf d _ w fs _) vs signal = do +eventLoop :: XConf -> [[(Maybe ThreadId, TVar String)]] -> IO () +eventLoop xcfg@(XConf d _ w fs _) vs = do tv <- atomically $ newTVar [] - _ <- forkIO (checker tv [] `catch` \(SomeException _) -> putStrLn "Oh Noez checker" >> return ()) - _ <- forkOS (eventer `catch` \(SomeException _) -> putStrLn "Oh Noez eventer" >>return ()) - go tv xcfg + sig <- setupSignalHandler + _ <- forkIO (checker tv [] sig `catch` \(SomeException _) -> putStrLn "Oh Noez checker" >> return ()) + _ <- forkOS (eventer sig `catch` \(SomeException _) -> putStrLn "Oh Noez eventer" >>return ()) + go tv xcfg sig where -- interrupt the drawing thread every time a var is updated - checker tvar ov = do + checker tvar ov signal = do nval <- atomically $ do nv <- mapM concatV vs guard (nv /= ov) writeTVar tvar nv return nv putMVar signal Wakeup - checker tvar nval + checker tvar nval signal concatV = fmap concat . mapM (readTVar . snd) - eventer = + eventer signal = alloca $ \ptrEventBase -> alloca $ \ptrErrorBase -> allocaXEvent $ \e -> do @@ -123,12 +123,12 @@ eventLoop xcfg@(XConf d _ w fs _) vs signal = do -- Continuously wait for a timer interrupt or an expose event - go tv xc@(XConf _ _ _ _ cfg) = do + go tv xc@(XConf _ _ _ _ cfg) signal = do typ <- takeMVar signal case typ of Wakeup -> do runX xc (updateWin tv) - go tv xc + go tv xc signal Reposition -> reposWindow cfg ChangeScreen -> case position cfg of @@ -143,7 +143,7 @@ eventLoop xcfg@(XConf d _ w fs _) vs signal = do where reposWindow rcfg = do r' <- repositionWin d w fs rcfg - go tv (XConf d r' w fs rcfg) + go tv (XConf d r' w fs rcfg) signal -- | Signal handling setupSignalHandler :: IO (MVar SignalType) -- cgit v1.2.3