diff --git a/ChangeLog.md b/ChangeLog.md --- a/ChangeLog.md +++ b/ChangeLog.md @@ -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`, diff --git a/app/Main.hs b/app/Main.hs --- a/app/Main.hs +++ b/app/Main.hs @@ -707,6 +707,7 @@ trayRightClickAction = PopupMenu, trayMenuBackend = menuBackend, trayCenterIcons = centerIcons, + trayShowNewIconsImmediately = True, trayPriorityConfig = defaultTrayPriorityConfig, trayPixbufTransform = mkIconTransform, trayEventHooks = defaultTrayEventHooks diff --git a/gtk-sni-tray.cabal b/gtk-sni-tray.cabal --- a/gtk-sni-tray.cabal +++ b/gtk-sni-tray.cabal @@ -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 +description: Please see the README on Github at 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 diff --git a/src/StatusNotifier/Tray.hs b/src/StatusNotifier/Tray.hs --- a/src/StatusNotifier/Tray.hs +++ b/src/StatusNotifier/Tray.hs @@ -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 diff --git a/src/StatusNotifier/Tray/ContextMap.hs b/src/StatusNotifier/Tray/ContextMap.hs new file mode 100644 --- /dev/null +++ b/src/StatusNotifier/Tray/ContextMap.hs @@ -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 diff --git a/test/ContextMapSpec.hs b/test/ContextMapSpec.hs new file mode 100644 --- /dev/null +++ b/test/ContextMapSpec.hs @@ -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" diff --git a/test/Main.hs b/test/Main.hs new file mode 100644 --- /dev/null +++ b/test/Main.hs @@ -0,0 +1,7 @@ +module Main (main) where + +import qualified ContextMapSpec +import Test.Hspec + +main :: IO () +main = hspec ContextMapSpec.spec