diff --git a/ChangeLog.md b/ChangeLog.md
--- a/ChangeLog.md
+++ b/ChangeLog.md
@@ -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`.
-
diff --git a/README.md b/README.md
--- a/README.md
+++ b/README.md
@@ -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.
diff --git a/Setup.hs b/Setup.hs
--- a/Setup.hs
+++ b/Setup.hs
@@ -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
diff --git a/app/Main.hs b/app/Main.hs
--- a/app/Main.hs
+++ b/app/Main.hs
@@ -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)
diff --git a/dbus-xml/com.canonical.dbusmenu.xml b/dbus-xml/com.canonical.dbusmenu.xml
new file mode 100644
--- /dev/null
+++ b/dbus-xml/com.canonical.dbusmenu.xml
@@ -0,0 +1,69 @@
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
diff --git a/gtk-sni-tray.cabal b/gtk-sni-tray.cabal
--- a/gtk-sni-tray.cabal
+++ b/gtk-sni-tray.cabal
@@ -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
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
diff --git a/src/StatusNotifier/DBus/Client/DBusMenu.hs b/src/StatusNotifier/DBus/Client/DBusMenu.hs
new file mode 100644
--- /dev/null
+++ b/src/StatusNotifier/DBus/Client/DBusMenu.hs
@@ -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")
+
diff --git a/src/StatusNotifier/DBus/Client/Util.hs b/src/StatusNotifier/DBus/Client/Util.hs
new file mode 100644
--- /dev/null
+++ b/src/StatusNotifier/DBus/Client/Util.hs
@@ -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
diff --git a/src/StatusNotifier/DBusMenu.hs b/src/StatusNotifier/DBusMenu.hs
new file mode 100644
--- /dev/null
+++ b/src/StatusNotifier/DBusMenu.hs
@@ -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
diff --git a/src/StatusNotifier/Tray.hs b/src/StatusNotifier/Tray.hs
--- a/src/StatusNotifier/Tray.hs
+++ b/src/StatusNotifier/Tray.hs
@@ -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