gtk-sni-tray 0.2.0.0 → 0.2.1.0

raw patch · 7 files changed

+573/−340 lines, 7 filesdep +gi-gobjectdep +gtk-scaling-imagedep +hspecdep ~basedep ~containersdep ~status-notifier-itemPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

Dependencies added: gi-gobject, gtk-scaling-image, hspec

Dependency ranges changed: base, containers, status-notifier-item

API changes (from Hackage documentation)

Files

• ChangeLog.md +20/−0
• app/Main.hs +1/−0
• gtk-sni-tray.cabal +24/−6
• src/StatusNotifier/Tray.hs +386/−334
• src/StatusNotifier/Tray/ContextMap.hs +94/−0
• test/ContextMapSpec.hs +41/−0
• test/Main.hs +7/−0

@@ -1,5 +1,25 @@ # Changelog for gtk-sni-tray +## Unreleased++## 0.2.1.0++- Move prioritized tray controls into the tray menu instead of separate inline+  buttons.+- Auto-fit tray icons and defer prioritized-collapsible tray visibility until+  tray state is ready.+- Fix tray flicker and async menu regressions in prioritized/collapsible tray+  updates.+- Prevent duplicate tray contexts during async initialization and eliminate+  duplicate tray icons on startup.+- Preserve tray item identities across refreshes, refresh prioritized trays in+  place, drop stale rebuilds before swapping, and avoid routine tray churn on+  normal updates.+- Require `status-notifier-item >= 0.3.2.11` for the logical item+  deduplication fixes used by the tray stack.+- Extract generic pixbuf scaling and auto-fill image helpers into the new+  `gtk-scaling-image` package.+ ## 0.2.0.0  - Breaking: remove `buildTrayWithPriority`, `buildTrayWithPixbufTransform`,

@@ -707,6 +707,7 @@                   trayRightClickAction = PopupMenu,                   trayMenuBackend = menuBackend,                   trayCenterIcons = centerIcons,+                  trayShowNewIconsImmediately = True,                   trayPriorityConfig = defaultTrayPriorityConfig,                   trayPixbufTransform = mkIconTransform,                   trayEventHooks = defaultTrayEventHooks

@@ -5,12 +5,12 @@ -- see: https://github.com/sol/hpack  name:           gtk-sni-tray-version:        0.2.0.0+version:        0.2.1.0 synopsis:       A standalone StatusNotifierItem/AppIndicator tray-description:    Please see the README on Github at <https://github.com/IvanMalison/gtk-sni-tray#readme>+description:    Please see the README on Github at <https://github.com/taffybar/gtk-sni-tray#readme> category:       System-homepage:       https://github.com/IvanMalison/gtk-sni-tray#readme-bug-reports:    https://github.com/IvanMalison/gtk-sni-tray/issues+homepage:       https://github.com/taffybar/gtk-sni-tray#readme+bug-reports:    https://github.com/taffybar/gtk-sni-tray/issues author:         Ivan Malison maintainer:     IvanMalison@gmail.com copyright:      2018 Ivan Malison@@ -23,11 +23,12 @@  source-repository head   type: git-  location: https://github.com/IvanMalison/gtk-sni-tray+  location: https://github.com/taffybar/gtk-sni-tray  library   exposed-modules:       StatusNotifier.Icon.Pixbuf+      StatusNotifier.Tray.ContextMap       StatusNotifier.TransparentWindow       StatusNotifier.Tray   other-modules:@@ -52,12 +53,14 @@     , gi-gdk3 ==3.0.*     , gi-gdkpixbuf >=2.0.16 && <2.1     , gi-glib ==2.0.*+    , gi-gobject ==2.0.*     , gi-gtk3 ==3.0.*+    , gtk-scaling-image ==0.1.*     , gtk-strut >=0.1.4 && <0.2     , haskell-gi >=0.21.2 && <0.27     , haskell-gi-base >=0.21.1 && <0.27     , hslogger >=1.2 && <1.4-    , status-notifier-item >=0.3.2 && <0.4+    , status-notifier-item >=0.3.2.11 && <0.4     , text >=1.2 && <2.2     , transformers >=0.4 && <0.7     , transformers-base ==0.4.*@@ -86,4 +89,19 @@     , status-notifier-item     , text     , unix+  default-language: Haskell2010++test-suite gtk-sni-tray-test+  type: exitcode-stdio-1.0+  main-is: Main.hs+  other-modules:+      ContextMapSpec+      Paths_gtk_sni_tray+  hs-source-dirs:+      test+  build-depends:+      base+    , containers+    , gtk-sni-tray+    , hspec <3   default-language: Haskell2010

@@ -4,6 +4,7 @@  module StatusNotifier.Tray where +import Control.Concurrent (forkIO) import Control.Concurrent.MVar as MV import Control.Exception.Base import Control.Exception.Enclosed (catchAny)@@ -26,11 +27,21 @@ import Data.Ord import Data.Ratio import qualified Data.Text as T+import Data.Unique (hashUnique, newUnique) import Data.Word-import Foreign.Ptr (Ptr)+import Foreign.Ptr (Ptr, nullPtr)+import Foreign.StablePtr+  ( StablePtr,+    castPtrToStablePtr,+    castStablePtrToPtr,+    deRefStablePtr,+    freeStablePtr,+    newStablePtr,+  ) import qualified GI.DbusmenuGtk3.Objects.Menu as DM import qualified GI.GLib as GLib import GI.GLib.Structs.Bytes+import qualified GI.GObject as GObject import qualified GI.Gdk as Gdk import GI.Gdk.Enums import GI.Gdk.Structs.EventScroll@@ -39,9 +50,11 @@ import qualified GI.Gtk as Gtk import GI.Gtk.Flags import GI.Gtk.Objects.IconTheme+import Graphics.UI.GIGtkScalingImage import Graphics.UI.GIGtkStrut import StatusNotifier.Host.Service import qualified StatusNotifier.Item.Client as IC+import qualified StatusNotifier.Tray.ContextMap as ContextMap import System.Directory import System.FilePath import System.Log.Logger@@ -50,9 +63,20 @@ trayLogger :: Priority -> String -> IO () trayLogger = logM "StatusNotifier.Tray" +dbusMenuLayoutPropNames :: [String]+dbusMenuLayoutPropNames =+  [ "type",+    "label",+    "visible",+    "enabled",+    "children-display",+    "toggle-type",+    "toggle-state"+  ]+ -- | Optional post-processing hook for item icons. This is applied after scaling -- and overlay composition.-type PixbufTransform = Gtk.Image -> Pixbuf -> IO Pixbuf+type PixbufTransform = Gtk.Widget -> Pixbuf -> IO Pixbuf  logItemInfo :: ItemInfo -> String -> IO () logItemInfo info message =@@ -63,48 +87,6 @@       (show $ info {iconPixmaps = []})       (show $ length $ iconPixmaps info) -getScaledWidthHeight :: Bool -> Int32 -> Int32 -> Int32 -> (Int32, Int32)-getScaledWidthHeight shouldTargetWidth targetSize width height =-  let getRatio :: Int32 -> Rational-      getRatio toScale =-        fromIntegral targetSize / fromIntegral toScale-      getOther :: Int32 -> Int32 -> Int32-      getOther toScale other = max 1 $ floor $ getRatio toScale * fromIntegral other-   in if shouldTargetWidth-        then (targetSize, getOther width height)-        else (getOther height width, targetSize)--scalePixbufToSize :: Int32 -> Gtk.Orientation -> Pixbuf -> IO Pixbuf-scalePixbufToSize size orientation pixbuf = do-  width <- pixbufGetWidth pixbuf-  height <- pixbufGetHeight pixbuf-  let warnAndReturnOrig =-        trayLogger WARNING "Unable to scale pixbuf" >> return pixbuf-  if width <= 0 || height <= 0-    then warnAndReturnOrig-    else do-      let targetWidth = case orientation of-            Gtk.OrientationHorizontal -> False-            _ -> True-          (scaledWidth, scaledHeight) =-            getScaledWidthHeight targetWidth size width height-      trayLogger DEBUG $-        printf-          "Scaling pb to %s, actualW: %s, actualH: %s, scaledW: %s, scaledH: %s"-          (show size)-          (show width)-          (show height)-          (show scaledWidth)-          (show scaledHeight)--      trayLogger DEBUG $-        printf-          "targetW: %s, targetH: %s"-          (show scaledWidth)-          (show scaledHeight)-      maybe warnAndReturnOrig return-        =<< pixbufScaleSimple pixbuf scaledWidth scaledHeight InterpTypeBilinear- themeLoadFlags :: [IconLookupFlags] themeLoadFlags = [IconLookupFlagsGenericFallback, IconLookupFlagsUseBuiltin] @@ -241,7 +223,8 @@ data ItemContext = ItemContext   { contextName :: DBusTypes.BusName,     contextMenuPath :: Maybe DBusTypes.ObjectPath,-    contextImage :: Gtk.Image,+    contextIconWidget :: Gtk.Widget,+    contextSetIcon :: ItemInfo -> IO (),     contextButton :: Gtk.EventBox   } @@ -284,6 +267,50 @@   { trayPriorityMatchers :: [TrayItemMatcher]   } +trayItemIdentityKey :: T.Text+trayItemIdentityKey = "status-notifier.tray.item-identity"++trayItemIdentity :: ItemInfo -> String+trayItemIdentity info =+  show (itemServiceName info) <> "|" <> show (itemServicePath info)++setTrayItemIdentity :: Gtk.EventBox -> ItemInfo -> IO ()+setTrayItemIdentity widget info = do+  sp <- newStablePtr (trayItemIdentity info)+  GObject.objectSetDataFull+    widget+    trayItemIdentityKey+    (castStablePtrToPtr sp :: Ptr ())+    (Just $ \p -> freeStablePtr (castPtrToStablePtr p :: StablePtr String))++getTrayItemIdentity :: Gtk.Widget -> IO (Maybe String)+getTrayItemIdentity widget = do+  p <- GObject.objectGetData widget trayItemIdentityKey+  if p == nullPtr+    then pure Nothing+    else Just <$> deRefStablePtr (castPtrToStablePtr p :: StablePtr String)++reorderTrayChildrenByIdentities :: Gtk.Box -> [String] -> IO ()+reorderTrayChildrenByIdentities trayBox orderedIdentities = do+  currentChildren <- Gtk.containerGetChildren trayBox+  let identityOrder = Map.fromList (zip orderedIdentities [0 :: Int ..])+      fallbackOrder = length orderedIdentities+  childRows <- forM (zip [0 :: Int ..] currentChildren) $ \(currentIndex, child) -> do+    identity <- getTrayItemIdentity child+    let desiredIndex =+          fromMaybe+            (fallbackOrder + currentIndex)+            (identity >>= (`Map.lookup` identityOrder))+    pure (desiredIndex, currentIndex, child)+  let sortedChildren =+        sortOn (\(desiredIndex, currentIndex, _) -> (desiredIndex, currentIndex)) childRows+      currentOrder = map (\(_, _, child) -> child) childRows+      desiredOrder = map (\(_, _, child) -> child) sortedChildren+  unless (currentOrder == desiredOrder) $+    forM_ (zip [0 :: Int ..] sortedChildren) $+      \(newIndex, (_, _, child)) ->+        Gtk.boxReorderChild trayBox child (fromIntegral newIndex)+ defaultTrayPriorityConfig :: TrayPriorityConfig defaultTrayPriorityConfig = TrayPriorityConfig {trayPriorityMatchers = []} @@ -467,6 +494,10 @@     trayRightClickAction :: TrayClickAction,     trayMenuBackend :: MenuBackend,     trayCenterIcons :: Bool,+    -- | Whether newly-added item widgets are shown immediately.+    -- Collapsible wrappers can disable this and decide visibility in their+    -- own refresh pass to avoid transient flashes of hidden items.+    trayShowNewIconsImmediately :: Bool,     trayPriorityConfig :: TrayPriorityConfig,     trayPixbufTransform :: Maybe PixbufTransform,     trayEventHooks :: TrayEventHooks@@ -486,6 +517,7 @@       trayRightClickAction = PopupMenu,       trayMenuBackend = HaskellDBusMenu,       trayCenterIcons = False,+      trayShowNewIconsImmediately = True,       trayPriorityConfig = defaultTrayPriorityConfig,       trayPixbufTransform = Nothing,       trayEventHooks = defaultTrayEventHooks@@ -511,6 +543,7 @@       trayRightClickAction = rightClickAction,       trayMenuBackend = menuBackend,       trayCenterIcons = centerIcons,+      trayShowNewIconsImmediately = showNewIconsImmediately,       trayPriorityConfig =         TrayPriorityConfig           { trayPriorityMatchers = priorityMatchers@@ -522,7 +555,8 @@           }     } =     do-      trayLogger INFO "Building tray"+      trayInstance <- hashUnique <$> newUnique+      trayLogger INFO $ printf "Building tray instance=%d" trayInstance        trayBox <- Gtk.boxNew orientation 0       when centerIcons $ case orientation of@@ -530,18 +564,11 @@         _ -> Gtk.widgetSetValign trayBox Gtk.AlignCenter       Gtk.widgetGetStyleContext trayBox         >>= flip Gtk.styleContextAddClass "tray-box"-      contextMap <- MV.newMVar Map.empty+      contextMap <- MV.newMVar ContextMap.empty -      let getContext name = Map.lookup name <$> MV.readMVar contextMap+      let getContext name = ContextMap.lookupReadyContext name <$> MV.readMVar contextMap           showInfo info = show info {iconPixmaps = []} -          getSize rectangle =-            case orientation of-              Gtk.OrientationHorizontal ->-                Gdk.getRectangleHeight rectangle-              _ ->-                Gdk.getRectangleWidth rectangle-           getInfoAttr fn def name = maybe def fn . Map.lookup name <$> getInfoMap            getInfo :: ItemInfo -> DBusTypes.BusName -> IO ItemInfo@@ -553,54 +580,27 @@               (findIndex (\matcher -> trayItemMatcherPredicate matcher info) priorityMatchers)            reorderTrayByPriority = when (not (null priorityMatchers)) $ do-            currentChildren <- Gtk.containerGetChildren trayBox-            contexts <- MV.readMVar contextMap-            contextWidgets <- forM (Map.toList contexts) $-              \(busName, ItemContext {contextButton = button}) -> do-                widget <- Gtk.toWidget button-                return (busName, widget)             infoMap <- getInfoMap-            let childRows =-                  [ let busName = fst <$> find (\(_, widget) -> widget == child) contextWidgets-                        itemInfo = busName >>= (`Map.lookup` infoMap)-                        priority = maybe (length priorityMatchers) getPriorityIndex itemInfo-                     in (priority, currentIndex, child)-                  | (currentIndex, child) <- zip [0 :: Int ..] currentChildren-                  ]-                sortedChildren =-                  [ child-                  | (_, _, child) <--                      sortOn (\(priority, currentIndex, _) -> (priority, currentIndex)) childRows-                  ]-            forM_ (zip [0 :: Int ..] sortedChildren) $-              \(newIndex, child) ->-                Gtk.boxReorderChild trayBox child (fromIntegral newIndex)+            let orderedInfos =+                  sortOn+                    (\info -> (getPriorityIndex info, trayItemIdentity info))+                    (Map.elems infoMap)+            reorderTrayChildrenByIdentities+              trayBox+              (map trayItemIdentity orderedInfos) -          applyTransform :: Gtk.Image -> Maybe Pixbuf -> IO (Maybe Pixbuf)+          applyTransform :: Gtk.Widget -> Maybe Pixbuf -> IO (Maybe Pixbuf)           applyTransform _ Nothing = return Nothing-          applyTransform image (Just pb) =+          applyTransform widget (Just pb) =             case mTransform of               Nothing -> return (Just pb)-              Just f -> Just <$> f image pb+              Just f -> Just <$> f widget pb            updateIconFromInfo info@ItemInfo {itemServiceName = name} =             getContext name >>= updateIcon             where               updateIcon Nothing = updateHandler ItemAdded info-              updateIcon (Just ItemContext {contextImage = image}) = do-                size <- case imageSize of-                  TrayImageSize size -> return size-                  Expand -> Gtk.widgetGetAllocation image >>= getSize-                getScaledPixBufFromInfo size info-                  >>= applyTransform image-                  >>= let handlePixbuf mpbuf =-                            if isJust mpbuf-                              then Gtk.imageSetFromPixbuf image mpbuf-                              else-                                trayLogger WARNING $-                                  printf "Failed to get pixbuf for %s" $-                                    showInfo info-                       in handlePixbuf+              updateIcon (Just ItemContext {contextSetIcon = setIcon}) = setIcon info            getTooltipText ItemInfo {itemToolTip = Just (_, _, titleText, fullText)}             | titleText == fullText = fullText@@ -620,265 +620,298 @@                 itemServicePath = servicePath               } =               do-                let serviceNameStr = (coerce serviceName :: String)-                    servicePathStr = coerce servicePath :: String-                    logText =-                      printf-                        "Adding widget for %s - %s"-                        serviceNameStr-                        servicePathStr--                trayLogger INFO logText--                eventBox <- Gtk.eventBoxNew-                Gtk.widgetAddEvents eventBox [Gdk.EventMaskScrollMask]-                Gtk.widgetGetStyleContext eventBox-                  >>= flip Gtk.styleContextAddClass "tray-icon-button"--                image <- Gtk.imageNew--                case imageSize of-                  Expand -> do-                    lastAllocation <- MV.newMVar Nothing--                    let setPixbuf allocation =-                          do-                            size <- getSize allocation--                            actualWidth <- Gdk.getRectangleWidth allocation-                            actualHeight <- Gdk.getRectangleHeight allocation--                            requestResize <- MV.modifyMVar lastAllocation $ \previous ->-                              let thisTime = Just (size, actualWidth, actualHeight)-                               in return (thisTime, thisTime /= previous)--                            trayLogger DEBUG $+                reservation <- MV.modifyMVar contextMap $ \contexts ->+                  let (reserved, newContexts) =+                        ContextMap.reserveContext serviceName contexts+                   in pure (newContexts, reserved)+                forM_ reservation $+                  \reservation ->+                    flip+                      onException+                      ( MV.modifyMVar_ contextMap $+                          pure . ContextMap.cancelReservation serviceName reservation+                      )+                      $ do+                        let serviceNameStr = (coerce serviceName :: String)+                            servicePathStr = coerce servicePath :: String+                            logText =                               printf-                                ( "Allocating image size %s, width %s,"-                                    <> " height %s, resize %s"-                                )-                                (show size)-                                (show actualWidth)-                                (show actualHeight)-                                (show requestResize)+                                "Adding widget for %s - %s"+                                serviceNameStr+                                servicePathStr -                            when requestResize $ do-                              trayLogger DEBUG "Requesting resize"-                              pixBuf0 <--                                getInfo info serviceName-                                  >>= getScaledPixBufFromInfo size-                              pixBuf <- applyTransform image pixBuf0-                              when (isNothing pixBuf) $-                                trayLogger WARNING $-                                  printf "Got null pixbuf for info %s" $-                                    showInfo info-                              Gtk.imageSetFromPixbuf image pixBuf-                              void $-                                traverse-                                  ( \pb -> do-                                      width <- pixbufGetWidth pb-                                      height <- pixbufGetHeight pb-                                      Gtk.widgetSetSizeRequest image width height-                                  )-                                  pixBuf-                              void-                                ( Gdk.threadsAddIdle GLib.PRIORITY_DEFAULT $-                                    Gtk.widgetQueueResize image >> return False-                                )+                        trayLogger INFO logText -                    _ <- Gtk.onWidgetSizeAllocate image setPixbuf-                    return ()-                  TrayImageSize size -> do-                    pixBuf0 <- getScaledPixBufFromInfo size info-                    pixBuf <- applyTransform image pixBuf0-                    Gtk.imageSetFromPixbuf image pixBuf+                        eventBox <- Gtk.eventBoxNew+                        Gtk.widgetAddEvents eventBox [Gdk.EventMaskScrollMask]+                        Gtk.widgetGetStyleContext eventBox+                          >>= flip Gtk.styleContextAddClass "tray-icon-button" -                Gtk.widgetGetStyleContext image-                  >>= flip Gtk.styleContextAddClass "tray-icon-image"+                        infoRef <- newIORef info+                        (iconWidget, setIcon) <- case imageSize of+                          Expand -> do+                            drawArea <- Gtk.drawingAreaNew+                            Gtk.widgetGetStyleContext drawArea+                              >>= flip Gtk.styleContextAddClass "tray-icon-image"+                            iconWidget <- Gtk.toWidget drawArea+                            let getPixbufForSize size = do+                                  currentInfo <- readIORef infoRef+                                  pixBuf0 <- getScaledPixBufFromInfo size currentInfo+                                  pixBuf <- applyTransform iconWidget pixBuf0+                                  when (isNothing pixBuf) $+                                    trayLogger WARNING $+                                      printf "Got null pixbuf for info %s" (showInfo currentInfo)+                                  return pixBuf+                            refresh <- autoFillImage drawArea getPixbufForSize orientation+                            let setIconFromInfo iconInfo = do+                                  writeIORef infoRef iconInfo+                                  refresh+                            setIconFromInfo info+                            return (iconWidget, setIconFromInfo)+                          TrayImageSize size -> do+                            image <- Gtk.imageNew+                            Gtk.widgetGetStyleContext image+                              >>= flip Gtk.styleContextAddClass "tray-icon-image"+                            iconWidget <- Gtk.toWidget image+                            let setIconFromInfo iconInfo = do+                                  writeIORef infoRef iconInfo+                                  pixBuf0 <- getScaledPixBufFromInfo size iconInfo+                                  pixBuf <- applyTransform iconWidget pixBuf0+                                  when (isNothing pixBuf) $+                                    trayLogger WARNING $+                                      printf "Got null pixbuf for info %s" $+                                        showInfo iconInfo+                                  Gtk.imageSetFromPixbuf image pixBuf+                            setIconFromInfo info+                            return (iconWidget, setIconFromInfo) -                Gtk.containerAdd eventBox image-                setTooltipText eventBox info+                        Gtk.containerAdd eventBox iconWidget+                        setTrayItemIdentity eventBox info+                        setTooltipText eventBox info -                let context =-                      ItemContext-                        { contextName = serviceName,-                          contextMenuPath = pathForMenu,-                          contextImage = image,-                          contextButton = eventBox-                        }+                        let context =+                              ItemContext+                                { contextName = serviceName,+                                  contextMenuPath = pathForMenu,+                                  contextIconWidget = iconWidget,+                                  contextSetIcon = setIcon,+                                  contextButton = eventBox+                                } -                    popupGtkMenu gtkMenu mEvent = do-                      Gtk.menuAttachToWidget gtkMenu eventBox Nothing-                      _ <- Gtk.onWidgetHide gtkMenu $-                        void $-                          GLib.idleAdd GLib.PRIORITY_LOW $ do-                            Gtk.widgetDestroy gtkMenu-                            return False-                      Gtk.widgetShowAll gtkMenu-                      Gtk.menuPopupAtPointer gtkMenu mEvent+                            popupGtkMenu gtkMenu mEvent = do+                              Gtk.menuAttachToWidget gtkMenu eventBox Nothing+                              _ <- Gtk.onWidgetHide gtkMenu $+                                void $+                                  GLib.idleAdd GLib.PRIORITY_LOW $ do+                                    Gtk.widgetDestroy gtkMenu+                                    return False+                              Gtk.widgetShowAll gtkMenu+                              Gtk.menuPopupAtPointer gtkMenu mEvent -                _ <- Gtk.onWidgetButtonPressEvent eventBox $ \event -> do-                  -- Capture the current event as a Gdk.Event before any-                  -- blocking calls (DBus etc.) so menuPopupAtPointer can-                  -- use its coordinates for popup positioning.-                  currentEvent <- Gtk.getCurrentEvent-                  currentInfo <- getInfo info serviceName-                  mouseButton <- Gdk.getEventButtonButton event-                  x <- round <$> Gdk.getEventButtonXRoot event-                  y <- round <$> Gdk.getEventButtonYRoot event-                  modifiers <- Gdk.getEventButtonState event-                  let defaultAction = case mouseButton of-                        1 -> if itemIsMenu currentInfo then PopupMenu else leftClickAction-                        2 -> middleClickAction-                        _ -> rightClickAction-                  clickDecision <--                    maybe-                      (pure UseDefaultClickAction)-                      ( \hook ->-                          hook-                            TrayClickContext-                              { trayClickItemInfo = currentInfo,-                                trayClickButton = mouseButton,-                                trayClickXRoot = x,-                                trayClickYRoot = y,-                                trayClickModifiers = modifiers,-                                trayClickDefaultAction = defaultAction-                              }-                      )-                      mClickHook-                  let mAction = case clickDecision of-                        UseDefaultClickAction -> Just defaultAction-                        OverrideClickAction action -> Just action-                        ConsumeClick -> Nothing-                  let logActionError actionName e =-                        trayLogger WARNING $-                          printf-                            "%s failed for %s: %s"-                            (actionName :: String)-                            (coerce serviceName :: String)-                            (show e)-                  traverse_-                    ( \action -> case action of-                        Activate ->-                          catchAny-                            (void $ IC.activate client serviceName servicePath x y)-                            (logActionError "Activate")-                        SecondaryActivate ->-                          catchAny-                            ( void $-                                IC.secondaryActivate-                                  client-                                  serviceName-                                  servicePath-                                  x-                                  y+                        _ <- Gtk.onWidgetButtonPressEvent eventBox $ \event -> do+                          -- Capture the current event as a Gdk.Event before any+                          -- blocking calls (DBus etc.) so menuPopupAtPointer can+                          -- use its coordinates for popup positioning.+                          currentEvent <- Gtk.getCurrentEvent+                          currentInfo <- getInfo info serviceName+                          mouseButton <- Gdk.getEventButtonButton event+                          x <- round <$> Gdk.getEventButtonXRoot event+                          y <- round <$> Gdk.getEventButtonYRoot event+                          modifiers <- Gdk.getEventButtonState event+                          let defaultAction = case mouseButton of+                                1 -> if itemIsMenu currentInfo then PopupMenu else leftClickAction+                                2 -> middleClickAction+                                _ -> rightClickAction+                          clickDecision <-+                            maybe+                              (pure UseDefaultClickAction)+                              ( \hook ->+                                  hook+                                    TrayClickContext+                                      { trayClickItemInfo = currentInfo,+                                        trayClickButton = mouseButton,+                                        trayClickXRoot = x,+                                        trayClickYRoot = y,+                                        trayClickModifiers = modifiers,+                                        trayClickDefaultAction = defaultAction+                                      }+                              )+                              mClickHook+                          let mAction = case clickDecision of+                                UseDefaultClickAction -> Just defaultAction+                                OverrideClickAction action -> Just action+                                ConsumeClick -> Nothing+                          let logActionError actionName e =+                                trayLogger WARNING $+                                  printf+                                    "%s failed for %s: %s"+                                    (actionName :: String)+                                    (coerce serviceName :: String)+                                    (show e)+                              runAsync actionName action =+                                void $+                                  forkIO $+                                    catchAny action (logActionError actionName)+                              buildAndPopupHaskellMenu p =+                                runAsync "PopupMenu" $ do+                                  _ <- DBusMenu.aboutToShow client serviceName p 0+                                  (_, layout) <-+                                    DBusMenu.getLayout+                                      client+                                      serviceName+                                      p+                                      0+                                      (-1)+                                      dbusMenuLayoutPropNames+                                  void $+                                    GLib.idleAdd GLib.PRIORITY_DEFAULT_IDLE $ do+                                      gtkMenu <- Gtk.menuNew+                                      DBusMenu.populateGtkMenu client serviceName p gtkMenu layout+                                      popupGtkMenu gtkMenu currentEvent+                                      return False+                          traverse_+                            ( \action -> case action of+                                Activate ->+                                  runAsync "Activate" $+                                    void $+                                      IC.activate client serviceName servicePath x y+                                SecondaryActivate ->+                                  runAsync "SecondaryActivate" $+                                    void $+                                      IC.secondaryActivate+                                        client+                                        serviceName+                                        servicePath+                                        x+                                        y+                                PopupMenu -> do+                                  let menuPath' = menuPath currentInfo+                                  traverse_+                                    ( \p ->+                                        case menuBackend of+                                          LibDBusMenu ->+                                            catchAny+                                              ( do+                                                  let sn = T.pack (coerce serviceName :: String)+                                                      mp = T.pack (coerce p :: String)+                                                  gtkMenu <- DM.menuNew sn mp >>= unsafeCastTo Gtk.Menu+                                                  Gtk.menuAttachToWidget gtkMenu eventBox Nothing+                                                  _ <- Gtk.onWidgetHide gtkMenu $+                                                    void $+                                                      GLib.idleAdd GLib.PRIORITY_DEFAULT_IDLE $ do+                                                        Gtk.widgetDestroy gtkMenu+                                                        return False+                                                  -- libdbusmenu-gtk fetches the menu layout+                                                  -- asynchronously; showing before the root menuitem+                                                  -- is available triggers assertion failures. Defer+                                                  -- the popup until the menu is populated.+                                                  attemptsRef <- newIORef (0 :: Int)+                                                  _ <- GLib.timeoutAdd GLib.PRIORITY_DEFAULT 50 $ do+                                                    n <- readIORef attemptsRef+                                                    if n >= 100+                                                      then do+                                                        Gtk.widgetDestroy gtkMenu+                                                        return False+                                                      else do+                                                        writeIORef attemptsRef (n + 1)+                                                        children <- Gtk.containerGetChildren gtkMenu+                                                        if null children+                                                          then return True+                                                          else do+                                                            Gtk.widgetShowAll gtkMenu+                                                            -- libdbusmenu is populated asynchronously, so we popup later via a+                                                            -- timeout. On Wayland, popups generally need the original trigger+                                                            -- event; use menuPopupAtWidget anchored to the EventBox to avoid+                                                            -- "no trigger event" and invalid rect_window assertions.+                                                            -- Anchor to the actual icon widget so the popup aligns with the+                                                            -- visible image, not the full EventBox allocation.+                                                            Gtk.menuPopupAtWidget+                                                              gtkMenu+                                                              iconWidget+                                                              GravitySouth+                                                              GravityNorth+                                                              currentEvent+                                                            return False+                                                  return ()+                                              )+                                              (logActionError "PopupMenu")+                                          HaskellDBusMenu ->+                                            buildAndPopupHaskellMenu p+                                    )+                                    menuPath'                             )-                            (logActionError "SecondaryActivate")-                        PopupMenu -> do-                          let menuPath' = menuPath currentInfo+                            mAction+                          return False+                        _ <- Gtk.onWidgetScrollEvent eventBox $ \event -> do+                          direction <- getEventScrollDirection event+                          let direction' = case direction of+                                ScrollDirectionUp -> Just "vertical"+                                ScrollDirectionDown -> Just "vertical"+                                ScrollDirectionLeft -> Just "horizontal"+                                ScrollDirectionRight -> Just "horizontal"+                                _ -> Nothing+                              delta = case direction of+                                ScrollDirectionUp -> -1+                                ScrollDirectionDown -> 1+                                ScrollDirectionLeft -> -1+                                ScrollDirectionRight -> 1+                                _ -> 0                           traverse_-                            ( \p ->+                            ( \d ->                                 catchAny-                                  ( case menuBackend of-                                      LibDBusMenu -> do-                                        let sn = T.pack (coerce serviceName :: String)-                                            mp = T.pack (coerce p :: String)-                                        gtkMenu <- DM.menuNew sn mp >>= unsafeCastTo Gtk.Menu-                                        Gtk.menuAttachToWidget gtkMenu eventBox Nothing-                                        _ <- Gtk.onWidgetHide gtkMenu $-                                          void $-                                            GLib.idleAdd GLib.PRIORITY_DEFAULT_IDLE $ do-                                              Gtk.widgetDestroy gtkMenu-                                              return False-                                        -- libdbusmenu-gtk fetches the menu layout-                                        -- asynchronously; showing before the root menuitem-                                        -- is available triggers assertion failures. Defer-                                        -- the popup until the menu is populated.-                                        attemptsRef <- newIORef (0 :: Int)-                                        _ <- GLib.timeoutAdd GLib.PRIORITY_DEFAULT 50 $ do-                                          n <- readIORef attemptsRef-                                          if n >= 100-                                            then do-                                              Gtk.widgetDestroy gtkMenu-                                              return False-                                            else do-                                              writeIORef attemptsRef (n + 1)-                                              children <- Gtk.containerGetChildren gtkMenu-                                              if null children-                                                then return True-                                                else do-                                                  Gtk.widgetShowAll gtkMenu-                                                  -- libdbusmenu is populated asynchronously, so we popup later via a-                                                  -- timeout. On Wayland, popups generally need the original trigger-                                                  -- event; use menuPopupAtWidget anchored to the EventBox to avoid-                                                  -- "no trigger event" and invalid rect_window assertions.-                                                  -- Anchor to the actual icon widget so the popup aligns with the-                                                  -- visible image, not the full EventBox allocation.-                                                  Gtk.menuPopupAtWidget-                                                    gtkMenu-                                                    image-                                                    GravitySouth-                                                    GravityNorth-                                                    currentEvent-                                                  return False-                                        return ()-                                      HaskellDBusMenu -> do-                                        gtkMenu <- DBusMenu.buildMenu client serviceName p-                                        popupGtkMenu gtkMenu currentEvent+                                  (void $ IC.scroll client serviceName servicePath delta d)+                                  ( \e ->+                                      trayLogger WARNING $+                                        printf+                                          "Scroll failed for %s: %s"+                                          (coerce serviceName :: String)+                                          (show e)                                   )-                                  (logActionError "PopupMenu")                             )-                            menuPath'-                    )-                    mAction-                  return False-                _ <- Gtk.onWidgetScrollEvent eventBox $ \event -> do-                  direction <- getEventScrollDirection event-                  let direction' = case direction of-                        ScrollDirectionUp -> Just "vertical"-                        ScrollDirectionDown -> Just "vertical"-                        ScrollDirectionLeft -> Just "horizontal"-                        ScrollDirectionRight -> Just "horizontal"-                        _ -> Nothing-                      delta = case direction of-                        ScrollDirectionUp -> -1-                        ScrollDirectionDown -> 1-                        ScrollDirectionLeft -> -1-                        ScrollDirectionRight -> 1-                        _ -> 0-                  traverse_-                    ( \d ->-                        catchAny-                          (void $ IC.scroll client serviceName servicePath delta d)-                          ( \e ->-                              trayLogger WARNING $-                                printf-                                  "Scroll failed for %s: %s"-                                  (coerce serviceName :: String)-                                  (show e)-                          )-                    )-                    direction'-                  return False+                            direction'+                          return False -                MV.modifyMVar_ contextMap $ return . Map.insert serviceName context+                        didFinalize <- MV.modifyMVar contextMap $ \contexts ->+                          let (finalized, newContexts) =+                                ContextMap.setReadyContext serviceName reservation context contexts+                           in pure (newContexts, finalized) -                Gtk.widgetShowAll eventBox-                let packFn =-                      case alignment of-                        End -> Gtk.boxPackEnd-                        _ -> Gtk.boxPackStart+                        if didFinalize+                          then do+                            let packFn =+                                  case alignment of+                                    End -> Gtk.boxPackEnd+                                    _ -> Gtk.boxPackStart -                packFn trayBox eventBox shouldExpand True 0+                            packFn trayBox eventBox shouldExpand True 0+                            Gtk.widgetShow iconWidget+                            when showNewIconsImmediately $+                              Gtk.widgetShow eventBox+                          else do+                            trayLogger DEBUG $+                              printf+                                "Dropping stale tray widget for %s - %s because its reservation was invalidated."+                                serviceNameStr+                                servicePathStr+                            Gtk.widgetDestroy eventBox+          updateHandler ItemAdded ItemInfo {itemServiceName = serviceName} =+            trayLogger DEBUG $+              printf+                "Skipping duplicate tray add for %s while a widget is pending or ready."+                (coerce serviceName :: String)           updateHandler ItemRemoved ItemInfo {itemServiceName = name} =-            getContext name >>= removeWidget+            MV.modifyMVar contextMap removeContext >>= removeWidget             where+              removeContext contexts =+                let readyContext = ContextMap.lookupReadyContext name contexts+                 in pure (ContextMap.deleteContext name contexts, readyContext)               removeWidget Nothing =-                trayLogger WARNING "removeWidget: unrecognized service name."+                trayLogger DEBUG $+                  printf+                    "Removed tray context for %s before widget realization."+                    (coerce name :: String)               removeWidget (Just ItemContext {contextButton = widgetToRemove}) =-                do-                  Gtk.containerRemove trayBox widgetToRemove-                  MV.modifyMVar_ contextMap $ return . Map.delete name+                Gtk.containerRemove trayBox widgetToRemove           updateHandler IconUpdated i = updateIconFromInfo i           updateHandler OverlayIconUpdated i = updateIconFromInfo i           updateHandler ToolTipUpdated info@ItemInfo {itemServiceName = name} =@@ -979,7 +1012,15 @@             void $               Gdk.threadsAddIdle GLib.PRIORITY_DEFAULT $                 catchAny-                  ( updateHandler updateType info+                  ( trayLogger+                      DEBUG+                      ( printf+                          "Tray instance=%d handling update=%s service=%s"+                          trayInstance+                          (show updateType)+                          (coerce (itemServiceName info) :: String)+                      )+                      >> updateHandler updateType info                       >> reorderTrayByPriority                       >> return False                   )@@ -989,5 +1030,16 @@                   )        handlerId <- addUHandler uiUpdateHandler-      _ <- Gtk.onWidgetDestroy trayBox $ removeUHandler handlerId+      trayLogger INFO $+        printf+          "Registered tray update handler tray=%d handler=%d"+          trayInstance+          (hashUnique handlerId)+      _ <- Gtk.onWidgetDestroy trayBox $ do+        trayLogger INFO $+          printf+            "Removing tray update handler tray=%d handler=%d"+            trayInstance+            (hashUnique handlerId)+        removeUHandler handlerId       return trayBox

@@ -0,0 +1,94 @@+module StatusNotifier.Tray.ContextMap+  ( ContextEntry (..),+    ContextMap,+    Reservation,+    cancelReservation,+    deleteContext,+    empty,+    lookupReadyContext,+    readyContexts,+    reserveContext,+    setReadyContext,+  )+where++import Control.Monad ((>=>))+import qualified Data.Map.Strict as Map++newtype Reservation = Reservation Int+  deriving (Eq, Ord, Show)++data ContextEntry a+  = ContextPending Reservation+  | ContextReady a+  deriving (Eq, Show)++data ContextMap k a = ContextMap+  { nextReservation :: !Int,+    contextEntries :: Map.Map k (ContextEntry a)+  }+  deriving (Eq, Show)++empty :: ContextMap k a+empty = ContextMap {nextReservation = 0, contextEntries = Map.empty}++reserveContext ::+  (Ord k) =>+  k ->+  ContextMap k a ->+  (Maybe Reservation, ContextMap k a)+reserveContext key contexts@(ContextMap {nextReservation = nextReservation', contextEntries = contextEntries'})+  | Map.member key contextEntries' = (Nothing, contexts)+  | otherwise =+      let reservation = Reservation nextReservation'+       in ( Just reservation,+            ContextMap+              { nextReservation = nextReservation' + 1,+                contextEntries = Map.insert key (ContextPending reservation) contextEntries'+              }+          )++setReadyContext ::+  (Ord k) =>+  k ->+  Reservation ->+  a ->+  ContextMap k a ->+  (Bool, ContextMap k a)+setReadyContext key reservation value contexts@(ContextMap {contextEntries = contextEntries'})+  | isActiveReservation key reservation contexts =+      (True, contexts {contextEntries = Map.insert key (ContextReady value) contextEntries'})+  | otherwise = (False, contexts)++lookupReadyContext :: (Ord k) => k -> ContextMap k a -> Maybe a+lookupReadyContext key = Map.lookup key . contextEntries >=> readyContext+  where+    readyContext (ContextPending _) = Nothing+    readyContext (ContextReady value) = Just value++readyContexts :: ContextMap k a -> Map.Map k a+readyContexts = Map.mapMaybe readyContext . contextEntries+  where+    readyContext (ContextPending _) = Nothing+    readyContext (ContextReady value) = Just value++deleteContext :: (Ord k) => k -> ContextMap k a -> ContextMap k a+deleteContext key contexts@(ContextMap {contextEntries = contextEntries'}) =+  contexts {contextEntries = Map.delete key contextEntries'}++cancelReservation ::+  (Ord k) =>+  k ->+  Reservation ->+  ContextMap k a ->+  ContextMap k a+cancelReservation key reservation contexts+  | isActiveReservation key reservation contexts = deleteContext key contexts+  | otherwise = contexts++isActiveReservation :: (Ord k) => k -> Reservation -> ContextMap k a -> Bool+isActiveReservation key reservation =+  maybe False matchesPending . Map.lookup key . contextEntries+  where+    matchesPending (ContextPending reservation') = reservation' == reservation+    matchesPending (ContextReady _) = False

@@ -0,0 +1,41 @@+module ContextMapSpec (spec) where++import qualified Data.Map.Strict as Map+import StatusNotifier.Tray.ContextMap+import Test.Hspec++spec :: Spec+spec = describe "StatusNotifier.Tray.ContextMap" $ do+  it "reserves a new key once and blocks duplicates until ready" $ do+    let (reserved1, contexts1) = reserveContext "item-a" empty+        (reserved2, contexts2) = reserveContext "item-a" contexts1+    reserved1 `shouldSatisfy` (/= Nothing)+    reserved2 `shouldBe` Nothing+    lookupReadyContext "item-a" contexts2 `shouldBe` (Nothing :: Maybe String)++  it "exposes a value once the reservation is marked ready" $ do+    let (Just reservation, contexts1) = reserveContext "item-a" empty+        (didFinalize, contexts2) =+          setReadyContext "item-a" reservation ("ready" :: String) contexts1+    didFinalize `shouldBe` True+    lookupReadyContext "item-a" contexts2 `shouldBe` Just "ready"+    readyContexts contexts2 `shouldBe` Map.fromList [("item-a", "ready")]++  it "allows a fresh reservation after deleting a pending entry" $ do+    let (Just reservation1, contexts1) = reserveContext "item-a" empty+        contexts2 = deleteContext "item-a" contexts1+        contexts3 = cancelReservation "item-a" reservation1 contexts2+        (reservedAgain, _) = reserveContext "item-a" contexts3+    reservedAgain `shouldSatisfy` (/= Nothing)++  it "rejects a stale reservation after remove and re-add" $ do+    let (Just reservation1, contexts1) = reserveContext "item-a" empty+        contexts2 = deleteContext "item-a" contexts1+        (Just reservation2, contexts3) = reserveContext "item-a" contexts2+        (didFinalizeOld, contexts4) =+          setReadyContext "item-a" reservation1 ("stale" :: String) contexts3+        (didFinalizeNew, contexts5) =+          setReadyContext "item-a" reservation2 "fresh" contexts4+    didFinalizeOld `shouldBe` False+    didFinalizeNew `shouldBe` True+    lookupReadyContext "item-a" contexts5 `shouldBe` Just "fresh"

@@ -0,0 +1,7 @@+module Main (main) where++import qualified ContextMapSpec+import Test.Hspec++main :: IO ()+main = hspec ContextMapSpec.spec