gtk-sni-tray 0.1.15.0 → 0.2.0.0

raw patch · 4 files changed

+1781/−1578 lines, 4 filesPVP ok

version bump matches the API change (PVP)

API changes (from Hackage documentation)

Files

• ChangeLog.md +9/−0
• app/Main.hs +778/−704
• gtk-sni-tray.cabal +1/−1
• src/StatusNotifier/Tray.hs +993/−873

@@ -1,5 +1,14 @@ # Changelog for gtk-sni-tray +## 0.2.0.0++- Breaking: remove `buildTrayWithPriority`, `buildTrayWithPixbufTransform`,+  and `buildTrayWithPriorityAndPixbufTransform`.+- Consolidate tray configuration into `TrayParams` with new fields:+  `trayPriorityConfig`, `trayPixbufTransform`, and `trayEventHooks`.+- Add click interception hooks via `TrayEventHooks`/`TrayClickHook` so callers+  can run custom per-item behavior and choose default/override/consume.+ ## 0.1.15.0  - Fix: respect the user's GTK icon theme when an SNI item provides IconThemePath

@@ -1,706 +1,780 @@ {-# LANGUAGE OverloadedStrings #-} {-# OPTIONS_GHC -fno-warn-deprecations #-}-module Main where--import           Control.Monad-import           DBus.Client-import           Data.Int-import           Data.Char (toLower)-import           Data.Maybe-import           Data.Ratio-import qualified Data.Map.Strict as Map-import qualified Data.Text as T-import           Data.Version (showVersion)-import qualified DBus as DBus-import qualified GI.Gdk as Gdk-import qualified GI.Gtk as Gtk-import           Graphics.UI.GIGtkStrut-import           Options.Applicative-import qualified StatusNotifier.Host.Service as Host-import qualified StatusNotifier.Icon.Pixbuf as IconPixbuf-import           StatusNotifier.TransparentWindow-import           StatusNotifier.Tray-import           System.Log.Logger-import           System.Posix.Process-import           System.Environment (lookupEnv)-import           System.Exit (exitFailure)-import           Text.Printf--import           Paths_gtk_sni_tray (version)--import qualified GI.GtkLayerShell as GtkLayerShell--data Backend = BackendX11 | BackendWayland deriving (Eq, Show)--data BackendChoice = BackendAuto | BackendX11Choice | BackendWaylandChoice-  deriving (Eq, Show, Read)--data IconRecolorMode-  = IconRecolorNone-  | IconRecolorMono-  | IconRecolorDuotone-  deriving (Eq, Show, Read)--detectBackend :: IO Backend-detectBackend = do-  supported <- GtkLayerShell.isSupported-  pure $ if supported then BackendWayland else BackendX11--backendChoiceP :: Parser BackendChoice-backendChoiceP =-  option (eitherReader parseBackendChoice)-  (  long "backend"-  <> help "Backend selection: auto | x11 | wayland"-  <> value BackendAuto-  <> metavar "BACKEND"-  )-  where-    parseBackendChoice s =-      case map toLower s of-        "auto" -> Right BackendAuto-        "x11" -> Right BackendX11Choice-        "wayland" -> Right BackendWaylandChoice-        _ -> Left "expected one of: auto, x11, wayland"--logRuntimeInfo :: BackendChoice -> Backend -> IO ()-logRuntimeInfo backendChoice backend = do-  sessionType <- lookupEnv "XDG_SESSION_TYPE"-  waylandDisplay <- lookupEnv "WAYLAND_DISPLAY"-  gdkBackend <- lookupEnv "GDK_BACKEND"-  mDisplay <- Gdk.displayGetDefault-  displayName <- case mDisplay of-    Nothing -> pure Nothing-    Just d -> Just <$> Gdk.displayGetName d-  layerShellSupported <- GtkLayerShell.isSupported-  logM "StatusNotifier.StandaloneWindow" INFO $-    printf "backendChoice=%s backend=%s layerShellSupported=%s XDG_SESSION_TYPE=%s WAYLAND_DISPLAY=%s GDK_BACKEND=%s gdkDisplay=%s"-      (show backendChoice)-      (show backend)-      (show layerShellSupported)-      (show sessionType)-      (show waylandDisplay)-      (show gdkBackend)-      (show displayName)--hasStatusNotifierWatcher :: Client -> IO Bool-hasStatusNotifierWatcher client = do-  let mc =-        (DBus.methodCall dbusPath-          (DBus.interfaceName_ "org.freedesktop.DBus")-          (DBus.memberName_ "NameHasOwner"))-        { DBus.methodCallDestination = Just dbusName-        , DBus.methodCallBody = [DBus.toVariant ("org.kde.StatusNotifierWatcher" :: String)]-        }-  reply <- call_ client mc-  case DBus.methodReturnBody reply of-    [v] -> pure $ fromMaybe False (DBus.fromVariant v)-    _ -> pure False--setupLayerShellWindow :: StrutConfig -> Gtk.Window -> Bool -> IO ()-setupLayerShellWindow StrutConfig-                      { strutWidth = widthSize-                      , strutHeight = heightSize-                      , strutXPadding = xpadding-                      , strutYPadding = ypadding-                      , strutMonitor = monitorNumber-                      , strutPosition = position-                      , strutAlignment = alignment-                      , strutDisplayName = maybeDisplayName-                      } window reserveSpace = do-  supported <- GtkLayerShell.isSupported-  unless supported $-    logM "StatusNotifier.StandaloneWindow" WARNING $-      "Wayland detected, but gtk-layer-shell is not supported; falling back to a regular toplevel window"-  when supported $ do-    Gtk.windowSetDecorated window False--    maybeDisplay <- maybe Gdk.displayGetDefault Gdk.displayOpen maybeDisplayName-    case maybeDisplay of-      Nothing -> logM "StatusNotifier.StandaloneWindow" WARNING "Failed to get GDK display for layer-shell"-      Just display -> do-        nMonitors <- Gdk.displayGetNMonitors display-        logM "StatusNotifier.StandaloneWindow" INFO $ printf "GDK monitors reported: %d" nMonitors--        let tryIndex idx = if idx < 0 || idx >= nMonitors then pure Nothing else Gdk.displayGetMonitor display idx--        mPrimary <- Gdk.displayGetPrimaryMonitor display-        mChosen <- case monitorNumber of-          Nothing -> pure mPrimary-          Just idx -> tryIndex idx--        monitor <--          case mChosen <|> mPrimary of-            Just m -> pure (Just m)-            Nothing -> tryIndex 0--        GtkLayerShell.initForWindow window-        GtkLayerShell.setKeyboardMode window GtkLayerShell.KeyboardModeNone-        GtkLayerShell.setNamespace window (T.pack "gtk-sni-tray")-        GtkLayerShell.setLayer window GtkLayerShell.LayerTop--        GtkLayerShell.setMargin window GtkLayerShell.EdgeLeft xpadding-        GtkLayerShell.setMargin window GtkLayerShell.EdgeRight xpadding-        GtkLayerShell.setMargin window GtkLayerShell.EdgeTop ypadding-        GtkLayerShell.setMargin window GtkLayerShell.EdgeBottom ypadding--        let setAnchor = GtkLayerShell.setAnchor window-        case position of-          TopPos -> do-            setAnchor GtkLayerShell.EdgeTop True-            setAnchor GtkLayerShell.EdgeBottom False-            setAnchor GtkLayerShell.EdgeLeft True-            setAnchor GtkLayerShell.EdgeRight True-          BottomPos -> do-            setAnchor GtkLayerShell.EdgeTop False-            setAnchor GtkLayerShell.EdgeBottom True-            setAnchor GtkLayerShell.EdgeLeft True-            setAnchor GtkLayerShell.EdgeRight True-          LeftPos -> do-            setAnchor GtkLayerShell.EdgeLeft True-            setAnchor GtkLayerShell.EdgeRight False-            setAnchor GtkLayerShell.EdgeTop True-            setAnchor GtkLayerShell.EdgeBottom True-          RightPos -> do-            setAnchor GtkLayerShell.EdgeLeft False-            setAnchor GtkLayerShell.EdgeRight True-            setAnchor GtkLayerShell.EdgeTop True-            setAnchor GtkLayerShell.EdgeBottom True--        let fallbackExclusive =-              if reserveSpace-              then case position of-                     TopPos -> case heightSize of ExactSize h -> h + 2 * ypadding; _ -> 0-                     BottomPos -> case heightSize of ExactSize h -> h + 2 * ypadding; _ -> 0-                     LeftPos -> case widthSize of ExactSize w -> w + 2 * xpadding; _ -> 0-                     RightPos -> case widthSize of ExactSize w -> w + 2 * xpadding; _ -> 0-              else 0-        GtkLayerShell.setExclusiveZone window fallbackExclusive--        case monitor of-          Nothing -> logM "StatusNotifier.StandaloneWindow" WARNING "Failed to select a GDK monitor for layer-shell; using fallback sizing/anchors"-          Just m -> do-            GtkLayerShell.setMonitor window m-            isPrim <- Gdk.monitorIsPrimary m-            model <- Gdk.monitorGetModel m-            manuf <- Gdk.monitorGetManufacturer m-            logM "StatusNotifier.StandaloneWindow" INFO $-              printf "Using monitor primary=%s manufacturer=%s model=%s"-                (show isPrim) (show manuf) (show model)--            monitorGeometry <- Gdk.monitorGetGeometry m-            monitorWidth <- Gdk.getRectangleWidth monitorGeometry-            monitorHeight <- Gdk.getRectangleHeight monitorGeometry-            let availableWidth = monitorWidth - (2 * xpadding)-                availableHeight = monitorHeight - (2 * ypadding)-                width =-                  case widthSize of-                    ExactSize w -> w-                    ScreenRatio p ->-                      floor $ p * fromIntegral availableWidth-                height =-                  case heightSize of-                    ExactSize h -> h-                    ScreenRatio p ->-                      floor $ p * fromIntegral availableHeight-                clampNonNegative x = if x < 0 then 0 else x-                centerOffset availSize size =-                  clampNonNegative $ (availSize - size) `div` 2-                endOffset availSize size =-                  clampNonNegative $ availSize - size--                (leftMargin, rightMargin, topMargin, bottomMargin) =-                  case position of-                    TopPos ->-                      let offset =-                            if width >= availableWidth-                            then 0-                            else case alignment of-                                   Beginning -> 0-                                   Center -> centerOffset availableWidth width-                                   End -> endOffset availableWidth width-                          l = xpadding + offset-                          r = xpadding-                      in (l, r, ypadding, ypadding)-                    BottomPos ->-                      let offset =-                            if width >= availableWidth-                            then 0-                            else case alignment of-                                   Beginning -> 0-                                   Center -> centerOffset availableWidth width-                                   End -> endOffset availableWidth width-                          l = xpadding + offset-                          r = xpadding-                      in (l, r, ypadding, ypadding)-                    LeftPos ->-                      let offset =-                            if height >= availableHeight-                            then 0-                            else case alignment of-                                   Beginning -> 0-                                   Center -> centerOffset availableHeight height-                                   End -> endOffset availableHeight height-                          t = ypadding + offset-                          b = ypadding-                      in (xpadding, xpadding, t, b)-                    RightPos ->-                      let offset =-                            if height >= availableHeight-                            then 0-                            else case alignment of-                                   Beginning -> 0-                                   Center -> centerOffset availableHeight height-                                   End -> endOffset availableHeight height-                          t = ypadding + offset-                          b = ypadding-                      in (xpadding, xpadding, t, b)--                exclusive =-                  if reserveSpace-                  then case position of-                         TopPos -> height + topMargin-                         BottomPos -> height + bottomMargin-                         LeftPos -> width + leftMargin-                         RightPos -> width + rightMargin-                  else 0--            Gtk.windowSetDefaultSize window (fromIntegral width) (fromIntegral height)-            let (reqWidth, reqHeight) =-                  case position of-                    TopPos -> (min width availableWidth, height)-                    BottomPos -> (min width availableWidth, height)-                    LeftPos -> (width, min height availableHeight)-                    RightPos -> (width, min height availableHeight)-            Gtk.widgetSetSizeRequest window-              (fromIntegral reqWidth)-              (fromIntegral reqHeight)--            GtkLayerShell.setMargin window GtkLayerShell.EdgeLeft leftMargin-            GtkLayerShell.setMargin window GtkLayerShell.EdgeRight rightMargin-            GtkLayerShell.setMargin window GtkLayerShell.EdgeTop topMargin-            GtkLayerShell.setMargin window GtkLayerShell.EdgeBottom bottomMargin--            case position of-              TopPos -> do-                setAnchor GtkLayerShell.EdgeTop True-                setAnchor GtkLayerShell.EdgeBottom False-                if width >= availableWidth-                then do-                  setAnchor GtkLayerShell.EdgeLeft True-                  setAnchor GtkLayerShell.EdgeRight True-                else case alignment of-                       Beginning -> do-                         setAnchor GtkLayerShell.EdgeLeft True-                         setAnchor GtkLayerShell.EdgeRight False-                       Center -> do-                         setAnchor GtkLayerShell.EdgeLeft True-                         setAnchor GtkLayerShell.EdgeRight False-                       End -> do-                         setAnchor GtkLayerShell.EdgeLeft False-                         setAnchor GtkLayerShell.EdgeRight True-              BottomPos -> do-                setAnchor GtkLayerShell.EdgeTop False-                setAnchor GtkLayerShell.EdgeBottom True-                if width >= availableWidth-                then do-                  setAnchor GtkLayerShell.EdgeLeft True-                  setAnchor GtkLayerShell.EdgeRight True-                else case alignment of-                       Beginning -> do-                         setAnchor GtkLayerShell.EdgeLeft True-                         setAnchor GtkLayerShell.EdgeRight False-                       Center -> do-                         setAnchor GtkLayerShell.EdgeLeft True-                         setAnchor GtkLayerShell.EdgeRight False-                       End -> do-                         setAnchor GtkLayerShell.EdgeLeft False-                         setAnchor GtkLayerShell.EdgeRight True-              LeftPos -> do-                setAnchor GtkLayerShell.EdgeLeft True-                setAnchor GtkLayerShell.EdgeRight False-                if height >= availableHeight-                then do-                  setAnchor GtkLayerShell.EdgeTop True-                  setAnchor GtkLayerShell.EdgeBottom True-                else case alignment of-                       Beginning -> do-                         setAnchor GtkLayerShell.EdgeTop True-                         setAnchor GtkLayerShell.EdgeBottom False-                       Center -> do-                         setAnchor GtkLayerShell.EdgeTop True-                         setAnchor GtkLayerShell.EdgeBottom False-                       End -> do-                         setAnchor GtkLayerShell.EdgeTop False-                         setAnchor GtkLayerShell.EdgeBottom True-              RightPos -> do-                setAnchor GtkLayerShell.EdgeLeft False-                setAnchor GtkLayerShell.EdgeRight True-                if height >= availableHeight-                then do-                  setAnchor GtkLayerShell.EdgeTop True-                  setAnchor GtkLayerShell.EdgeBottom True-                else case alignment of-                       Beginning -> do-                         setAnchor GtkLayerShell.EdgeTop True-                         setAnchor GtkLayerShell.EdgeBottom False-                       Center -> do-                         setAnchor GtkLayerShell.EdgeTop True-                         setAnchor GtkLayerShell.EdgeBottom False-                       End -> do-                         setAnchor GtkLayerShell.EdgeTop False-                         setAnchor GtkLayerShell.EdgeBottom True--            GtkLayerShell.setExclusiveZone window exclusive--positionP :: Parser StrutPosition-positionP = fromMaybe TopPos <$> optional-  (   flag' TopPos-  (  long "top"-  <> help "Position the bar at the top of the screen"-  )-  <|> flag' BottomPos-  (  long "bottom"-  <> help "Position the bar at the bottom of the screen"-  )-  <|> flag' LeftPos-  (  long "left"-  <> help "Position the bar on the left side of the screen"-  )-  <|> flag' RightPos-  (  long "right"-  <> help "Position the bar on the right side of the screen"-  ))--alignmentP :: Parser StrutAlignment-alignmentP = fromMaybe Center <$> optional-  (   flag' Beginning-  (  long "beginning"-  <> help "Use beginning alignment"-  )-  <|> flag' Center-  (  long "center"-  <> help "Use center alignment"-  )-  <|> flag' End-  (  long "end"-  <> help "Use end alignment"-  ))--sizeP :: Parser Int32-sizeP =-  option auto-  (  long "size"-  <> short 's'-  <> help "Set the size of the bar"-  <> value 30-  <> metavar "SIZE"-  )--paddingP :: Parser Int32-paddingP =-  option auto-  (  long "padding"-  <> short 'p'-  <> help "Set the padding of the bar"-  <> value 0-  <> metavar "PADDING"-  )--monitorNumberP :: Parser [Int32]-monitorNumberP = many $-  option auto-  (  long "monitor"-  <> short 'm'-  <> help "Display a tray bar on the given monitor"-  <> metavar "MONITOR"-  )--logP :: Parser Priority-logP =-  option auto-  (  long "log-level"-  <> short 'l'-  <> help "Set the log level"-  <> metavar "LEVEL"-  <> value WARNING-  )--colorP :: Parser (Maybe String)-colorP = optional $-  strOption-  (  long "color"-  <> short 'c'-  <> help "Set the background color of the tray; See https://developer.gnome.org/gdk3/stable/gdk3-RGBA-Colors.html#gdk-rgba-parse for acceptable values"-  <> metavar "COLOR"-  )--expandP :: Parser Bool-expandP =-  switch-  (  long "expand"-  <> help "Let icons expand into the space allocated to the tray"-  <> short 'e'-  )--centerIconsP :: Parser Bool-centerIconsP =-  switch-  (  long "center-icons"-  <> help "Center the tray icons within the bar"-  )--startWatcherP :: Parser Bool-startWatcherP =-  switch-  (  long "watcher"-  <> short 'w'-  <> help "Start a Watcher to handle SNI registration if one does not exist"-  )--noStrutP :: Parser Bool-noStrutP =-  switch-  (  long "no-strut"-  <> help "Do not reserve space for the window (X11: no strut; Wayland: exclusive zone 0)"-  )--barLengthP :: Parser Rational-barLengthP =-  option auto-  (  long "length"-  <> help "Set the proportion of the screen that the tray bar should occupy -- values are parsed as haskell rationals (e.g. 1 % 2)"-  <> value 1-  )--overlayScaleP :: Parser Rational-overlayScaleP =-  option auto-  (  long "overlay-scale"-  <> short 'o'-  <> help "The proportion of the tray icon's size that should be set for overlay icons."-  <> value (5 % 7)-  )--iconPreferenceP :: Parser TrayIconPreference-iconPreferenceP =-  option (eitherReader parsePref)-    ( long "icon-preference"-        <> help "Icon preference when both are provided: pixmaps (default) | themed"-        <> value PreferPixmaps-        <> metavar "PREFERENCE"-    )-  where-    parsePref s =-      case map toLower s of-        "pixmaps" -> Right PreferPixmaps-        "pixmap" -> Right PreferPixmaps-        "themed" -> Right PreferThemedIcons-        "theme" -> Right PreferThemedIcons-        _ -> Left "expected one of: pixmaps, themed"--iconRecolorModeP :: Parser IconRecolorMode-iconRecolorModeP =-  option (eitherReader parseMode)-    ( long "icon-recolor"-        <> help "Recolor icons based on their alpha mask: none (default) | mono | duotone"-        <> value IconRecolorNone-        <> metavar "MODE"-    )-  where-    parseMode s =-      case map toLower s of-        "none" -> Right IconRecolorNone-        "mono" -> Right IconRecolorMono-        "duo" -> Right IconRecolorDuotone-        "duotone" -> Right IconRecolorDuotone-        _ -> Left "expected one of: none, mono, duotone"--menuBackendP :: Parser MenuBackend-menuBackendP =-  option (eitherReader parseMenuBackend)-  (  long "menu-backend"-  <> help "Menu backend: haskell (default) | libdbusmenu"-  <> value HaskellDBusMenu-  <> metavar "BACKEND"-  )-  where-    parseMenuBackend s =-      case map toLower s of-        "libdbusmenu" -> Right LibDBusMenu-        "haskell" -> Right HaskellDBusMenu-        _ -> Left "expected one of: libdbusmenu, haskell"--getColor :: String -> IO Gdk.RGBA-getColor colorString = do-  rgba <- Gdk.newZeroRGBA-  colorParsed <- Gdk.rGBAParse rgba (T.pack colorString)-  unless colorParsed $ do-    logM "StatusNotifier.Tray" WARNING "Failed to parse provided color"-    void $ Gdk.rGBAParse rgba "#000000"-  return rgba--buildWindows :: StrutPosition-             -> StrutAlignment-             -> Int32-             -> Int32-             -> [Int32]-             -> Priority-             -> BackendChoice-             -> Maybe String-             -> Bool-             -> Bool-             -> Bool-             -> Bool-             -> Rational-             -> Rational-             -> MenuBackend-             -> TrayIconPreference-             -> IconRecolorMode-             -> IO ()-buildWindows pos align size padding monitors priority backendChoice maybeColorString expand-             centerIcons startWatcher noStrut barLength overlayScale menuBackend iconPreference iconRecolorMode = do-  _ <- Gtk.init Nothing-  logger <- getLogger "StatusNotifier"-  saveGlobalLogger $ setLevel priority logger-  detectedBackend <- detectBackend-  let backend =-        case backendChoice of-          BackendAuto -> detectedBackend-          BackendX11Choice -> BackendX11-          BackendWaylandChoice -> BackendWayland-  client <- connectSession-  logRuntimeInfo backendChoice backend-  watcherPresent <- hasStatusNotifierWatcher client-  unless watcherPresent $ do-    logM "StatusNotifier" WARNING $-      "No StatusNotifierWatcher found on D-Bus (org.kde.StatusNotifierWatcher). Tray will likely be empty."-    unless startWatcher $-      logM "StatusNotifier" WARNING $-        "Start a watcher first (recommended) or run with --watcher to start one in-process."-  _ <- getRootLogger-  pid <- getProcessID-  host <--    Host.build-      Host.defaultParams-        { Host.dbusClient = Just client-        , Host.uniqueIdentifier = printf "standalone-%s" $ show pid-        , Host.startWatcher = startWatcher-        }-      >>= maybe (logM "StatusNotifier" ERROR "Failed to start StatusNotifier host" >> exitFailure) pure-  initialItems <- Host.itemInfoMap host-  logM "StatusNotifier" INFO $ printf "Initial tray items: %d" (Map.size initialItems)-  let c1 =-        defaultStrutConfig-        { strutPosition = pos-        , strutAlignment = align-        , strutXPadding = padding-        , strutYPadding = padding-        }-      defaultRatio = ScreenRatio barLength-      configBase =-        case pos of-          TopPos -> c1 {strutHeight = ExactSize size, strutWidth = defaultRatio}-          BottomPos ->-            c1 {strutHeight = ExactSize size, strutWidth = defaultRatio}-          RightPos ->-            c1 {strutHeight = defaultRatio, strutWidth = ExactSize size}-          LeftPos ->-            c1 {strutHeight = defaultRatio, strutWidth = ExactSize size}-      buildWithConfig config = do-        let orientation =-              case strutPosition config of-                TopPos -> Gtk.OrientationHorizontal-                BottomPos -> Gtk.OrientationHorizontal-                _ -> Gtk.OrientationVertical-            mixWord8 t a b =-              let ta = fromIntegral a :: Double-                  tb = fromIntegral b :: Double-                  out = ta + max 0 (min 1 t) * (tb - ta)-              in fromIntegral (max (0 :: Int) (min 255 (round out)))-            mixRgb8 t (IconPixbuf.Rgb8 r g b) (IconPixbuf.Rgb8 r2 g2 b2) =-              IconPixbuf.Rgb8 (mixWord8 t r r2) (mixWord8 t g g2) (mixWord8 t b b2)-            mkIconTransform =-              case iconRecolorMode of-                IconRecolorNone -> Nothing-                IconRecolorMono ->-                  Just $ \image pb -> do-                    ctx <- Gtk.widgetGetStyleContext image-                    fg <- Gtk.styleContextGetColor ctx [Gtk.StateFlagsNormal]-                    fg8 <- IconPixbuf.rgb8FromGdkRGBA fg-                    mpb <- IconPixbuf.recolorPixbufMonochrome fg8 pb-                    return $ fromMaybe pb mpb-                IconRecolorDuotone ->-                  Just $ \image pb -> do-                    ctx <- Gtk.widgetGetStyleContext image-                    fg <- Gtk.styleContextGetColor ctx [Gtk.StateFlagsNormal]-                    fg8 <- IconPixbuf.rgb8FromGdkRGBA fg-                    let black = IconPixbuf.Rgb8 0 0 0-                        white = IconPixbuf.Rgb8 255 255 255-                        dark = mixRgb8 0.35 fg8 black-                        light = mixRgb8 0.35 fg8 white-                    mpb <- IconPixbuf.recolorPixbufDuotone dark light pb-                    return $ fromMaybe pb mpb-        tray <--          buildTrayWithPixbufTransform host client-            TrayParams-            { trayOrientation = orientation-            , trayImageSize = Expand-            , trayIconExpand = expand-            , trayIconPreference = iconPreference-            , trayAlignment = align-            , trayOverlayScale = overlayScale-            , trayLeftClickAction = Activate-            , trayMiddleClickAction = SecondaryActivate-            , trayRightClickAction = PopupMenu-            , trayMenuBackend = menuBackend-            , trayCenterIcons = centerIcons-            }-            mkIconTransform-        window <- Gtk.windowNew Gtk.WindowTypeToplevel-        Gtk.windowSetResizable window False-        Gtk.windowSetSkipTaskbarHint window True-        Gtk.windowSetSkipPagerHint window True-        Gtk.windowSetAcceptFocus window False-        Gtk.windowSetFocusOnMap window False-        Gtk.windowSetKeepAbove window True-        Gtk.windowSetTypeHint window Gdk.WindowTypeHintDock-        case backend of-          BackendX11 ->-            when (not noStrut) $ setupStrutWindow config window-          BackendWayland ->-            setupLayerShellWindow config window (not noStrut)-        maybe-          (makeWindowTransparent window)-          (getColor >=>-           Gtk.widgetOverrideBackgroundColor window [Gtk.StateFlagsNormal] .-           Just)-          maybeColorString-        Gtk.containerAdd window tray-        Gtk.widgetShowAll window-      runForMonitor monitor =-        buildWithConfig configBase {strutMonitor = Just monitor}-  if null monitors-    then buildWithConfig configBase-    else mapM_ runForMonitor monitors-  Gtk.main--parser :: Parser (IO ())-parser =-  buildWindows <$> positionP <*> alignmentP <*> sizeP <*> paddingP <*>-  monitorNumberP <*> logP <*> backendChoiceP <*> colorP <*> expandP <*>-  centerIconsP <*> startWatcherP <*>-  noStrutP <*> barLengthP <*> overlayScaleP <*> menuBackendP <*> iconPreferenceP <*> iconRecolorModeP--versionOption :: Parser (a -> a)-versionOption = infoOption-                (printf "gtk-sni-tray-standalone %s" $ showVersion version)-                (  long "version"-                <> help "Show the version number of gtk-sni-tray"-                )--main :: IO ()-main =-  join $ execParser $ info (helper <*> versionOption <*> parser)-         (  fullDesc-         <> progDesc "Run a standalone StatusNotifierItem/AppIndicator tray"-         )++module Main where++import Control.Monad+import qualified DBus as DBus+import DBus.Client+import Data.Char (toLower)+import Data.Int+import qualified Data.Map.Strict as Map+import Data.Maybe+import Data.Ratio+import qualified Data.Text as T+import Data.Version (showVersion)+import qualified GI.Gdk as Gdk+import qualified GI.Gtk as Gtk+import qualified GI.GtkLayerShell as GtkLayerShell+import Graphics.UI.GIGtkStrut+import Options.Applicative+import Paths_gtk_sni_tray (version)+import qualified StatusNotifier.Host.Service as Host+import qualified StatusNotifier.Icon.Pixbuf as IconPixbuf+import StatusNotifier.TransparentWindow+import StatusNotifier.Tray+import System.Environment (lookupEnv)+import System.Exit (exitFailure)+import System.Log.Logger+import System.Posix.Process+import Text.Printf++data Backend = BackendX11 | BackendWayland deriving (Eq, Show)++data BackendChoice = BackendAuto | BackendX11Choice | BackendWaylandChoice+  deriving (Eq, Show, Read)++data IconRecolorMode+  = IconRecolorNone+  | IconRecolorMono+  | IconRecolorDuotone+  deriving (Eq, Show, Read)++detectBackend :: IO Backend+detectBackend = do+  supported <- GtkLayerShell.isSupported+  pure $ if supported then BackendWayland else BackendX11++backendChoiceP :: Parser BackendChoice+backendChoiceP =+  option+    (eitherReader parseBackendChoice)+    ( long "backend"+        <> help "Backend selection: auto | x11 | wayland"+        <> value BackendAuto+        <> metavar "BACKEND"+    )+  where+    parseBackendChoice s =+      case map toLower s of+        "auto" -> Right BackendAuto+        "x11" -> Right BackendX11Choice+        "wayland" -> Right BackendWaylandChoice+        _ -> Left "expected one of: auto, x11, wayland"++logRuntimeInfo :: BackendChoice -> Backend -> IO ()+logRuntimeInfo backendChoice backend = do+  sessionType <- lookupEnv "XDG_SESSION_TYPE"+  waylandDisplay <- lookupEnv "WAYLAND_DISPLAY"+  gdkBackend <- lookupEnv "GDK_BACKEND"+  mDisplay <- Gdk.displayGetDefault+  displayName <- case mDisplay of+    Nothing -> pure Nothing+    Just d -> Just <$> Gdk.displayGetName d+  layerShellSupported <- GtkLayerShell.isSupported+  logM "StatusNotifier.StandaloneWindow" INFO $+    printf+      "backendChoice=%s backend=%s layerShellSupported=%s XDG_SESSION_TYPE=%s WAYLAND_DISPLAY=%s GDK_BACKEND=%s gdkDisplay=%s"+      (show backendChoice)+      (show backend)+      (show layerShellSupported)+      (show sessionType)+      (show waylandDisplay)+      (show gdkBackend)+      (show displayName)++hasStatusNotifierWatcher :: Client -> IO Bool+hasStatusNotifierWatcher client = do+  let mc =+        ( DBus.methodCall+            dbusPath+            (DBus.interfaceName_ "org.freedesktop.DBus")+            (DBus.memberName_ "NameHasOwner")+        )+          { DBus.methodCallDestination = Just dbusName,+            DBus.methodCallBody = [DBus.toVariant ("org.kde.StatusNotifierWatcher" :: String)]+          }+  reply <- call_ client mc+  case DBus.methodReturnBody reply of+    [v] -> pure $ fromMaybe False (DBus.fromVariant v)+    _ -> pure False++setupLayerShellWindow :: StrutConfig -> Gtk.Window -> Bool -> IO ()+setupLayerShellWindow+  StrutConfig+    { strutWidth = widthSize,+      strutHeight = heightSize,+      strutXPadding = xpadding,+      strutYPadding = ypadding,+      strutMonitor = monitorNumber,+      strutPosition = position,+      strutAlignment = alignment,+      strutDisplayName = maybeDisplayName+    }+  window+  reserveSpace = do+    supported <- GtkLayerShell.isSupported+    unless supported $+      logM "StatusNotifier.StandaloneWindow" WARNING $+        "Wayland detected, but gtk-layer-shell is not supported; falling back to a regular toplevel window"+    when supported $ do+      Gtk.windowSetDecorated window False++      maybeDisplay <- maybe Gdk.displayGetDefault Gdk.displayOpen maybeDisplayName+      case maybeDisplay of+        Nothing -> logM "StatusNotifier.StandaloneWindow" WARNING "Failed to get GDK display for layer-shell"+        Just display -> do+          nMonitors <- Gdk.displayGetNMonitors display+          logM "StatusNotifier.StandaloneWindow" INFO $ printf "GDK monitors reported: %d" nMonitors++          let tryIndex idx = if idx < 0 || idx >= nMonitors then pure Nothing else Gdk.displayGetMonitor display idx++          mPrimary <- Gdk.displayGetPrimaryMonitor display+          mChosen <- case monitorNumber of+            Nothing -> pure mPrimary+            Just idx -> tryIndex idx++          monitor <-+            case mChosen <|> mPrimary of+              Just m -> pure (Just m)+              Nothing -> tryIndex 0++          GtkLayerShell.initForWindow window+          GtkLayerShell.setKeyboardMode window GtkLayerShell.KeyboardModeNone+          GtkLayerShell.setNamespace window (T.pack "gtk-sni-tray")+          GtkLayerShell.setLayer window GtkLayerShell.LayerTop++          GtkLayerShell.setMargin window GtkLayerShell.EdgeLeft xpadding+          GtkLayerShell.setMargin window GtkLayerShell.EdgeRight xpadding+          GtkLayerShell.setMargin window GtkLayerShell.EdgeTop ypadding+          GtkLayerShell.setMargin window GtkLayerShell.EdgeBottom ypadding++          let setAnchor = GtkLayerShell.setAnchor window+          case position of+            TopPos -> do+              setAnchor GtkLayerShell.EdgeTop True+              setAnchor GtkLayerShell.EdgeBottom False+              setAnchor GtkLayerShell.EdgeLeft True+              setAnchor GtkLayerShell.EdgeRight True+            BottomPos -> do+              setAnchor GtkLayerShell.EdgeTop False+              setAnchor GtkLayerShell.EdgeBottom True+              setAnchor GtkLayerShell.EdgeLeft True+              setAnchor GtkLayerShell.EdgeRight True+            LeftPos -> do+              setAnchor GtkLayerShell.EdgeLeft True+              setAnchor GtkLayerShell.EdgeRight False+              setAnchor GtkLayerShell.EdgeTop True+              setAnchor GtkLayerShell.EdgeBottom True+            RightPos -> do+              setAnchor GtkLayerShell.EdgeLeft False+              setAnchor GtkLayerShell.EdgeRight True+              setAnchor GtkLayerShell.EdgeTop True+              setAnchor GtkLayerShell.EdgeBottom True++          let fallbackExclusive =+                if reserveSpace+                  then case position of+                    TopPos -> case heightSize of ExactSize h -> h + 2 * ypadding; _ -> 0+                    BottomPos -> case heightSize of ExactSize h -> h + 2 * ypadding; _ -> 0+                    LeftPos -> case widthSize of ExactSize w -> w + 2 * xpadding; _ -> 0+                    RightPos -> case widthSize of ExactSize w -> w + 2 * xpadding; _ -> 0+                  else 0+          GtkLayerShell.setExclusiveZone window fallbackExclusive++          case monitor of+            Nothing -> logM "StatusNotifier.StandaloneWindow" WARNING "Failed to select a GDK monitor for layer-shell; using fallback sizing/anchors"+            Just m -> do+              GtkLayerShell.setMonitor window m+              isPrim <- Gdk.monitorIsPrimary m+              model <- Gdk.monitorGetModel m+              manuf <- Gdk.monitorGetManufacturer m+              logM "StatusNotifier.StandaloneWindow" INFO $+                printf+                  "Using monitor primary=%s manufacturer=%s model=%s"+                  (show isPrim)+                  (show manuf)+                  (show model)++              monitorGeometry <- Gdk.monitorGetGeometry m+              monitorWidth <- Gdk.getRectangleWidth monitorGeometry+              monitorHeight <- Gdk.getRectangleHeight monitorGeometry+              let availableWidth = monitorWidth - (2 * xpadding)+                  availableHeight = monitorHeight - (2 * ypadding)+                  width =+                    case widthSize of+                      ExactSize w -> w+                      ScreenRatio p ->+                        floor $ p * fromIntegral availableWidth+                  height =+                    case heightSize of+                      ExactSize h -> h+                      ScreenRatio p ->+                        floor $ p * fromIntegral availableHeight+                  clampNonNegative x = if x < 0 then 0 else x+                  centerOffset availSize size =+                    clampNonNegative $ (availSize - size) `div` 2+                  endOffset availSize size =+                    clampNonNegative $ availSize - size++                  (leftMargin, rightMargin, topMargin, bottomMargin) =+                    case position of+                      TopPos ->+                        let offset =+                              if width >= availableWidth+                                then 0+                                else case alignment of+                                  Beginning -> 0+                                  Center -> centerOffset availableWidth width+                                  End -> endOffset availableWidth width+                            l = xpadding + offset+                            r = xpadding+                         in (l, r, ypadding, ypadding)+                      BottomPos ->+                        let offset =+                              if width >= availableWidth+                                then 0+                                else case alignment of+                                  Beginning -> 0+                                  Center -> centerOffset availableWidth width+                                  End -> endOffset availableWidth width+                            l = xpadding + offset+                            r = xpadding+                         in (l, r, ypadding, ypadding)+                      LeftPos ->+                        let offset =+                              if height >= availableHeight+                                then 0+                                else case alignment of+                                  Beginning -> 0+                                  Center -> centerOffset availableHeight height+                                  End -> endOffset availableHeight height+                            t = ypadding + offset+                            b = ypadding+                         in (xpadding, xpadding, t, b)+                      RightPos ->+                        let offset =+                              if height >= availableHeight+                                then 0+                                else case alignment of+                                  Beginning -> 0+                                  Center -> centerOffset availableHeight height+                                  End -> endOffset availableHeight height+                            t = ypadding + offset+                            b = ypadding+                         in (xpadding, xpadding, t, b)++                  exclusive =+                    if reserveSpace+                      then case position of+                        TopPos -> height + topMargin+                        BottomPos -> height + bottomMargin+                        LeftPos -> width + leftMargin+                        RightPos -> width + rightMargin+                      else 0++              Gtk.windowSetDefaultSize window (fromIntegral width) (fromIntegral height)+              let (reqWidth, reqHeight) =+                    case position of+                      TopPos -> (min width availableWidth, height)+                      BottomPos -> (min width availableWidth, height)+                      LeftPos -> (width, min height availableHeight)+                      RightPos -> (width, min height availableHeight)+              Gtk.widgetSetSizeRequest+                window+                (fromIntegral reqWidth)+                (fromIntegral reqHeight)++              GtkLayerShell.setMargin window GtkLayerShell.EdgeLeft leftMargin+              GtkLayerShell.setMargin window GtkLayerShell.EdgeRight rightMargin+              GtkLayerShell.setMargin window GtkLayerShell.EdgeTop topMargin+              GtkLayerShell.setMargin window GtkLayerShell.EdgeBottom bottomMargin++              case position of+                TopPos -> do+                  setAnchor GtkLayerShell.EdgeTop True+                  setAnchor GtkLayerShell.EdgeBottom False+                  if width >= availableWidth+                    then do+                      setAnchor GtkLayerShell.EdgeLeft True+                      setAnchor GtkLayerShell.EdgeRight True+                    else case alignment of+                      Beginning -> do+                        setAnchor GtkLayerShell.EdgeLeft True+                        setAnchor GtkLayerShell.EdgeRight False+                      Center -> do+                        setAnchor GtkLayerShell.EdgeLeft True+                        setAnchor GtkLayerShell.EdgeRight False+                      End -> do+                        setAnchor GtkLayerShell.EdgeLeft False+                        setAnchor GtkLayerShell.EdgeRight True+                BottomPos -> do+                  setAnchor GtkLayerShell.EdgeTop False+                  setAnchor GtkLayerShell.EdgeBottom True+                  if width >= availableWidth+                    then do+                      setAnchor GtkLayerShell.EdgeLeft True+                      setAnchor GtkLayerShell.EdgeRight True+                    else case alignment of+                      Beginning -> do+                        setAnchor GtkLayerShell.EdgeLeft True+                        setAnchor GtkLayerShell.EdgeRight False+                      Center -> do+                        setAnchor GtkLayerShell.EdgeLeft True+                        setAnchor GtkLayerShell.EdgeRight False+                      End -> do+                        setAnchor GtkLayerShell.EdgeLeft False+                        setAnchor GtkLayerShell.EdgeRight True+                LeftPos -> do+                  setAnchor GtkLayerShell.EdgeLeft True+                  setAnchor GtkLayerShell.EdgeRight False+                  if height >= availableHeight+                    then do+                      setAnchor GtkLayerShell.EdgeTop True+                      setAnchor GtkLayerShell.EdgeBottom True+                    else case alignment of+                      Beginning -> do+                        setAnchor GtkLayerShell.EdgeTop True+                        setAnchor GtkLayerShell.EdgeBottom False+                      Center -> do+                        setAnchor GtkLayerShell.EdgeTop True+                        setAnchor GtkLayerShell.EdgeBottom False+                      End -> do+                        setAnchor GtkLayerShell.EdgeTop False+                        setAnchor GtkLayerShell.EdgeBottom True+                RightPos -> do+                  setAnchor GtkLayerShell.EdgeLeft False+                  setAnchor GtkLayerShell.EdgeRight True+                  if height >= availableHeight+                    then do+                      setAnchor GtkLayerShell.EdgeTop True+                      setAnchor GtkLayerShell.EdgeBottom True+                    else case alignment of+                      Beginning -> do+                        setAnchor GtkLayerShell.EdgeTop True+                        setAnchor GtkLayerShell.EdgeBottom False+                      Center -> do+                        setAnchor GtkLayerShell.EdgeTop True+                        setAnchor GtkLayerShell.EdgeBottom False+                      End -> do+                        setAnchor GtkLayerShell.EdgeTop False+                        setAnchor GtkLayerShell.EdgeBottom True++              GtkLayerShell.setExclusiveZone window exclusive++positionP :: Parser StrutPosition+positionP =+  fromMaybe TopPos+    <$> optional+      ( flag'+          TopPos+          ( long "top"+              <> help "Position the bar at the top of the screen"+          )+          <|> flag'+            BottomPos+            ( long "bottom"+                <> help "Position the bar at the bottom of the screen"+            )+          <|> flag'+            LeftPos+            ( long "left"+                <> help "Position the bar on the left side of the screen"+            )+          <|> flag'+            RightPos+            ( long "right"+                <> help "Position the bar on the right side of the screen"+            )+      )++alignmentP :: Parser StrutAlignment+alignmentP =+  fromMaybe Center+    <$> optional+      ( flag'+          Beginning+          ( long "beginning"+              <> help "Use beginning alignment"+          )+          <|> flag'+            Center+            ( long "center"+                <> help "Use center alignment"+            )+          <|> flag'+            End+            ( long "end"+                <> help "Use end alignment"+            )+      )++sizeP :: Parser Int32+sizeP =+  option+    auto+    ( long "size"+        <> short 's'+        <> help "Set the size of the bar"+        <> value 30+        <> metavar "SIZE"+    )++paddingP :: Parser Int32+paddingP =+  option+    auto+    ( long "padding"+        <> short 'p'+        <> help "Set the padding of the bar"+        <> value 0+        <> metavar "PADDING"+    )++monitorNumberP :: Parser [Int32]+monitorNumberP =+  many $+    option+      auto+      ( long "monitor"+          <> short 'm'+          <> help "Display a tray bar on the given monitor"+          <> metavar "MONITOR"+      )++logP :: Parser Priority+logP =+  option+    auto+    ( long "log-level"+        <> short 'l'+        <> help "Set the log level"+        <> metavar "LEVEL"+        <> value WARNING+    )++colorP :: Parser (Maybe String)+colorP =+  optional $+    strOption+      ( long "color"+          <> short 'c'+          <> help "Set the background color of the tray; See https://developer.gnome.org/gdk3/stable/gdk3-RGBA-Colors.html#gdk-rgba-parse for acceptable values"+          <> metavar "COLOR"+      )++expandP :: Parser Bool+expandP =+  switch+    ( long "expand"+        <> help "Let icons expand into the space allocated to the tray"+        <> short 'e'+    )++centerIconsP :: Parser Bool+centerIconsP =+  switch+    ( long "center-icons"+        <> help "Center the tray icons within the bar"+    )++startWatcherP :: Parser Bool+startWatcherP =+  switch+    ( long "watcher"+        <> short 'w'+        <> help "Start a Watcher to handle SNI registration if one does not exist"+    )++noStrutP :: Parser Bool+noStrutP =+  switch+    ( long "no-strut"+        <> help "Do not reserve space for the window (X11: no strut; Wayland: exclusive zone 0)"+    )++barLengthP :: Parser Rational+barLengthP =+  option+    auto+    ( long "length"+        <> help "Set the proportion of the screen that the tray bar should occupy -- values are parsed as haskell rationals (e.g. 1 % 2)"+        <> value 1+    )++overlayScaleP :: Parser Rational+overlayScaleP =+  option+    auto+    ( long "overlay-scale"+        <> short 'o'+        <> help "The proportion of the tray icon's size that should be set for overlay icons."+        <> value (5 % 7)+    )++iconPreferenceP :: Parser TrayIconPreference+iconPreferenceP =+  option+    (eitherReader parsePref)+    ( long "icon-preference"+        <> help "Icon preference when both are provided: pixmaps (default) | themed"+        <> value PreferPixmaps+        <> metavar "PREFERENCE"+    )+  where+    parsePref s =+      case map toLower s of+        "pixmaps" -> Right PreferPixmaps+        "pixmap" -> Right PreferPixmaps+        "themed" -> Right PreferThemedIcons+        "theme" -> Right PreferThemedIcons+        _ -> Left "expected one of: pixmaps, themed"++iconRecolorModeP :: Parser IconRecolorMode+iconRecolorModeP =+  option+    (eitherReader parseMode)+    ( long "icon-recolor"+        <> help "Recolor icons based on their alpha mask: none (default) | mono | duotone"+        <> value IconRecolorNone+        <> metavar "MODE"+    )+  where+    parseMode s =+      case map toLower s of+        "none" -> Right IconRecolorNone+        "mono" -> Right IconRecolorMono+        "duo" -> Right IconRecolorDuotone+        "duotone" -> Right IconRecolorDuotone+        _ -> Left "expected one of: none, mono, duotone"++menuBackendP :: Parser MenuBackend+menuBackendP =+  option+    (eitherReader parseMenuBackend)+    ( long "menu-backend"+        <> help "Menu backend: haskell (default) | libdbusmenu"+        <> value HaskellDBusMenu+        <> metavar "BACKEND"+    )+  where+    parseMenuBackend s =+      case map toLower s of+        "libdbusmenu" -> Right LibDBusMenu+        "haskell" -> Right HaskellDBusMenu+        _ -> Left "expected one of: libdbusmenu, haskell"++getColor :: String -> IO Gdk.RGBA+getColor colorString = do+  rgba <- Gdk.newZeroRGBA+  colorParsed <- Gdk.rGBAParse rgba (T.pack colorString)+  unless colorParsed $ do+    logM "StatusNotifier.Tray" WARNING "Failed to parse provided color"+    void $ Gdk.rGBAParse rgba "#000000"+  return rgba++buildWindows ::+  StrutPosition ->+  StrutAlignment ->+  Int32 ->+  Int32 ->+  [Int32] ->+  Priority ->+  BackendChoice ->+  Maybe String ->+  Bool ->+  Bool ->+  Bool ->+  Bool ->+  Rational ->+  Rational ->+  MenuBackend ->+  TrayIconPreference ->+  IconRecolorMode ->+  IO ()+buildWindows+  pos+  align+  size+  padding+  monitors+  priority+  backendChoice+  maybeColorString+  expand+  centerIcons+  startWatcher+  noStrut+  barLength+  overlayScale+  menuBackend+  iconPreference+  iconRecolorMode = do+    _ <- Gtk.init Nothing+    logger <- getLogger "StatusNotifier"+    saveGlobalLogger $ setLevel priority logger+    detectedBackend <- detectBackend+    let backend =+          case backendChoice of+            BackendAuto -> detectedBackend+            BackendX11Choice -> BackendX11+            BackendWaylandChoice -> BackendWayland+    client <- connectSession+    logRuntimeInfo backendChoice backend+    watcherPresent <- hasStatusNotifierWatcher client+    unless watcherPresent $ do+      logM "StatusNotifier" WARNING $+        "No StatusNotifierWatcher found on D-Bus (org.kde.StatusNotifierWatcher). Tray will likely be empty."+      unless startWatcher $+        logM "StatusNotifier" WARNING $+          "Start a watcher first (recommended) or run with --watcher to start one in-process."+    _ <- getRootLogger+    pid <- getProcessID+    host <-+      Host.build+        Host.defaultParams+          { Host.dbusClient = Just client,+            Host.uniqueIdentifier = printf "standalone-%s" $ show pid,+            Host.startWatcher = startWatcher+          }+        >>= maybe (logM "StatusNotifier" ERROR "Failed to start StatusNotifier host" >> exitFailure) pure+    initialItems <- Host.itemInfoMap host+    logM "StatusNotifier" INFO $ printf "Initial tray items: %d" (Map.size initialItems)+    let c1 =+          defaultStrutConfig+            { strutPosition = pos,+              strutAlignment = align,+              strutXPadding = padding,+              strutYPadding = padding+            }+        defaultRatio = ScreenRatio barLength+        configBase =+          case pos of+            TopPos -> c1 {strutHeight = ExactSize size, strutWidth = defaultRatio}+            BottomPos ->+              c1 {strutHeight = ExactSize size, strutWidth = defaultRatio}+            RightPos ->+              c1 {strutHeight = defaultRatio, strutWidth = ExactSize size}+            LeftPos ->+              c1 {strutHeight = defaultRatio, strutWidth = ExactSize size}+        buildWithConfig config = do+          let orientation =+                case strutPosition config of+                  TopPos -> Gtk.OrientationHorizontal+                  BottomPos -> Gtk.OrientationHorizontal+                  _ -> Gtk.OrientationVertical+              mixWord8 t a b =+                let ta = fromIntegral a :: Double+                    tb = fromIntegral b :: Double+                    out = ta + max 0 (min 1 t) * (tb - ta)+                 in fromIntegral (max (0 :: Int) (min 255 (round out)))+              mixRgb8 t (IconPixbuf.Rgb8 r g b) (IconPixbuf.Rgb8 r2 g2 b2) =+                IconPixbuf.Rgb8 (mixWord8 t r r2) (mixWord8 t g g2) (mixWord8 t b b2)+              mkIconTransform =+                case iconRecolorMode of+                  IconRecolorNone -> Nothing+                  IconRecolorMono ->+                    Just $ \image pb -> do+                      ctx <- Gtk.widgetGetStyleContext image+                      fg <- Gtk.styleContextGetColor ctx [Gtk.StateFlagsNormal]+                      fg8 <- IconPixbuf.rgb8FromGdkRGBA fg+                      mpb <- IconPixbuf.recolorPixbufMonochrome fg8 pb+                      return $ fromMaybe pb mpb+                  IconRecolorDuotone ->+                    Just $ \image pb -> do+                      ctx <- Gtk.widgetGetStyleContext image+                      fg <- Gtk.styleContextGetColor ctx [Gtk.StateFlagsNormal]+                      fg8 <- IconPixbuf.rgb8FromGdkRGBA fg+                      let black = IconPixbuf.Rgb8 0 0 0+                          white = IconPixbuf.Rgb8 255 255 255+                          dark = mixRgb8 0.35 fg8 black+                          light = mixRgb8 0.35 fg8 white+                      mpb <- IconPixbuf.recolorPixbufDuotone dark light pb+                      return $ fromMaybe pb mpb+          tray <-+            buildTray+              host+              client+              TrayParams+                { trayOrientation = orientation,+                  trayImageSize = Expand,+                  trayIconExpand = expand,+                  trayIconPreference = iconPreference,+                  trayAlignment = align,+                  trayOverlayScale = overlayScale,+                  trayLeftClickAction = Activate,+                  trayMiddleClickAction = SecondaryActivate,+                  trayRightClickAction = PopupMenu,+                  trayMenuBackend = menuBackend,+                  trayCenterIcons = centerIcons,+                  trayPriorityConfig = defaultTrayPriorityConfig,+                  trayPixbufTransform = mkIconTransform,+                  trayEventHooks = defaultTrayEventHooks+                }+          window <- Gtk.windowNew Gtk.WindowTypeToplevel+          Gtk.windowSetResizable window False+          Gtk.windowSetSkipTaskbarHint window True+          Gtk.windowSetSkipPagerHint window True+          Gtk.windowSetAcceptFocus window False+          Gtk.windowSetFocusOnMap window False+          Gtk.windowSetKeepAbove window True+          Gtk.windowSetTypeHint window Gdk.WindowTypeHintDock+          case backend of+            BackendX11 ->+              when (not noStrut) $ setupStrutWindow config window+            BackendWayland ->+              setupLayerShellWindow config window (not noStrut)+          maybe+            (makeWindowTransparent window)+            ( getColor+                >=> Gtk.widgetOverrideBackgroundColor window [Gtk.StateFlagsNormal]+                  . Just+            )+            maybeColorString+          Gtk.containerAdd window tray+          Gtk.widgetShowAll window+        runForMonitor monitor =+          buildWithConfig configBase {strutMonitor = Just monitor}+    if null monitors+      then buildWithConfig configBase+      else mapM_ runForMonitor monitors+    Gtk.main++parser :: Parser (IO ())+parser =+  buildWindows+    <$> positionP+    <*> alignmentP+    <*> sizeP+    <*> paddingP+    <*> monitorNumberP+    <*> logP+    <*> backendChoiceP+    <*> colorP+    <*> expandP+    <*> centerIconsP+    <*> startWatcherP+    <*> noStrutP+    <*> barLengthP+    <*> overlayScaleP+    <*> menuBackendP+    <*> iconPreferenceP+    <*> iconRecolorModeP++versionOption :: Parser (a -> a)+versionOption =+  infoOption+    (printf "gtk-sni-tray-standalone %s" $ showVersion version)+    ( long "version"+        <> help "Show the version number of gtk-sni-tray"+    )++main :: IO ()+main =+  join $+    execParser $+      info+        (helper <*> versionOption <*> parser)+        ( fullDesc+            <> progDesc "Run a standalone StatusNotifierItem/AppIndicator tray"+        )

@@ -5,7 +5,7 @@ -- see: https://github.com/sol/hpack  name:           gtk-sni-tray-version:        0.1.15.0+version:        0.2.0.0 synopsis:       A standalone StatusNotifierItem/AppIndicator tray description:    Please see the README on Github at <https://github.com/IvanMalison/gtk-sni-tray#readme> category:       System

@@ -1,873 +1,993 @@-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE OverloadedLabels #-}-{-# LANGUAGE CPP #-}-module StatusNotifier.Tray where--import           Control.Concurrent.MVar as MV-import           Data.IORef (newIORef, readIORef, writeIORef)-import           Control.Exception.Base-import           Control.Exception.Enclosed (catchAny)-import           Control.Monad-import           Control.Monad.Trans.Class-import           Control.Monad.Trans.Maybe-import           DBus.Client-import qualified DBus.Internal.Types as DBusTypes-import           Data.Bool (bool)-import qualified Data.ByteString as BS-import           Data.Coerce-import           Data.Foldable (traverse_)-import           Data.GI.Base (unsafeCastTo)-import           Data.GI.Base.GError-import           Data.Int-import           Data.List-import qualified Data.Map.Strict as Map-import           Data.Maybe-import           Data.Ord-import           Data.Ratio-import qualified Data.Text as T-import qualified GI.DbusmenuGtk3.Objects.Menu as DM-import qualified GI.GLib as GLib-import           GI.GLib.Structs.Bytes-import qualified GI.Gdk as Gdk-import           GI.Gdk.Enums-import           GI.Gdk.Structs.EventScroll-import           GI.GdkPixbuf.Enums-import           GI.GdkPixbuf.Objects.Pixbuf as Gdk-import qualified GI.Gtk as Gtk-import           GI.Gtk.Flags-import           GI.Gtk.Objects.IconTheme-import           Graphics.UI.GIGtkStrut-import qualified DBusMenu-import           StatusNotifier.Host.Service-import qualified StatusNotifier.Item.Client as IC-import           System.Directory-import           System.FilePath-import           System.Log.Logger-import           Text.Printf-import           Foreign.Ptr (Ptr)--trayLogger :: Priority -> String -> IO ()-trayLogger = logM "StatusNotifier.Tray"---- | Optional post-processing hook for item icons. This is applied after scaling--- and overlay composition.-type PixbufTransform = Gtk.Image -> Pixbuf -> IO Pixbuf--logItemInfo :: ItemInfo -> String -> IO ()-logItemInfo info message =-  trayLogger INFO $ printf "%s - %s pixmap count: %s" message-         (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]--getThemeWithOptionalSearchPath :: Maybe String -> IO IconTheme-getThemeWithOptionalSearchPath themePath = do-  theme <- iconThemeGetDefault-  forM_ (themePath >>= nonEmpty) $ \p -> do-    -- Respect the user's configured icon theme by using GTK's default theme-    -- object, but include any item-provided IconThemePath as an additional-    -- search path.-    ---    -- Some items provide IconThemePath pointing inside a theme dir, e.g.:-    --   .../Papirus/64x64/mimetypes-    -- GTK expects search paths that contain theme directories, so also try to-    -- append the parent directory of any ancestor that contains index.theme.-    pathsToAppend <- pathsForIconThemePath p-    existing <- iconThemeGetSearchPath theme-    forM_ pathsToAppend $ \p' ->-      unless (p' `elem` existing) $ iconThemeAppendSearchPath theme p'-  return theme-  where-    nonEmpty "" = Nothing-    nonEmpty x = Just x--pathsForIconThemePath :: FilePath -> IO [FilePath]-pathsForIconThemePath rawPath = do-  mThemeDir <- findAncestorWithIndexTheme 8 rawPath-  let base =-        case mThemeDir of-          Nothing -> []-          Just themeDir -> [takeDirectory themeDir]-  return $ nub $ base ++ [rawPath]-  where-    findAncestorWithIndexTheme :: Int -> FilePath -> IO (Maybe FilePath)-    findAncestorWithIndexTheme 0 _ = return Nothing-    findAncestorWithIndexTheme n p = do-      hasIndex <- doesFileExist (p </> "index.theme")-      if hasIndex-        then return (Just p)-        else do-          let parent = takeDirectory p-          if parent == p-            then return Nothing-            else findAncestorWithIndexTheme (n - 1) parent--catchGErrorsAsLeft :: IO a -> IO (Either GError a)-catchGErrorsAsLeft action = catch (Right <$> action) (return . Left)--catchGErrorsAsNothing :: IO a -> IO (Maybe a)-catchGErrorsAsNothing action = catchGErrorsAsLeft action >>= rightToJustLogLeft-       where rightToJustLogLeft (Right value) = return $ Just value-             rightToJustLogLeft (Left err) = do-               trayLogger WARNING $ printf "Encountered error: %s" $ show err-               return Nothing--safePixbufNewFromFile :: FilePath -> IO (Maybe Gdk.Pixbuf)-safePixbufNewFromFile =-  handleResult . catchGErrorsAsNothing . Gdk.pixbufNewFromFile-  where-#if MIN_VERSION_gi_gdkpixbuf(2,0,26)-    handleResult = fmap join-#else-    handleResult = id-#endif--getIconPixbufByName :: Int32 -> T.Text -> Maybe String -> IO (Maybe Pixbuf)-getIconPixbufByName size name themePath = do-  trayLogger DEBUG $ printf "Getting Pixbuf from name for %s" name-  themeForIcon <- getThemeWithOptionalSearchPath themePath--  let panelName = T.pack $ printf "%s-panel" name-  -- Avoid relying on iconThemeHasIcon: it can be overly strict when fallback-  -- loading is enabled. Just try to load and fall back if it fails.-  let tryLoad :: T.Text -> IO (Maybe Pixbuf)-      tryLoad iconName =-        catchAny (iconThemeLoadIcon themeForIcon iconName size themeLoadFlags)-                 (const $ pure Nothing)--  themedPixbuf <- do-    pbPanel <- tryLoad panelName-    case pbPanel of-      Just _ -> return pbPanel-      Nothing -> tryLoad name--  case themedPixbuf of-    Just _ -> return themedPixbuf-    Nothing -> do-      trayLogger DEBUG $ printf "Trying to load icon %s as filepath" name-      -- Try to load the icon as a filepath-      let nameString = T.unpack name-      fileExists <- doesFileExist nameString-      maybeFile <- if fileExists-      then return $ Just nameString-      else fmap join $ sequenceA $ getIconPathFromThemePath nameString <$> themePath-#if MIN_VERSION_gi_gdkpixbuf(2,0,26)-      let handleResult = fmap join . sequenceA-#else-      let handleResult = sequenceA-#endif-      handleResult $ safePixbufNewFromFile <$> maybeFile--getIconPathFromThemePath :: String -> String -> IO (Maybe String)-getIconPathFromThemePath name themePath = if name == "" then return Nothing else do-  trayLogger DEBUG $ printf-    "Trying to load icon %s as filepath with theme path %s"-    name themePath-  pathExists <- doesDirectoryExist themePath-  if pathExists-  then do-    fileNames <- catchAny (listDirectory themePath) (const $ return [])-    trayLogger DEBUG $ printf-      "Found files in theme path %s" (show fileNames)-    return $ (themePath </>) <$> find (isPrefixOf name) fileNames-  else return Nothing--getIconPixbufFromByteString :: Int32 -> Int32 -> BS.ByteString -> IO (Maybe Pixbuf)-getIconPixbufFromByteString width height byteString-  | width <= 0 || height <= 0 = do-      trayLogger WARNING $ printf "Invalid icon dimensions: %dx%d" width height-      return Nothing-  | otherwise = catchGErrorsAsNothing $ do-      trayLogger DEBUG "Getting Pixbuf from bytestring"-      bytes <- bytesNew $ Just byteString-      let bytesPerPixel = 4-          rowStride = width * bytesPerPixel-          sampleBits = 8-      pixbufNewFromBytes bytes ColorspaceRgb True sampleBits width height rowStride--data ItemContext = ItemContext-  { contextName :: DBusTypes.BusName-  , contextMenuPath :: Maybe DBusTypes.ObjectPath-  , contextImage :: Gtk.Image-  , contextButton :: Gtk.EventBox-  }--data TrayImageSize = Expand | TrayImageSize Int32--data TrayClickAction = Activate | SecondaryActivate | PopupMenu--data MenuBackend = LibDBusMenu | HaskellDBusMenu deriving (Eq, Show)--data TrayItemMatcher = TrayItemMatcher-  { trayItemMatcherDescription :: String-  , trayItemMatcherPredicate :: ItemInfo -> Bool-  }--data TrayPriorityConfig = TrayPriorityConfig-  { trayPriorityMatchers :: [TrayItemMatcher]-  }--defaultTrayPriorityConfig :: TrayPriorityConfig-defaultTrayPriorityConfig = TrayPriorityConfig { trayPriorityMatchers = [] }--mkTrayItemMatcher :: String -> (ItemInfo -> Bool) -> TrayItemMatcher-mkTrayItemMatcher = TrayItemMatcher--trayMatchAny :: [TrayItemMatcher] -> TrayItemMatcher-trayMatchAny matchers = mkTrayItemMatcher "any" $ \info ->-  any (\matcher -> trayItemMatcherPredicate matcher info) matchers--trayMatchAll :: [TrayItemMatcher] -> TrayItemMatcher-trayMatchAll matchers = mkTrayItemMatcher "all" $ \info ->-  all (\matcher -> trayItemMatcherPredicate matcher info) matchers--trayMatchNot :: TrayItemMatcher -> TrayItemMatcher-trayMatchNot matcher =-  mkTrayItemMatcher ("not(" <> trayItemMatcherDescription matcher <> ")") $-    not . trayItemMatcherPredicate matcher--normalizeText :: T.Text -> T.Text-normalizeText = T.toCaseFold--containsCI :: T.Text -> T.Text -> Bool-containsCI needle haystack =-  normalizeText needle `T.isInfixOf` normalizeText haystack--equalsCI :: T.Text -> T.Text -> Bool-equalsCI left right = normalizeText left == normalizeText right--matchOnTextFields ::-  String ->-  (T.Text -> T.Text -> Bool) ->-  [ItemInfo -> Maybe T.Text] ->-  T.Text ->-  TrayItemMatcher-matchOnTextFields matcherName comparator fieldGetters target =-  mkTrayItemMatcher matcherName $ \info ->-    any-      (\fieldGetter -> maybe False (comparator target) (fieldGetter info))-      fieldGetters--serviceNameText :: ItemInfo -> T.Text-serviceNameText = T.pack . (coerce :: DBusTypes.BusName -> String) . itemServiceName--servicePathText :: ItemInfo -> T.Text-servicePathText = T.pack . (coerce :: DBusTypes.ObjectPath -> String) . itemServicePath--menuPathText :: ItemInfo -> Maybe T.Text-menuPathText = fmap (T.pack . (coerce :: DBusTypes.ObjectPath -> String)) . menuPath--itemIdText :: ItemInfo -> Maybe T.Text-itemIdText = fmap T.pack . itemId--itemCategoryText :: ItemInfo -> Maybe T.Text-itemCategoryText = fmap T.pack . itemCategory--itemStatusText :: ItemInfo -> Maybe T.Text-itemStatusText = fmap T.pack . itemStatus--iconNameText :: ItemInfo -> T.Text-iconNameText = T.pack . iconName--iconTitleText :: ItemInfo -> T.Text-iconTitleText = T.pack . iconTitle--tooltipTitleText :: ItemInfo -> Maybe T.Text-tooltipTitleText info = (\(_, _, titleText, _) -> T.pack titleText) <$> itemToolTip info--tooltipBodyText :: ItemInfo -> Maybe T.Text-tooltipBodyText info = (\(_, _, _, bodyText) -> T.pack bodyText) <$> itemToolTip info--trayMatchServiceNameContains :: T.Text -> TrayItemMatcher-trayMatchServiceNameContains =-  matchOnTextFields "service-name-contains" containsCI [Just . serviceNameText]--trayMatchServiceNameEquals :: T.Text -> TrayItemMatcher-trayMatchServiceNameEquals =-  matchOnTextFields "service-name-equals" equalsCI [Just . serviceNameText]--trayMatchServicePathContains :: T.Text -> TrayItemMatcher-trayMatchServicePathContains =-  matchOnTextFields "service-path-contains" containsCI [Just . servicePathText]--trayMatchServicePathEquals :: T.Text -> TrayItemMatcher-trayMatchServicePathEquals =-  matchOnTextFields "service-path-equals" equalsCI [Just . servicePathText]--trayMatchMenuPathContains :: T.Text -> TrayItemMatcher-trayMatchMenuPathContains =-  matchOnTextFields "menu-path-contains" containsCI [menuPathText]--trayMatchMenuPathEquals :: T.Text -> TrayItemMatcher-trayMatchMenuPathEquals =-  matchOnTextFields "menu-path-equals" equalsCI [menuPathText]--trayMatchItemIdContains :: T.Text -> TrayItemMatcher-trayMatchItemIdContains =-  matchOnTextFields "item-id-contains" containsCI [itemIdText]--trayMatchItemIdEquals :: T.Text -> TrayItemMatcher-trayMatchItemIdEquals =-  matchOnTextFields "item-id-equals" equalsCI [itemIdText]--trayMatchItemCategoryContains :: T.Text -> TrayItemMatcher-trayMatchItemCategoryContains =-  matchOnTextFields "item-category-contains" containsCI [itemCategoryText]--trayMatchItemCategoryEquals :: T.Text -> TrayItemMatcher-trayMatchItemCategoryEquals =-  matchOnTextFields "item-category-equals" equalsCI [itemCategoryText]--trayMatchStatusContains :: T.Text -> TrayItemMatcher-trayMatchStatusContains =-  matchOnTextFields "item-status-contains" containsCI [itemStatusText]--trayMatchStatusEquals :: T.Text -> TrayItemMatcher-trayMatchStatusEquals =-  matchOnTextFields "item-status-equals" equalsCI [itemStatusText]--trayMatchIconNameContains :: T.Text -> TrayItemMatcher-trayMatchIconNameContains =-  matchOnTextFields "icon-name-contains" containsCI [Just . iconNameText]--trayMatchIconNameEquals :: T.Text -> TrayItemMatcher-trayMatchIconNameEquals =-  matchOnTextFields "icon-name-equals" equalsCI [Just . iconNameText]--trayMatchIconTitleContains :: T.Text -> TrayItemMatcher-trayMatchIconTitleContains =-  matchOnTextFields "icon-title-contains" containsCI [Just . iconTitleText]--trayMatchIconTitleEquals :: T.Text -> TrayItemMatcher-trayMatchIconTitleEquals =-  matchOnTextFields "icon-title-equals" equalsCI [Just . iconTitleText]--trayMatchTooltipContains :: T.Text -> TrayItemMatcher-trayMatchTooltipContains =-  matchOnTextFields "tooltip-contains" containsCI [tooltipTitleText, tooltipBodyText]--trayMatchTooltipEquals :: T.Text -> TrayItemMatcher-trayMatchTooltipEquals =-  matchOnTextFields "tooltip-equals" equalsCI [tooltipTitleText, tooltipBodyText]--trayMatchAnyTextContains :: T.Text -> TrayItemMatcher-trayMatchAnyTextContains =-  matchOnTextFields-    "any-text-contains"-    containsCI-    [ Just . serviceNameText-    , Just . servicePathText-    , menuPathText-    , itemIdText-    , itemCategoryText-    , itemStatusText-    , Just . iconNameText-    , Just . iconTitleText-    , tooltipTitleText-    , tooltipBodyText-    ]--trayMatchIsMenu :: Bool -> TrayItemMatcher-trayMatchIsMenu expected =-  mkTrayItemMatcher "is-menu" $ \info -> itemIsMenu info == expected---- | Controls whether to prefer application-provided pixmaps or themed icons--- when both are present. Some items provide both.-data TrayIconPreference-  = PreferPixmaps-  | PreferThemedIcons-  deriving (Eq, Show, Read)--data TrayParams = TrayParams-  { trayOrientation :: Gtk.Orientation-  , trayImageSize :: TrayImageSize-  , trayIconExpand :: Bool-  , trayIconPreference :: TrayIconPreference-  , trayAlignment :: StrutAlignment-  , trayOverlayScale :: Rational-  , trayLeftClickAction :: TrayClickAction-  , trayMiddleClickAction :: TrayClickAction-  , trayRightClickAction :: TrayClickAction-  , trayMenuBackend :: MenuBackend-  , trayCenterIcons :: Bool-  }--defaultTrayParams :: TrayParams-defaultTrayParams = TrayParams-  { trayOrientation = Gtk.OrientationHorizontal-  , trayImageSize = Expand-  , trayIconExpand = False-  , trayIconPreference = PreferPixmaps-  , trayAlignment = End-  , trayOverlayScale = 2 % 5-  , trayLeftClickAction = Activate-  , trayMiddleClickAction = SecondaryActivate-  , trayRightClickAction = PopupMenu-  , trayMenuBackend = HaskellDBusMenu-  , trayCenterIcons = False-  }--buildTray :: Host -> Client -> TrayParams -> IO Gtk.Box-buildTray host client params =-  buildTrayWithPixbufTransform host client params Nothing--buildTrayWithPriority :: Host -> Client -> TrayParams -> TrayPriorityConfig -> IO Gtk.Box-buildTrayWithPriority host client params priorityConfig =-  buildTrayWithPriorityAndPixbufTransform host client params priorityConfig Nothing--buildTrayWithPixbufTransform :: Host -> Client -> TrayParams -> Maybe PixbufTransform -> IO Gtk.Box-buildTrayWithPixbufTransform host client params mTransform =-  buildTrayWithPriorityAndPixbufTransform host client params defaultTrayPriorityConfig mTransform--buildTrayWithPriorityAndPixbufTransform :: Host -> Client -> TrayParams -> TrayPriorityConfig -> Maybe PixbufTransform -> IO Gtk.Box-buildTrayWithPriorityAndPixbufTransform Host-            { itemInfoMap = getInfoMap-            , addUpdateHandler = addUHandler-            , removeUpdateHandler = removeUHandler-            }-          client-          TrayParams { trayOrientation = orientation-                     , trayImageSize = imageSize-                     , trayIconExpand = shouldExpand-                     , trayIconPreference = iconPreference-                     , trayAlignment = alignment-                     , trayOverlayScale = overlayScale-                     , trayLeftClickAction = leftClickAction-                     , trayMiddleClickAction = middleClickAction-                     , trayRightClickAction = rightClickAction-                     , trayMenuBackend = menuBackend-                     , trayCenterIcons = centerIcons-                     }-          TrayPriorityConfig { trayPriorityMatchers = priorityMatchers }-          mTransform = do-  trayLogger INFO "Building tray"--  trayBox <- Gtk.boxNew orientation 0-  when centerIcons $ case orientation of-    Gtk.OrientationHorizontal -> Gtk.widgetSetHalign trayBox Gtk.AlignCenter-    _ -> Gtk.widgetSetValign trayBox Gtk.AlignCenter-  Gtk.widgetGetStyleContext trayBox >>=-    flip Gtk.styleContextAddClass "tray-box"-  contextMap <- MV.newMVar Map.empty--  let getContext name = Map.lookup 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-      getInfo = getInfoAttr id--      getPriorityIndex info =-        fromMaybe-          (length priorityMatchers)-          (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)--      applyTransform :: Gtk.Image -> Maybe Pixbuf -> IO (Maybe Pixbuf)-      applyTransform _ Nothing = return Nothing-      applyTransform image (Just pb) =-        case mTransform of-          Nothing -> return (Just pb)-          Just f -> Just <$> f image 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--      getTooltipText ItemInfo { itemToolTip = Just (_, _, titleText, fullText )}-        | titleText == fullText = fullText-        | titleText == "" = fullText-        | fullText == "" = titleText-        | otherwise = printf "%s: %s" titleText fullText-      getTooltipText _ = ""--      setTooltipText widget info =-        Gtk.widgetSetTooltipText widget $ Just $ T.pack $ getTooltipText info--      updateHandler ItemAdded-                    info@ItemInfo { menuPath = pathForMenu-                                  , itemServiceName = serviceName-                                  , 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 $-                                 printf-                                 ("Allocating image size %s, width %s," <>-                                  " height %s, resize %s")-                                 (show size)-                                 (show actualWidth)-                                 (show actualHeight)-                                 (show requestResize)--                      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)--              _ <- Gtk.onWidgetSizeAllocate image setPixbuf-              return ()-            TrayImageSize size -> do-              pixBuf0 <- getScaledPixBufFromInfo size info-              pixBuf <- applyTransform image pixBuf0-              Gtk.imageSetFromPixbuf image pixBuf--          Gtk.widgetGetStyleContext image >>=-             flip Gtk.styleContextAddClass "tray-icon-image"--          Gtk.containerAdd eventBox image-          setTooltipText eventBox info--          let context =-                ItemContext { contextName = serviceName-                            , contextMenuPath = pathForMenu-                            , contextImage = image-                            , 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--          _ <- 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-            mouseButton <- Gdk.getEventButtonButton event-            x <- round <$> Gdk.getEventButtonXRoot event-            y <- round <$> Gdk.getEventButtonYRoot event-            action <- case mouseButton of-              1 -> bool leftClickAction PopupMenu <$> getInfoAttr-                   itemIsMenu True serviceName-              2 -> return middleClickAction-              _ -> return rightClickAction-            let logActionError actionName e =-                  trayLogger WARNING $ printf "%s failed for %s: %s"-                    (actionName :: String)-                    (coerce serviceName :: String)-                    (show e)-            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)-                (logActionError "SecondaryActivate")-              PopupMenu -> do-                menuPath' <- getInfoAttr menuPath Nothing serviceName-                traverse_-                  (\p -> 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)-                    (logActionError "PopupMenu"))-                  menuPath'-            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--          MV.modifyMVar_ contextMap $ return . Map.insert serviceName context--          Gtk.widgetShowAll eventBox-          let packFn =-                case alignment of-                  End -> Gtk.boxPackEnd-                  _ -> Gtk.boxPackStart--          packFn trayBox eventBox shouldExpand True 0--      updateHandler ItemRemoved ItemInfo { itemServiceName = name }-        = getContext name >>= removeWidget-        where removeWidget Nothing =-                trayLogger WARNING "removeWidget: unrecognized service name."-              removeWidget (Just ItemContext { contextButton = widgetToRemove }) =-                do-                  Gtk.containerRemove trayBox widgetToRemove-                  MV.modifyMVar_ contextMap $ return . Map.delete name--      updateHandler IconUpdated i = updateIconFromInfo i-      updateHandler OverlayIconUpdated i = updateIconFromInfo i--      updateHandler ToolTipUpdated info@ItemInfo { itemServiceName = name } =-        void $ getContext name >>=-             traverse (flip setTooltipText info . contextButton)--      updateHandler _ _ = return ()--      maybeAddOverlayToPixbuf size info pixbuf = do-        _ <- runMaybeT $ do-          let overlayHeight = floor (fromIntegral size * overlayScale)-          overlayPixbuf <--            MaybeT $ getOverlayPixBufFromInfo overlayHeight info >>=-            traverse (scalePixbufToSize overlayHeight Gtk.OrientationHorizontal)-          lift $ do-            actualOHeight <- getPixbufHeight overlayPixbuf-            actualOWidth <- getPixbufWidth overlayPixbuf-            _mainHeight <- getPixbufHeight pixbuf-            _mainWidth <- getPixbufWidth pixbuf-            pixbufComposite overlayPixbuf pixbuf-              0 0-              actualOWidth actualOHeight-              0 0-              1.0 1.0-              InterpTypeBilinear-              255-        return pixbuf--      getScaledPixBufFromInfo size info =-        getPixBufFromInfo size info >>=-        traverse (scalePixbufToSize size orientation >=>-                  maybeAddOverlayToPixbuf size info)--      getPixBufFromInfo size-                        ItemInfo { iconName = name-                                 , iconThemePath = mpath-                                 , iconPixmaps = pixmaps-                                 } = getPixBufFrom size name mpath pixmaps--      getOverlayPixBufFromInfo size-                               ItemInfo-                                     { overlayIconName = name-                                     , iconThemePath = mpath-                                     , overlayIconPixmaps = pixmaps-                                     } = getPixBufFrom size (fromMaybe "" name)-                               mpath pixmaps--      getPixBufFrom size name mpath pixmaps = do-        let tooSmall (w, h, _) = w < size || h < size-            largeEnough = filter (not . tooSmall) pixmaps-            orderer (w1, h1, _) (w2, h2, _) =-              case comparing id w1 w2 of-                EQ -> comparing id h1 h2-                a -> a-            selectedPixmap =-              if null largeEnough-              then maximumBy orderer pixmaps-              else minimumBy orderer largeEnough-            getFromPixmaps (w, h, p) =-              if BS.length p == 0-              then return Nothing-              else getIconPixbufFromByteString w h p-            getFromThemed =-              if name == ""-              then return Nothing-              else getIconPixbufByName size (T.pack name) mpath-            firstJustM a b = do-              ma <- a-              case ma of-                Just _ -> return ma-                Nothing -> b--        if null pixmaps-        then getIconPixbufByName size (T.pack name) mpath-        else case iconPreference of-               PreferThemedIcons ->-                 firstJustM getFromThemed (getFromPixmaps selectedPixmap)-               PreferPixmaps ->-                 firstJustM (getFromPixmaps selectedPixmap) getFromThemed--      uiUpdateHandler updateType info =-        void $ Gdk.threadsAddIdle GLib.PRIORITY_DEFAULT $-             catchAny-               (updateHandler updateType info-                >> reorderTrayByPriority-                >> return False)-               (\e -> do-                 trayLogger WARNING $ printf "Update handler failed: %s" (show e)-                 return False)--  handlerId <- addUHandler uiUpdateHandler-  _ <- Gtk.onWidgetDestroy trayBox $ removeUHandler handlerId-  return trayBox+{-# LANGUAGE CPP #-}+{-# LANGUAGE OverloadedLabels #-}+{-# LANGUAGE OverloadedStrings #-}++module StatusNotifier.Tray where++import Control.Concurrent.MVar as MV+import Control.Exception.Base+import Control.Exception.Enclosed (catchAny)+import Control.Monad+import Control.Monad.Trans.Class+import Control.Monad.Trans.Maybe+import DBus.Client+import qualified DBus.Internal.Types as DBusTypes+import qualified DBusMenu+import qualified Data.ByteString as BS+import Data.Coerce+import Data.Foldable (traverse_)+import Data.GI.Base (unsafeCastTo)+import Data.GI.Base.GError+import Data.IORef (newIORef, readIORef, writeIORef)+import Data.Int+import Data.List+import qualified Data.Map.Strict as Map+import Data.Maybe+import Data.Ord+import Data.Ratio+import qualified Data.Text as T+import Data.Word+import Foreign.Ptr (Ptr)+import qualified GI.DbusmenuGtk3.Objects.Menu as DM+import qualified GI.GLib as GLib+import GI.GLib.Structs.Bytes+import qualified GI.Gdk as Gdk+import GI.Gdk.Enums+import GI.Gdk.Structs.EventScroll+import GI.GdkPixbuf.Enums+import GI.GdkPixbuf.Objects.Pixbuf as Gdk+import qualified GI.Gtk as Gtk+import GI.Gtk.Flags+import GI.Gtk.Objects.IconTheme+import Graphics.UI.GIGtkStrut+import StatusNotifier.Host.Service+import qualified StatusNotifier.Item.Client as IC+import System.Directory+import System.FilePath+import System.Log.Logger+import Text.Printf++trayLogger :: Priority -> String -> IO ()+trayLogger = logM "StatusNotifier.Tray"++-- | Optional post-processing hook for item icons. This is applied after scaling+-- and overlay composition.+type PixbufTransform = Gtk.Image -> Pixbuf -> IO Pixbuf++logItemInfo :: ItemInfo -> String -> IO ()+logItemInfo info message =+  trayLogger INFO $+    printf+      "%s - %s pixmap count: %s"+      message+      (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]++getThemeWithOptionalSearchPath :: Maybe String -> IO IconTheme+getThemeWithOptionalSearchPath themePath = do+  theme <- iconThemeGetDefault+  forM_ (themePath >>= nonEmpty) $ \p -> do+    -- Respect the user's configured icon theme by using GTK's default theme+    -- object, but include any item-provided IconThemePath as an additional+    -- search path.+    --+    -- Some items provide IconThemePath pointing inside a theme dir, e.g.:+    --   .../Papirus/64x64/mimetypes+    -- GTK expects search paths that contain theme directories, so also try to+    -- append the parent directory of any ancestor that contains index.theme.+    pathsToAppend <- pathsForIconThemePath p+    existing <- iconThemeGetSearchPath theme+    forM_ pathsToAppend $ \p' ->+      unless (p' `elem` existing) $ iconThemeAppendSearchPath theme p'+  return theme+  where+    nonEmpty "" = Nothing+    nonEmpty x = Just x++pathsForIconThemePath :: FilePath -> IO [FilePath]+pathsForIconThemePath rawPath = do+  mThemeDir <- findAncestorWithIndexTheme 8 rawPath+  let base =+        case mThemeDir of+          Nothing -> []+          Just themeDir -> [takeDirectory themeDir]+  return $ nub $ base ++ [rawPath]+  where+    findAncestorWithIndexTheme :: Int -> FilePath -> IO (Maybe FilePath)+    findAncestorWithIndexTheme 0 _ = return Nothing+    findAncestorWithIndexTheme n p = do+      hasIndex <- doesFileExist (p </> "index.theme")+      if hasIndex+        then return (Just p)+        else do+          let parent = takeDirectory p+          if parent == p+            then return Nothing+            else findAncestorWithIndexTheme (n - 1) parent++catchGErrorsAsLeft :: IO a -> IO (Either GError a)+catchGErrorsAsLeft action = catch (Right <$> action) (return . Left)++catchGErrorsAsNothing :: IO a -> IO (Maybe a)+catchGErrorsAsNothing action = catchGErrorsAsLeft action >>= rightToJustLogLeft+  where+    rightToJustLogLeft (Right value) = return $ Just value+    rightToJustLogLeft (Left err) = do+      trayLogger WARNING $ printf "Encountered error: %s" $ show err+      return Nothing++safePixbufNewFromFile :: FilePath -> IO (Maybe Gdk.Pixbuf)+safePixbufNewFromFile =+  handleResult . catchGErrorsAsNothing . Gdk.pixbufNewFromFile+  where+#if MIN_VERSION_gi_gdkpixbuf(2,0,26)+    handleResult = fmap join+#else+    handleResult = id+#endif++getIconPixbufByName :: Int32 -> T.Text -> Maybe String -> IO (Maybe Pixbuf)+getIconPixbufByName size name themePath = do+  trayLogger DEBUG $ printf "Getting Pixbuf from name for %s" name+  themeForIcon <- getThemeWithOptionalSearchPath themePath++  let panelName = T.pack $ printf "%s-panel" name+  -- Avoid relying on iconThemeHasIcon: it can be overly strict when fallback+  -- loading is enabled. Just try to load and fall back if it fails.+  let tryLoad :: T.Text -> IO (Maybe Pixbuf)+      tryLoad iconName =+        catchAny+          (iconThemeLoadIcon themeForIcon iconName size themeLoadFlags)+          (const $ pure Nothing)++  themedPixbuf <- do+    pbPanel <- tryLoad panelName+    case pbPanel of+      Just _ -> return pbPanel+      Nothing -> tryLoad name++  case themedPixbuf of+    Just _ -> return themedPixbuf+    Nothing -> do+      trayLogger DEBUG $ printf "Trying to load icon %s as filepath" name+      -- Try to load the icon as a filepath+      let nameString = T.unpack name+      fileExists <- doesFileExist nameString+      maybeFile <-+        if fileExists+          then return $ Just nameString+          else fmap join $ sequenceA $ getIconPathFromThemePath nameString <$> themePath+      fmap join $ sequenceA $ safePixbufNewFromFile <$> maybeFile++getIconPathFromThemePath :: String -> String -> IO (Maybe String)+getIconPathFromThemePath name themePath =+  if name == ""+    then return Nothing+    else do+      trayLogger DEBUG $+        printf+          "Trying to load icon %s as filepath with theme path %s"+          name+          themePath+      pathExists <- doesDirectoryExist themePath+      if pathExists+        then do+          fileNames <- catchAny (listDirectory themePath) (const $ return [])+          trayLogger DEBUG $+            printf+              "Found files in theme path %s"+              (show fileNames)+          return $ (themePath </>) <$> find (isPrefixOf name) fileNames+        else return Nothing++getIconPixbufFromByteString :: Int32 -> Int32 -> BS.ByteString -> IO (Maybe Pixbuf)+getIconPixbufFromByteString width height byteString+  | width <= 0 || height <= 0 = do+      trayLogger WARNING $ printf "Invalid icon dimensions: %dx%d" width height+      return Nothing+  | otherwise = catchGErrorsAsNothing $ do+      trayLogger DEBUG "Getting Pixbuf from bytestring"+      bytes <- bytesNew $ Just byteString+      let bytesPerPixel = 4+          rowStride = width * bytesPerPixel+          sampleBits = 8+      pixbufNewFromBytes bytes ColorspaceRgb True sampleBits width height rowStride++data ItemContext = ItemContext+  { contextName :: DBusTypes.BusName,+    contextMenuPath :: Maybe DBusTypes.ObjectPath,+    contextImage :: Gtk.Image,+    contextButton :: Gtk.EventBox+  }++data TrayImageSize = Expand | TrayImageSize Int32++data TrayClickAction = Activate | SecondaryActivate | PopupMenu deriving (Eq, Show)++data TrayClickContext = TrayClickContext+  { trayClickItemInfo :: ItemInfo,+    trayClickButton :: Word32,+    trayClickXRoot :: Int32,+    trayClickYRoot :: Int32,+    trayClickModifiers :: [Gdk.ModifierType],+    trayClickDefaultAction :: TrayClickAction+  }++data TrayClickDecision+  = UseDefaultClickAction+  | OverrideClickAction TrayClickAction+  | ConsumeClick+  deriving (Eq, Show)++type TrayClickHook = TrayClickContext -> IO TrayClickDecision++data TrayEventHooks = TrayEventHooks+  { trayClickHook :: Maybe TrayClickHook+  }++defaultTrayEventHooks :: TrayEventHooks+defaultTrayEventHooks = TrayEventHooks {trayClickHook = Nothing}++data MenuBackend = LibDBusMenu | HaskellDBusMenu deriving (Eq, Show)++data TrayItemMatcher = TrayItemMatcher+  { trayItemMatcherDescription :: String,+    trayItemMatcherPredicate :: ItemInfo -> Bool+  }++data TrayPriorityConfig = TrayPriorityConfig+  { trayPriorityMatchers :: [TrayItemMatcher]+  }++defaultTrayPriorityConfig :: TrayPriorityConfig+defaultTrayPriorityConfig = TrayPriorityConfig {trayPriorityMatchers = []}++mkTrayItemMatcher :: String -> (ItemInfo -> Bool) -> TrayItemMatcher+mkTrayItemMatcher = TrayItemMatcher++trayMatchAny :: [TrayItemMatcher] -> TrayItemMatcher+trayMatchAny matchers = mkTrayItemMatcher "any" $ \info ->+  any (\matcher -> trayItemMatcherPredicate matcher info) matchers++trayMatchAll :: [TrayItemMatcher] -> TrayItemMatcher+trayMatchAll matchers = mkTrayItemMatcher "all" $ \info ->+  all (\matcher -> trayItemMatcherPredicate matcher info) matchers++trayMatchNot :: TrayItemMatcher -> TrayItemMatcher+trayMatchNot matcher =+  mkTrayItemMatcher ("not(" <> trayItemMatcherDescription matcher <> ")") $+    not . trayItemMatcherPredicate matcher++normalizeText :: T.Text -> T.Text+normalizeText = T.toCaseFold++containsCI :: T.Text -> T.Text -> Bool+containsCI needle haystack =+  normalizeText needle `T.isInfixOf` normalizeText haystack++equalsCI :: T.Text -> T.Text -> Bool+equalsCI left right = normalizeText left == normalizeText right++matchOnTextFields ::+  String ->+  (T.Text -> T.Text -> Bool) ->+  [ItemInfo -> Maybe T.Text] ->+  T.Text ->+  TrayItemMatcher+matchOnTextFields matcherName comparator fieldGetters target =+  mkTrayItemMatcher matcherName $ \info ->+    any+      (\fieldGetter -> maybe False (comparator target) (fieldGetter info))+      fieldGetters++serviceNameText :: ItemInfo -> T.Text+serviceNameText = T.pack . (coerce :: DBusTypes.BusName -> String) . itemServiceName++servicePathText :: ItemInfo -> T.Text+servicePathText = T.pack . (coerce :: DBusTypes.ObjectPath -> String) . itemServicePath++menuPathText :: ItemInfo -> Maybe T.Text+menuPathText = fmap (T.pack . (coerce :: DBusTypes.ObjectPath -> String)) . menuPath++itemIdText :: ItemInfo -> Maybe T.Text+itemIdText = fmap T.pack . itemId++itemCategoryText :: ItemInfo -> Maybe T.Text+itemCategoryText = fmap T.pack . itemCategory++itemStatusText :: ItemInfo -> Maybe T.Text+itemStatusText = fmap T.pack . itemStatus++iconNameText :: ItemInfo -> T.Text+iconNameText = T.pack . iconName++iconTitleText :: ItemInfo -> T.Text+iconTitleText = T.pack . iconTitle++tooltipTitleText :: ItemInfo -> Maybe T.Text+tooltipTitleText info = (\(_, _, titleText, _) -> T.pack titleText) <$> itemToolTip info++tooltipBodyText :: ItemInfo -> Maybe T.Text+tooltipBodyText info = (\(_, _, _, bodyText) -> T.pack bodyText) <$> itemToolTip info++trayMatchServiceNameContains :: T.Text -> TrayItemMatcher+trayMatchServiceNameContains =+  matchOnTextFields "service-name-contains" containsCI [Just . serviceNameText]++trayMatchServiceNameEquals :: T.Text -> TrayItemMatcher+trayMatchServiceNameEquals =+  matchOnTextFields "service-name-equals" equalsCI [Just . serviceNameText]++trayMatchServicePathContains :: T.Text -> TrayItemMatcher+trayMatchServicePathContains =+  matchOnTextFields "service-path-contains" containsCI [Just . servicePathText]++trayMatchServicePathEquals :: T.Text -> TrayItemMatcher+trayMatchServicePathEquals =+  matchOnTextFields "service-path-equals" equalsCI [Just . servicePathText]++trayMatchMenuPathContains :: T.Text -> TrayItemMatcher+trayMatchMenuPathContains =+  matchOnTextFields "menu-path-contains" containsCI [menuPathText]++trayMatchMenuPathEquals :: T.Text -> TrayItemMatcher+trayMatchMenuPathEquals =+  matchOnTextFields "menu-path-equals" equalsCI [menuPathText]++trayMatchItemIdContains :: T.Text -> TrayItemMatcher+trayMatchItemIdContains =+  matchOnTextFields "item-id-contains" containsCI [itemIdText]++trayMatchItemIdEquals :: T.Text -> TrayItemMatcher+trayMatchItemIdEquals =+  matchOnTextFields "item-id-equals" equalsCI [itemIdText]++trayMatchItemCategoryContains :: T.Text -> TrayItemMatcher+trayMatchItemCategoryContains =+  matchOnTextFields "item-category-contains" containsCI [itemCategoryText]++trayMatchItemCategoryEquals :: T.Text -> TrayItemMatcher+trayMatchItemCategoryEquals =+  matchOnTextFields "item-category-equals" equalsCI [itemCategoryText]++trayMatchStatusContains :: T.Text -> TrayItemMatcher+trayMatchStatusContains =+  matchOnTextFields "item-status-contains" containsCI [itemStatusText]++trayMatchStatusEquals :: T.Text -> TrayItemMatcher+trayMatchStatusEquals =+  matchOnTextFields "item-status-equals" equalsCI [itemStatusText]++trayMatchIconNameContains :: T.Text -> TrayItemMatcher+trayMatchIconNameContains =+  matchOnTextFields "icon-name-contains" containsCI [Just . iconNameText]++trayMatchIconNameEquals :: T.Text -> TrayItemMatcher+trayMatchIconNameEquals =+  matchOnTextFields "icon-name-equals" equalsCI [Just . iconNameText]++trayMatchIconTitleContains :: T.Text -> TrayItemMatcher+trayMatchIconTitleContains =+  matchOnTextFields "icon-title-contains" containsCI [Just . iconTitleText]++trayMatchIconTitleEquals :: T.Text -> TrayItemMatcher+trayMatchIconTitleEquals =+  matchOnTextFields "icon-title-equals" equalsCI [Just . iconTitleText]++trayMatchTooltipContains :: T.Text -> TrayItemMatcher+trayMatchTooltipContains =+  matchOnTextFields "tooltip-contains" containsCI [tooltipTitleText, tooltipBodyText]++trayMatchTooltipEquals :: T.Text -> TrayItemMatcher+trayMatchTooltipEquals =+  matchOnTextFields "tooltip-equals" equalsCI [tooltipTitleText, tooltipBodyText]++trayMatchAnyTextContains :: T.Text -> TrayItemMatcher+trayMatchAnyTextContains =+  matchOnTextFields+    "any-text-contains"+    containsCI+    [ Just . serviceNameText,+      Just . servicePathText,+      menuPathText,+      itemIdText,+      itemCategoryText,+      itemStatusText,+      Just . iconNameText,+      Just . iconTitleText,+      tooltipTitleText,+      tooltipBodyText+    ]++trayMatchIsMenu :: Bool -> TrayItemMatcher+trayMatchIsMenu expected =+  mkTrayItemMatcher "is-menu" $ \info -> itemIsMenu info == expected++-- | Controls whether to prefer application-provided pixmaps or themed icons+-- when both are present. Some items provide both.+data TrayIconPreference+  = PreferPixmaps+  | PreferThemedIcons+  deriving (Eq, Show, Read)++data TrayParams = TrayParams+  { trayOrientation :: Gtk.Orientation,+    trayImageSize :: TrayImageSize,+    trayIconExpand :: Bool,+    trayIconPreference :: TrayIconPreference,+    trayAlignment :: StrutAlignment,+    trayOverlayScale :: Rational,+    trayLeftClickAction :: TrayClickAction,+    trayMiddleClickAction :: TrayClickAction,+    trayRightClickAction :: TrayClickAction,+    trayMenuBackend :: MenuBackend,+    trayCenterIcons :: Bool,+    trayPriorityConfig :: TrayPriorityConfig,+    trayPixbufTransform :: Maybe PixbufTransform,+    trayEventHooks :: TrayEventHooks+  }++defaultTrayParams :: TrayParams+defaultTrayParams =+  TrayParams+    { trayOrientation = Gtk.OrientationHorizontal,+      trayImageSize = Expand,+      trayIconExpand = False,+      trayIconPreference = PreferPixmaps,+      trayAlignment = End,+      trayOverlayScale = 2 % 5,+      trayLeftClickAction = Activate,+      trayMiddleClickAction = SecondaryActivate,+      trayRightClickAction = PopupMenu,+      trayMenuBackend = HaskellDBusMenu,+      trayCenterIcons = False,+      trayPriorityConfig = defaultTrayPriorityConfig,+      trayPixbufTransform = Nothing,+      trayEventHooks = defaultTrayEventHooks+    }++buildTray :: Host -> Client -> TrayParams -> IO Gtk.Box+buildTray+  Host+    { itemInfoMap = getInfoMap,+      addUpdateHandler = addUHandler,+      removeUpdateHandler = removeUHandler+    }+  client+  TrayParams+    { trayOrientation = orientation,+      trayImageSize = imageSize,+      trayIconExpand = shouldExpand,+      trayIconPreference = iconPreference,+      trayAlignment = alignment,+      trayOverlayScale = overlayScale,+      trayLeftClickAction = leftClickAction,+      trayMiddleClickAction = middleClickAction,+      trayRightClickAction = rightClickAction,+      trayMenuBackend = menuBackend,+      trayCenterIcons = centerIcons,+      trayPriorityConfig =+        TrayPriorityConfig+          { trayPriorityMatchers = priorityMatchers+          },+      trayPixbufTransform = mTransform,+      trayEventHooks =+        TrayEventHooks+          { trayClickHook = mClickHook+          }+    } =+    do+      trayLogger INFO "Building tray"++      trayBox <- Gtk.boxNew orientation 0+      when centerIcons $ case orientation of+        Gtk.OrientationHorizontal -> Gtk.widgetSetHalign trayBox Gtk.AlignCenter+        _ -> Gtk.widgetSetValign trayBox Gtk.AlignCenter+      Gtk.widgetGetStyleContext trayBox+        >>= flip Gtk.styleContextAddClass "tray-box"+      contextMap <- MV.newMVar Map.empty++      let getContext name = Map.lookup 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+          getInfo = getInfoAttr id++          getPriorityIndex info =+            fromMaybe+              (length priorityMatchers)+              (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)++          applyTransform :: Gtk.Image -> Maybe Pixbuf -> IO (Maybe Pixbuf)+          applyTransform _ Nothing = return Nothing+          applyTransform image (Just pb) =+            case mTransform of+              Nothing -> return (Just pb)+              Just f -> Just <$> f image 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++          getTooltipText ItemInfo {itemToolTip = Just (_, _, titleText, fullText)}+            | titleText == fullText = fullText+            | titleText == "" = fullText+            | fullText == "" = titleText+            | otherwise = printf "%s: %s" titleText fullText+          getTooltipText _ = ""++          setTooltipText widget info =+            Gtk.widgetSetTooltipText widget $ Just $ T.pack $ getTooltipText info++          updateHandler+            ItemAdded+            info@ItemInfo+              { menuPath = pathForMenu,+                itemServiceName = serviceName,+                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 $+                              printf+                                ( "Allocating image size %s, width %s,"+                                    <> " height %s, resize %s"+                                )+                                (show size)+                                (show actualWidth)+                                (show actualHeight)+                                (show requestResize)++                            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+                                )++                    _ <- Gtk.onWidgetSizeAllocate image setPixbuf+                    return ()+                  TrayImageSize size -> do+                    pixBuf0 <- getScaledPixBufFromInfo size info+                    pixBuf <- applyTransform image pixBuf0+                    Gtk.imageSetFromPixbuf image pixBuf++                Gtk.widgetGetStyleContext image+                  >>= flip Gtk.styleContextAddClass "tray-icon-image"++                Gtk.containerAdd eventBox image+                setTooltipText eventBox info++                let context =+                      ItemContext+                        { contextName = serviceName,+                          contextMenuPath = pathForMenu,+                          contextImage = image,+                          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++                _ <- 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+                            )+                            (logActionError "SecondaryActivate")+                        PopupMenu -> do+                          let menuPath' = menuPath currentInfo+                          traverse_+                            ( \p ->+                                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+                                  )+                                  (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++                MV.modifyMVar_ contextMap $ return . Map.insert serviceName context++                Gtk.widgetShowAll eventBox+                let packFn =+                      case alignment of+                        End -> Gtk.boxPackEnd+                        _ -> Gtk.boxPackStart++                packFn trayBox eventBox shouldExpand True 0+          updateHandler ItemRemoved ItemInfo {itemServiceName = name} =+            getContext name >>= removeWidget+            where+              removeWidget Nothing =+                trayLogger WARNING "removeWidget: unrecognized service name."+              removeWidget (Just ItemContext {contextButton = widgetToRemove}) =+                do+                  Gtk.containerRemove trayBox widgetToRemove+                  MV.modifyMVar_ contextMap $ return . Map.delete name+          updateHandler IconUpdated i = updateIconFromInfo i+          updateHandler OverlayIconUpdated i = updateIconFromInfo i+          updateHandler ToolTipUpdated info@ItemInfo {itemServiceName = name} =+            void $+              getContext name+                >>= traverse (flip setTooltipText info . contextButton)+          updateHandler _ _ = return ()++          maybeAddOverlayToPixbuf size info pixbuf = do+            _ <- runMaybeT $ do+              let overlayHeight = floor (fromIntegral size * overlayScale)+              overlayPixbuf <-+                MaybeT $+                  getOverlayPixBufFromInfo overlayHeight info+                    >>= traverse (scalePixbufToSize overlayHeight Gtk.OrientationHorizontal)+              lift $ do+                actualOHeight <- getPixbufHeight overlayPixbuf+                actualOWidth <- getPixbufWidth overlayPixbuf+                _mainHeight <- getPixbufHeight pixbuf+                _mainWidth <- getPixbufWidth pixbuf+                pixbufComposite+                  overlayPixbuf+                  pixbuf+                  0+                  0+                  actualOWidth+                  actualOHeight+                  0+                  0+                  1.0+                  1.0+                  InterpTypeBilinear+                  255+            return pixbuf++          getScaledPixBufFromInfo size info =+            getPixBufFromInfo size info+              >>= traverse+                ( scalePixbufToSize size orientation+                    >=> maybeAddOverlayToPixbuf size info+                )++          getPixBufFromInfo+            size+            ItemInfo+              { iconName = name,+                iconThemePath = mpath,+                iconPixmaps = pixmaps+              } = getPixBufFrom size name mpath pixmaps++          getOverlayPixBufFromInfo+            size+            ItemInfo+              { overlayIconName = name,+                iconThemePath = mpath,+                overlayIconPixmaps = pixmaps+              } =+              getPixBufFrom+                size+                (fromMaybe "" name)+                mpath+                pixmaps++          getPixBufFrom size name mpath pixmaps = do+            let tooSmall (w, h, _) = w < size || h < size+                largeEnough = filter (not . tooSmall) pixmaps+                orderer (w1, h1, _) (w2, h2, _) =+                  case comparing id w1 w2 of+                    EQ -> comparing id h1 h2+                    a -> a+                selectedPixmap =+                  if null largeEnough+                    then maximumBy orderer pixmaps+                    else minimumBy orderer largeEnough+                getFromPixmaps (w, h, p) =+                  if BS.length p == 0+                    then return Nothing+                    else getIconPixbufFromByteString w h p+                getFromThemed =+                  if name == ""+                    then return Nothing+                    else getIconPixbufByName size (T.pack name) mpath+                firstJustM a b = do+                  ma <- a+                  case ma of+                    Just _ -> return ma+                    Nothing -> b++            if null pixmaps+              then getIconPixbufByName size (T.pack name) mpath+              else case iconPreference of+                PreferThemedIcons ->+                  firstJustM getFromThemed (getFromPixmaps selectedPixmap)+                PreferPixmaps ->+                  firstJustM (getFromPixmaps selectedPixmap) getFromThemed++          uiUpdateHandler updateType info =+            void $+              Gdk.threadsAddIdle GLib.PRIORITY_DEFAULT $+                catchAny+                  ( updateHandler updateType info+                      >> reorderTrayByPriority+                      >> return False+                  )+                  ( \e -> do+                      trayLogger WARNING $ printf "Update handler failed: %s" (show e)+                      return False+                  )++      handlerId <- addUHandler uiUpdateHandler+      _ <- Gtk.onWidgetDestroy trayBox $ removeUHandler handlerId+      return trayBox