From 4fe99635e87c4f2262a27bf91c1ab6c7e3ee0988 Mon Sep 17 00:00:00 2001
From: Martin Perner <martin@perner.cc>
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 +++-
 src/Xmobar.hs | 40 ++++++++++++++++++++++++++++------------
 2 files changed, 31 insertions(+), 13 deletions(-)

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]
diff --git a/src/Xmobar.hs b/src/Xmobar.hs
index 462de14..97d6990 100644
--- a/src/Xmobar.hs
+++ b/src/Xmobar.hs
@@ -23,7 +23,7 @@ module Xmobar
     , startCommand
     -- * Window Management
     -- $window
-    , createWin, updateWin
+    , createWin, updateWin, enableXRandrEventListen
     -- * Printing
     -- $print
     , drawInWin, printStrings
@@ -60,6 +60,7 @@ 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
@@ -75,7 +76,7 @@ instance Exception WakeUp
 
 -- | The event loop
 eventLoop :: XConf -> [[(Maybe ThreadId, TVar String)]] -> IO ()
-eventLoop xc@(XConf d _ w fs c) vs = block $ do
+eventLoop xc@(XConf d xrrD _ w fs c) vs = block $ do
     tv <- atomically $ newTVar []
     t  <- myThreadId
     ct <- forkIO (checker t tv [] `catch` \(SomeException _) -> return ())
@@ -101,16 +102,24 @@ eventLoop xc@(XConf d _ w fs c) vs = block $ do
       go tv ct
 
     -- event hanlder
-    handle _ _ (ConfigureEvent {}) = return ()
+    handle _ ct (ConfigureEvent {}) = recreateWindow ct
 
-    handle tvar _ (ExposeEvent {}) = runX xc (updateWin tvar)
+    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
 
-    --  this catches the RRScreenChangeNotify
-    handle _ ct _  = block $ do
-                      killThread ct
-                      destroyWindow d w
-                      (r',w') <- createWin d fs c
-                      eventLoop (XConf d r' w' fs c) vs
+    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
 
 -- $command
 
@@ -129,6 +138,14 @@ 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 d fs c = do
@@ -139,8 +156,7 @@ 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
-  --  RRScreenChangeNotifyMask has the same value as keyPressMask
-  xrrSelectInput    d rootw keyPressMask
+  selectInput       d win (exposureMask .|. structureNotifyMask)
   setProperties r c d win srs
   when (lowerOnStart c) (lowerWindow d win)
   mapWindow         d win
-- 
cgit v1.2.3