dbus-menu 0.1.3.2 → 0.1.3.3
raw patch · 5 files changed
+186/−156 lines, 5 filesPVP ok
version bump matches the API change (PVP)
API changes (from Hackage documentation)
Files
- ChangeLog.md +4/−0
- dbus-menu.cabal +1/−1
- src/DBusMenu.hs +123/−100
- src/DBusMenu/Client.hs +3/−2
- src/DBusMenu/Client/Util.hs +55/−53
ChangeLog.md view
@@ -1,5 +1,9 @@ # Changelog for dbus-menu +## 0.1.3.3 - 2026-05-13++* Refresh generated setup metadata and formatting for the monorepo release.+ ## 0.1.3.2 * Relax `template-haskell` upper bound to `< 2.24` to support GHC 9.12.
@@ -5,7 +5,7 @@ -- see: https://github.com/sol/hpack name: dbus-menu-version: 0.1.3.2+version: 0.1.3.3 synopsis: A Haskell implementation of the DBusMenu protocol description: Haskell client for the com.canonical.dbusmenu DBus interface, providing GTK3 menu construction from DBusMenu services. category: System
src/DBusMenu.hs view
@@ -1,72 +1,74 @@ {-# LANGUAGE OverloadedStrings #-}+ module DBusMenu ( -- * High-level menu construction- buildMenu- , populateGtkMenu- , buildGtkMenuItem+ buildMenu,+ populateGtkMenu,+ buildGtkMenuItem, -- * DBusMenu protocol operations- , getLayout- , aboutToShow- , sendClicked+ getLayout,+ aboutToShow,+ sendClicked, -- * Layout tree- , LayoutNode(..)- , variantToLayout- , tupleToLayout+ LayoutNode (..),+ variantToLayout,+ tupleToLayout, -- * Layout node property accessors- , menuItemType- , menuItemLabel- , menuItemVisible- , menuItemEnabled- , menuItemChildrenDisplay- , menuItemToggleType- , menuItemToggleState- ) where+ menuItemType,+ menuItemLabel,+ menuItemVisible,+ menuItemEnabled,+ menuItemChildrenDisplay,+ menuItemToggleType,+ menuItemToggleState,+ )+where import Control.Concurrent (forkIO) import Control.Exception.Enclosed (catchAny) import Control.Monad (forM_, void, when)-import Data.Int (Int32)+import DBus+import DBus.Client+import qualified DBusMenu.Client as DM+import Data.Either (fromRight)+import Data.GI.Base (unsafeCastTo) import Data.IORef (IORef, atomicModifyIORef', newIORef, readIORef, writeIORef)+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 Foreign.Ptr (Ptr, nullPtr) import Foreign.StablePtr- ( StablePtr- , castPtrToStablePtr- , castStablePtrToPtr- , deRefStablePtr- , freeStablePtr- , newStablePtr+ ( StablePtr,+ castPtrToStablePtr,+ castStablePtrToPtr,+ deRefStablePtr,+ freeStablePtr,+ newStablePtr, ) import qualified GI.GLib as GLib import qualified GI.GObject.Objects.Object as GObject import qualified GI.Gtk as Gtk-import System.Log.Logger (Priority(..), logM)+import System.Log.Logger (Priority (..), logM) import Text.Printf -import qualified DBusMenu.Client as DM- dbusMenuLogger :: Priority -> String -> IO () dbusMenuLogger = logM "DBusMenu" layoutPropNames :: [String] layoutPropNames =- [ "type"- , "label"- , "visible"- , "enabled"- , "children-display"- , "toggle-type"- , "toggle-state"+ [ "type",+ "label",+ "visible",+ "enabled",+ "children-display",+ "toggle-type",+ "toggle-state" ] addCssClass :: Gtk.Widget -> T.Text -> IO ()@@ -75,10 +77,11 @@ -- | A node in the DBusMenu layout tree. data LayoutNode = LayoutNode- { lnId :: Int32- , lnProps :: Map String Variant- , lnChildren :: [LayoutNode]- } deriving (Eq, Show)+ { lnId :: Int32,+ lnProps :: Map String Variant,+ lnChildren :: [LayoutNode]+ }+ deriving (Eq, Show) type LayoutTuple = (Int32, Map String Variant, [Variant]) @@ -135,15 +138,15 @@ variantToLayout v = do (i, props, kids) <- fromVariant v :: Maybe LayoutTuple children <- traverse variantToLayout kids- pure LayoutNode { lnId = i, lnProps = props, lnChildren = children }+ pure LayoutNode {lnId = i, lnProps = props, lnChildren = children} -- | Convert a raw layout tuple into a LayoutNode. tupleToLayout :: LayoutTuple -> LayoutNode tupleToLayout (i, props, kids) = LayoutNode- { lnId = i- , lnProps = props- , lnChildren = [ n | v <- kids, Just n <- [variantToLayout v] ]+ { lnId = i,+ lnProps = props,+ lnChildren = [n | v <- kids, Just n <- [variantToLayout v]] } -- | Unwrap an Either MethodError, failing on Left.@@ -155,13 +158,14 @@ -- Returns True if the service indicates an update is needed. aboutToShow :: Client -> BusName -> ObjectPath -> Int32 -> IO Bool aboutToShow client dest path i =- either (const False) id <$> DM.aboutToShow client dest path i+ fromRight False <$> DM.aboutToShow client dest path i -- | Fetch the layout tree from the DBusMenu service. 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+ (rev, tup) <-+ unwrapCall "GetLayout"+ =<< DM.getLayout client dest path parentId depth propNames pure (rev, tupleToLayout tup) -- | Send a \"clicked\" event to the DBusMenu service for the given item.@@ -169,39 +173,48 @@ 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- ]- }+ 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))+ 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"+ )+ (dbusMenuLogger WARNING . printf "sendClicked: Event exception: %s" . show) getPropS :: String -> LayoutNode -> Maybe String-getPropS key LayoutNode { lnProps = props } =+getPropS key LayoutNode {lnProps = props} = Map.lookup key props >>= fromVariant getPropB :: String -> LayoutNode -> Maybe Bool-getPropB key LayoutNode { lnProps = props } =+getPropB key LayoutNode {lnProps = props} = Map.lookup key props >>= fromVariant getPropI32 :: String -> LayoutNode -> Maybe Int32-getPropI32 key LayoutNode { lnProps = props } =+getPropI32 key LayoutNode {lnProps = props} = Map.lookup key props >>= fromVariant -- | The item type (e.g. @\"separator\"@), or Nothing for standard items.@@ -340,19 +353,23 @@ -- Register click action in the menu-level dispatch table. let itemId = lnId node atomicModifyIORef' dispatch $ \m ->- ( Map.insert itemId (sendClicked client dest path itemId =<< Gtk.getCurrentEventTime) m- , ()+ ( Map.insert itemId (sendClicked client dest path itemId =<< Gtk.getCurrentEventTime) m,+ () ) -- Thin trampoline: look up action from the persistent dispatch table -- at activation time rather than capturing it in a per-widget closure.- _ <- Gtk.onMenuItemActivate item $ catchAny- (do actions <- readIORef dispatch- case Map.lookup itemId actions of- Just action -> action- Nothing -> dbusMenuLogger WARNING $- printf "Dispatch: no action for item %d" itemId)- (\e -> dbusMenuLogger WARNING $- printf "Menu item %d dispatch failed: %s" itemId (show e))+ _ <-+ Gtk.onMenuItemActivate item $+ catchAny+ ( do+ actions <- readIORef dispatch+ case Map.lookup itemId actions of+ Just action -> action+ Nothing ->+ dbusMenuLogger WARNING $+ printf "Dispatch: no action for item %d" itemId+ )+ (dbusMenuLogger WARNING . printf "Menu item %d dispatch failed: %s" itemId . show) pure () else do addCssClass itemW "dbusmenu-has-submenu"@@ -365,25 +382,31 @@ -- the service doesn't support/require lazy updates. populateGtkMenu' client dest path dispatch submenu node loadedRef <- newIORef (not (null (lnChildren node)))- let refresh = void $ forkIO $ catchAny- (do -- Run DBus calls on a forked thread to avoid blocking the GTK- -- main loop (which would cause queued click events to be lost- -- when populateGtkMenu rebuilds menu items).- needUpdate <- aboutToShow client dest path (lnId node)- loaded <- readIORef loadedRef- when (needUpdate || not loaded) $ do- (_, layout) <- getLayout client dest path (lnId node) 1 layoutPropNames- -- Post GTK updates back on the main thread. Using- -- PRIORITY_DEFAULT_IDLE ensures pending input events (clicks)- -- are processed first.- void $ GLib.idleAdd GLib.PRIORITY_DEFAULT_IDLE $ do- populateGtkMenu' client dest path dispatch submenu layout- writeIORef loadedRef True- Gtk.widgetShowAll submenu- return False)- (\e -> dbusMenuLogger WARNING $- printf "Submenu %d refresh failed (stale ID?): %s"- (lnId node) (show e))+ let refresh =+ void $+ forkIO $+ catchAny+ ( do+ -- Run DBus calls on a forked thread to avoid blocking the GTK+ -- main loop (which would cause queued click events to be lost+ -- when populateGtkMenu rebuilds menu items).+ needUpdate <- aboutToShow client dest path (lnId node)+ loaded <- readIORef loadedRef+ when (needUpdate || not loaded) $ do+ (_, layout) <- getLayout client dest path (lnId node) 1 layoutPropNames+ -- Post GTK updates back on the main thread. Using+ -- PRIORITY_DEFAULT_IDLE ensures pending input events (clicks)+ -- are processed first.+ void $ GLib.idleAdd GLib.PRIORITY_DEFAULT_IDLE $ do+ populateGtkMenu' client dest path dispatch submenu layout+ writeIORef loadedRef True+ Gtk.widgetShowAll submenu+ return False+ )+ ( dbusMenuLogger WARNING+ . printf "Submenu %d refresh failed (stale ID?): %s" (lnId node)+ . show+ ) _ <- Gtk.onWidgetShow submenu $ do refresh Gtk.widgetShowAll submenu
src/DBusMenu/Client.hs view
@@ -1,14 +1,15 @@ {-# LANGUAGE TemplateHaskell #-}+ module DBusMenu.Client where import DBus.Generation-import System.FilePath import DBusMenu.Client.Util+import System.FilePath -- Generates DBus client functions/signals for the com.canonical.dbusmenu -- interface from introspection XML, similar to Taffybar's approach. generateClientFromFile defaultRecordGenerationParams- defaultGenerationParams { genTakeSignalErrorHandler = True }+ defaultGenerationParams {genTakeSignalErrorHandler = True} False ("dbus-xml" </> "com.canonical.dbusmenu.xml")
src/DBusMenu/Client/Util.hs view
@@ -1,12 +1,14 @@ {-# LANGUAGE CPP #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE TemplateHaskellQuotes #-}+ module DBusMenu.Client.Util- ( RecordGenerationParams(..)- , GetTypeForName- , defaultRecordGenerationParams- , generateClientFromFile- ) where+ ( RecordGenerationParams (..),+ GetTypeForName,+ defaultRecordGenerationParams,+ generateClientFromFile,+ )+where import Control.Monad (forM) import DBus (ObjectPath)@@ -23,17 +25,18 @@ type GetTypeForName = String -> DBusTypes.Type -> Maybe Type data RecordGenerationParams = RecordGenerationParams- { recordName :: Maybe String- , recordPrefix :: String- , recordTypeForName :: GetTypeForName+ { recordName :: Maybe String,+ recordPrefix :: String,+ recordTypeForName :: GetTypeForName } defaultRecordGenerationParams :: RecordGenerationParams-defaultRecordGenerationParams = RecordGenerationParams- { recordName = Nothing- , recordPrefix = "_"- , recordTypeForName = const $ const Nothing- }+defaultRecordGenerationParams =+ RecordGenerationParams+ { recordName = Nothing,+ recordPrefix = "_",+ recordTypeForName = const $ const Nothing+ } deriveShowAndEQ :: [DerivClause] deriveShowAndEQ =@@ -44,43 +47,42 @@ DataD [] name [] Nothing [RecC name (map mkVarBangType pairs)] deriveShowAndEQ where mkVarBangType (fieldName, fieldType) =- ( fieldName- , Bang NoSourceUnpackedness NoSourceStrictness- , fieldType+ ( fieldName,+ Bang NoSourceUnpackedness NoSourceStrictness,+ fieldType ) -generateGetAllRecord- :: RecordGenerationParams- -> GenerationParams- -> I.Interface- -> Q [Dec]+generateGetAllRecord ::+ RecordGenerationParams ->+ GenerationParams ->+ I.Interface ->+ Q [Dec] generateGetAllRecord RecordGenerationParams- { recordName = recordNameString- , recordPrefix = prefix- , recordTypeForName = getTypeForName+ { recordName = recordNameString,+ recordPrefix = prefix,+ recordTypeForName = getTypeForName }- GenerationParams { getTHType = getArgType }+ GenerationParams {getTHType = getArgType} I.Interface- { I.interfaceName = interfaceName- , I.interfaceProperties = properties+ { 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]+ let theRecordName =+ mkName $+ Maybe.fromMaybe+ (map Char.toUpper $ filter Char.isLetter $ Coerce.coerce interfaceName)+ 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@@ -91,21 +93,21 @@ Nothing -> fail $ "Failed to parse DBus introspection XML: " <> filepath Just obj -> pure obj -generateClientFromFile- :: RecordGenerationParams- -> GenerationParams- -> Bool- -> FilePath- -> Q [Dec]+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 }+ 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+ generateGetAllRecord recordGenerationParams params interface+ <++> generateClient realParams interface+ <++> generateSignalsFromInterface realParams interface