Some initial systray code

3 files changed, 151 insertions, 15 deletions

diff --git a/lib/Phi/Widgets/Clock.hs b/lib/Phi/Widgets/Clock.hs
index 7172f77..492d807 100644
--- a/lib/Phi/Widgets/Clock.hs
+++ b/lib/Phi/Widgets/Clock.hs
@@ -55,7 +55,7 @@ instance WidgetClass Clock where
     return $ ClockState time
 
     
-  minSize (Clock config ) = clockSize config
+  minSize (Clock config) _ _ = clockSize config
   
   render (Clock config) (ClockState time) w h _ = do
     time <- liftIO getZonedTime
diff --git a/lib/Phi/Widgets/Systray.hs b/lib/Phi/Widgets/Systray.hs
new file mode 100644
index 0000000..26ff0a4
--- /dev/null
+++ b/lib/Phi/Widgets/Systray.hs
@@ -0,0 +1,137 @@
+{-# LANGUAGE TypeFamilies, DeriveDataTypeable #-}
+
+module Phi.Widgets.Systray ( systray
+                           ) where
+
+import Control.Concurrent
+import Control.Monad
+
+import Data.Maybe
+
+import Foreign.C.Types
+
+import Graphics.X11.Xlib hiding (Display)
+import qualified Graphics.X11.Xlib as Xlib
+import Graphics.X11.Xlib.Extras
+
+import Phi.Bindings.Util
+
+import Phi.Phi
+import Phi.Types
+import Phi.Widget
+import Phi.X11.Atoms
+
+
+data SystrayIconState = SystrayIconState deriving Show
+
+data SystrayState = SystrayState [SystrayIconState] deriving Show
+
+data Systray = Systray deriving Show
+
+
+instance WidgetClass Systray where
+  type WidgetData Systray = SystrayState
+  
+  initWidget (Systray) phi dispvar = do
+    forkIO $ systrayRunner phi dispvar
+    
+    return $ SystrayState []
+  
+  minSize _ (SystrayState icons) height = (length icons)*height
+  weight _ = 0
+  
+  render Systray (SystrayState icons) w h screen = do
+    return ()
+
+
+systrayRunner :: Phi -> Display -> IO ()
+systrayRunner phi dispvar = do
+  let atoms = getAtoms dispvar
+  initSuccess <- withDisplay dispvar $ flip initSystray atoms
+  
+  case initSuccess of
+    Just xembedWindow -> forever $ do
+      m <- receiveMessage phi
+      case (fromMessage m) of
+        Just event ->
+          handleEvent event phi dispvar xembedWindow
+        _ ->
+          return ()
+    Nothing ->
+      return ()
+
+
+initSystray :: Xlib.Display -> Atoms -> IO (Maybe Window)
+initSystray disp atoms = do
+  currentSystrayWin <- xGetSelectionOwner disp $ atom_NET_SYSTEM_TRAY_SCREEN atoms
+  
+  if currentSystrayWin /= 0 then do
+    pid <- liftM (fromMaybe "" . fmap (\pid -> " (pid" ++ show (fromIntegral pid :: CUShort) ++ ")") . join . fmap listToMaybe) $
+           getWindowProperty16 disp (atom_NET_WM_PID atoms) currentSystrayWin
+    
+    putStrLn $ "Phi: another systray is running." ++ pid
+    
+    return Nothing
+    else do
+    xembedWin <- createSimpleWindow disp (defaultRootWindow disp) (-1) (-1) 1 1 0 0 0
+    
+    -- orient horizontally
+    changeProperty32 disp xembedWin (atom_NET_SYSTEM_TRAY_ORIENTATION atoms) cARDINAL propModeReplace [0]
+    
+    -- set visual
+    let rootwin = defaultRootWindow disp
+        screen = defaultScreen disp
+        visual = defaultVisual disp screen
+        visualID = visualIDFromVisual visual
+    changeProperty32 disp xembedWin (atom_NET_SYSTEM_TRAY_VISUAL atoms) vISUALID propModeReplace [fromIntegral visualID]
+    
+    xSetSelectionOwner disp (atom_NET_SYSTEM_TRAY_SCREEN atoms) xembedWin currentTime
+    systrayWin <- xGetSelectionOwner disp $ atom_NET_SYSTEM_TRAY_SCREEN atoms
+    if systrayWin /= xembedWin then do
+      destroyWindow disp xembedWin
+      putStrLn $ "Phi: can't initialize systray."
+      return Nothing
+      
+      else do
+      allocaXEvent $ \event -> do
+        putClientMessage event rootwin (atomMANAGER atoms) [fromIntegral currentTime, fromIntegral (atom_NET_SYSTEM_TRAY_SCREEN atoms), fromIntegral xembedWin, 0, 0]
+        sendEvent disp rootwin False structureNotifyMask event
+      
+      return $ Just xembedWin
+
+
+sYSTEM_TRAY_REQUEST_DOCK :: CInt
+sYSTEM_TRAY_REQUEST_DOCK = 0
+
+sYSTEM_TRAY_BEGIN_MESSAGE :: CInt
+sYSTEM_TRAY_BEGIN_MESSAGE = 1
+
+sYSTEM_TRAY_CANCEL_MESSAGE :: CInt
+sYSTEM_TRAY_CANCEL_MESSAGE = 2
+
+
+handleEvent :: Event -> Phi -> Display -> Window -> IO ()
+handleEvent ClientMessageEvent { ev_message_type = message_type, ev_data = messageData, ev_window = window } phi dispvar xembedWindow = do
+  let atoms = getAtoms dispvar
+  when (window == xembedWindow && message_type == atom_NET_SYSTEM_TRAY_OPCODE atoms) $ do
+    case messageData of
+      (_:opcode:iconID:_) -> do
+        case True of
+          _ | opcode == sYSTEM_TRAY_REQUEST_DOCK -> do
+            return ()
+        
+            | opcode == sYSTEM_TRAY_BEGIN_MESSAGE || opcode == sYSTEM_TRAY_CANCEL_MESSAGE -> do
+            return ()
+            
+            | otherwise -> do
+            return ()
+        
+          
+      _ ->
+        return ()
+    
+  
+handleEvent _ _ _ _ = return ()
+
+systray :: Widget
+systray = Widget $ Systray
diff --git a/lib/Phi/Widgets/Taskbar.hs b/lib/Phi/Widgets/Taskbar.hs
index caa7599..bd45add 100644
--- a/lib/Phi/Widgets/Taskbar.hs
+++ b/lib/Phi/Widgets/Taskbar.hs
@@ -121,8 +121,8 @@ data TaskbarState = TaskbarState { taskbarActiveWindow   :: !Window
                                  , taskbarCurrentDesktop :: !Int
                                  , taskbarWindows        :: ![Window]
                                  , taskbarWindowStates   :: !(M.Map Window WindowState)
-                                 , taskbarWindowIcons    ::  !(M.Map Window [(Int, Surface)])
-                                 , taskbarWindowScreens  ::  !(M.Map Window Xlib.Rectangle)
+                                 , taskbarWindowIcons    :: !(M.Map Window [(Int, Surface)])
+                                 , taskbarWindowScreens  :: !(M.Map Window Xlib.Rectangle)
                                  } deriving Show
 
 data WindowState = WindowState { windowTitle   :: !String
@@ -145,7 +145,7 @@ instance WidgetClass Taskbar where
     return $ TaskbarState 0 0 (-1) [] M.empty M.empty M.empty
 
     
-  minSize _ = 0
+  minSize _ _ _ = 0
   weight _ = 1
   
   render (Taskbar config) TaskbarState { taskbarActiveWindow = activeWindow
@@ -294,15 +294,14 @@ handleEvent phi dispvar XExtras.PropertyEvent {XExtras.ev_atom = atom, XExtras.e
   let atoms = getAtoms dispvar
   let screens = getScreens dispvar
   
-  when (elem atom $ map ($ atoms) [ atom_NET_ACTIVE_WINDOW
-                                  , atom_NET_NUMBER_OF_DESKTOPS
-                                  , atom_NET_CURRENT_DESKTOP
-                                  , atom_NET_CLIENT_LIST
-                                  , atom_NET_WM_ICON
-                                  , atom_NET_WM_NAME
-                                  , atomWM_NAME
-                                  , atom_NET_WM_DESKTOP
-                                  , atom_NET_WM_STATE
+  when (elem atom $ Xlib.wM_NAME : map ($ atoms) [ atom_NET_ACTIVE_WINDOW
+                                                 , atom_NET_NUMBER_OF_DESKTOPS
+                                                 , atom_NET_CURRENT_DESKTOP
+                                                 , atom_NET_CLIENT_LIST
+                                                 , atom_NET_WM_ICON
+                                                 , atom_NET_WM_NAME
+                                                 , atom_NET_WM_DESKTOP
+                                                 , atom_NET_WM_STATE
                                   ]) $ withDisplay dispvar $ \disp -> do
     let rootwin = Xlib.defaultRootWindow disp
     if (window == rootwin)
@@ -414,7 +413,7 @@ getWindowState disp atoms window = do
   netwmname <- liftM (fmap (decode . map fromIntegral)) $ XExtras.getWindowProperty8 disp (atom_NET_WM_NAME atoms) window
   wmname <- case netwmname of
     Just name -> return name
-    Nothing -> liftM (map unsignedChr . fromMaybe []) $ XExtras.getWindowProperty8 disp (atomWM_NAME atoms) window
+    Nothing -> liftM (map unsignedChr . fromMaybe []) $ XExtras.getWindowProperty8 disp Xlib.wM_NAME window
   
   workspace <- liftM (fromIntegral . fromMaybe 0xFFFFFFFF . join . fmap listToMaybe) $ XExtras.getWindowProperty32 disp (atom_NET_WM_DESKTOP atoms) window
   
@@ -434,7 +433,7 @@ readIcons (width:height:iconData) = do
     let (thisIcon, rest) = splitAt (fromIntegral (width*height)) iconData
     icon <- createImageSurface FormatARGB32 (fromIntegral width) (fromIntegral height)
     surfaceData <- imageSurfaceGetPixels icon :: IO (SurfaceData Int Word32)
-    forM_ (zip thisIcon [1..]) $ \(e, i) -> writeArray surfaceData i $ premultiply $ fromIntegral e
+    forM_ (zip thisIcon [0..]) $ \(e, i) -> writeArray surfaceData i $ premultiply $ fromIntegral e
     
     surfaceMarkDirty icon