Basic systray implementation

lib/Phi/Bindings/Util.hsc

@@ -3,6 +3,7 @@
 module Phi.Bindings.Util ( setClassHint
                          , visualIDFromVisual
                          , putClientMessage
+                         , Phi.Bindings.Util.getEvent
                          , createXlibSurface
                          ) where
 
@@ -51,6 +52,35 @@ putClientMessage event window message_type messageData = do
 foreign import ccall unsafe "cairo-xlib.h cairo_xlib_surface_create"
   xlibSurfaceCreate :: Display -> Drawable -> Visual -> CInt -> CInt -> IO (Ptr Surface)
 
+getEvent :: Display -> XEventPtr -> IO Event
+getEvent display p = do
+  eventType <- get_EventType p
+  case True of
+    _ | eventType == clientMessage -> do
+      serial       <- (#peek XClientMessageEvent, serial) p
+      send_event   <- (#peek XClientMessageEvent, send_event) p
+      window       <- (#peek XClientMessageEvent, window) p
+      message_type <- (#peek XClientMessageEvent, message_type) p
+      format       <- (#peek XClientMessageEvent, format) p
+      let datPtr =    (#ptr XClientMessageEvent, data) p
+      dat          <- case (format::CInt) of
+        8  -> do a <- peekArray 20 datPtr
+                 return $ map fromIntegral (a::[CUChar])
+        16 -> do a <- peekArray 10 datPtr
+                 return $ map fromIntegral (a::[CUShort])
+        32 -> do a <- peekArray 5 datPtr
+                 return $ map fromIntegral (a::[CULong])
+      return $ ClientMessageEvent { ev_event_type    = eventType
+                                  , ev_serial        = serial
+                                  , ev_send_event    = send_event
+                                  , ev_event_display = display
+                                  , ev_window        = window
+                                  , ev_message_type  = message_type
+                                  , ev_data          = dat
+                                  }
+      | otherwise -> Graphics.X11.Xlib.Extras.getEvent p
+
+
 createXlibSurface :: Display -> Drawable -> Visual -> CInt -> CInt -> IO Surface
 createXlibSurface dpy drawable visual width height = do
   surfacePtr <- xlibSurfaceCreate dpy drawable visual width height

lib/Phi/Phi.hs

@@ -22,7 +22,7 @@ data Phi = Phi (TChan Message)
 data Message = forall a. (Typeable a, Show a) => Message a
 deriving instance Show Message
 
-data DefaultMessage = Repaint deriving (Typeable, Show)
+data DefaultMessage = Repaint | ResetBackground deriving (Typeable, Show)
 
 fromMessage :: (Typeable a, Show a) => Message -> Maybe a
 fromMessage (Message m) = cast m

lib/Phi/Widget.hs

@@ -3,6 +3,7 @@
 module Phi.Widget ( Display(..)
                   , withDisplay
                   , getAtoms
+                  , getScreenWindows
                   , getScreens
                   , unionArea
                   , Widget(..)
@@ -28,7 +29,7 @@ import Phi.Phi
 import Phi.X11.Atoms
 
 
-data Display = Display (MVar Xlib.Display) Atoms [Xlib.Rectangle]
+data Display = Display (MVar Xlib.Display) Atoms [(Xlib.Rectangle, Xlib.Window)]
 
 withDisplay :: MonadIO m => Display -> (Xlib.Display -> m a) -> m a
 withDisplay (Display dispvar _ _) f = do
@@ -40,8 +41,12 @@ withDisplay (Display dispvar _ _) f = do
 getAtoms :: Display -> Atoms
 getAtoms (Display _ atoms _) = atoms
 
+getScreenWindows :: Display -> [(Xlib.Rectangle, Xlib.Window)]
+getScreenWindows (Display _ _ screenWindows) = screenWindows
+
 getScreens :: Display -> [Xlib.Rectangle]
-getScreens (Display _ _ screens) = screens
+getScreens = map fst . getScreenWindows
+
 
 unionArea :: Xlib.Rectangle -> Xlib.Rectangle -> Int
 unionArea a b = fromIntegral $ uw*uh

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 <?>"
 
-data SystrayState = SystrayState Rectangle [SystrayIconState] deriving Show
+instance Show Phi where
+  show _ = "Phi <?>"
+
+instance Show (IORef a) where
+  show _ = "IORef <?>"
+
+
+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 :: Event -> Phi -> Display -> Window -> StateT (M.Map Window Window) IO ()
-handleEvent ClientMessageEvent { ev_message_type = message_type, ev_data = messageData, ev_window = window } phi dispvar xembedWindow = do
+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 ->
+          _ | opcode == sYSTEM_TRAY_REQUEST_DOCK -> do
-            when (iconID /= 0) $ addIcon phi dispvar $ fromIntegral iconID
+            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 -> Xlib.Display -> Atoms -> Window -> Window -> StateT (M.Map Window Window) IO ()
-addIcon phi display window = do
+addIcon phi disp atoms panelWindow window = do
-  return ()
+  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

lib/Phi/X11.hs

@@ -41,7 +41,7 @@ data PhiState = PhiState { phiRootImage  :: !Surface
                          }
 
 data PanelState = PanelState { panelWindow       :: !Window
-                             , panelBuffer       :: !Surface
+                             , panelPixmap       :: !Pixmap
                              , panelArea         :: !Rectangle
                              , panelScreenArea   :: !Rectangle
                              , panelWidgetStates :: ![Widget.WidgetState]
@@ -85,12 +85,15 @@ runPhi xconfig config widgets = do
     
     screens <- liftIO $ phiXScreenInfo xconfig disp
     
+    panelWindows <- mapM (createPanelWindow disp) screens
+                      
     dispmvar <- liftIO $ newMVar disp
-    let dispvar = Widget.Display dispmvar atoms screens
+    let screenPanels = zip screens panelWindows
+        dispvar = Widget.Display dispmvar atoms screenPanels
     widgetStates <- liftIO $ mapM (Widget.createWidgetState phi dispvar) widgets
     
     Widget.withDisplay dispvar $ \disp -> do
-      panels <- mapM (createPanel disp widgetStates) screens
+      panels <- mapM (\(screen, window) -> createPanel disp window widgetStates screen) screenPanels
       
       forM_ panels $ \panel -> do
         setPanelProperties disp panel
@@ -105,7 +108,7 @@ runPhi xconfig config widgets = do
       unless available $ do
         repaint <- gets phiRepaint
         when repaint $ do
-          Widget.withDisplay dispvar $ flip updatePanels True
+          updatePanels dispvar
           modify $ \state -> state {phiRepaint = False}
       
       message <- receiveMessage phi
@@ -127,8 +130,6 @@ handleMessage dispvar m = do
       modify $ \state -> state {phiRepaint = True}
     _ ->
       case (fromMessage m) of
-        Just ExposeEvent {} ->
-          Widget.withDisplay dispvar $ flip updatePanels False
         Just event@PropertyEvent {} ->
           Widget.withDisplay dispvar $ flip handlePropertyUpdate event
         _ ->
@@ -144,7 +145,7 @@ receiveEvents phi dispvar = do
       if pend /= 0 then
         do
           liftIO $ nextEvent disp xevent
-          event <- liftIO $ getEvent xevent
+          event <- liftIO $ Util.getEvent disp xevent
           sendMessage phi event
 
           return True
@@ -152,18 +153,23 @@ receiveEvents phi dispvar = do
       
     when (not handled) $ threadWaitRead connection
 
-updatePanels :: Display -> Bool -> PhiX ()
+updatePanels :: Widget.Display -> PhiX ()
-updatePanels disp redraw = do
+updatePanels dispvar = do
   rootImage <- gets phiRootImage
   panels <- gets phiPanels
     
   panels' <- forM panels $ \panel -> do
-    let buffer = panelBuffer panel
+    let pixmap = panelPixmap panel
         area = panelArea panel
     
-    newPanel <- if not redraw then return panel else do
+    let layoutedWidgets = (withDimension area $ Widget.layoutWidgets (panelWidgetStates panel) 0 0) $ panelScreenArea panel
-      let layoutedWidgets = (withDimension area $ Widget.layoutWidgets (panelWidgetStates panel) 0 0) $ panelScreenArea panel
+        panel' = panel { panelWidgetStates = layoutedWidgets }
-          panel' = panel { panelWidgetStates = layoutedWidgets }
+    
+    Widget.withDisplay dispvar $ \disp -> do
+      let screen = defaultScreen disp
+          visual = defaultVisual disp screen
+      
+      buffer <- liftIO $ withDimension area $ Util.createXlibSurface disp pixmap visual
       
       renderWith buffer $ do
         withPatternForSurface rootImage $ \pattern -> do
@@ -174,20 +180,16 @@ updatePanels disp redraw = do
           restore
         Widget.renderWidgets layoutedWidgets $ panelScreenArea panel
       
-      return panel'
+      surfaceFinish buffer
+      
+      -- copy buffer to window
+      liftIO $ do
+        setWindowBackgroundPixmap disp (panelWindow panel') pixmap
+        (withDimension area $ clearArea disp (panelWindow panel') 0 0) True
+        sync disp False
     
-    let screen = defaultScreen disp
+    return panel'
-        visual = defaultVisual disp screen
+  
-    surface <- liftIO $ withDimension area $ Util.createXlibSurface disp (panelWindow newPanel) visual
-    
-    -- copy buffer to window
-    renderWith surface $ withPatternForSurface buffer $ \pattern -> do
-      setSource pattern
-      paint
-    surfaceFinish surface
-    
-    return newPanel
-
   modify $ \state -> state { phiPanels = panels' }
 
 
@@ -199,6 +201,7 @@ handlePropertyUpdate disp PropertyEvent { ev_atom = atom } = do
 
   when (atom == atom_XROOTPMAP_ID atoms || atom == atom_XROOTMAP_ID atoms) $ do
     updateRootImage disp
+    sendMessage phi ResetBackground
     sendMessage phi Repaint
   
 
@@ -232,26 +235,27 @@ updateRootImage disp = do
   surfaceFinish rootSurface
 
 
-createPanel :: Display -> [Widget.WidgetState] -> Rectangle -> PhiX PanelState
+createPanel :: Display -> Window -> [Widget.WidgetState] -> Rectangle -> PhiX PanelState
-createPanel disp widgets screenRect = do
+createPanel disp win widgets screenRect = do
-  phi <- asks phiPhi
   config <- asks phiPanelConfig
   let rect = panelBounds config screenRect
-      
+  let screen = defaultScreen disp
-  win <- createPanelWindow disp rect
+      depth = defaultDepth disp screen
-  
+    
-  buffer <- liftIO $ withDimension rect $ createImageSurface FormatRGB24
+  pixmap <- liftIO $ (withDimension rect $ createPixmap disp win) depth
   
   return PanelState { panelWindow = win
-                    , panelBuffer = buffer
+                    , panelPixmap = pixmap
                     , panelArea = rect
                     , panelScreenArea = screenRect
                     , panelWidgetStates = widgets
                     }
 
 createPanelWindow :: Display -> Rectangle -> PhiX Window
-createPanelWindow disp rect = do
+createPanelWindow disp screenRect = do
-  let screen = defaultScreen disp
+  config <- asks phiPanelConfig
+  let rect = panelBounds config screenRect
+      screen = defaultScreen disp
       depth = defaultDepth disp screen
       visual = defaultVisual disp screen
       colormap = defaultColormap disp screen

lib/Phi/X11/AtomList.hs

@@ -37,6 +37,7 @@ atoms = [ "UTF8_STRING"
         , "_NET_CURRENT_DESKTOP"
         , "_NET_CLIENT_LIST"
         , "_MOTIF_WM_HINTS"
+        , "_XEMBED"
         , "_XROOTPMAP_ID"
         , "_XROOTMAP_ID"
         ]

phi.cabal

@@ -18,7 +18,7 @@ library
   hs-source-dirs:    lib
   extra-libraries:   X11
   pkgconfig-depends: cairo >= 1.2.0, cairo-xlib
-  ghc-options:       -fspec-constr-count=16 -threaded
+  --ghc-options:       -fspec-constr-count=16 -threaded
 
 executable Phi
   build-depends:     base >= 4, phi