Basic systray implementation

1 files changed, 145 insertions, 18 deletions

diff --git a/lib/Phi/Widgets/Systray.hs b/lib/Phi/Widgets/Systray.hs
index e1ab198..3d3c38b 100644
--- a/lib/Phi/Widgets/Systray.hs
+++ b/lib/Phi/Widgets/Systray.hs
@@ -5,11 +5,20 @@ module Phi.Widgets.Systray ( systray
 
 import Control.Concurrent
 import Control.Monad
+import Control.Monad.State
+import Control.Monad.Trans
 
+import Data.Bits
+import Data.IORef
 import Data.Maybe
+import Data.Typeable
+import qualified Data.Map as M
 
 import Foreign.C.Types
 
+import Graphics.Rendering.Cairo
+import Graphics.Rendering.Cairo.Types
+
 import Graphics.X11.Xlib hiding (Display)
 import qualified Graphics.X11.Xlib as Xlib
 import Graphics.X11.Xlib.Extras
@@ -22,12 +31,25 @@ import Phi.Widget
 import Phi.X11.Atoms
 
 
-data SystrayIconState = SystrayIconState deriving Show
+instance Show Display where
+  show _ = "Display <?>"
+
+instance Show Phi where
+  show _ = "Phi <?>"
+
+instance Show (IORef a) where
+  show _ = "IORef <?>"
+
 
-data SystrayState = SystrayState Rectangle [SystrayIconState] deriving Show
+data SystrayIconState = SystrayIconState Window Window deriving Show
+
+data SystrayState = SystrayState Phi Rectangle Int (IORef Int) [SystrayIconState] deriving Show
 
 data Systray = Systray deriving Show
 
+data SystrayMessage = AddIcon Window Window | RemoveIcon Window | RenderIcon Window Window Int Int Int Int Bool
+                      deriving (Show, Typeable)
+
 
 instance WidgetClass Systray where
   type WidgetData Systray = SystrayState
@@ -35,18 +57,33 @@ instance WidgetClass Systray where
   initWidget (Systray) phi dispvar = do
     forkIO $ systrayRunner phi dispvar
     
-    return $ SystrayState (head . getScreens $ dispvar) []
+    lastReset <- newIORef 0
+    return $ SystrayState phi (head . getScreens $ dispvar) 0 lastReset []
   
-  minSize _ (SystrayState systrayScreen icons) height screen = case True of 
+  minSize _ (SystrayState _ systrayScreen _ _ icons) height screen = case True of 
     _ | screen == systrayScreen -> (length icons)*height
       | otherwise -> 0
 
   weight _ = 0
   
-  render Systray (SystrayState systrayScreen icons) w h screen = case True of 
+  render Systray (SystrayState phi systrayScreen reset lastResetRef icons) w h screen = case True of 
     _ | screen == systrayScreen -> do
-      return ()
+      lastReset <- liftIO $ readIORef lastResetRef
+      liftIO $ writeIORef lastResetRef reset
+      Matrix _ _ _ _ dx dy <- getMatrix
+      forM_ (zip [0..] icons) $ \(i, SystrayIconState midParent window) -> do
+        let x = round dx + i*h 
+            y = round dy
+        sendMessage phi $ RenderIcon midParent window x y h h (lastReset /= reset)
+        
       | otherwise -> return ()
+  
+  handleMessage _ priv@(SystrayState phi screen reset lastReset icons) m = case (fromMessage m) of
+    Just (AddIcon midParent window) -> SystrayState phi screen reset lastReset ((SystrayIconState midParent window):icons)
+    Just (RemoveIcon window) -> SystrayState phi screen reset lastReset $ filter (\(SystrayIconState _ stateWindow) -> stateWindow /= window) icons
+    _ -> case (fromMessage m) of
+      Just ResetBackground -> SystrayState phi screen (reset+1) lastReset icons
+      _ ->  priv
 
 
 systrayRunner :: Phi -> Display -> IO ()
@@ -55,13 +92,45 @@ systrayRunner phi dispvar = do
   initSuccess <- withDisplay dispvar $ flip initSystray atoms
   
   case initSuccess of
-    Just xembedWindow -> forever $ do
+    Just xembedWindow -> flip evalStateT M.empty $ forever $ do
       m <- receiveMessage phi
       case (fromMessage m) of
         Just event ->
           handleEvent event phi dispvar xembedWindow
         _ ->
-          return ()
+          case (fromMessage m) of
+            Just (RenderIcon midParent window x y w h reset) -> do
+              errorWindowRef <- liftIO $ newIORef []
+              
+              withDisplay dispvar $ \disp -> do
+                liftIO $ 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)
+
+                (_, x', y', w', h', _, _) <- liftIO $ getGeometry disp midParent
+                let resize = (fromIntegral x) /= x' || (fromIntegral y) /= y' || (fromIntegral w) /= w' || (fromIntegral h) /= h'
+                
+                when resize $ liftIO $ do
+                  moveResizeWindow disp midParent (fromIntegral x) (fromIntegral y) (fromIntegral w) (fromIntegral h)
+                  resizeWindow disp window (fromIntegral w) (fromIntegral h)
+                  liftIO $ sync disp False
+                
+                when (resize || reset) $ liftIO $ do
+                  clearArea disp midParent 0 0 (fromIntegral w) (fromIntegral h) True
+                  liftIO $ sync disp False
+                  clearArea disp window 0 0 (fromIntegral w) (fromIntegral h) True
+                  liftIO $ sync disp False
+                
+                liftIO $ xSetErrorHandler
+                
+                errorWindows <- liftIO $ readIORef errorWindowRef
+                mapM_ (removeIcon phi disp) errorWindows
+            _ ->
+              return ()
     Nothing ->
       return ()
 
@@ -114,34 +183,92 @@ sYSTEM_TRAY_BEGIN_MESSAGE = 1
 sYSTEM_TRAY_CANCEL_MESSAGE :: CInt
 sYSTEM_TRAY_CANCEL_MESSAGE = 2
 
+xEMBED_EMBEDDED_NOTIFY :: CInt
+xEMBED_EMBEDDED_NOTIFY = 0
 
-handleEvent :: Event -> Phi -> Display -> Window -> IO ()
-handleEvent ClientMessageEvent { ev_message_type = message_type, ev_data = messageData, ev_window = window } phi dispvar xembedWindow = do
+handleEvent :: Event -> Phi -> Display -> Window -> StateT (M.Map Window Window) IO ()
+handleEvent message@ClientMessageEvent { ev_message_type = message_type, ev_data = messageData, ev_window = window } phi dispvar xembedWindow = do
   let atoms = getAtoms dispvar
+      screenWindows = getScreenWindows dispvar
   when (window == xembedWindow && message_type == atom_NET_SYSTEM_TRAY_OPCODE atoms) $ do
     case messageData of
-      (_:opcode:iconID:_) -> do
+      _:opcode:iconID:_ -> do
         case True of
-          _ | opcode == sYSTEM_TRAY_REQUEST_DOCK ->
-            when (iconID /= 0) $ addIcon phi dispvar $ fromIntegral iconID
-        
+          _ | opcode == sYSTEM_TRAY_REQUEST_DOCK -> do
+            when (iconID /= 0) $ withDisplay dispvar $ \disp -> addIcon phi disp (getAtoms dispvar) (snd . head $ screenWindows) $ fromIntegral iconID
+          
             | opcode == sYSTEM_TRAY_BEGIN_MESSAGE || opcode == sYSTEM_TRAY_CANCEL_MESSAGE ->
             return ()
             
             | otherwise -> do
-            putStrLn "Phi: unknown tray message"
+            liftIO $ putStrLn "Phi: unknown tray message"
             return ()
         
           
       _ ->
         return ()
 
+handleEvent message@UnmapEvent { ev_window = window } phi dispvar xembedWindow =
+  withDisplay dispvar $ flip (removeIcon phi) window
+
+handleEvent message@DestroyWindowEvent { ev_window = window } phi dispvar xembedWindow =
+  withDisplay dispvar $ flip (removeIcon phi) window
+
 handleEvent _ _ _ _ = return ()
 
 
-addIcon :: Phi -> Display -> Window -> IO ()
-addIcon phi display window = do
-  return ()
+addIcon :: Phi -> Xlib.Display -> Atoms -> Window -> Window -> StateT (M.Map Window Window) IO ()
+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
+    
+    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]
+      sendEvent disp window False 0xFFFFFF event
+    
+    sync disp False
+    xSetErrorHandler
+  
+  error <- liftIO $ readIORef errorRef
+  case error of
+    False -> do
+      sendMessage phi $ AddIcon midParent window
+      sendMessage phi Repaint
+      modify $ M.insert window midParent
+    True ->
+      liftIO $ destroyWindow disp midParent
+
+
+removeIcon :: Phi -> Xlib.Display -> Window -> StateT (M.Map Window Window) IO ()
+removeIcon phi disp window = do
+  mmidParent <- gets $ M.lookup window
+  case mmidParent of
+    Just midParent -> do
+      sendMessage phi $ RemoveIcon window
+      sendMessage phi Repaint
+      liftIO $ do
+        reparentWindow disp window (defaultRootWindow disp) 0 0
+        destroyWindow disp midParent
+    _ ->
+      return ()
 
 
 systray :: Widget