Some initial systray code

8 files changed, 204 insertions, 27 deletions

diff --git a/lib/Phi/Bindings/Util.hsc b/lib/Phi/Bindings/Util.hsc
index 5058a8b..32737ff 100644
--- a/lib/Phi/Bindings/Util.hsc
+++ b/lib/Phi/Bindings/Util.hsc
@@ -1,10 +1,13 @@
 {-# LANGUAGE ForeignFunctionInterface #-}
 
 module Phi.Bindings.Util ( setClassHint
+                         , visualIDFromVisual
+                         , putClientMessage
                          , createXlibSurface
                          ) where
 
 
+#include <X11/Xlib.h>
 #include <X11/Xutil.h>
 #include <cairo.h>
 #include <cairo-xlib.h>
@@ -14,6 +17,7 @@ import Foreign.C.String (withCString)
 import Foreign.C.Types
 import Foreign.Ptr
 import Foreign.Marshal.Alloc (alloca, allocaBytes)
+import Foreign.Marshal.Array
 import Foreign.Storable
 
 import Graphics.X11.Xlib
@@ -33,6 +37,17 @@ setClassHint disp wnd hint = allocaBytes (#size XClassHint) $ \p ->
     (#poke XClassHint, res_class) p res_class
     xSetClassHint disp wnd p
 
+foreign import ccall unsafe "X11/Xlib.h XVisualIDFromVisual"
+  visualIDFromVisual :: Visual -> VisualID
+
+putClientMessage :: XEventPtr -> Window -> Atom -> [CLong] -> IO ()
+putClientMessage event window message_type messageData = do
+  setEventType event clientMessage
+  (#poke XClientMessageEvent, window) event window
+  (#poke XClientMessageEvent, message_type) event message_type
+  (#poke XClientMessageEvent, format) event (32 :: CInt)
+  pokeArray ((#ptr XClientMessageEvent, data.l) event) $ take 5 messageData
+
 foreign import ccall unsafe "cairo-xlib.h cairo_xlib_surface_create"
   xlibSurfaceCreate :: Display -> Drawable -> Visual -> CInt -> CInt -> IO (Ptr Surface)
 
@@ -42,3 +57,4 @@ createXlibSurface dpy drawable visual width height = do
   surface <- mkSurface surfacePtr
   manageSurface surface
   return surface
+
diff --git a/lib/Phi/Border.hs b/lib/Phi/Border.hs
index 791845d..a025ab6 100644
--- a/lib/Phi/Border.hs
+++ b/lib/Phi/Border.hs
@@ -41,7 +41,7 @@ data BorderConfig = BorderConfig { margin          :: !BorderWidth
                                  , padding         :: !BorderWidth
                                  , borderColor     :: !Color
                                  , backgroundColor :: !Color
-                                 , cornerRadius    :: !Double
+                                 , cornerRadius    :: !Int
                                  , borderWeight    :: !Float
                                  } deriving Show
 
@@ -60,11 +60,14 @@ instance WidgetClass Border where
   type WidgetData Border = BorderState
   initWidget (Border _ widgets) phi disp = liftM BorderState $ mapM (createWidgetState phi disp) widgets
   
-  minSize (Border config widgets) = sum (map (\(Widget w) -> minSize w) widgets) + borderH p + 2*bw + borderH m
+  minSize (Border config _) (BorderState widgetStates) height =
+    max (borderH m+2*(bw+cr)) $ sum (map (\(WidgetState {stateWidget = w, statePrivateData = priv}) -> minSize w priv height') widgetStates) + borderH p + 2*bw + borderH m
     where
       m = margin config
       bw = borderWidth config
       p = padding config
+      cr = cornerRadius config
+      height' = height - borderV m - 2*bw - borderV p
   
   weight (Border config _) = borderWeight config
   
@@ -102,7 +105,7 @@ drawBorder config dx dy w h = do
       m = margin config
       bw = borderWidth config
       p = padding config
-      radius = cornerRadius config
+      radius = fromIntegral $ cornerRadius config
       
       x = (fromIntegral dx) + (fromIntegral $ borderLeft m) + (fromIntegral bw)/2
       y = (fromIntegral dy) + (fromIntegral $ borderTop m) + (fromIntegral bw)/2
diff --git a/lib/Phi/Widget.hs b/lib/Phi/Widget.hs
index 48ab536..d954b58 100644
--- a/lib/Phi/Widget.hs
+++ b/lib/Phi/Widget.hs
@@ -64,7 +64,7 @@ class Show a => WidgetClass a where
   
   initWidget :: a -> Phi -> Display -> IO (WidgetData a)
   
-  minSize :: a -> Int
+  minSize :: a -> WidgetData a -> Int -> Int
   
   weight :: a -> Float
   weight _ = 0
@@ -104,7 +104,7 @@ createWidgetState phi disp (Widget w) = do
 layoutWidgets :: [WidgetState] -> Int -> Int -> Int -> Int -> [WidgetState]
 layoutWidgets widgets x y width height = snd $ mapAccumL layoutWidgetAndX x widgets
   where
-    sizesum = sum $ map (\(WidgetState {stateWidget = w} ) -> nneg . minSize $ w) widgets
+    sizesum = sum $ map (\(WidgetState {stateWidget = w, statePrivateData = priv} ) -> nneg $ minSize w priv height) widgets
     wsum = let wsum = sum $ map (\(WidgetState {stateWidget = w} ) ->  nneg . weight $ w) widgets
              in if wsum > 0 then wsum else 1
     
@@ -115,7 +115,7 @@ layoutWidgets widgets x y width height = snd $ mapAccumL layoutWidgetAndX x widg
     
     layoutWidget wX state = case state of
       WidgetState {stateWidget = w, statePrivateData = priv} ->
-        let wWidth = floor $ (fromIntegral $ minSize w) + (fromIntegral surplus)*(nneg $ weight w)/wsum
+        let wWidth = floor $ (fromIntegral $ minSize w priv height) + (fromIntegral surplus)*(nneg $ weight w)/wsum
             priv' = layout w priv wWidth height
         in WidgetState w wX y wWidth height priv'
     
@@ -145,7 +145,7 @@ instance WidgetClass Separator where
   type WidgetData Separator = ()
   initWidget _ _ _ = return ()
   
-  minSize (Separator s _) = s
+  minSize (Separator s _) _ _ = s
   weight (Separator _ w) = w
   render _ _ _ _ _ = return ()
 
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
   
diff --git a/lib/Phi/X11/AtomList.hs b/lib/Phi/X11/AtomList.hs
index d18be71..b91ae3e 100644
--- a/lib/Phi/X11/AtomList.hs
+++ b/lib/Phi/X11/AtomList.hs
@@ -1,8 +1,16 @@
+{-# LANGUAGE TemplateHaskell #-}
+
 module Phi.X11.AtomList ( atoms
+                        , specialAtoms
                         ) where
 
+import Language.Haskell.TH
+
+import Graphics.X11.Xlib
+
+atoms :: [String]
 atoms = [ "UTF8_STRING"
-        , "WM_NAME"
+        , "MANAGER"
         , "_NET_WM_NAME"
         , "_NET_WM_WINDOW_TYPE"
         , "_NET_WM_WINDOW_TYPE_NORMAL"
@@ -20,6 +28,10 @@ atoms = [ "UTF8_STRING"
         , "_NET_WM_STATE_BELOW"
         , "_NET_WM_STRUT"
         , "_NET_WM_STRUT_PARTIAL"
+        , "_NET_WM_PID"
+        , "_NET_SYSTEM_TRAY_OPCODE"
+        , "_NET_SYSTEM_TRAY_ORIENTATION"
+        , "_NET_SYSTEM_TRAY_VISUAL"
         , "_NET_ACTIVE_WINDOW"
         , "_NET_NUMBER_OF_DESKTOPS"
         , "_NET_CURRENT_DESKTOP"
@@ -28,3 +40,8 @@ atoms = [ "UTF8_STRING"
         , "_XROOTPMAP_ID"
         , "_XROOTMAP_ID"
         ]
+
+-- the expression must have the type (Display -> String)
+specialAtoms :: [(String, Q Exp)]
+specialAtoms = [ ("_NET_SYSTEM_TRAY_SCREEN", [|("_NET_SYSTEM_TRAY_S" ++) . show . defaultScreen|])
+               ]
\ No newline at end of file
diff --git a/lib/Phi/X11/Atoms.hs b/lib/Phi/X11/Atoms.hs
index 38f8f3c..acbae64 100644
--- a/lib/Phi/X11/Atoms.hs
+++ b/lib/Phi/X11/Atoms.hs
@@ -12,7 +12,7 @@ import Phi.X11.AtomList
 
 
 $(let atomsName = mkName "Atoms"
-      atomNames = map (\atom -> (atom, mkName ("atom" ++ atom))) atoms
+      atomNames = map (\atom -> (atom, mkName ("atom" ++ atom))) $ atoms ++ (map fst specialAtoms)
       fields = map (\(_, name) -> (name, IsStrict, ConT ''Atom)) atomNames
   in return [DataD [] atomsName [] [RecC atomsName fields] []]
  )
@@ -20,12 +20,17 @@ $(let atomsName = mkName "Atoms"
 initAtoms :: Display -> IO Atoms
 initAtoms display =
   $(do
-       atomNames <- mapM (\atom -> do
+       normalAtomNames <- mapM (\atom -> do
                              varName <- newName ('_':atom)
-                             return (atom, mkName ("atom" ++ atom), varName)
+                             return ([|const atom|], mkName ("atom" ++ atom), varName)
                          ) atoms
+       specialAtomNames <- mapM (\(name, atomgen) -> do
+                             varName <- newName ('_':name)
+                             return (atomgen, mkName ("atom" ++ name), varName)
+                         ) specialAtoms
+       let atomNames = normalAtomNames ++ specialAtomNames
        atomInitializers <- forM atomNames $
-                           \(atom, _, varName) -> liftM (BindS (VarP varName)) [| internAtom display atom False |]
+                           \(atomgen, _, varName) -> liftM (BindS (VarP varName)) [| internAtom display ($atomgen display) False |]
            
        let atomFieldExps = map (\(_, atomName, varName) -> (atomName, VarE varName)) atomNames
            atomsName = mkName "Atoms"