diff options
Diffstat (limited to 'lib/Phi/Widgets')
-rw-r--r-- | lib/Phi/Widgets/Systray.hs | 163 |
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 |