Add native error handler for systray

lib/Phi/Bindings/SystrayErrorHandler.hsc

@@ -0,0 +1,17 @@
+{-# LANGUAGE ForeignFunctionInterface #-}
+
+module Phi.Bindings.SystrayErrorHandler ( setSystrayErrorHandler
+                                        , getLastErrorWindow
+                                        ) where
+
+#include <SystrayErrorHandler.h>
+
+
+import Graphics.X11.Xlib
+
+
+foreign import ccall unsafe "SystrayErrorHandler.h setSystrayErrorHandler"
+  setSystrayErrorHandler :: IO ()
+
+foreign import ccall unsafe "SystrayErrorHandler.h getLastErrorWindow"
+  getLastErrorWindow :: IO Window

lib/Phi/Widgets/Systray.hs

@@ -24,6 +24,7 @@ import qualified Graphics.X11.Xlib as Xlib
 import Graphics.X11.Xlib.Extras
 
 import Phi.Bindings.Util
+import Phi.Bindings.SystrayErrorHandler
 
 import Phi.Phi
 import Phi.Types
@@ -103,16 +104,10 @@ systrayRunner phi dispvar = do
           _ ->
             case (fromMessage m) of
               Just (RenderIcon midParent window x y w h reset) -> do
-                errorWindowRef <- liftIO $ newIORef []
-                
                 withDisplay dispvar $ \disp -> do
                   liftIO $ flip catch (\_ -> return ()) $ do
                     sync disp False
-                    setErrorHandler $ \disp eventptr -> do
-                      event <- getErrorEvent eventptr
-                      when (ev_error_code event == fromIntegral badWindow) $ do
-                        errorWindows <- readIORef errorWindowRef
-                        writeIORef errorWindowRef (ev_resourceid event:errorWindows)
+                    setSystrayErrorHandler
                     
                     (_, x', y', w', h', _, _) <- getGeometry disp midParent
                     (_, _, _, w'', h'', _, _) <- getGeometry disp window
@@ -124,14 +119,15 @@ systrayRunner phi dispvar = do
                       resizeWindow disp window (fromIntegral w) (fromIntegral h)
                       sync disp False
                     
-                    when (resize || reset) $ do
-                      clearArea disp window 0 0 (fromIntegral w) (fromIntegral h) True
-                      sync disp False
-                  
+                    clearArea disp window 0 0 (fromIntegral w) (fromIntegral h) True
+                      
+                    sync disp False
                     xSetErrorHandler
                   
-                  errorWindows <- liftIO $ readIORef errorWindowRef
-                  mapM_ (removeIcon phi disp) errorWindows
+                  lastErrorWindow <- liftIO $ getLastErrorWindow
+                  when (lastErrorWindow == window) $ do
+                    liftIO $ print window
+                    removeIcon phi disp window
               _ ->
                 case (fromMessage m) of
                   Just Shutdown -> do
@@ -234,24 +230,18 @@ addIcon :: Phi -> Xlib.Display -> Atoms -> Window -> Window -> StateT (M.Map Win
 addIcon phi disp atoms panelWindow window = do
   liftIO $ selectInput disp window $ structureNotifyMask .|. propertyChangeMask
   
-  errorRef <- liftIO $ newIORef False
   midParent <- liftIO $ createSimpleWindow disp panelWindow (-16) (-16) 16 16 0 0 0
   
   liftIO $ do
     setWindowBackgroundPixmap disp midParent 1 -- ParentRelative
     
     sync disp False
-    setErrorHandler $ \disp eventptr -> do
-      event <- getErrorEvent eventptr
-      when (ev_error_code event == fromIntegral badWindow && ev_resourceid event == window) $
-        writeIORef errorRef True
+    setSystrayErrorHandler
     
     reparentWindow disp window midParent 0 0
-    sync disp False
     
     mapRaised disp midParent
     mapWindow disp window
-    sync disp False
     
     allocaXEvent $ \event -> do
       putClientMessage event window (atom_XEMBED atoms) [fromIntegral currentTime, fromIntegral xEMBED_EMBEDDED_NOTIFY, 0, fromIntegral midParent, 0]
@@ -260,13 +250,13 @@ addIcon phi disp atoms panelWindow window = do
     sync disp False
     xSetErrorHandler
   
-  error <- liftIO $ readIORef errorRef
-  case error of
-    False -> do
+  errorWindow <- liftIO $ getLastErrorWindow
+  case True of
+    _ | errorWindow /= window -> do
       sendMessage phi $ AddIcon midParent window
       sendMessage phi Repaint
       modify $ M.insert window midParent
-    True ->
+      | otherwise ->
       liftIO $ destroyWindow disp midParent
 
 

lib/Phi/X11.hs

@@ -223,7 +223,6 @@ updatePanels dispvar = do
       
       -- copy buffer to window
       liftIO $ do
-        setWindowBackgroundPixmap disp (panelWindow panel') pixmap
         (withDimension area $ clearArea disp (panelWindow panel') 0 0) True
         sync disp False
     
@@ -282,6 +281,7 @@ createPanel disp win widgets screenRect = do
       depth = defaultDepth disp screen
     
   pixmap <- liftIO $ (withDimension rect $ createPixmap disp win) depth
+  liftIO $ setWindowBackgroundPixmap disp win pixmap
   
   return PanelState { panelWindow = win
                     , panelPixmap = pixmap