1 files changed, 294 insertions, 0 deletions
diff --git a/lib/Phi/Widgets/X11/Systray.hs b/lib/Phi/Widgets/X11/Systray.hs
new file mode 100644
index 0000000..fffb181
--- /dev/null
+++ b/lib/Phi/Widgets/X11/Systray.hs
@@ -0,0 +1,294 @@
+{-# LANGUAGE MultiParamTypeClasses, DeriveDataTypeable, TypeSynonymInstances, FlexibleInstances #-}
+
+module Phi.Widgets.X11.Systray ( systray
+                               ) where
+
+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 Foreign.Marshal
+import Foreign.Ptr
+import Foreign.Storable
+
+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
+
+import Phi.Bindings.Util
+import Phi.Bindings.SystrayErrorHandler
+
+import Phi.Phi
+import Phi.Types
+import Phi.Widget
+import Phi.X11.Atoms
+
+
+data SystrayIconState = SystrayIconState !Window !Window deriving (Show, Eq)
+
+instance Eq Phi where
+  _ == _ = True
+
+data SystrayState = SystrayState !Phi !Rectangle !Int ![SystrayIconState] deriving Eq
+
+data Systray = Systray deriving (Show, Eq)
+
+data SystrayMessage = AddIcon !Window !Window | RemoveIcon !Window | RenderIcon !Window !Window !Int !Int !Int !Int
+                      deriving (Show, Typeable)
+
+
+instance Widget Systray SystrayState (RenderCache SystrayState) where
+  initWidget (Systray) phi dispvar screens = do
+    phi' <- dupPhi phi
+    forkIO $ systrayRunner phi' dispvar $ snd . head $ screens
+    
+    return $ SystrayState phi (fst . head $ screens) 0 []
+  
+  initCache _ = createRenderCache $ \(SystrayState phi systrayScreen reset icons) x y w h screen -> do
+    when (screen == systrayScreen) $ do
+      forM_ (zip [0..] icons) $ \(i, SystrayIconState midParent window) -> do
+        let x' = x + i*(h+2)
+        sendMessage phi $ RenderIcon midParent window x' y h h
+    
+    setOperator OperatorClear
+    paint
+  
+  minSize _ (SystrayState _ systrayScreen _ icons) height screen = case True of 
+    _ | screen == systrayScreen -> max 0 $ (length icons)*(height+2)-1
+      | otherwise -> 0
+
+  weight _ = 0
+  
+  render _ = renderCached
+
+  
+  handleMessage _ priv@(SystrayState phi screen reset icons) m = case (fromMessage m) of
+    Just (AddIcon midParent window) -> SystrayState phi screen reset ((SystrayIconState midParent window):icons)
+    Just (RemoveIcon window) -> SystrayState phi screen reset $ filter (\(SystrayIconState _ stateWindow) -> stateWindow /= window) icons
+    _ -> case (fromMessage m) of
+      Just (UpdateScreens screens) -> SystrayState phi (fst . head $ screens) reset icons
+      _ -> case (fromMessage m) of
+        Just ResetBackground -> SystrayState phi screen (reset+1) icons
+        _ ->  priv
+
+
+systrayRunner :: Phi -> Display -> Window -> IO ()
+systrayRunner phi dispvar panelWindow = do
+  let atoms = getAtoms dispvar
+  initSuccess <- withDisplay dispvar $ flip initSystray atoms
+  
+  case initSuccess of
+    Just xembedWindow -> flip evalStateT M.empty $ do
+      sendMessage phi HoldShutdown
+      
+      forever $ do
+        m <- receiveMessage phi
+        case (fromMessage m) of
+          Just event ->
+            handleEvent event phi dispvar panelWindow xembedWindow
+          _ ->
+            case (fromMessage m) of
+              Just (RenderIcon midParent window x y w h) -> do
+                withDisplay dispvar $ \disp -> do
+                  liftIO $ flip catch (\_ -> return ()) $ do
+                    sync disp False
+                    setSystrayErrorHandler
+                    
+                    (_, x', y', w', h', _, _) <- getGeometry disp midParent
+                    (_, x'', y'', w'', h'', _, _) <- getGeometry disp window
+                    let resize = (fromIntegral x) /= x' || (fromIntegral y) /= y' || (fromIntegral w) /= w' || (fromIntegral h) /= h'
+                                 || 0 /= x'' || 0 /= y'' || (fromIntegral w) /= w'' || (fromIntegral h) /= h''
+                    
+                    when resize $ do
+                      moveResizeWindow disp midParent (fromIntegral x) (fromIntegral y) (fromIntegral w) (fromIntegral h)
+                      moveResizeWindow disp window 0 0 (fromIntegral w) (fromIntegral h)
+                      sync disp False
+                    
+                    clearArea disp window 0 0 (fromIntegral w) (fromIntegral h) True
+                      
+                    sync disp False
+                    xSetErrorHandler
+                  
+                  lastErrorWindow <- liftIO $ getLastErrorWindow
+                  when (lastErrorWindow == window) $ do
+                    removeIcon phi disp True window
+              _ ->
+                case (fromMessage m) of
+                  Just Shutdown -> do
+                    windows <- gets M.keys
+                    withDisplay dispvar $ \disp -> do
+                      mapM_ (removeIcon phi disp True) windows
+                      liftIO $ do
+                        destroyWindow disp xembedWindow
+                        sync disp False
+                      sendMessage phi ReleaseShutdown
+                  _ ->
+                    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
+
+xEMBED_EMBEDDED_NOTIFY :: CInt
+xEMBED_EMBEDDED_NOTIFY = 0
+
+handleEvent :: Event -> Phi -> Display -> Window -> Window -> StateT (M.Map Window Window) IO ()
+handleEvent message@ClientMessageEvent { ev_message_type = message_type, ev_data = messageData, ev_window = window } phi dispvar panelWindow 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
+            when (iconID /= 0) $ withDisplay dispvar $ \disp -> addIcon phi disp (getAtoms dispvar) panelWindow $ fromIntegral iconID
+          
+            | opcode == sYSTEM_TRAY_BEGIN_MESSAGE || opcode == sYSTEM_TRAY_CANCEL_MESSAGE ->
+            return ()
+            
+            | otherwise -> do
+            liftIO $ putStrLn "Phi: unknown tray message"
+            return ()
+        
+          
+      _ ->
+        return ()
+
+handleEvent message@UnmapEvent { ev_window = window } phi dispvar panelWindow xembedWindow =
+  withDisplay dispvar $ \disp -> removeIcon phi disp True window
+
+handleEvent message@DestroyWindowEvent { ev_window = window } phi dispvar panelWindow xembedWindow =
+  withDisplay dispvar $ \disp -> removeIcon phi disp False window
+
+handleEvent message@AnyEvent { ev_window = window } phi dispvar panelWindow xembedWindow | ev_event_type message == reparentNotify = do
+  parent <- liftIO $ alloca $ \rootPtr -> alloca $ \parentPtr -> alloca $ \childrenPtrPtr -> alloca $ \nChildrenPtr -> do
+    status <- withDisplay dispvar $ \disp -> xQueryTree disp window rootPtr parentPtr childrenPtrPtr nChildrenPtr
+    case status of
+      0 ->
+        return 0
+      _ -> do
+        childrenPtr <- peek childrenPtrPtr
+        when (childrenPtr /= nullPtr) $
+          xFree childrenPtr >> return ()
+        peek parentPtr
+  midParent <- gets $ M.lookup window
+  when (midParent /= Just parent) $
+    withDisplay dispvar $ \disp -> removeIcon phi disp False window
+  return ()
+
+handleEvent _ _ _ _ _ = return ()
+
+
+addIcon :: Phi -> Xlib.Display -> Atoms -> Window -> Window -> StateT (M.Map Window Window) IO ()
+addIcon phi disp atoms panelWindow window = do
+  removeIcon phi disp False window
+  
+  liftIO $ selectInput disp window $ structureNotifyMask .|. propertyChangeMask
+  
+  midParent <- liftIO $ createSimpleWindow disp panelWindow (-16) (-16) 16 16 0 0 0
+  
+  liftIO $ do
+    setWindowBackgroundPixmap disp midParent 1 -- ParentRelative
+    
+    sync disp False
+    setSystrayErrorHandler
+    
+    reparentWindow disp window midParent 0 0
+    
+    mapRaised disp midParent
+    mapWindow disp window
+    
+    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
+  
+  errorWindow <- liftIO $ getLastErrorWindow
+  case True of
+    _ | errorWindow /= window -> do
+      sendMessage phi $ AddIcon midParent window
+      sendMessage phi Repaint
+      modify $ M.insert window midParent
+      | otherwise ->
+      liftIO $ destroyWindow disp midParent
+
+
+removeIcon :: Phi -> Xlib.Display -> Bool -> Window -> StateT (M.Map Window Window) IO ()
+removeIcon phi disp reparent window = do
+  mmidParent <- gets $ M.lookup window
+  case mmidParent of
+    Just midParent -> do
+      sendMessage phi $ RemoveIcon window
+      sendMessage phi Repaint
+      liftIO $ do
+        selectInput disp window $ noEventMask
+        when reparent $
+          reparentWindow disp window (defaultRootWindow disp) 0 0
+        destroyWindow disp midParent
+        sync disp False
+      modify $ M.delete window
+    _ ->
+      return ()
+
+
+systray :: Systray
+systray = Systray