summaryrefslogtreecommitdiffhomepage
diff options
context:
space:
mode:
-rw-r--r--src/Main.hs12
-rw-r--r--src/XUtil.hsc10
-rw-r--r--src/Xmobar.hs143
-rw-r--r--xmobar.cabal2
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)