From 19c4bb35212b422ce0c3d8808357e0edf8728218 Mon Sep 17 00:00:00 2001 From: Matthias Schiffer Date: Tue, 19 Jul 2011 11:16:50 +0200 Subject: Basic systray implementation --- lib/Phi/Bindings/Util.hsc | 30 +++++++++ lib/Phi/Phi.hs | 2 +- lib/Phi/Widget.hs | 9 ++- lib/Phi/Widgets/Systray.hs | 163 ++++++++++++++++++++++++++++++++++++++++----- lib/Phi/X11.hs | 76 +++++++++++---------- lib/Phi/X11/AtomList.hs | 1 + phi.cabal | 2 +- 7 files changed, 225 insertions(+), 58 deletions(-) diff --git a/lib/Phi/Bindings/Util.hsc b/lib/Phi/Bindings/Util.hsc index 32737ff..bae6c71 100644 --- a/lib/Phi/Bindings/Util.hsc +++ b/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 diff --git a/lib/Phi/Phi.hs b/lib/Phi/Phi.hs index ab384a0..f7cf4c7 100644 --- a/lib/Phi/Phi.hs +++ b/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 diff --git a/lib/Phi/Widget.hs b/lib/Phi/Widget.hs index 6a2a9f6..7bce659 100644 --- a/lib/Phi/Widget.hs +++ b/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 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 diff --git a/lib/Phi/X11.hs b/lib/Phi/X11.hs index 3930826..0da8594 100644 --- a/lib/Phi/X11.hs +++ b/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 disp redraw = do +updatePanels :: Widget.Display -> PhiX () +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 - panel' = panel { panelWidgetStates = layoutedWidgets } + let layoutedWidgets = (withDimension area $ Widget.layoutWidgets (panelWidgetStates panel) 0 0) $ panelScreenArea panel + 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' - - let screen = defaultScreen disp - 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 + 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 - return newPanel - + return panel' + 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 disp widgets screenRect = do - phi <- asks phiPhi +createPanel :: Display -> Window -> [Widget.WidgetState] -> Rectangle -> PhiX PanelState +createPanel disp win widgets screenRect = do config <- asks phiPanelConfig let rect = panelBounds config screenRect - - win <- createPanelWindow disp rect - - buffer <- liftIO $ withDimension rect $ createImageSurface FormatRGB24 + let screen = defaultScreen disp + depth = defaultDepth disp screen + + 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 - let screen = defaultScreen disp +createPanelWindow disp screenRect = do + config <- asks phiPanelConfig + let rect = panelBounds config screenRect + screen = defaultScreen disp depth = defaultDepth disp screen visual = defaultVisual disp screen colormap = defaultColormap disp screen diff --git a/lib/Phi/X11/AtomList.hs b/lib/Phi/X11/AtomList.hs index b91ae3e..535a252 100644 --- a/lib/Phi/X11/AtomList.hs +++ b/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" ] diff --git a/phi.cabal b/phi.cabal index 07820ce..72a14b4 100644 --- a/phi.cabal +++ b/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 -- cgit v1.2.3