gtk-sni-tray 0.1.9.1 → 0.1.10.0
raw patch · 10 files changed
+897/−45 lines, 10 filesdep +gi-gtk-layer-shelldep +template-haskelldep −gi-dbusmenugtk3dep ~status-notifier-itemsetup-changed
Dependencies added: gi-gtk-layer-shell, template-haskell
Dependencies removed: gi-dbusmenugtk3
Dependency ranges changed: status-notifier-item
Files
- ChangeLog.md +6/−1
- README.md +12/−1
- Setup.hs +59/−1
- app/Main.hs +363/−11
- dbus-xml/com.canonical.dbusmenu.xml +69/−0
- gtk-sni-tray.cabal +9/−4
- src/StatusNotifier/DBus/Client/DBusMenu.hs +15/−0
- src/StatusNotifier/DBus/Client/Util.hs +112/−0
- src/StatusNotifier/DBusMenu.hs +208/−0
- src/StatusNotifier/Tray.hs +44/−27
ChangeLog.md view
@@ -1,5 +1,11 @@ # Changelog for gtk-sni-tray +## 0.1.10.0++- Replace `libdbusmenu` usage (`gi-dbusmenugtk3`) with a pure Haskell+ implementation of the `com.canonical.dbusmenu` protocol.+- Add CSS style classes/names to tray menu widgets to make them themeable.+ ## 0.1.9.1 - Fix type error with DM.Menu and Gtk.menuPopupAtWidget by adding explicit@@ -10,4 +16,3 @@ - Use the `gi-gtk3` and `gi-gdk3` build dependencies, which have been renamed from `gi-gtk` and `gi-gdk`.-
README.md view
@@ -3,7 +3,7 @@  [](https://hackage.haskell.org/package/gtk-sni-tray) [](http://stackage.org/lts/package/gtk-sni-tray) [](http://stackage.org/nightly/package/gtk-sni-tray) -gtk-sni-tray provides a [StatusNotifierHost](https://www.freedesktop.org/wiki/Specifications/StatusNotifierItem/StatusNotifierHost/) widget written using the gtk+3 bindings for haskell provided by [gi-gtk](https://hackage.haskell.org/package/gi-gtk). It also provides a simple standalone executable, `gtk-sni-tray-standalone`, that is configured with command line arguments. This executable will run the aforementioned widget by itself in a strut window, on each monitor it is requested.+gtk-sni-tray provides a [StatusNotifierHost](https://www.freedesktop.org/wiki/Specifications/StatusNotifierItem/StatusNotifierHost/) widget written using the gtk+3 bindings for haskell provided by [gi-gtk](https://hackage.haskell.org/package/gi-gtk). It also provides a simple standalone executable, `gtk-sni-tray-standalone`, that is configured with command line arguments. This executable will run the aforementioned widget by itself in a strut window on X11, or (when available) a layer-shell surface on Wayland. taffybar --------@@ -27,3 +27,14 @@ [`cabal`](https://www.haskell.org/cabal/download.html) can all be used to install gtk-sni-tray. +When building with `cabal`, you will need the following system dependencies+available via `pkg-config`:++* `gtk+-3.0`+* `gtk-layer-shell-0` (for the standalone Wayland layer-shell window)++For Nix users, this repository provides a flake dev shell. If you use `direnv`,+`direnv allow` then `direnv reload` should set up the environment.++If you see a Cabal error about missing pkg-config packages, `scripts/cabal-run`+does a quick preflight check and prints a more direct message.
Setup.hs view
@@ -1,2 +1,60 @@ import Distribution.Simple-main = defaultMain+import Distribution.Simple.Setup (ConfigFlags(..), fromFlagOrDefault)+import Distribution.Verbosity (Verbosity, normal)+import Distribution.Simple.Utils (die')+import System.Exit (ExitCode(..))+import System.Process (readProcessWithExitCode)+import Control.Exception (try, IOException)+import Data.List (intercalate)+import Data.Maybe (isJust)+import System.Environment (lookupEnv)++main :: IO ()+main =+ defaultMainWithHooks simpleUserHooks+ { confHook = \pkg flags -> do+ preflightPkgConfig (fromFlagOrDefault normal (configVerbosity flags))+ confHook simpleUserHooks pkg flags+ }++preflightPkgConfig :: Verbosity -> IO ()+preflightPkgConfig verbosity = do+ -- Cabal's pkg-config failure mode can be a bit opaque if you aren't already+ -- in the Nix/dev environment. Fail early with a message that points to the+ -- common fixes.+ -- Only hard-require GTK itself. The standalone executable also uses+ -- gtk-layer-shell on Wayland, but we don't want to prevent building the+ -- library when that optional dependency is unavailable.+ let required = ["gtk+-3.0"]+ present <- mapM (\p -> (\ok -> (p, ok)) <$> pkgConfigExists p) required+ let missing = [p | (p, ok) <- present, not ok]+ if null missing+ then pure ()+ else do+ inDirenv <- isJust <$> lookupEnv "DIRENV_DIR"+ let nixHint =+ if inDirenv+ then "If you just changed Nix inputs, try: `direnv reload`"+ else intercalate " " [ "If you're using Nix, enter the dev shell:"+ , "`nix develop` (or `direnv allow` + `direnv reload`)."+ ]+ msg = unlines+ [ "Missing system dependencies required via pkg-config:"+ , " " ++ intercalate ", " missing+ , ""+ , "This package needs `pkg-config` to find its C dependencies."+ , "If you are building the standalone executable for Wayland, you will also need: gtk-layer-shell-0"+ , ""+ , nixHint+ , "Otherwise, install the development packages for your distro (and pkg-config)."+ ]+ die' verbosity msg++pkgConfigExists :: String -> IO Bool+pkgConfigExists name = do+ let cmd = "pkg-config"+ args = ["--exists", name]+ e <- try (readProcessWithExitCode cmd args "") :: IO (Either IOException (ExitCode, String, String))+ pure $ case e of+ Right (ExitSuccess, _, _) -> True+ _ -> False
app/Main.hs view
@@ -4,11 +4,14 @@ import Control.Monad import DBus.Client import Data.Int+import Data.Char (toLower) import Data.Maybe import Data.Ratio import Data.Semigroup ((<>))+import qualified Data.Map.Strict as Map import qualified Data.Text as T import Data.Version (showVersion)+import qualified DBus as DBus import qualified GI.Gdk as Gdk import qualified GI.Gtk as Gtk import Graphics.UI.GIGtkStrut@@ -18,10 +21,331 @@ import StatusNotifier.Tray import System.Log.Logger import System.Posix.Process+import System.Environment (lookupEnv)+import System.Exit (exitFailure) import Text.Printf import Paths_gtk_sni_tray (version) +import qualified GI.GtkLayerShell as GtkLayerShell++data Backend = BackendX11 | BackendWayland deriving (Eq, Show)++data BackendChoice = BackendAuto | BackendX11Choice | BackendWaylandChoice+ deriving (Eq, Show, Read)++detectBackend :: IO Backend+detectBackend = do+ supported <- GtkLayerShell.isSupported+ pure $ if supported then BackendWayland else BackendX11++backendChoiceP :: Parser BackendChoice+backendChoiceP =+ option (eitherReader parseBackendChoice)+ ( long "backend"+ <> help "Backend selection: auto | x11 | wayland"+ <> value BackendAuto+ <> metavar "BACKEND"+ )+ where+ parseBackendChoice s =+ case map toLower s of+ "auto" -> Right BackendAuto+ "x11" -> Right BackendX11Choice+ "wayland" -> Right BackendWaylandChoice+ _ -> Left "expected one of: auto, x11, wayland"++logRuntimeInfo :: BackendChoice -> Backend -> IO ()+logRuntimeInfo backendChoice backend = do+ sessionType <- lookupEnv "XDG_SESSION_TYPE"+ waylandDisplay <- lookupEnv "WAYLAND_DISPLAY"+ gdkBackend <- lookupEnv "GDK_BACKEND"+ mDisplay <- Gdk.displayGetDefault+ displayName <- case mDisplay of+ Nothing -> pure Nothing+ Just d -> Just <$> Gdk.displayGetName d+ layerShellSupported <- GtkLayerShell.isSupported+ logM "StatusNotifier.StandaloneWindow" INFO $+ printf "backendChoice=%s backend=%s layerShellSupported=%s XDG_SESSION_TYPE=%s WAYLAND_DISPLAY=%s GDK_BACKEND=%s gdkDisplay=%s"+ (show backendChoice)+ (show backend)+ (show layerShellSupported)+ (show sessionType)+ (show waylandDisplay)+ (show gdkBackend)+ (show displayName)++hasStatusNotifierWatcher :: Client -> IO Bool+hasStatusNotifierWatcher client = do+ let mc =+ (DBus.methodCall dbusPath+ (DBus.interfaceName_ "org.freedesktop.DBus")+ (DBus.memberName_ "NameHasOwner"))+ { DBus.methodCallDestination = Just dbusName+ , DBus.methodCallBody = [DBus.toVariant ("org.kde.StatusNotifierWatcher" :: String)]+ }+ reply <- call_ client mc+ case DBus.methodReturnBody reply of+ [v] -> pure $ fromMaybe False (DBus.fromVariant v)+ _ -> pure False++setupLayerShellWindow :: StrutConfig -> Gtk.Window -> Bool -> IO ()+setupLayerShellWindow StrutConfig+ { strutWidth = widthSize+ , strutHeight = heightSize+ , strutXPadding = xpadding+ , strutYPadding = ypadding+ , strutMonitor = monitorNumber+ , strutPosition = position+ , strutAlignment = alignment+ , strutDisplayName = maybeDisplayName+ } window reserveSpace = do+ supported <- GtkLayerShell.isSupported+ unless supported $+ logM "StatusNotifier.StandaloneWindow" WARNING $+ "Wayland detected, but gtk-layer-shell is not supported; falling back to a regular toplevel window"+ when supported $ do+ Gtk.windowSetDecorated window False++ maybeDisplay <- maybe Gdk.displayGetDefault Gdk.displayOpen maybeDisplayName+ case maybeDisplay of+ Nothing -> logM "StatusNotifier.StandaloneWindow" WARNING "Failed to get GDK display for layer-shell"+ Just display -> do+ nMonitors <- Gdk.displayGetNMonitors display+ logM "StatusNotifier.StandaloneWindow" INFO $ printf "GDK monitors reported: %d" nMonitors++ let tryIndex idx = if idx < 0 || idx >= nMonitors then pure Nothing else Gdk.displayGetMonitor display idx++ mPrimary <- Gdk.displayGetPrimaryMonitor display+ mChosen <- case monitorNumber of+ Nothing -> pure mPrimary+ Just idx -> tryIndex idx++ monitor <-+ case mChosen <|> mPrimary of+ Just m -> pure (Just m)+ Nothing -> tryIndex 0++ GtkLayerShell.initForWindow window+ GtkLayerShell.setKeyboardMode window GtkLayerShell.KeyboardModeNone+ GtkLayerShell.setNamespace window (T.pack "gtk-sni-tray")+ GtkLayerShell.setLayer window GtkLayerShell.LayerTop++ -- Default behavior if monitor info isn't available: behave like a full-width/height panel.+ GtkLayerShell.setMargin window GtkLayerShell.EdgeLeft xpadding+ GtkLayerShell.setMargin window GtkLayerShell.EdgeRight xpadding+ GtkLayerShell.setMargin window GtkLayerShell.EdgeTop ypadding+ GtkLayerShell.setMargin window GtkLayerShell.EdgeBottom ypadding++ let setAnchor = GtkLayerShell.setAnchor window+ case position of+ TopPos -> do+ setAnchor GtkLayerShell.EdgeTop True+ setAnchor GtkLayerShell.EdgeBottom False+ setAnchor GtkLayerShell.EdgeLeft True+ setAnchor GtkLayerShell.EdgeRight True+ BottomPos -> do+ setAnchor GtkLayerShell.EdgeTop False+ setAnchor GtkLayerShell.EdgeBottom True+ setAnchor GtkLayerShell.EdgeLeft True+ setAnchor GtkLayerShell.EdgeRight True+ LeftPos -> do+ setAnchor GtkLayerShell.EdgeLeft True+ setAnchor GtkLayerShell.EdgeRight False+ setAnchor GtkLayerShell.EdgeTop True+ setAnchor GtkLayerShell.EdgeBottom True+ RightPos -> do+ setAnchor GtkLayerShell.EdgeLeft False+ setAnchor GtkLayerShell.EdgeRight True+ setAnchor GtkLayerShell.EdgeTop True+ setAnchor GtkLayerShell.EdgeBottom True++ let fallbackExclusive =+ if reserveSpace+ then case position of+ TopPos -> case heightSize of ExactSize h -> h + 2 * ypadding; _ -> 0+ BottomPos -> case heightSize of ExactSize h -> h + 2 * ypadding; _ -> 0+ LeftPos -> case widthSize of ExactSize w -> w + 2 * xpadding; _ -> 0+ RightPos -> case widthSize of ExactSize w -> w + 2 * xpadding; _ -> 0+ else 0+ GtkLayerShell.setExclusiveZone window fallbackExclusive++ case monitor of+ Nothing -> logM "StatusNotifier.StandaloneWindow" WARNING "Failed to select a GDK monitor for layer-shell; using fallback sizing/anchors"+ Just m -> do+ GtkLayerShell.setMonitor window m+ isPrim <- Gdk.monitorIsPrimary m+ model <- Gdk.monitorGetModel m+ manuf <- Gdk.monitorGetManufacturer m+ logM "StatusNotifier.StandaloneWindow" INFO $+ printf "Using monitor primary=%s manufacturer=%s model=%s"+ (show isPrim) (show manuf) (show model)++ monitorGeometry <- Gdk.monitorGetGeometry m+ monitorWidth <- Gdk.getRectangleWidth monitorGeometry+ monitorHeight <- Gdk.getRectangleHeight monitorGeometry+ let availableWidth = monitorWidth - (2 * xpadding)+ availableHeight = monitorHeight - (2 * ypadding)+ width =+ case widthSize of+ ExactSize w -> w+ ScreenRatio p ->+ floor $ p * fromIntegral availableWidth+ height =+ case heightSize of+ ExactSize h -> h+ ScreenRatio p ->+ floor $ p * fromIntegral availableHeight+ clampNonNegative x = if x < 0 then 0 else x+ centerOffset availSize size =+ clampNonNegative $ (availSize - size) `div` 2+ endOffset availSize size =+ clampNonNegative $ availSize - size++ (leftMargin, rightMargin, topMargin, bottomMargin) =+ case position of+ TopPos ->+ let offset =+ if width >= availableWidth+ then 0+ else case alignment of+ Beginning -> 0+ Center -> centerOffset availableWidth width+ End -> endOffset availableWidth width+ l = xpadding + offset+ r = xpadding+ in (l, r, ypadding, ypadding)+ BottomPos ->+ let offset =+ if width >= availableWidth+ then 0+ else case alignment of+ Beginning -> 0+ Center -> centerOffset availableWidth width+ End -> endOffset availableWidth width+ l = xpadding + offset+ r = xpadding+ in (l, r, ypadding, ypadding)+ LeftPos ->+ let offset =+ if height >= availableHeight+ then 0+ else case alignment of+ Beginning -> 0+ Center -> centerOffset availableHeight height+ End -> endOffset availableHeight height+ t = ypadding + offset+ b = ypadding+ in (xpadding, xpadding, t, b)+ RightPos ->+ let offset =+ if height >= availableHeight+ then 0+ else case alignment of+ Beginning -> 0+ Center -> centerOffset availableHeight height+ End -> endOffset availableHeight height+ t = ypadding + offset+ b = ypadding+ in (xpadding, xpadding, t, b)++ exclusive =+ if reserveSpace+ then case position of+ TopPos -> height + topMargin+ BottomPos -> height + bottomMargin+ LeftPos -> width + leftMargin+ RightPos -> width + rightMargin+ else 0++ Gtk.windowSetDefaultSize window (fromIntegral width) (fromIntegral height)+ let (reqWidth, reqHeight) =+ case position of+ TopPos -> (min width availableWidth, height)+ BottomPos -> (min width availableWidth, height)+ LeftPos -> (width, min height availableHeight)+ RightPos -> (width, min height availableHeight)+ Gtk.widgetSetSizeRequest window+ (fromIntegral reqWidth)+ (fromIntegral reqHeight)++ GtkLayerShell.setMargin window GtkLayerShell.EdgeLeft leftMargin+ GtkLayerShell.setMargin window GtkLayerShell.EdgeRight rightMargin+ GtkLayerShell.setMargin window GtkLayerShell.EdgeTop topMargin+ GtkLayerShell.setMargin window GtkLayerShell.EdgeBottom bottomMargin++ case position of+ TopPos -> do+ setAnchor GtkLayerShell.EdgeTop True+ setAnchor GtkLayerShell.EdgeBottom False+ if width >= availableWidth+ then do+ setAnchor GtkLayerShell.EdgeLeft True+ setAnchor GtkLayerShell.EdgeRight True+ else case alignment of+ Beginning -> do+ setAnchor GtkLayerShell.EdgeLeft True+ setAnchor GtkLayerShell.EdgeRight False+ Center -> do+ setAnchor GtkLayerShell.EdgeLeft True+ setAnchor GtkLayerShell.EdgeRight False+ End -> do+ setAnchor GtkLayerShell.EdgeLeft False+ setAnchor GtkLayerShell.EdgeRight True+ BottomPos -> do+ setAnchor GtkLayerShell.EdgeTop False+ setAnchor GtkLayerShell.EdgeBottom True+ if width >= availableWidth+ then do+ setAnchor GtkLayerShell.EdgeLeft True+ setAnchor GtkLayerShell.EdgeRight True+ else case alignment of+ Beginning -> do+ setAnchor GtkLayerShell.EdgeLeft True+ setAnchor GtkLayerShell.EdgeRight False+ Center -> do+ setAnchor GtkLayerShell.EdgeLeft True+ setAnchor GtkLayerShell.EdgeRight False+ End -> do+ setAnchor GtkLayerShell.EdgeLeft False+ setAnchor GtkLayerShell.EdgeRight True+ LeftPos -> do+ setAnchor GtkLayerShell.EdgeLeft True+ setAnchor GtkLayerShell.EdgeRight False+ if height >= availableHeight+ then do+ setAnchor GtkLayerShell.EdgeTop True+ setAnchor GtkLayerShell.EdgeBottom True+ else case alignment of+ Beginning -> do+ setAnchor GtkLayerShell.EdgeTop True+ setAnchor GtkLayerShell.EdgeBottom False+ Center -> do+ setAnchor GtkLayerShell.EdgeTop True+ setAnchor GtkLayerShell.EdgeBottom False+ End -> do+ setAnchor GtkLayerShell.EdgeTop False+ setAnchor GtkLayerShell.EdgeBottom True+ RightPos -> do+ setAnchor GtkLayerShell.EdgeLeft False+ setAnchor GtkLayerShell.EdgeRight True+ if height >= availableHeight+ then do+ setAnchor GtkLayerShell.EdgeTop True+ setAnchor GtkLayerShell.EdgeBottom True+ else case alignment of+ Beginning -> do+ setAnchor GtkLayerShell.EdgeTop True+ setAnchor GtkLayerShell.EdgeBottom False+ Center -> do+ setAnchor GtkLayerShell.EdgeTop True+ setAnchor GtkLayerShell.EdgeBottom False+ End -> do+ setAnchor GtkLayerShell.EdgeTop False+ setAnchor GtkLayerShell.EdgeBottom True++ GtkLayerShell.setExclusiveZone window exclusive+ positionP :: Parser StrutPosition positionP = fromMaybe TopPos <$> optional ( flag' TopPos@@ -124,7 +448,7 @@ noStrutP = switch ( long "no-strut"- <> help "Do not set strut properties for the gtk window"+ <> help "Do not reserve space for the window (X11: no strut; Wayland: exclusive zone 0)" ) barLengthP :: Parser Rational@@ -158,6 +482,7 @@ -> Int32 -> [Int32] -> Priority+ -> BackendChoice -> Maybe String -> Bool -> Bool@@ -165,22 +490,38 @@ -> Rational -> Rational -> IO ()-buildWindows pos align size padding monitors priority maybeColorString expand+buildWindows pos align size padding monitors priority backendChoice maybeColorString expand startWatcher noStrut length overlayScale = do Gtk.init Nothing logger <- getLogger "StatusNotifier" saveGlobalLogger $ setLevel priority logger+ detectedBackend <- detectBackend+ let backend =+ case backendChoice of+ BackendAuto -> detectedBackend+ BackendX11Choice -> BackendX11+ BackendWaylandChoice -> BackendWayland client <- connectSession+ logRuntimeInfo backendChoice backend+ watcherPresent <- hasStatusNotifierWatcher client+ unless watcherPresent $ do+ logM "StatusNotifier" WARNING $+ "No StatusNotifierWatcher found on D-Bus (org.kde.StatusNotifierWatcher). Tray will likely be empty."+ unless startWatcher $+ logM "StatusNotifier" WARNING $+ "Start a watcher first (recommended) or run with --watcher to start one in-process." logger <- getRootLogger pid <- getProcessID- -- Okay to use a forced pattern here because we want to die if this fails anyway- Just host <-+ host <- Host.build Host.defaultParams- { Host.dbusClient = Just client- , Host.uniqueIdentifier = printf "standalone-%s" $ show pid- , Host.startWatcher = startWatcher- }+ { Host.dbusClient = Just client+ , Host.uniqueIdentifier = printf "standalone-%s" $ show pid+ , Host.startWatcher = startWatcher+ }+ >>= maybe (logM "StatusNotifier" ERROR "Failed to start StatusNotifier host" >> exitFailure) pure+ initialItems <- Host.itemInfoMap host+ logM "StatusNotifier" INFO $ printf "Initial tray items: %d" (Map.size initialItems) let c1 = defaultStrutConfig { strutPosition = pos@@ -217,8 +558,19 @@ , trayRightClickAction = PopupMenu } window <- Gtk.windowNew Gtk.WindowTypeToplevel- when (not noStrut) $- setupStrutWindow config window+ -- Make it behave more like a panel/tray window in the fallback cases.+ Gtk.windowSetResizable window False+ Gtk.windowSetSkipTaskbarHint window True+ Gtk.windowSetSkipPagerHint window True+ Gtk.windowSetAcceptFocus window False+ Gtk.windowSetFocusOnMap window False+ Gtk.windowSetKeepAbove window True+ Gtk.windowSetTypeHint window Gdk.WindowTypeHintDock+ case backend of+ BackendX11 ->+ when (not noStrut) $ setupStrutWindow config window+ BackendWayland ->+ setupLayerShellWindow config window (not noStrut) maybe (makeWindowTransparent window) (getColor >=>@@ -237,7 +589,7 @@ parser :: Parser (IO ()) parser = buildWindows <$> positionP <*> alignmentP <*> sizeP <*> paddingP <*>- monitorNumberP <*> logP <*> colorP <*> expandP <*> startWatcherP <*>+ monitorNumberP <*> logP <*> backendChoiceP <*> colorP <*> expandP <*> startWatcherP <*> noStrutP <*> barLengthP <*> overlayScaleP versionOption :: Parser (a -> a)
@@ -0,0 +1,69 @@+<node>+ <interface name="com.canonical.dbusmenu">+ <property name="Version" type="u" access="read"/>+ <property name="TextDirection" type="s" access="read"/>+ <property name="Status" type="s" access="read"/>+ <property name="IconThemePath" type="as" access="read"/>++ <method name="GetLayout">+ <arg type="i" name="parentId" direction="in"/>+ <arg type="i" name="recursionDepth" direction="in"/>+ <arg type="as" name="propertyNames" direction="in"/>+ <arg type="u" name="revision" direction="out"/>+ <arg type="(ia{sv}av)" name="layout" direction="out"/>+ <annotation name="org.qtproject.QtDBus.QtTypeName.Out1" value="DBusMenuLayout"/>+ </method>+ <method name="GetGroupProperties">+ <arg type="ai" name="ids" direction="in"/>+ <arg type="as" name="propertyNames" direction="in"/>+ <arg type="a(ia{sv})" name="properties" direction="out"/>+ <annotation name="org.qtproject.QtDBus.QtTypeName.In0" value="DBusMenuIdList"/>+ <annotation name="org.qtproject.QtDBus.QtTypeName.Out0" value="DBusMenuItemPropertiesList"/>+ </method>+ <method name="GetProperty">+ <arg type="i" name="id" direction="in"/>+ <arg type="s" name="name" direction="in"/>+ <arg type="v" name="value" direction="out"/>+ </method>+ <method name="Event">+ <arg type="i" name="id" direction="in"/>+ <arg type="s" name="eventId" direction="in"/>+ <arg type="v" name="data" direction="in"/>+ <arg type="u" name="timestamp" direction="in"/>+ </method>+ <!--<method name="EventGroup">+ <arg type="a(isvu)" name="events" direction="in"/>+ <arg type="ai" name="idErrors" direction="out"/>+ <annotation name="org.qtproject.QtDBus.QtTypeName.In0" value="DBusMenuEventList"/>+ <annotation name="org.qtproject.QtDBus.QtTypeName.Out0" value="DBusMenuIdList"/>+ </method>-->+ <method name="AboutToShow">+ <arg type="i" name="id" direction="in"/>+ <arg type="b" name="needUpdate" direction="out"/>+ </method>+ <method name="AboutToShowGroup">+ <arg type="ai" name="ids" direction="in"/>+ <arg type="ai" name="updatesNeeded" direction="out"/>+ <arg type="ai" name="idErrors" direction="out"/>+ <annotation name="org.qtproject.QtDBus.QtTypeName.In0" value="DBusMenuIdList"/>+ <annotation name="org.qtproject.QtDBus.QtTypeName.Out0" value="DBusMenuIdList"/>+ <annotation name="org.qtproject.QtDBus.QtTypeName.Out1" value="DBusMenuIdList"/>+ </method>++ <signal name="ItemsPropertiesUpdated">+ <arg type="a(ia{sv})" name="updatedProps" direction="out"/>+ <arg type="a(ias)" name="removedProps" direction="out"/>+ <annotation name="org.qtproject.QtDBus.QtTypeName.Out0" value="DBusMenuItemPropertiesList"/>+ <annotation name="org.qtproject.QtDBus.QtTypeName.Out1" value="DBusMenuItemPropertyNamesList"/>+ </signal>+ <signal name="LayoutUpdated">+ <arg type="u" name="revision" direction="out"/>+ <arg type="i" name="parent" direction="out"/>+ </signal>+ <signal name="ItemActivationRequested">+ <arg type="i" name="id" direction="out"/>+ <arg type="u" name="timestamp" direction="out"/>+ </signal>+ </interface>+</node>+
gtk-sni-tray.cabal view
@@ -5,7 +5,7 @@ -- see: https://github.com/sol/hpack name: gtk-sni-tray-version: 0.1.9.1+version: 0.1.10.0 synopsis: A standalone StatusNotifierItem/AppIndicator tray description: Please see the README on Github at <https://github.com/IvanMalison/gtk-sni-tray#readme> category: System@@ -20,6 +20,7 @@ extra-source-files: README.md ChangeLog.md+ dbus-xml/com.canonical.dbusmenu.xml source-repository head type: git@@ -30,7 +31,9 @@ StatusNotifier.TransparentWindow StatusNotifier.Tray other-modules:- Paths_gtk_sni_tray+ StatusNotifier.DBusMenu+ StatusNotifier.DBus.Client.Util+ StatusNotifier.DBus.Client.DBusMenu hs-source-dirs: src pkgconfig-depends:@@ -46,7 +49,6 @@ , gi-cairo , gi-cairo-connector , gi-cairo-render- , gi-dbusmenugtk3 , gi-gdk3 , gi-gdkpixbuf >=2.0.16 , gi-glib@@ -55,7 +57,8 @@ , haskell-gi >=0.21.2 , haskell-gi-base >=0.21.1 , hslogger- , status-notifier-item >=0.3.0.1 && <0.4.0.0+ , status-notifier-item >=0.3.2.0 && <0.4.0.0+ , template-haskell , text , transformers , transformers-base >=0.4@@ -71,9 +74,11 @@ ghc-options: -threaded -rtsopts -with-rtsopts=-N build-depends: base+ , containers , dbus , dbus-hslogger >=0.1.0.1 && <0.2.0.0 , gi-gdk3+ , gi-gtk-layer-shell , gi-gtk3 , gtk-sni-tray , gtk-strut
+ src/StatusNotifier/DBus/Client/DBusMenu.hs view
@@ -0,0 +1,15 @@+{-# LANGUAGE TemplateHaskell #-}+module StatusNotifier.DBus.Client.DBusMenu where++import DBus.Generation+import System.FilePath+import StatusNotifier.DBus.Client.Util++-- Generates DBus client functions/signals for the com.canonical.dbusmenu+-- interface from introspection XML, similar to Taffybar's approach.+generateClientFromFile+ defaultRecordGenerationParams+ defaultGenerationParams { genTakeSignalErrorHandler = True }+ False+ ("dbus-xml" </> "com.canonical.dbusmenu.xml")+
+ src/StatusNotifier/DBus/Client/Util.hs view
@@ -0,0 +1,112 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TemplateHaskellQuotes #-}+module StatusNotifier.DBus.Client.Util+ ( RecordGenerationParams(..)+ , GetTypeForName+ , defaultRecordGenerationParams+ , generateClientFromFile+ ) where++import Control.Monad (forM)+import DBus (ObjectPath)+import DBus.Generation+import qualified DBus.Internal.Types as DBusTypes+import qualified DBus.Introspection as I+import qualified Data.Char as Char+import qualified Data.Coerce as Coerce+import qualified Data.Maybe as Maybe+import qualified Data.Text as T+import qualified Data.Text.IO as TIO+import Language.Haskell.TH+import Language.Haskell.TH.Syntax (addDependentFile, makeRelativeToProject)++type GetTypeForName = String -> DBusTypes.Type -> Maybe Type++data RecordGenerationParams = RecordGenerationParams+ { recordName :: Maybe String+ , recordPrefix :: String+ , recordTypeForName :: GetTypeForName+ }++defaultRecordGenerationParams :: RecordGenerationParams+defaultRecordGenerationParams = RecordGenerationParams+ { recordName = Nothing+ , recordPrefix = "_"+ , recordTypeForName = const $ const Nothing+ }++deriveShowAndEQ :: [DerivClause]+deriveShowAndEQ =+ [DerivClause Nothing [ConT ''Eq, ConT ''Show]]++buildDataFromNameTypePairs :: Name -> [(Name, Type)] -> Dec+buildDataFromNameTypePairs name pairs =+ DataD [] name [] Nothing [RecC name (map mkVarBangType pairs)] deriveShowAndEQ+ where+ mkVarBangType (fieldName, fieldType) =+ ( fieldName+ , Bang NoSourceUnpackedness NoSourceStrictness+ , fieldType+ )++generateGetAllRecord+ :: RecordGenerationParams+ -> GenerationParams+ -> I.Interface+ -> Q [Dec]+generateGetAllRecord+ RecordGenerationParams+ { recordName = recordNameString+ , recordPrefix = prefix+ , recordTypeForName = getTypeForName+ }+ GenerationParams { getTHType = getArgType }+ I.Interface+ { I.interfaceName = interfaceName+ , I.interfaceProperties = properties+ } = do+ let theRecordName =+ mkName $+ maybe+ (map Char.toUpper $ filter Char.isLetter $ Coerce.coerce interfaceName)+ id+ recordNameString+ getPairFromProperty+ I.Property { I.propertyName = propName, I.propertyType = propType } =+ ( mkName $ prefix ++ propName+ , Maybe.fromMaybe (getArgType propType) $+ getTypeForName propName propType+ )+ getAllRecord =+ buildDataFromNameTypePairs theRecordName $+ map getPairFromProperty properties+ pure [getAllRecord]++getIntrospectionObjectFromFile :: FilePath -> ObjectPath -> Q I.Object+getIntrospectionObjectFromFile filepath path = do+ realPath <- makeRelativeToProject filepath+ addDependentFile realPath+ xml <- runIO (TIO.readFile realPath)+ case I.parseXML path xml of+ Nothing -> fail $ "Failed to parse DBus introspection XML: " <> filepath+ Just obj -> pure obj++generateClientFromFile+ :: RecordGenerationParams+ -> GenerationParams+ -> Bool+ -> FilePath+ -> Q [Dec]+generateClientFromFile recordGenerationParams params useObjectPath filepath = do+ obj <- getIntrospectionObjectFromFile filepath "/"+ let actualObjectPath = I.objectPath obj+ realParams =+ if useObjectPath+ then params { genObjectPath = Just actualObjectPath }+ else params+ (<++>) = liftA2 (++)+ fmap concat $ forM (I.objectInterfaces obj) $ \interface -> do+ generateGetAllRecord recordGenerationParams params interface <++>+ generateClient realParams interface <++>+ generateSignalsFromInterface realParams interface
+ src/StatusNotifier/DBusMenu.hs view
@@ -0,0 +1,208 @@+{-# LANGUAGE OverloadedStrings #-}+module StatusNotifier.DBusMenu+ ( buildMenu+ ) where++import Control.Monad (forM_, when)+import Data.Int (Int32)+import Data.Map.Strict (Map)+import qualified Data.Map.Strict as Map+import Data.Maybe (fromMaybe)+import qualified Data.Text as T+import Data.Word (Word32)+import DBus+import DBus.Client+import Data.GI.Base (unsafeCastTo)+import qualified GI.Gtk as Gtk+import System.Log.Logger (Priority(..), logM)++dbusMenuLogger :: Priority -> String -> IO ()+dbusMenuLogger = logM "StatusNotifier.DBusMenu"++addCssClass :: Gtk.Widget -> T.Text -> IO ()+addCssClass widget cssClass =+ Gtk.widgetGetStyleContext widget >>= (`Gtk.styleContextAddClass` cssClass)++data LayoutNode = LayoutNode+ { lnId :: Int32+ , lnProps :: Map String Variant+ , lnChildren :: [LayoutNode]+ } deriving (Eq, Show)++type LayoutTuple = (Int32, Map String Variant, [Variant])++variantToLayout :: Variant -> Maybe LayoutNode+variantToLayout v = do+ (i, props, kids) <- fromVariant v :: Maybe LayoutTuple+ children <- traverse variantToLayout kids+ pure LayoutNode { lnId = i, lnProps = props, lnChildren = children }++callMenu+ :: Client+ -> BusName+ -> ObjectPath+ -> MemberName+ -> [Variant]+ -> IO [Variant]+callMenu client dest path member body = do+ let call0 =+ (methodCall path "com.canonical.dbusmenu" member)+ { methodCallDestination = Just dest+ , methodCallBody = body+ }+ reply <- call client call0+ case reply of+ Left err -> fail $ "DBusMenu call failed: " <> show err+ Right ret -> pure (methodReturnBody ret)++aboutToShow :: Client -> BusName -> ObjectPath -> Int32 -> IO Bool+aboutToShow client dest path i = do+ body <- callMenu client dest path "AboutToShow" [toVariant i]+ case body of+ (v : _) -> pure $ fromMaybe False (fromVariant v)+ _ -> pure False++getLayout :: Client -> BusName -> ObjectPath -> Int32 -> Int32 -> [String] -> IO (Word32, LayoutNode)+getLayout client dest path parentId depth propNames = do+ body <- callMenu client dest path "GetLayout"+ [ toVariant parentId+ , toVariant depth+ , toVariant propNames+ ]+ case body of+ (revV : layoutV : _) -> do+ rev <- maybe (fail "GetLayout: bad revision") pure (fromVariant revV)+ node <- maybe (fail "GetLayout: bad layout") pure (variantToLayout layoutV)+ pure (rev, node)+ _ -> fail "GetLayout: unexpected reply body"++getPropS :: String -> LayoutNode -> Maybe String+getPropS key LayoutNode { lnProps = props } =+ Map.lookup key props >>= fromVariant++getPropB :: String -> LayoutNode -> Maybe Bool+getPropB key LayoutNode { lnProps = props } =+ Map.lookup key props >>= fromVariant++getPropI32 :: String -> LayoutNode -> Maybe Int32+getPropI32 key LayoutNode { lnProps = props } =+ Map.lookup key props >>= fromVariant++menuItemType :: LayoutNode -> Maybe String+menuItemType = getPropS "type"++menuItemLabel :: LayoutNode -> String+menuItemLabel n =+ -- libdbusmenu uses "label" with underscores for mnemonics; GTK3 MenuItem+ -- has use-underline support, but defaulting to literal label is fine.+ fromMaybe "" (getPropS "label" n)++menuItemVisible :: LayoutNode -> Bool+menuItemVisible n = fromMaybe True (getPropB "visible" n)++menuItemEnabled :: LayoutNode -> Bool+menuItemEnabled n = fromMaybe True (getPropB "enabled" n)++menuItemToggleType :: LayoutNode -> Maybe String+menuItemToggleType = getPropS "toggle-type"++menuItemToggleState :: LayoutNode -> Maybe Int32+menuItemToggleState = getPropI32 "toggle-state"++sendClicked :: Client -> BusName -> ObjectPath -> Int32 -> Word32 -> IO ()+sendClicked client dest path itemId ts = do+ -- "clicked" is the common event for activating menu items in the DBusMenu spec.+ _ <- callMenu client dest path "Event"+ [ toVariant itemId+ , toVariant ("clicked" :: String)+ , toVariant ("" :: String) -- v (data)+ , toVariant ts+ ]+ pure ()++populateGtkMenu :: Client -> BusName -> ObjectPath -> Gtk.Menu -> LayoutNode -> IO ()+populateGtkMenu client dest path gtkMenu root = do+ gtkMenuW <- Gtk.toWidget gtkMenu+ addCssClass gtkMenuW "tray-menu"++ -- Clear existing children (for refreshes, e.g. submenus).+ children <- Gtk.containerGetChildren gtkMenu+ forM_ children Gtk.widgetDestroy++ forM_ (lnChildren root) $ \child -> when (menuItemVisible child) $ do+ widget <- buildGtkMenuItem client dest path child+ Gtk.menuShellAppend gtkMenu widget++buildGtkMenuItem :: Client -> BusName -> ObjectPath -> LayoutNode -> IO Gtk.MenuItem+buildGtkMenuItem client dest path node = do+ item <- case menuItemType node of+ Just "separator" -> do+ sep <- Gtk.separatorMenuItemNew+ unsafeCastTo Gtk.MenuItem sep+ _ -> do+ let label = T.pack (menuItemLabel node)+ case menuItemToggleType node of+ Just "checkmark" -> do+ c <- Gtk.checkMenuItemNewWithMnemonic label+ Gtk.checkMenuItemSetActive c (menuItemToggleState node == Just 1)+ unsafeCastTo Gtk.MenuItem c+ Just "radio" -> do+ c <- Gtk.checkMenuItemNewWithMnemonic label+ Gtk.checkMenuItemSetDrawAsRadio c True+ Gtk.checkMenuItemSetActive c (menuItemToggleState node == Just 1)+ unsafeCastTo Gtk.MenuItem c+ _ -> Gtk.menuItemNewWithMnemonic label++ Gtk.widgetSetName item (T.pack ("tray-menu-item-" <> show (lnId node)))+ itemW <- Gtk.toWidget item+ addCssClass itemW "tray-menu-item"++ case menuItemType node of+ Just "separator" -> addCssClass itemW "tray-menu-separator"+ _ -> pure ()++ case menuItemToggleType node of+ Just "checkmark" -> addCssClass itemW "tray-menu-check"+ Just "radio" -> addCssClass itemW "tray-menu-radio"+ _ -> pure ()++ Gtk.widgetSetSensitive item (menuItemEnabled node)++ -- Submenu handling: build children now, and refresh on show via AboutToShow/GetLayout.+ if null (lnChildren node)+ then do+ _ <- Gtk.onMenuItemActivate item $ do+ ts <- Gtk.getCurrentEventTime+ sendClicked client dest path (lnId node) ts+ pure ()+ else do+ addCssClass itemW "tray-menu-item-has-submenu"+ submenu <- Gtk.menuNew+ Gtk.widgetSetName submenu (T.pack ("tray-menu-submenu-" <> show (lnId node)))+ submenuW <- Gtk.toWidget submenu+ addCssClass submenuW "tray-menu-submenu"+ -- Populate with the eagerly-fetched layout so submenus are usable even if+ -- the service doesn't support/require lazy updates.+ populateGtkMenu client dest path submenu node+ let refresh = do+ -- Allow the service to update the submenu content lazily.+ _ <- aboutToShow client dest path (lnId node)+ (_, layout) <- getLayout client dest path (lnId node) 1 []+ populateGtkMenu client dest path submenu layout+ Gtk.widgetShowAll submenu+ _ <- Gtk.onWidgetShow submenu refresh+ Gtk.menuItemSetSubmenu item (Just submenu)++ pure item++buildMenu :: Client -> BusName -> ObjectPath -> IO Gtk.Menu+buildMenu client dest path = do+ dbusMenuLogger DEBUG "Building DBusMenu Gtk.Menu"+ _ <- aboutToShow client dest path 0+ (_, layout) <- getLayout client dest path 0 (-1) []+ menu <- Gtk.menuNew+ Gtk.widgetSetName menu "tray-menu-root"+ menuW <- Gtk.toWidget menu+ addCssClass menuW "tray-menu-root"+ populateGtkMenu client dest path menu layout+ pure menu
src/StatusNotifier/Tray.hs view
@@ -15,7 +15,7 @@ import qualified Data.ByteString as BS import Data.Coerce import Data.Foldable (traverse_)-import Data.GI.Base (unsafeCastTo)+import qualified Data.GI.Base.ManagedPtr as ManagedPtr import Data.GI.Base.GError import Data.Int import Data.List@@ -24,7 +24,6 @@ import Data.Ord import Data.Ratio import qualified Data.Text as T-import qualified GI.DbusmenuGtk3.Objects.Menu as DM import qualified GI.GLib as GLib import GI.GLib.Structs.Bytes import qualified GI.Gdk as Gdk@@ -37,12 +36,14 @@ import GI.Gtk.Flags import GI.Gtk.Objects.IconTheme import Graphics.UI.GIGtkStrut+import qualified StatusNotifier.DBusMenu as DBusMenu import StatusNotifier.Host.Service import qualified StatusNotifier.Item.Client as IC import System.Directory import System.FilePath import System.Log.Logger import Text.Printf+import Foreign.Ptr (Ptr) trayLogger :: Priority -> String -> IO () trayLogger = logM "StatusNotifier.Tray"@@ -184,7 +185,7 @@ data ItemContext = ItemContext { contextName :: DBusTypes.BusName- , contextMenu :: Maybe DM.Menu+ , contextMenuPath :: Maybe DBusTypes.ObjectPath , contextImage :: Gtk.Image , contextButton :: Gtk.EventBox }@@ -234,6 +235,8 @@ trayLogger INFO "Building tray" trayBox <- Gtk.boxNew orientation 0+ Gtk.widgetGetStyleContext trayBox >>=+ flip Gtk.styleContextAddClass "tray-box" contextMap <- MV.newMVar Map.empty let getContext name = Map.lookup name <$> MV.readMVar contextMap@@ -281,18 +284,19 @@ info@ItemInfo { menuPath = pathForMenu , itemServiceName = serviceName , itemServicePath = servicePath- } =+ } = do- let serviceNameStr = coerce serviceName+ let serviceNameStr = (coerce serviceName :: String) servicePathStr = coerce servicePath :: String- serviceMenuPathStr = coerce <$> pathForMenu logText = printf "Adding widget for %s - %s" serviceNameStr servicePathStr trayLogger INFO logText - button <- Gtk.eventBoxNew- Gtk.widgetAddEvents button [Gdk.EventMaskScrollMask]+ eventBox <- Gtk.eventBoxNew+ Gtk.widgetAddEvents eventBox [Gdk.EventMaskScrollMask]+ Gtk.widgetGetStyleContext eventBox >>=+ flip Gtk.styleContextAddClass "tray-icon-button" image <- case imageSize of@@ -347,29 +351,34 @@ Gtk.widgetGetStyleContext image >>= flip Gtk.styleContextAddClass "tray-icon-image" - Gtk.containerAdd button image- setTooltipText button info-- maybeMenu <- sequenceA $ DM.menuNew (T.pack serviceNameStr) .- T.pack <$> serviceMenuPathStr+ Gtk.containerAdd eventBox image+ setTooltipText eventBox info let context = ItemContext { contextName = serviceName- , contextMenu = maybeMenu+ , contextMenuPath = pathForMenu , contextImage = image- , contextButton = button+ , contextButton = eventBox }- popupItemForMenu menu = do- -- Cast DM.Menu to Gtk.Menu for menuPopupAtWidget- gtkMenu <- unsafeCastTo Gtk.Menu menu- Gtk.menuPopupAtWidget gtkMenu image- GravitySouthWest GravityNorthWest Nothing - _ <- Gtk.onWidgetButtonPressEvent button $ \event -> do- button <- Gdk.getEventButtonButton event+ popupGtkMenu gtkMenu triggerEvent = do+ -- On Wayland (e.g. Hyprland) popups need the triggering input+ -- event so GTK can associate the popup with the correct seat/+ -- serial. Also, anchor to the EventBox rather than the Image+ -- (GtkImage is typically "no-window"), or the popup may be+ -- positioned/realized incorrectly.+ Gtk.widgetShowAll gtkMenu+ _ <- Gtk.onWidgetHide gtkMenu (Gtk.widgetDestroy gtkMenu)+ evPtr <- ManagedPtr.unsafeManagedPtrCastPtr triggerEvent :: IO (Ptr Gdk.Event)+ ManagedPtr.withTransient evPtr $ \ev ->+ Gtk.menuPopupAtWidget gtkMenu eventBox+ GravitySouthWest GravityNorthWest (Just ev)++ _ <- Gtk.onWidgetButtonPressEvent eventBox $ \event -> do+ mouseButton <- Gdk.getEventButtonButton event x <- round <$> Gdk.getEventButtonXRoot event y <- round <$> Gdk.getEventButtonYRoot event- action <- case button of+ action <- case mouseButton of 1 -> bool leftClickAction PopupMenu <$> getInfoAttr itemIsMenu True serviceName 2 -> return middleClickAction@@ -378,9 +387,17 @@ Activate -> void $ IC.activate client serviceName servicePath x y SecondaryActivate -> void $ IC.secondaryActivate client serviceName servicePath x y- PopupMenu -> maybe (return ()) popupItemForMenu maybeMenu+ PopupMenu -> do+ menuPath' <- getInfoAttr menuPath Nothing serviceName+ traverse_+ (\p -> catchAny+ (DBusMenu.buildMenu client serviceName p >>= (`popupGtkMenu` event))+ (\e -> trayLogger WARNING $ printf "Failed to build menu for %s: %s"+ (coerce serviceName :: String)+ (show e)))+ menuPath' return False- _ <- Gtk.onWidgetScrollEvent button $ \event -> do+ _ <- Gtk.onWidgetScrollEvent eventBox $ \event -> do direction <- getEventScrollDirection event let direction' = case direction of ScrollDirectionUp -> Just "vertical"@@ -401,13 +418,13 @@ MV.modifyMVar_ contextMap $ return . Map.insert serviceName context - Gtk.widgetShowAll button+ Gtk.widgetShowAll eventBox let packFn = case alignment of End -> Gtk.boxPackEnd _ -> Gtk.boxPackStart - packFn trayBox button shouldExpand True 0+ packFn trayBox eventBox shouldExpand True 0 updateHandler ItemRemoved ItemInfo { itemServiceName = name } = getContext name >>= removeWidget