From 0fefcaa35f217ca2e1f15e2dd77742adfd231571 Mon Sep 17 00:00:00 2001 From: Matthias Schiffer Date: Sun, 17 Jul 2011 19:20:19 +0200 Subject: Some initial systray code --- lib/Phi/Bindings/Util.hsc | 16 ++++++ lib/Phi/Border.hs | 9 ++- lib/Phi/Widget.hs | 8 +-- lib/Phi/Widgets/Clock.hs | 2 +- lib/Phi/Widgets/Systray.hs | 137 +++++++++++++++++++++++++++++++++++++++++++++ lib/Phi/Widgets/Taskbar.hs | 27 +++++---- lib/Phi/X11/AtomList.hs | 19 ++++++- lib/Phi/X11/Atoms.hs | 13 +++-- phi.cabal | 8 +-- src/Phi.hs | 6 +- 10 files changed, 213 insertions(+), 32 deletions(-) create mode 100644 lib/Phi/Widgets/Systray.hs 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 #include #include #include @@ -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" diff --git a/phi.cabal b/phi.cabal index aa65df4..263db7f 100644 --- a/phi.cabal +++ b/phi.cabal @@ -13,14 +13,14 @@ build-type: Simple library build-depends: base >= 4, template-haskell, stm, array, containers, transformers, mtl, utf8-string, time, old-locale, X11, cairo, pango exposed-modules: Phi.Types, Phi.Phi, Phi.Panel, Phi.Widget, Phi.Border, Phi.X11, - Phi.Widgets.Clock, Phi.Widgets.Taskbar + Phi.Widgets.Clock, Phi.Widgets.Taskbar, Phi.Widgets.Systray other-modules: Phi.X11.Atoms, Phi.X11.AtomList, Phi.Bindings.Util hs-source-dirs: lib - ghc-options: -fspec-constr-count=16 + extra-libraries: X11 + pkgconfig-depends: cairo >= 1.2.0, cairo-xlib + ghc-options: -fspec-constr-count=16 -threaded executable Phi build-depends: base >= 4, phi hs-source-dirs: src main-is: Phi.hs - extra-libraries: X11 - pkgconfig-depends: cairo >= 1.2.0, cairo-xlib diff --git a/src/Phi.hs b/src/Phi.hs index ea35633..e9bf43f 100644 --- a/src/Phi.hs +++ b/src/Phi.hs @@ -6,11 +6,13 @@ import Phi.X11 import Phi.Widgets.Clock import Phi.Widgets.Taskbar +import Phi.Widgets.Systray + main :: IO () main = do runPhi defaultXConfig defaultPanelConfig { panelPosition = Bottom } - [theTaskbar, brightBorder [theClock]] + [theTaskbar, brightBorder [theSystray], brightBorder [theClock]] where normalTaskBorder = BorderConfig (BorderWidth 2 (-3) 2 7) 1 (BorderWidth 0 5 0 5) (0.9, 0.9, 0.9, 0.8) (0.45, 0.45, 0.45, 1) 5 0 activeTaskBorder = normalTaskBorder { borderColor = (1, 1, 1, 0.8) @@ -44,6 +46,8 @@ main = do , desktopStyle = Just (normalDesktopStyle, currentDesktopStyle) } + theSystray = systray + theClock = clock defaultClockConfig { clockFormat = "%R\n%A %d %B" , lineSpacing = (-2) , clockSize = 75 -- cgit v1.2.3