packages feed

gtk-sni-tray 0.1.12.0 → 0.1.13.0

raw patch · 7 files changed

+13/−427 lines, 7 filesdep +dbus-menudep −template-haskellPVP ok

version bump matches the API change (PVP)

Dependencies added: dbus-menu

Dependencies removed: template-haskell

API changes (from Hackage documentation)

Files

ChangeLog.md view
@@ -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
− dbus-xml/com.canonical.dbusmenu.xml 
@@ -1,69 +0,0 @@-<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.12.0+version:        0.1.13.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,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.*
− src/StatusNotifier/DBus/Client/DBusMenu.hs 
@@ -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")-
− src/StatusNotifier/DBus/Client/Util.hs 
@@ -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
− src/StatusNotifier/DBusMenu.hs 
@@ -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
src/StatusNotifier/Tray.hs view
@@ -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