diff --git a/ChangeLog.md b/ChangeLog.md --- a/ChangeLog.md +++ b/ChangeLog.md @@ -1,5 +1,12 @@ # Changelog for gtk-sni-tray +## 0.1.13.0 + +- Use extracted `dbus-menu` library instead of inline DBusMenu implementation. +- Reduce default overlay icon scale from 60% to 40%. +- Fix: clamp scaled pixbuf dimensions to >= 1 to prevent GDK assertion failure. +- Bump `dbus-menu` lower bound to 0.1.1. + ## 0.1.12.0 - Add `trayCenterIcons` field to `TrayParams` and `--center-icons` CLI flag to diff --git a/dbus-xml/com.canonical.dbusmenu.xml b/dbus-xml/com.canonical.dbusmenu.xml deleted file mode 100644 --- a/dbus-xml/com.canonical.dbusmenu.xml +++ /dev/null @@ -1,69 +0,0 @@ - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - 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.12.0 +version: 0.1.13.0 synopsis: A standalone StatusNotifierItem/AppIndicator tray description: Please see the README on Github at category: System @@ -20,7 +20,6 @@ extra-source-files: README.md ChangeLog.md - dbus-xml/com.canonical.dbusmenu.xml source-repository head type: git @@ -31,9 +30,7 @@ StatusNotifier.TransparentWindow StatusNotifier.Tray other-modules: - StatusNotifier.DBusMenu - StatusNotifier.DBus.Client.Util - StatusNotifier.DBus.Client.DBusMenu + Paths_gtk_sni_tray hs-source-dirs: src pkgconfig-depends: @@ -43,6 +40,7 @@ , bytestring >=0.10 && <0.13 , containers >=0.5 && <0.8 , dbus ==1.* + , dbus-menu >=0.1.1 && <0.2 , directory >=1.2 && <1.4 , enclosed-exceptions >=1.0.0.1 && <1.1 , filepath >=1.3 && <1.6 @@ -59,7 +57,6 @@ , haskell-gi-base >=0.21.1 && <0.27 , hslogger >=1.2 && <1.4 , status-notifier-item >=0.3.2 && <0.4 - , template-haskell >=2.10 && <2.23 , text >=1.2 && <2.2 , transformers >=0.4 && <0.7 , transformers-base ==0.4.* diff --git a/src/StatusNotifier/DBus/Client/DBusMenu.hs b/src/StatusNotifier/DBus/Client/DBusMenu.hs deleted file mode 100644 --- a/src/StatusNotifier/DBus/Client/DBusMenu.hs +++ /dev/null @@ -1,15 +0,0 @@ -{-# 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 deleted file mode 100644 --- a/src/StatusNotifier/DBus/Client/Util.hs +++ /dev/null @@ -1,111 +0,0 @@ -{-# 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.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 deleted file mode 100644 --- a/src/StatusNotifier/DBusMenu.hs +++ /dev/null @@ -1,223 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} -module StatusNotifier.DBusMenu - ( buildMenu - ) where - -import Control.Concurrent (forkIO) -import Control.Exception.Enclosed (catchAny) -import Control.Monad (forM_, void, 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) -import Text.Printf - -import qualified StatusNotifier.DBus.Client.DBusMenu as DM - -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 } - -tupleToLayout :: LayoutTuple -> LayoutNode -tupleToLayout (i, props, kids) = - LayoutNode - { lnId = i - , lnProps = props - , lnChildren = [ n | v <- kids, Just n <- [variantToLayout v] ] - } - --- | Unwrap an Either MethodError, failing on Left. -unwrapCall :: String -> Either MethodError a -> IO a -unwrapCall label (Left err) = fail $ label <> " failed: " <> show err -unwrapCall _ (Right a) = pure a - -aboutToShow :: Client -> BusName -> ObjectPath -> Int32 -> IO Bool -aboutToShow client dest path i = - either (const False) id <$> DM.aboutToShow client dest path i - -getLayout :: Client -> BusName -> ObjectPath -> Int32 -> Int32 -> [String] -> IO (Word32, LayoutNode) -getLayout client dest path parentId depth propNames = do - (rev, tup) <- unwrapCall "GetLayout" =<< - DM.getLayout client dest path parentId depth propNames - pure (rev, tupleToLayout tup) - -sendClicked :: Client -> BusName -> ObjectPath -> Int32 -> Word32 -> IO () -sendClicked client dest path itemId ts = do - dbusMenuLogger DEBUG $ - printf "sendClicked: id=%d dest=%s path=%s ts=%d" - itemId (show dest) (show path) ts - let mc = DM.eventMethodCall - { methodCallDestination = Just dest - , methodCallPath = path - , methodCallBody = - [ toVariant itemId - , toVariant ("clicked" :: String) - , toVariant (toVariant (0 :: Int32)) - , toVariant ts - ] - } - -- Send on a forked thread to avoid blocking GTK; use `call` instead of - -- `callNoReply` so we can detect service errors. - void $ forkIO $ catchAny - (do result <- call client mc - case result of - Left err -> dbusMenuLogger WARNING $ - printf "sendClicked: Event error: %s" (show err) - Right _ -> dbusMenuLogger DEBUG "sendClicked: Event succeeded") - (\e -> dbusMenuLogger WARNING $ - printf "sendClicked: Event exception: %s" (show e)) - -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" - -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 $ - catchAny - (do ts <- Gtk.getCurrentEventTime - sendClicked client dest path (lnId node) ts) - (\e -> dbusMenuLogger WARNING $ - printf "Menu item %d click failed (stale ID?): %s" - (lnId node) (show e)) - 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 = - catchAny - (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) - (\e -> dbusMenuLogger WARNING $ - printf "Submenu %d refresh failed (stale ID?): %s" - (lnId node) (show e)) - _ <- 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 $ - printf "buildMenu: dest=%s path=%s" (show dest) (show path) - _ <- aboutToShow client dest path 0 - (_, layout) <- getLayout client dest path 0 (-1) [] - dbusMenuLogger DEBUG $ - printf "buildMenu: root has %d children" (length (lnChildren layout)) - 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 @@ -39,7 +39,7 @@ import GI.Gtk.Flags import GI.Gtk.Objects.IconTheme import Graphics.UI.GIGtkStrut -import qualified StatusNotifier.DBusMenu as DBusMenu +import qualified DBusMenu import StatusNotifier.Host.Service import qualified StatusNotifier.Item.Client as IC import System.Directory @@ -63,7 +63,7 @@ getRatio toScale = fromIntegral targetSize / fromIntegral toScale getOther :: Int32 -> Int32 -> Int32 - getOther toScale other = floor $ getRatio toScale * fromIntegral other + getOther toScale other = max 1 $ floor $ getRatio toScale * fromIntegral other in if shouldTargetWidth then (targetSize, getOther width height) @@ -225,7 +225,7 @@ , trayImageSize = Expand , trayIconExpand = False , trayAlignment = End - , trayOverlayScale = 3 % 5 + , trayOverlayScale = 2 % 5 , trayLeftClickAction = Activate , trayMiddleClickAction = SecondaryActivate , trayRightClickAction = PopupMenu