Merge branch 'screen_update' of git://github.com/skinner33/xmobar into skinner-screen_update

Conflicts:
	NEWS
	src/XUtil.hsc

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