complete reword of the eventLoop

*) replaced window destroy and create with a reposition
*) replaced the exception for redraw with an MVar
*) put nextEvent into an own thread, communication over the MVar
*) signal handlers for repositioning and screen swap

Notes:
*) getScreenInfo is a parameter of eventLoop because it blocks when there
is an nextEvent waiting for an new event

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)