diff options
Diffstat (limited to 'src')
| -rw-r--r-- | src/Main.hs | 5 | ||||
| -rw-r--r-- | src/XUtil.hsc | 16 | ||||
| -rw-r--r-- | src/Xmobar.hs | 111 |
3 files changed, 101 insertions, 31 deletions
diff --git a/src/Main.hs b/src/Main.hs index 18e05e2..e8efd61 100644 --- a/src/Main.hs +++ b/src/Main.hs @@ -41,6 +41,7 @@ import Control.Monad (unless) -- | The main entry point main :: IO () main = do + initThreads d <- openDisplay "" args <- getArgs (o,file) <- getOpts args @@ -51,10 +52,6 @@ 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) diff --git a/src/XUtil.hsc b/src/XUtil.hsc index 1de5e47..ea051f8 100644 --- a/src/XUtil.hsc +++ b/src/XUtil.hsc @@ -1,8 +1,8 @@ --- {-# OPTIONS -fglasgow-exts #-} +{-# LANGUAGE ForeignFunctionInterface #-} ----------------------------------------------------------------------------- -- | -- Module : XUtil --- Copyright : (C) 2007 Andrea Rossato +-- Copyright : (C) 2007, 2011 Andrea Rossato -- License : BSD3 -- -- Maintainer : andrea.rossato@unitn.it @@ -28,12 +28,15 @@ module XUtil , fi , withColors , DynPixel(..) + , 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 @@ -257,3 +260,12 @@ setupLocale = withCString "" (setlocale $ #const LC_ALL) >> return () setupLocale :: IO () setupLocale = return () #endif + +-- XRRSelectInput +#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 eb7a1dd..37fd653 100644 --- a/src/Xmobar.hs +++ b/src/Xmobar.hs @@ -42,7 +42,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 @@ -73,45 +75,94 @@ 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 _ w fs c) vs = block $ do +eventLoop xcfg@(XConf d _ w fs _) vs = do tv <- atomically $ newTVar [] - t <- myThreadId - ct <- forkIO (checker t tv [] `catch` \(SomeException _) -> return ()) - go tv ct - where + sig <- setupSignalHandler + _ <- forkIO (checker tv [] sig `catch` \(SomeException _) -> putStrLn "Thread checker failed" >> return ()) + _ <- forkOS (eventer sig `catch` \(SomeException _) -> putStrLn "Thread eventer failed" >> return ()) + go tv xcfg sig + where -- interrupt the drawing thread every time a var is updated - checker t tvar ov = do + checker tvar ov signal = 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 signal concatV = fmap concat . mapM (readTVar . snd) - -- 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 + eventer signal = + alloca $ \ptrEventBase -> + alloca $ \ptrErrorBase -> + allocaXEvent $ \e -> do - -- event hanlder - handle _ ct (ConfigureEvent {ev_window = win}) = do - rootw <- rootWindow d (defaultScreen d) - when (win == rootw) $ block $ do - killThread ct - destroyWindow d w - (r',w') <- createWin d fs c - eventLoop (XConf d r' w' fs c) vs + dpy <- openDisplay "" + -- keyPressMask is the same value as RRScreenChangeNotifyMask + xrrSelectInput dpy (defaultRootWindow dpy) keyPressMask + selectInput dpy w (exposureMask .|. structureNotifyMask) - handle tvar _ (ExposeEvent {}) = runX xc (updateWin tvar) + _ <- xrrQueryExtension dpy ptrEventBase ptrErrorBase + xrrEventBase <- peek ptrEventBase - handle _ _ _ = return () + forever $ do + nextEvent dpy e + ev <- getEvent e + case ev of + ConfigureEvent {} -> putMVar signal Reposition + ExposeEvent {} -> putMVar signal Wakeup + _ -> + -- 0 is the value of RRScreenChangeNotify + when ( (fromIntegral (ev_event_type ev) - xrrEventBase) == 0) + $ putMVar signal Reposition + + + -- Continuously wait for a timer interrupt or an expose event + go tv xc@(XConf _ _ _ _ cfg) signal = do + typ <- takeMVar signal + case typ of + Wakeup -> do + runX xc (updateWin tv) + go tv xc signal + Reposition -> reposWindow cfg + ChangeScreen -> + case position cfg of + OnScreen n o -> do + srs <- getScreenInfo d + if n == length srs then + 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 + r' <- repositionWin d w fs rcfg + go tv (XConf d r' w fs rcfg) signal + +-- | Signal handling +setupSignalHandler :: IO (MVar SignalType) +setupSignalHandler = do + tid <- newEmptyMVar + installHandler sigUSR2 (Catch $ updatePosHandler tid) Nothing + installHandler sigUSR1 (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 @@ -140,12 +191,22 @@ 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 - selectInput d win (exposureMask .|. structureNotifyMask) setProperties r c d win srs when (lowerOnStart c) (lowerWindow d win) mapWindow d win return (r,win) +-- | Updates the size and position of the window +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) + 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 = case p' of |