diff options
| -rw-r--r-- | src/Main.hs | 12 | ||||
| -rw-r--r-- | src/XUtil.hsc | 10 | ||||
| -rw-r--r-- | src/Xmobar.hs | 143 | ||||
| -rw-r--r-- | xmobar.cabal | 2 |
4 files changed, 110 insertions, 57 deletions
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 <X11/extensions/Xrandr.h> 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) |