dbus-menu 0.1.3.0 → 0.1.3.1
raw patch · 3 files changed
+70/−7 lines, 3 filesdep +gi-gobject
Dependencies added: gi-gobject
Files
- ChangeLog.md +7/−0
- dbus-menu.cabal +2/−1
- src/DBusMenu.hs +61/−6
ChangeLog.md view
@@ -1,5 +1,12 @@ # Changelog for dbus-menu +## 0.1.3.1++* Make click dispatch truly menu-owned: store the click dispatch table on the+ `Gtk.Menu` GObject so it survives `populateGtkMenu` refreshes and works+ correctly for exported `populateGtkMenu`/`buildGtkMenuItem` APIs.+* Add `gi-gobject` dependency (used to associate dispatch table with menu).+ ## 0.1.3.0 * Menu-level click dispatch: leaf item actions are registered in a persistent
@@ -5,7 +5,7 @@ -- see: https://github.com/sol/hpack name: dbus-menu-version: 0.1.3.0+version: 0.1.3.1 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@@ -44,6 +44,7 @@ , enclosed-exceptions >=1.0.0.1 && <1.1 , filepath >=1.3 && <1.6 , gi-glib ==2.0.*+ , gi-gobject ==2.0.* , gi-gtk3 ==3.0.* , haskell-gi >=0.21.2 && <0.27 , haskell-gi-base >=0.21.1 && <0.27
src/DBusMenu.hs view
@@ -29,7 +29,7 @@ import Control.Exception.Enclosed (catchAny) import Control.Monad (forM_, void, when) import Data.Int (Int32)-import Data.IORef (IORef, modifyIORef', newIORef, readIORef, writeIORef)+import Data.IORef (IORef, atomicModifyIORef', newIORef, readIORef, writeIORef) import Data.Map.Strict (Map) import qualified Data.Map.Strict as Map import Data.Maybe (fromMaybe)@@ -38,7 +38,17 @@ import DBus import DBus.Client import Data.GI.Base (unsafeCastTo)+import Foreign.Ptr (Ptr, nullPtr)+import Foreign.StablePtr+ ( 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 Text.Printf@@ -78,6 +88,48 @@ -- lifecycles. type ClickDispatch = IORef (Map Int32 (IO ())) +clickDispatchKey :: T.Text+clickDispatchKey = "dbus-menu.click-dispatch"++getMenuClickDispatch :: Gtk.Menu -> IO (Maybe ClickDispatch)+getMenuClickDispatch menu = do+ p <- GObject.objectGetData menu clickDispatchKey+ if p == nullPtr+ then pure Nothing+ else Just <$> deRefStablePtr (castPtrToStablePtr p)++setMenuClickDispatch :: Gtk.Menu -> ClickDispatch -> IO ()+setMenuClickDispatch menu dispatch = do+ -- Tie the dispatch table to the GObject lifetime. We store a StablePtr to the+ -- IORef; freeing the StablePtr does not free the IORef itself (which can+ -- still be referenced by signal handlers), but it does avoid leaking the+ -- stable pointer.+ sp <- newStablePtr dispatch+ GObject.objectSetDataFull+ menu+ clickDispatchKey+ (castStablePtrToPtr sp :: Ptr ())+ (Just $ \p -> freeStablePtr (castPtrToStablePtr p :: StablePtr ClickDispatch))++ensureMenuClickDispatch :: Gtk.Menu -> IO ClickDispatch+ensureMenuClickDispatch menu = do+ existing <- getMenuClickDispatch menu+ case existing of+ Just dispatch -> pure dispatch+ Nothing -> do+ dispatch <- newIORef Map.empty+ setMenuClickDispatch menu dispatch+ pure dispatch++ensureMenuClickDispatchWith :: Gtk.Menu -> ClickDispatch -> IO ()+ensureMenuClickDispatchWith menu dispatch = do+ existing <- getMenuClickDispatch menu+ case existing of+ Nothing -> setMenuClickDispatch menu dispatch+ Just existingDispatch ->+ when (existingDispatch /= dispatch) $+ dbusMenuLogger WARNING "Menu already has a different click dispatch; leaving existing one in place"+ -- | Parse a DBus Variant into a LayoutNode. variantToLayout :: Variant -> Maybe LayoutNode variantToLayout v = do@@ -192,7 +244,7 @@ -- CSS classes applied to the menu: @dbusmenu-menu@ populateGtkMenu :: Client -> BusName -> ObjectPath -> Gtk.Menu -> LayoutNode -> IO () populateGtkMenu client dest path gtkMenu root = do- dispatch <- newIORef Map.empty+ dispatch <- ensureMenuClickDispatch gtkMenu populateGtkMenu' client dest path dispatch gtkMenu root -- | Internal: populate with a shared dispatch table.@@ -227,7 +279,7 @@ -- * @dbusmenu-submenu@ buildGtkMenuItem :: Client -> BusName -> ObjectPath -> Gtk.Menu -> LayoutNode -> IO Gtk.MenuItem buildGtkMenuItem client dest path parentMenu node = do- dispatch <- newIORef Map.empty+ dispatch <- ensureMenuClickDispatch parentMenu buildGtkMenuItem' client dest path dispatch parentMenu node -- | Internal: build a menu item with a shared dispatch table.@@ -287,8 +339,10 @@ then do -- Register click action in the menu-level dispatch table. let itemId = lnId node- modifyIORef' dispatch $ Map.insert itemId $- sendClicked client dest path itemId =<< Gtk.getCurrentEventTime+ atomicModifyIORef' dispatch $ \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@@ -303,6 +357,7 @@ else do addCssClass itemW "dbusmenu-has-submenu" submenu <- Gtk.menuNew+ ensureMenuClickDispatchWith submenu dispatch Gtk.widgetSetName submenu (T.pack ("dbusmenu-submenu-" <> show (lnId node))) submenuW <- Gtk.toWidget submenu addCssClass submenuW "dbusmenu-submenu"@@ -347,8 +402,8 @@ (_, layout) <- getLayout client dest path 0 (-1) layoutPropNames dbusMenuLogger DEBUG $ printf "buildMenu: root has %d children" (length (lnChildren layout))- dispatch <- newIORef Map.empty menu <- Gtk.menuNew+ dispatch <- ensureMenuClickDispatch menu Gtk.widgetSetName menu "dbusmenu-root" menuW <- Gtk.toWidget menu addCssClass menuW "dbusmenu-root"