{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE TupleSections #-}

-- |
-- Module      : System.Taffybar.Widget.SNITray.PrioritizedCollapsible
-- Copyright   : (c) Ivan A. Malison
-- License     : BSD3-style (see LICENSE)
--
-- Maintainer  : Ivan A. Malison
-- Stability   : unstable
-- Portability : unportable
--
-- Prioritized, collapsible StatusNotifierItem tray with editable per-icon
-- priorities and persisted priority state.
module System.Taffybar.Widget.SNITray.PrioritizedCollapsible
  ( module System.Taffybar.Widget.SNITray.PrioritizedCollapsible,
  )
where

import Control.Applicative ((<|>))
import Control.Monad (forM_, guard, unless, void, when)
import Control.Monad.Trans.Class
import Control.Monad.Trans.Reader
import qualified DBus as D
import qualified DBus.Client as DBus
import qualified Data.Aeson as A
import qualified Data.Aeson.Key as AKey
import qualified Data.Aeson.KeyMap as AKeyMap
import Data.Aeson.Types (Parser, parseMaybe)
import qualified Data.ByteString as BS
import qualified Data.ByteString.Char8 as BS8
import Data.Char (isAlphaNum, isDigit, toLower)
import Data.Foldable (traverse_)
import Data.IORef
import Data.Int (Int32, Int64)
import Data.List (intercalate, isPrefixOf, sortOn, stripPrefix)
import qualified Data.Map.Strict as M
import Data.Maybe (catMaybes, fromMaybe, isJust, isNothing, listToMaybe, mapMaybe, maybeToList)
import Data.Ord (Down (..))
import qualified Data.Set as Set
import qualified Data.Text as T
import Data.Unique (hashUnique)
import Data.Word (Word32)
import qualified Data.Yaml as Y
import qualified GI.GLib as GLib
import qualified GI.Gdk as Gdk
import qualified GI.Gtk as Gtk
import Graphics.UI.GIGtkStrut (StrutAlignment (Beginning))
import qualified StatusNotifier.Host.Service as H
import StatusNotifier.Tray
import qualified StatusNotifier.Tray as Tray
import System.Directory (createDirectoryIfMissing, doesFileExist)
import System.Environment.XDG.BaseDir (getUserConfigFile)
import System.FilePath (isRelative, replaceExtension, takeBaseName, takeDirectory, takeExtension)
import System.Log.Logger (Priority (DEBUG, INFO), logM)
import System.Taffybar.Context
import System.Taffybar.Widget.SNITray
  ( CollapsibleSNITrayParams (..),
    SNITrayConfig (..),
    defaultCollapsibleSNITrayParams,
    getTrayHost,
  )
import System.Taffybar.Widget.Util
import Text.Printf
import Text.Read (readMaybe)

prioritizedTrayLog :: Priority -> String -> IO ()
prioritizedTrayLog = logM "System.Taffybar.Widget.SNITray.PrioritizedCollapsible"

type SNIPriorityMap = M.Map String Int

data SNIPriorityEntry = SNIPriorityEntry
  { sniPriorityEntryKey :: String,
    sniPriorityEntryPriority :: Int
  }

data SNIPriorityFile = SNIPriorityFile
  { sniPriorityFilePriorities :: SNIPriorityMap,
    sniPriorityFileMaxVisibleIcons :: Maybe Int,
    -- Nothing: no persisted override (use config default)
    -- Just Nothing: explicitly no threshold
    -- Just (Just n): explicit threshold n
    sniPriorityFileVisibilityThreshold :: Maybe (Maybe Int)
  }

instance A.FromJSON SNIPriorityEntry where
  parseJSON = A.withObject "SNIPriorityEntry" $ \obj ->
    SNIPriorityEntry
      <$> obj A..: "key"
      <*> obj A..: "priority"

instance A.ToJSON SNIPriorityEntry where
  toJSON SNIPriorityEntry {..} =
    A.object
      [ "key" A..= sniPriorityEntryKey,
        "priority" A..= sniPriorityEntryPriority
      ]

parsePrioritiesValue :: A.Value -> Parser SNIPriorityMap
parsePrioritiesValue value =
  parseEntries value <|> A.parseJSON value
  where
    parseEntries v = do
      entries <- A.parseJSON v :: Parser [SNIPriorityEntry]
      let toPair SNIPriorityEntry {..} =
            (sniPriorityEntryKey, sniPriorityEntryPriority)
      return $ M.fromList (map toPair entries)

instance A.FromJSON SNIPriorityFile where
  parseJSON = A.withObject "SNIPriorityFile" $ \obj -> do
    maybePriorities <- obj A..:? "priorities"
    priorities <- maybe (return M.empty) parsePrioritiesValue maybePriorities
    maxVisibleIcons <- obj A..:? "max_visible_icons"
    let thresholdKey = AKey.fromString "visibility_threshold"
    visibilityThreshold <-
      if AKeyMap.member thresholdKey obj
        then Just <$> obj A..:? "visibility_threshold"
        else return Nothing
    return $
      SNIPriorityFile
        { sniPriorityFilePriorities = priorities,
          sniPriorityFileMaxVisibleIcons = maxVisibleIcons,
          sniPriorityFileVisibilityThreshold = visibilityThreshold
        }

instance A.ToJSON SNIPriorityFile where
  toJSON SNIPriorityFile {..} =
    let sortedEntries =
          map
            (uncurry SNIPriorityEntry)
            (sortOn (\(key, priority) -> (Down priority, key)) (M.toList sniPriorityFilePriorities))
     in A.object
          ( [ "format_version" A..= (2 :: Int),
              "priorities" A..= sortedEntries
            ]
              <> maybe [] (\value -> ["max_visible_icons" A..= value]) sniPriorityFileMaxVisibleIcons
              <> maybe [] (\value -> ["visibility_threshold" A..= value]) sniPriorityFileVisibilityThreshold
          )

-- | Configuration for a collapsible tray with editable icon priorities.
data PrioritizedCollapsibleSNITrayParams = PrioritizedCollapsibleSNITrayParams
  { -- | Base collapsible tray parameters.
    prioritizedCollapsibleSNITrayParams :: CollapsibleSNITrayParams,
    -- | Path for priority state persistence.
    --
    -- Relative paths are resolved under @~/.config/taffybar/@.
    prioritizedCollapsibleSNITrayPriorityStateFile :: FilePath,
    -- | Minimum priority value.
    prioritizedCollapsibleSNITrayPriorityMin :: Int,
    -- | Maximum priority value.
    prioritizedCollapsibleSNITrayPriorityMax :: Int,
    -- | Default priority assigned to unmapped icons.
    prioritizedCollapsibleSNITrayDefaultPriority :: Int,
    -- | Hide icons with priority below this value.
    --
    -- This only applies while collapsed; expanded mode always shows all icons.
    prioritizedCollapsibleSNITrayVisibilityThreshold :: Maybe Int,
    -- | Whether priority edit mode starts enabled.
    prioritizedCollapsibleSNITrayStartPriorityEditMode :: Bool,
    -- | Always show the expand/collapse toggle button.
    prioritizedCollapsibleSNITrayAlwaysShowExpandToggle :: Bool,
    -- | Temporarily expand collapsed tray icons while the pointer is over the tray.
    prioritizedCollapsibleSNITrayHoverExpand :: Bool,
    -- | Delay before hover expansion starts.
    prioritizedCollapsibleSNITrayHoverExpandDelayMs :: Word32,
    -- | Delay before hover expansion collapses again.
    prioritizedCollapsibleSNITrayHoverCollapseDelayMs :: Word32,
    -- | Duration for the clipped tray extent animation while hover expanding/collapsing.
    prioritizedCollapsibleSNITrayHoverAnimationDurationMs :: Word32,
    -- | Label renderer for the priority-edit-mode toggle.
    --
    -- Argument: @editing@.
    prioritizedCollapsibleSNITrayPriorityModeLabel :: Bool -> T.Text
  }

defaultPrioritizedCollapsibleSNITrayPriorityModeLabel :: Bool -> T.Text
defaultPrioritizedCollapsibleSNITrayPriorityModeLabel editing
  | editing = "P*"
  | otherwise = "P"

-- | Default params for 'PrioritizedCollapsibleSNITrayParams'.
defaultPrioritizedCollapsibleSNITrayParams :: PrioritizedCollapsibleSNITrayParams
defaultPrioritizedCollapsibleSNITrayParams =
  PrioritizedCollapsibleSNITrayParams
    { prioritizedCollapsibleSNITrayParams = defaultCollapsibleSNITrayParams,
      prioritizedCollapsibleSNITrayPriorityStateFile = "sni-priorities.yaml",
      prioritizedCollapsibleSNITrayPriorityMin = -5,
      prioritizedCollapsibleSNITrayPriorityMax = 5,
      prioritizedCollapsibleSNITrayDefaultPriority = 0,
      prioritizedCollapsibleSNITrayVisibilityThreshold = Nothing,
      prioritizedCollapsibleSNITrayStartPriorityEditMode = False,
      prioritizedCollapsibleSNITrayAlwaysShowExpandToggle = True,
      prioritizedCollapsibleSNITrayHoverExpand = False,
      prioritizedCollapsibleSNITrayHoverExpandDelayMs = 120,
      prioritizedCollapsibleSNITrayHoverCollapseDelayMs = 500,
      prioritizedCollapsibleSNITrayHoverAnimationDurationMs = 320,
      prioritizedCollapsibleSNITrayPriorityModeLabel = defaultPrioritizedCollapsibleSNITrayPriorityModeLabel
    }

clampPriorityInRange :: Int -> Int -> Int -> Int
clampPriorityInRange priorityMin priorityMax =
  max priorityMin . min priorityMax

resolveSNIPriorityStateFile :: FilePath -> IO FilePath
resolveSNIPriorityStateFile path
  | isRelative path = getUserConfigFile "taffybar" path
  | otherwise = return path

parseLegacySNIPriorityMap :: BS.ByteString -> Maybe SNIPriorityMap
parseLegacySNIPriorityMap content =
  M.fromList <$> (readMaybe (BS8.unpack content) :: Maybe [(String, Int)])

parseLegacySNIPriorityFile :: BS.ByteString -> Maybe SNIPriorityFile
parseLegacySNIPriorityFile content =
  legacyFile <$> parseLegacySNIPriorityMap content
  where
    legacyFile priorities =
      SNIPriorityFile
        { sniPriorityFilePriorities = priorities,
          sniPriorityFileMaxVisibleIcons = Nothing,
          sniPriorityFileVisibilityThreshold = Nothing
        }

parseSNIPriorityFile :: BS.ByteString -> Maybe SNIPriorityFile
parseSNIPriorityFile content =
  parseYamlState <|> parseYamlPriorityOnly <|> parseLegacySNIPriorityFile content
  where
    parseYamlState =
      either
        (const Nothing)
        Just
        (Y.decodeEither' content :: Either Y.ParseException SNIPriorityFile)
    parseYamlPriorityOnly = do
      yamlValue <- either (const Nothing) Just (Y.decodeEither' content :: Either Y.ParseException A.Value)
      priorities <- parseMaybe parsePrioritiesValue yamlValue
      return $
        SNIPriorityFile
          { sniPriorityFilePriorities = priorities,
            sniPriorityFileMaxVisibleIcons = Nothing,
            sniPriorityFileVisibilityThreshold = Nothing
          }

loadSNIPriorityFileFromPath :: FilePath -> IO (Maybe SNIPriorityFile)
loadSNIPriorityFileFromPath path = do
  exists <- doesFileExist path
  if not exists
    then return Nothing
    else parseSNIPriorityFile <$> BS.readFile path

legacyPriorityStateFallbackPath :: FilePath -> Maybe FilePath
legacyPriorityStateFallbackPath path
  | takeExtension path == ".yaml" = Just (replaceExtension path "dat")
  | otherwise = Nothing

loadSNIPriorityFileFromFile :: FilePath -> IO SNIPriorityFile
loadSNIPriorityFileFromFile path = do
  loaded <- loadSNIPriorityFileFromPath path
  case loaded of
    Just priorityFile -> return priorityFile
    Nothing ->
      case legacyPriorityStateFallbackPath path of
        Nothing -> return emptyPriorityFile
        Just legacyPath -> do
          fallbackLoaded <- loadSNIPriorityFileFromPath legacyPath
          case fallbackLoaded of
            Nothing -> return emptyPriorityFile
            Just priorityFile -> do
              -- One-time migration path for existing show/read .dat files.
              persistSNIPriorityFileToFile path priorityFile
              return priorityFile

emptyPriorityFile :: SNIPriorityFile
emptyPriorityFile =
  SNIPriorityFile
    { sniPriorityFilePriorities = M.empty,
      sniPriorityFileMaxVisibleIcons = Nothing,
      sniPriorityFileVisibilityThreshold = Nothing
    }

persistSNIPriorityFileToFile :: FilePath -> SNIPriorityFile -> IO ()
persistSNIPriorityFileToFile path priorityFile = do
  createDirectoryIfMissing True (takeDirectory path)
  BS.writeFile path (Y.encode priorityFile)

nonEmptyString :: String -> Maybe String
nonEmptyString value
  | null value = Nothing
  | otherwise = Just value

itemStableIdentity :: H.ItemInfo -> String
itemStableIdentity info =
  show (H.itemServiceName info) <> "|" <> show (H.itemServicePath info)

itemStableIdentityKey :: H.ItemInfo -> String
itemStableIdentityKey info = "item-identity:" ++ itemStableIdentity info

itemDBusAddress :: H.ItemInfo -> String
itemDBusAddress info =
  D.formatBusName (H.itemServiceName info) <> "|" <> D.formatObjectPath (H.itemServicePath info)

orderingComponent :: Maybe String -> (Bool, String)
orderingComponent value =
  case value >>= nonEmptyString of
    Nothing -> (True, "")
    Just text -> (False, map toLower text)

hasNumericSuffix :: String -> String -> Bool
hasNumericSuffix prefix value =
  case stripPrefix prefix value of
    Just suffix -> not (null suffix) && all isDigit suffix
    Nothing -> False

unstableItemIdPrefixes :: [String]
unstableItemIdPrefixes =
  ["chrome_status_icon_", "systray_", "statusnotifieritem-", "statusnotifieritem_"]

sharedItemIdPrefixes :: [String]
sharedItemIdPrefixes = ["chrome_status_icon_", "systray_"]

unstableServiceNamePrefixes :: [String]
unstableServiceNamePrefixes = ["org.kde.StatusNotifierItem-"]

matchingItemIdPrefix :: [String] -> String -> Maybe String
matchingItemIdPrefix prefixes itemId =
  let lowerItemId = map toLower itemId
      matchingPrefixes =
        filter (`hasNumericSuffix` lowerItemId) prefixes
   in case matchingPrefixes of
        prefix : _ -> Just (take (length prefix) itemId)
        [] -> Nothing

unstableItemIdPrefix :: String -> Maybe String
unstableItemIdPrefix = matchingItemIdPrefix unstableItemIdPrefixes

sharedItemIdPrefix :: String -> Maybe String
sharedItemIdPrefix = matchingItemIdPrefix sharedItemIdPrefixes

isLikelyUnstableItemId :: String -> Bool
isLikelyUnstableItemId = isJust . unstableItemIdPrefix

stableItemIdKey :: H.ItemInfo -> Maybe String
stableItemIdKey info = do
  itemId <- H.itemId info >>= nonEmptyString
  guard (not (isLikelyUnstableItemId itemId))
  return ("item-id:" ++ itemId)

unstableItemIdKey :: H.ItemInfo -> Maybe String
unstableItemIdKey info = do
  itemId <- H.itemId info >>= nonEmptyString
  guard (isLikelyUnstableItemId itemId)
  return ("item-id:" ++ itemId)

itemIdOrderingToken :: H.ItemInfo -> Maybe String
itemIdOrderingToken info = do
  itemId <- H.itemId info >>= nonEmptyString
  return $ fromMaybe itemId (unstableItemIdPrefix itemId)

itemServiceNameOrderingToken :: H.ItemInfo -> Maybe String
itemServiceNameOrderingToken info =
  let serviceName = D.formatBusName (H.itemServiceName info)
   in if ":" `isPrefixOf` serviceName || any (`isPrefixOf` serviceName) unstableServiceNamePrefixes
        then Nothing
        else Just serviceName

itemOrderingKey :: Maybe String -> H.ItemInfo -> [(Bool, String)]
itemOrderingKey maybeProcessKey info =
  map
    orderingComponent
    [ maybeProcessKey,
      itemIdOrderingToken info,
      nonEmptyString (H.iconName info),
      nonEmptyString (H.iconTitle info),
      H.itemCategory info >>= nonEmptyString,
      itemServiceNameOrderingToken info,
      show <$> H.menuPath info,
      Just (show (H.itemServicePath info)),
      Just (itemDBusAddress info)
    ]

sharedItemIdPrefixIconNameKey :: H.ItemInfo -> Maybe String
sharedItemIdPrefixIconNameKey info = do
  itemId <- H.itemId info >>= nonEmptyString
  prefix <- sharedItemIdPrefix itemId
  iconName <- nonEmptyString (H.iconName info)
  return ("item-id-prefix+icon-name:" ++ prefix ++ "|" ++ iconName)

sharedItemIdPrefixIconTitleKey :: H.ItemInfo -> Maybe String
sharedItemIdPrefixIconTitleKey info = do
  itemId <- H.itemId info >>= nonEmptyString
  prefix <- sharedItemIdPrefix itemId
  iconTitle <- nonEmptyString (H.iconTitle info)
  return ("item-id-prefix+icon-title:" ++ prefix ++ "|" ++ iconTitle)

isLikelySharedItemIdForInfo :: H.ItemInfo -> Bool
isLikelySharedItemIdForInfo info =
  case H.itemId info >>= nonEmptyString of
    Nothing -> False
    Just itemId -> isJust (sharedItemIdPrefix itemId)

normalizeProcessToken :: String -> String
normalizeProcessToken =
  dropWhile (== '-') . reverse . dropWhile (== '-') . reverse . map normalizeChar
  where
    normalizeChar c
      | isAlphaNum c = toLower c
      | otherwise = '-'

processIdentityTokenFromArg :: String -> Maybe String
processIdentityTokenFromArg arg
  | takeExtension arg == ".asar" =
      nonEmptyString (takeBaseName (takeDirectory arg))
  | otherwise = Nothing

processIdentityTokenFromCmdline :: [String] -> Maybe String
processIdentityTokenFromCmdline [] = Nothing
processIdentityTokenFromCmdline (exeArg : args) =
  let argToken = listToMaybe (mapMaybe processIdentityTokenFromArg args)
      exeToken = nonEmptyString (takeBaseName exeArg)
      normalized = normalizeProcessToken <$> (argToken <|> exeToken)
   in normalized >>= nonEmptyString

readProcessCommandLine :: Word32 -> IO [String]
readProcessCommandLine pid = do
  let cmdlinePath = "/proc/" ++ show pid ++ "/cmdline"
  exists <- doesFileExist cmdlinePath
  if not exists
    then return []
    else do
      bytes <- BS.readFile cmdlinePath
      return $ filter (not . null) (map BS8.unpack (BS8.split '\0' bytes))

dbusDaemonName :: D.BusName
dbusDaemonName = D.busName_ "org.freedesktop.DBus"

dbusDaemonPath :: D.ObjectPath
dbusDaemonPath = D.objectPath_ "/org/freedesktop/DBus"

getConnectionUnixProcessID :: DBus.Client -> D.BusName -> IO (Maybe Word32)
getConnectionUnixProcessID client busName = do
  let method =
        (D.methodCall dbusDaemonPath "org.freedesktop.DBus" "GetConnectionUnixProcessID")
          { D.methodCallDestination = Just dbusDaemonName,
            D.methodCallBody = [D.toVariant (D.formatBusName busName)]
          }
  result <- DBus.call client method
  case result of
    Left _ -> return Nothing
    Right reply ->
      case D.methodReturnBody reply of
        [pidVariant] -> return (D.fromVariant pidVariant)
        _ -> return Nothing

processDisambiguationKeyForItem :: DBus.Client -> H.ItemInfo -> IO (Maybe String)
processDisambiguationKeyForItem client info = do
  maybePid <- getConnectionUnixProcessID client (H.itemServiceName info)
  case maybePid of
    Nothing -> return Nothing
    Just pid -> do
      cmdline <- readProcessCommandLine pid
      return $ ("process:" ++) <$> processIdentityTokenFromCmdline cmdline

processDisambiguationKeysForItems :: DBus.Client -> [H.ItemInfo] -> IO (M.Map String String)
processDisambiguationKeysForItems client infos = do
  pairs <- mapM withKey infos
  return $ M.fromList (catMaybes pairs)
  where
    withKey info = do
      processKey <- processDisambiguationKeyForItem client info
      return $ fmap (itemStableIdentity info,) processKey

dedupe :: (Ord a) => [a] -> [a]
dedupe = go Set.empty
  where
    go _ [] = []
    go seen (x : xs)
      | x `Set.member` seen = go seen xs
      | otherwise = x : go (Set.insert x seen) xs

priorityLookupKeyCandidates :: Maybe String -> H.ItemInfo -> [String]
priorityLookupKeyCandidates maybeProcessKey info =
  dedupe $
    concat
      [ maybeToList maybeProcessKey,
        map ("icon-name:" ++) (maybeToList (nonEmptyString (H.iconName info))),
        maybeToList (stableItemIdKey info),
        map ("icon-title:" ++) (maybeToList (nonEmptyString (H.iconTitle info))),
        maybeToList (sharedItemIdPrefixIconNameKey info),
        maybeToList (sharedItemIdPrefixIconTitleKey info),
        [itemStableIdentityKey info],
        maybeToList (unstableItemIdKey info)
      ]

priorityEditableKeyCandidates :: Maybe String -> H.ItemInfo -> [String]
priorityEditableKeyCandidates maybeProcessKey info =
  dedupe $
    concat
      [ maybeToList maybeProcessKey,
        map ("icon-name:" ++) (maybeToList (nonEmptyString (H.iconName info))),
        maybeToList (stableItemIdKey info),
        map ("icon-title:" ++) (maybeToList (nonEmptyString (H.iconTitle info))),
        maybeToList (sharedItemIdPrefixIconNameKey info),
        maybeToList (sharedItemIdPrefixIconTitleKey info),
        [itemStableIdentityKey info],
        maybeToList (unstableItemIdKey info)
      ]

priorityKeyFromItem :: Maybe String -> H.ItemInfo -> Maybe String
priorityKeyFromItem maybeProcessKey =
  listToMaybe . priorityEditableKeyCandidates maybeProcessKey

itemPriorityFromMap ::
  Int ->
  Int ->
  Int ->
  SNIPriorityMap ->
  Maybe String ->
  H.ItemInfo ->
  Int
itemPriorityFromMap priorityMin priorityMax defaultPriority priorities maybeProcessKey info =
  let clampPriority = clampPriorityInRange priorityMin priorityMax
      matchedPriority =
        listToMaybe $
          mapMaybe (`M.lookup` priorities) (priorityLookupKeyCandidates maybeProcessKey info)
   in clampPriority (fromMaybe defaultPriority matchedPriority)

formatMaybe :: Maybe String -> String
formatMaybe = fromMaybe "-"

describeItemForOrder ::
  (H.ItemInfo -> Int) ->
  (H.ItemInfo -> Maybe String) ->
  H.ItemInfo ->
  String
describeItemForOrder priorityForInfo processKeyForInfo info =
  printf
    "p=%d process=%s itemId=%s icon=%s title=%s category=%s service=%s path=%s"
    (priorityForInfo info)
    (formatMaybe $ processKeyForInfo info)
    (formatMaybe $ H.itemId info)
    (H.iconName info)
    (H.iconTitle info)
    (formatMaybe $ H.itemCategory info)
    (D.formatBusName $ H.itemServiceName info)
    (D.formatObjectPath $ H.itemServicePath info)

describeOrderedInfos ::
  (H.ItemInfo -> Int) ->
  (H.ItemInfo -> Maybe String) ->
  [H.ItemInfo] ->
  String
describeOrderedInfos priorityForInfo processKeyForInfo infos =
  intercalate
    " | "
    [ printf
        "%d:{%s}"
        index
        (describeItemForOrder priorityForInfo processKeyForInfo info)
    | (index, info) <- zip [0 :: Int ..] infos
    ]

sortedInfosByPriority ::
  Bool ->
  Int ->
  Int ->
  Int ->
  SNIPriorityMap ->
  (H.ItemInfo -> Maybe String) ->
  [H.ItemInfo] ->
  [H.ItemInfo]
sortedInfosByPriority highPriorityFirstInTrayOrder priorityMin priorityMax defaultPriority priorities processKeyForInfo infos =
  let itemPriority info =
        itemPriorityFromMap
          priorityMin
          priorityMax
          defaultPriority
          priorities
          (processKeyForInfo info)
          info
      prioritySortKey info =
        if highPriorityFirstInTrayOrder
          then negate (itemPriority info)
          else itemPriority info
   in sortOn
        (\info -> (prioritySortKey info, itemOrderingKey (processKeyForInfo info) info))
        infos

lookupExplicitPriority ::
  SNIPriorityMap ->
  Maybe String ->
  H.ItemInfo ->
  Maybe Int
lookupExplicitPriority priorities maybeProcessKey info =
  listToMaybe $ mapMaybe (`M.lookup` priorities) (priorityLookupKeyCandidates maybeProcessKey info)

setExplicitPriorityForItem ::
  IORef SNIPriorityMap ->
  (SNIPriorityMap -> IO ()) ->
  Maybe String ->
  H.ItemInfo ->
  Maybe Int ->
  IO ()
setExplicitPriorityForItem prioritiesRef afterUpdate maybeProcessKey info newPriority =
  case priorityKeyFromItem maybeProcessKey info of
    Nothing -> return ()
    Just primaryKey -> do
      let editableKeys = priorityEditableKeyCandidates maybeProcessKey info
      modifyIORef' prioritiesRef $ \priorities ->
        case newPriority of
          Nothing -> foldr M.delete priorities editableKeys
          Just priority -> M.insert primaryKey priority priorities
      readIORef prioritiesRef >>= afterUpdate

menuIconSize :: Int32
menuIconSize = fromIntegral $ fromEnum Gtk.IconSizeMenu

showPriorityEditMenu ::
  Gtk.Widget ->
  Int ->
  Int ->
  Int ->
  Maybe Int ->
  (Maybe Int -> IO ()) ->
  IO ()
showPriorityEditMenu anchor priorityMin priorityMax defaultPriority currentExplicit onSelection = do
  currentEvent <- Gtk.getCurrentEvent
  menu <- Gtk.menuNew
  Gtk.menuAttachToWidget menu anchor Nothing

  let options = [priorityMax, priorityMax - 1 .. priorityMin]
  forM_ options $ \priority -> do
    let prefix =
          if currentExplicit == Just priority
            then "\x2713 " :: T.Text
            else "   "
        labelText = prefix <> "Set priority " <> T.pack (show priority)
    item <- Gtk.menuItemNewWithLabel labelText
    void $ Gtk.onMenuItemActivate item $ onSelection (Just priority)
    Gtk.menuShellAppend menu item

  sep <- Gtk.separatorMenuItemNew
  Gtk.menuShellAppend menu sep

  let clearPrefix =
        if isNothing currentExplicit
          then "\x2713 " :: T.Text
          else "   "
      clearLabel =
        clearPrefix
          <> "Clear override (default "
          <> T.pack (show defaultPriority)
          <> ")"
  clearItem <- Gtk.menuItemNewWithLabel clearLabel
  void $ Gtk.onMenuItemActivate clearItem $ onSelection Nothing
  Gtk.menuShellAppend menu clearItem

  void $
    Gtk.onWidgetHide menu $
      void $
        GLib.idleAdd GLib.PRIORITY_LOW $ do
          Gtk.widgetDestroy menu
          return False

  Gtk.widgetShowAll menu
  Gtk.menuPopupAtPointer menu currentEvent

showPriorityControlsMenu ::
  Gtk.EventBox ->
  Int ->
  Int ->
  Bool ->
  (Bool -> T.Text) ->
  IORef Bool ->
  IORef Bool ->
  IORef Int ->
  IORef Int ->
  IORef (Maybe Int) ->
  IO () ->
  IO () ->
  IO ()
showPriorityControlsMenu anchor priorityMin priorityMax alwaysShowExpandControl priorityModeLabel expandedRef priorityEditModeRef hiddenCountRef maxVisibleRef thresholdRef =
  showPriorityControlsMenuWithExplicitCollapse
    anchor
    priorityMin
    priorityMax
    alwaysShowExpandControl
    priorityModeLabel
    expandedRef
    priorityEditModeRef
    hiddenCountRef
    maxVisibleRef
    thresholdRef
    (return ())

showPriorityControlsMenuWithExplicitCollapse ::
  Gtk.EventBox ->
  Int ->
  Int ->
  Bool ->
  (Bool -> T.Text) ->
  IORef Bool ->
  IORef Bool ->
  IORef Int ->
  IORef Int ->
  IORef (Maybe Int) ->
  IO () ->
  IO () ->
  IO () ->
  IO ()
showPriorityControlsMenuWithExplicitCollapse
  anchor
  priorityMin
  priorityMax
  alwaysShowExpandControl
  priorityModeLabel
  expandedRef
  priorityEditModeRef
  hiddenCountRef
  maxVisibleRef
  thresholdRef
  onExplicitCollapse
  onControlStateChanged
  onSettingsChanged = do
    currentEvent <- Gtk.getCurrentEvent
    currentExpanded <- readIORef expandedRef
    currentPriorityEditMode <- readIORef priorityEditModeRef
    currentHiddenCount <- readIORef hiddenCountRef
    currentMaxVisible <- readIORef maxVisibleRef
    currentThreshold <- readIORef thresholdRef

    menu <- Gtk.menuNew
    Gtk.menuAttachToWidget menu anchor Nothing

    let showExpandControl =
          alwaysShowExpandControl || currentExpanded || currentHiddenCount > 0
    when showExpandControl $ do
      let expandLabel =
            if currentExpanded
              then "Allow tray icon hiding" :: T.Text
              else "Show all tray icons"
      expandItem <- Gtk.menuItemNewWithLabel expandLabel
      void $ Gtk.onMenuItemActivate expandItem $ do
        let newExpanded = not currentExpanded
        writeIORef expandedRef newExpanded
        unless newExpanded onExplicitCollapse
        onControlStateChanged
      Gtk.menuShellAppend menu expandItem

    let priorityModePrefix =
          if currentPriorityEditMode
            then "\x2713 " :: T.Text
            else "   "
        priorityModeItemLabel =
          priorityModePrefix
            <> "Priority edit mode: "
            <> priorityModeLabel currentPriorityEditMode
    priorityModeItem <- Gtk.menuItemNewWithLabel priorityModeItemLabel
    void $ Gtk.onMenuItemActivate priorityModeItem $ do
      modifyIORef' priorityEditModeRef not
      onControlStateChanged
    Gtk.menuShellAppend menu priorityModeItem

    controlsSep <- Gtk.separatorMenuItemNew
    Gtk.menuShellAppend menu controlsSep

    maxVisibleItem <- Gtk.menuItemNewWithLabel ("Max visible (collapsed)" :: T.Text)
    maxVisibleMenu <- Gtk.menuNew
    Gtk.menuItemSetSubmenu maxVisibleItem (Just maxVisibleMenu)
    let maxVisibleOptions = [0 .. 20]
    forM_ maxVisibleOptions $ \option -> do
      let optionLabel =
            if option <= 0
              then "No limit" :: T.Text
              else T.pack (show option)
          prefix =
            if option == currentMaxVisible
              then "\x2713 " :: T.Text
              else "   "
      item <- Gtk.menuItemNewWithLabel (prefix <> optionLabel)
      void $ Gtk.onMenuItemActivate item $ do
        writeIORef maxVisibleRef option
        onSettingsChanged
      Gtk.menuShellAppend maxVisibleMenu item
    Gtk.menuShellAppend menu maxVisibleItem

    thresholdItem <- Gtk.menuItemNewWithLabel ("Priority threshold" :: T.Text)
    thresholdMenu <- Gtk.menuNew
    Gtk.menuItemSetSubmenu thresholdItem (Just thresholdMenu)
    let thresholdOptions = Nothing : map Just [priorityMin .. priorityMax]
    forM_ thresholdOptions $ \option -> do
      let optionLabel =
            case option of
              Nothing -> "No threshold" :: T.Text
              Just value -> ">= " <> T.pack (show value)
          prefix =
            if option == currentThreshold
              then "\x2713 " :: T.Text
              else "   "
      item <- Gtk.menuItemNewWithLabel (prefix <> optionLabel)
      void $ Gtk.onMenuItemActivate item $ do
        writeIORef thresholdRef option
        onSettingsChanged
      Gtk.menuShellAppend thresholdMenu item
    Gtk.menuShellAppend menu thresholdItem

    void $
      Gtk.onWidgetHide menu $
        void $
          GLib.idleAdd GLib.PRIORITY_LOW $ do
            Gtk.widgetDestroy menu
            return False

    Gtk.widgetShowAll menu
    Gtk.menuPopupAtPointer menu currentEvent

-- | State machine for the polled hover-expand mechanism.
--
-- The pointer position is polled directly (see 'pointerWithinWidget') rather
-- than inferred from crossing events, so synthetic crossing events (grabs,
-- child transitions) cannot corrupt hover state. Timestamps are
-- 'GLib.getMonotonicTime' microseconds.
data HoverPollState
  = HoverIdle
  | HoverPendingExpand Int64
  | HoverExpanded
  | HoverPendingCollapse Int64

-- | Return whether the pointer is currently within the bounds of the widget's
-- window, measured directly from GDK rather than inferred from crossing events.
--
-- This is used as ground truth to resynchronize hover state that can be
-- corrupted by synthetic crossing events (grabs, child transitions).
pointerWithinWidget :: (Gtk.IsWidget w) => w -> IO Bool
pointerWithinWidget widget = do
  maybeWindow <- Gtk.widgetGetWindow widget
  case maybeWindow of
    Nothing -> return False
    Just window -> do
      display <- Gdk.windowGetDisplay window
      seat <- Gdk.displayGetDefaultSeat display
      maybePointer <- Gdk.seatGetPointer seat
      case maybePointer of
        Nothing -> return False
        Just pointer -> do
          (_, x, y, _) <- Gdk.windowGetDevicePosition window pointer
          width <- Gdk.windowGetWidth window
          height <- Gdk.windowGetHeight window
          return (x >= 0 && y >= 0 && x < width && y < height)

-- | Build a collapsible StatusNotifierItem tray with priority editing controls
-- and persisted priority state.
sniTrayPrioritizedCollapsibleNew :: TaffyIO Gtk.Widget
sniTrayPrioritizedCollapsibleNew =
  sniTrayPrioritizedCollapsibleNewFromParams defaultPrioritizedCollapsibleSNITrayParams

-- | Build a prioritized collapsible tray from custom params.
sniTrayPrioritizedCollapsibleNewFromParams ::
  PrioritizedCollapsibleSNITrayParams -> TaffyIO Gtk.Widget
sniTrayPrioritizedCollapsibleNewFromParams params =
  getTrayHost False >>= sniTrayPrioritizedCollapsibleNewFromHostParams params

-- | Build a prioritized collapsible tray from custom params and a host.
sniTrayPrioritizedCollapsibleNewFromHostParams ::
  PrioritizedCollapsibleSNITrayParams -> H.Host -> TaffyIO Gtk.Widget
sniTrayPrioritizedCollapsibleNewFromHostParams PrioritizedCollapsibleSNITrayParams {..} host = do
  client <- asks sessionDBusClient
  lift $ do
    let CollapsibleSNITrayParams {..} = prioritizedCollapsibleSNITrayParams
        SNITrayConfig {..} = collapsibleSNITrayConfig
        rawPriorityMin = prioritizedCollapsibleSNITrayPriorityMin
        rawPriorityMax = prioritizedCollapsibleSNITrayPriorityMax
        priorityMin = min rawPriorityMin rawPriorityMax
        priorityMax = max rawPriorityMin rawPriorityMax
        clampPriority = clampPriorityInRange priorityMin priorityMax
        defaultPriority = clampPriority prioritizedCollapsibleSNITrayDefaultPriority
        visibilityThreshold = clampPriority <$> prioritizedCollapsibleSNITrayVisibilityThreshold
        trayOrientation' = trayOrientation sniTrayTrayParams
        highPriorityFirstInTrayOrder = True

    statePath <- resolveSNIPriorityStateFile prioritizedCollapsibleSNITrayPriorityStateFile
    persistedPriorityFile <- loadSNIPriorityFileFromFile statePath
    let persistedPriorities =
          M.map clampPriority (sniPriorityFilePriorities persistedPriorityFile)
        initialMaxVisibleIcons =
          max
            0
            ( fromMaybe
                collapsibleSNITrayMaxVisibleIcons
                (sniPriorityFileMaxVisibleIcons persistedPriorityFile)
            )
        initialVisibilityThreshold =
          case sniPriorityFileVisibilityThreshold persistedPriorityFile of
            Nothing -> visibilityThreshold
            Just persistedThreshold -> clampPriority <$> persistedThreshold
    prioritiesRef <- newIORef persistedPriorities
    expandedRef <- newIORef collapsibleSNITrayStartExpanded
    hoverExpandedRef <- newIORef False
    hoverPollStateRef <- newIORef HoverIdle
    hoverPollActiveRef <- newIORef False
    animationSerialRef <- newIORef (0 :: Int)
    animationActiveRef <- newIORef False
    priorityEditModeRef <- newIORef prioritizedCollapsibleSNITrayStartPriorityEditMode
    maxVisibleIconsRef <- newIORef initialMaxVisibleIcons
    visibilityThresholdRef <- newIORef initialVisibilityThreshold
    hiddenCountRef <- newIORef 0
    orderedInfosRef <- newIORef ([] :: [H.ItemInfo])
    processDisambiguationKeysRef <- newIORef (M.empty :: M.Map String String)
    trayRef <- newIORef Nothing
    updateHandlerRef <- newIORef Nothing

    outer <- Gtk.boxNew trayOrientation' 0
    _ <- widgetSetClassGI outer "sni-tray-collapsible"
    _ <- widgetSetClassGI outer "sni-tray-prioritized-collapsible"
    outerEventBox <- Gtk.eventBoxNew
    _ <- widgetSetClassGI outerEventBox "sni-tray-hover-expand-target"
    Gtk.containerAdd outerEventBox outer
    outerWidget <- Gtk.toWidget outerEventBox

    trayContainer <- Gtk.boxNew trayOrientation' 0
    _ <- widgetSetClassGI trayContainer "sni-tray-collapsible-container"
    trayClipper <-
      Gtk.scrolledWindowNew
        (Nothing :: Maybe Gtk.Adjustment)
        (Nothing :: Maybe Gtk.Adjustment)
    Gtk.scrolledWindowSetPolicy trayClipper Gtk.PolicyTypeNever Gtk.PolicyTypeNever
    Gtk.scrolledWindowSetShadowType trayClipper Gtk.ShadowTypeNone
    Gtk.scrolledWindowSetOverlayScrolling trayClipper False
    Gtk.scrolledWindowSetPropagateNaturalWidth trayClipper False
    Gtk.scrolledWindowSetPropagateNaturalHeight trayClipper False
    _ <- widgetSetClassGI trayClipper "sni-tray-collapsible-clipper"

    overflowCountLabel <- Gtk.labelNew Nothing
    _ <- widgetSetClassGI overflowCountLabel "sni-tray-overflow-count-label"

    settingsIcon <- Gtk.imageNewFromIconName (Just "emblem-system-symbolic") menuIconSize
    settingsContent <- Gtk.boxNew trayOrientation' 3
    _ <- widgetSetClassGI settingsContent "sni-tray-settings-toggle-content"
    Gtk.boxPackStart settingsContent settingsIcon False False 0
    Gtk.boxPackStart settingsContent overflowCountLabel False False 0
    settingsToggle <- Gtk.eventBoxNew
    _ <- widgetSetClassGI settingsToggle "sni-tray-settings-toggle"
    Gtk.containerAdd settingsToggle settingsContent
    Gtk.widgetSetTooltipText settingsToggle (Just "Tray controls")

    Gtk.boxPackStart outer trayContainer False False 0
    Gtk.boxPackStart outer settingsToggle False False 0

    let persistCurrentState = do
          priorities <- readIORef prioritiesRef
          maxVisibleIcons <- readIORef maxVisibleIconsRef
          visibilityThresholdOverride <- readIORef visibilityThresholdRef
          persistSNIPriorityFileToFile
            statePath
            SNIPriorityFile
              { sniPriorityFilePriorities = priorities,
                sniPriorityFileMaxVisibleIcons = Just (max 0 maxVisibleIcons),
                sniPriorityFileVisibilityThreshold = Just visibilityThresholdOverride
              }

        processKeyForInfoFromMap processKeyMap info =
          M.lookup (itemStableIdentity info) processKeyMap

        updateOrderedInfos recomputeProcessKeys = do
          infoMap <- H.itemInfoMap host
          let infos = M.elems infoMap
          processKeyMap <-
            if recomputeProcessKeys
              then processDisambiguationKeysForItems client infos
              else readIORef processDisambiguationKeysRef
          when recomputeProcessKeys $
            writeIORef processDisambiguationKeysRef processKeyMap
          priorities <- readIORef prioritiesRef
          let priorityForInfo info =
                itemPriorityFromMap
                  priorityMin
                  priorityMax
                  defaultPriority
                  priorities
                  (processKeyForInfoFromMap processKeyMap info)
                  info
              orderedInfos =
                sortedInfosByPriority
                  highPriorityFirstInTrayOrder
                  priorityMin
                  priorityMax
                  defaultPriority
                  priorities
                  (processKeyForInfoFromMap processKeyMap)
                  infos
          writeIORef orderedInfosRef orderedInfos
          prioritizedTrayLog DEBUG $
            printf
              "Prioritized tray computed order recomputeProcessKeys=%s count=%d order=[%s]"
              (show recomputeProcessKeys)
              (length orderedInfos)
              (describeOrderedInfos priorityForInfo (processKeyForInfoFromMap processKeyMap) orderedInfos)
          return orderedInfos

        scheduleRefresh recomputeProcessKeys waitForExactChildCount updateType = do
          attemptsRef <- newIORef (0 :: Int)
          void $
            Gdk.threadsAddIdle GLib.PRIORITY_DEFAULT $
              do
                orderedInfos <- updateOrderedInfos recomputeProcessKeys
                maybeTray <- readIORef trayRef
                case maybeTray of
                  Nothing -> return False
                  Just tray -> do
                    childCount <- length <$> Gtk.containerGetChildren tray
                    let expectedChildCount = length orderedInfos
                    attempts <- readIORef attemptsRef
                    if waitForExactChildCount && childCount /= expectedChildCount && attempts < 50
                      then do
                        when (attempts == 0 || attempts == 49) $
                          prioritizedTrayLog DEBUG $
                            printf
                              "Delaying prioritized tray refresh update=%s; attempt=%d childCount=%d expected=%d"
                              (show updateType)
                              attempts
                              childCount
                              expectedChildCount
                        writeIORef attemptsRef (attempts + 1)
                        return True
                      else do
                        void $ refreshTray tray
                        return False

        editPriorityForClick clickContext = do
          let clickedInfo = trayClickItemInfo clickContext
          priorities <- readIORef prioritiesRef
          processKeyMap <- readIORef processDisambiguationKeysRef
          let maybeProcessKey = processKeyForInfoFromMap processKeyMap clickedInfo
              currentExplicit =
                lookupExplicitPriority priorities maybeProcessKey clickedInfo
              updatePriority newPriority = do
                setExplicitPriorityForItem
                  prioritiesRef
                  (\_ -> persistCurrentState >> scheduleRefresh False False H.IconUpdated)
                  maybeProcessKey
                  clickedInfo
                  (fmap clampPriority newPriority)
          showPriorityEditMenu
            outerWidget
            priorityMin
            priorityMax
            defaultPriority
            currentExplicit
            updatePriority

        refreshPriorityModeToggle = do
          editing <- readIORef priorityEditModeRef
          if editing
            then do
              addClassIfMissing "sni-tray-editing" outer
            else do
              removeClassIfPresent "sni-tray-editing" outer

        getEffectiveExpanded = do
          expanded <- readIORef expandedRef
          hoverExpanded <- readIORef hoverExpandedRef
          return (expanded || hoverExpanded)

        computeNaturalVisibleCount totalCount = do
          effectiveExpanded <- getEffectiveExpanded
          priorities <- readIORef prioritiesRef
          maxVisibleIcons <- readIORef maxVisibleIconsRef
          thresholdValue <- readIORef visibilityThresholdRef
          orderedInfos <- readIORef orderedInfosRef
          processKeyMap <- readIORef processDisambiguationKeysRef
          let itemPriority info =
                itemPriorityFromMap
                  priorityMin
                  priorityMax
                  defaultPriority
                  priorities
                  (processKeyForInfoFromMap processKeyMap info)
                  info
              collapsedThresholdVisibleCount =
                case thresholdValue of
                  Nothing -> totalCount
                  Just threshold ->
                    min
                      totalCount
                      (length $ filter (\info -> itemPriority info >= threshold) orderedInfos)
              collapsedVisibleCount
                | maxVisibleIcons > 0 =
                    min collapsedThresholdVisibleCount maxVisibleIcons
                | otherwise = collapsedThresholdVisibleCount
          return $
            if effectiveExpanded
              then totalCount
              else collapsedVisibleCount

        childPreferredExtent child =
          case trayOrientation' of
            Gtk.OrientationVertical -> snd <$> Gtk.widgetGetPreferredHeight child
            _ -> snd <$> Gtk.widgetGetPreferredWidth child

        preferredTrayExtentForCount tray children visibleCount = do
          childExtents <- mapM childPreferredExtent (take visibleCount children)
          spacing <- Gtk.boxGetSpacing tray
          let spacingExtent =
                if visibleCount > 1
                  then fromIntegral (visibleCount - 1) * spacing
                  else 0
          return $ sum childExtents + spacingExtent

        setTrayClipperExtent extent =
          case trayOrientation' of
            Gtk.OrientationVertical ->
              Gtk.widgetSetSizeRequest trayClipper (-1) (fromIntegral extent)
            _ ->
              Gtk.widgetSetSizeRequest trayClipper (fromIntegral extent) (-1)

        allocatedTrayClipperExtent = do
          allocatedExtent <-
            case trayOrientation' of
              Gtk.OrientationVertical -> Gtk.widgetGetAllocatedHeight trayClipper
              _ -> Gtk.widgetGetAllocatedWidth trayClipper
          return $ max 0 allocatedExtent

        easeOutCubic :: Double -> Double
        easeOutCubic progress =
          1 - ((1 - progress) ^ (3 :: Int))

        animateTrayExtentTo tray targetVisibleCount = do
          modifyIORef' animationSerialRef (+ 1)
          animationSerial <- readIORef animationSerialRef
          writeIORef animationActiveRef True
          children <- Gtk.containerGetChildren tray
          forM_ children Gtk.widgetShow
          startExtent <- allocatedTrayClipperExtent
          targetExtent <- preferredTrayExtentForCount tray children targetVisibleCount
          let durationMs = prioritizedCollapsibleSNITrayHoverAnimationDurationMs
          if durationMs == 0 || startExtent == targetExtent
            then do
              setTrayClipperExtent targetExtent
              writeIORef animationActiveRef False
              void $ refreshTray tray
            else do
              startTime <- GLib.getMonotonicTime
              let durationUs = fromIntegral durationMs * 1000 :: Int64
                  extentAt now =
                    let elapsed = max 0 (now - startTime)
                        progress =
                          min
                            1
                            (fromIntegral elapsed / fromIntegral durationUs :: Double)
                        eased = easeOutCubic progress
                     in round $
                          fromIntegral startExtent
                            + (fromIntegral (targetExtent - startExtent) * eased :: Double)
              void $
                GLib.timeoutAdd GLib.PRIORITY_DEFAULT 16 $ do
                  currentSerial <- readIORef animationSerialRef
                  if currentSerial /= animationSerial
                    then return False
                    else do
                      now <- GLib.getMonotonicTime
                      setTrayClipperExtent (extentAt now)
                      if now - startTime >= durationUs
                        then do
                          setTrayClipperExtent targetExtent
                          writeIORef animationActiveRef False
                          void $ refreshTray tray
                          return False
                        else return True

        setHoverExpanded shouldExpand = do
          wasHoverExpanded <- readIORef hoverExpandedRef
          writeIORef hoverExpandedRef shouldExpand
          maybeTray <- readIORef trayRef
          case maybeTray of
            Nothing -> return ()
            Just tray ->
              when (wasHoverExpanded /= shouldExpand) $
                do
                  children <- Gtk.containerGetChildren tray
                  targetVisibleCount <- computeNaturalVisibleCount (length children)
                  animateTrayExtentTo tray targetVisibleCount

        hoverPollIntervalMs = 100 :: Word32

        engageHoverPoll = do
          state <- readIORef hoverPollStateRef
          case state of
            HoverIdle -> do
              now <- GLib.getMonotonicTime
              writeIORef hoverPollStateRef (HoverPendingExpand now)
            _ -> return ()
          pollActive <- readIORef hoverPollActiveRef
          unless pollActive $ do
            writeIORef hoverPollActiveRef True
            void $
              GLib.timeoutAdd GLib.PRIORITY_DEFAULT hoverPollIntervalMs $ do
                keepPolling <- stepHoverPoll
                unless keepPolling $ writeIORef hoverPollActiveRef False
                return keepPolling

        stepHoverPoll = do
          state <- readIORef hoverPollStateRef
          now <- GLib.getMonotonicTime
          let expandDelayUs =
                fromIntegral prioritizedCollapsibleSNITrayHoverExpandDelayMs * 1000 :: Int64
              collapseDelayUs =
                fromIntegral prioritizedCollapsibleSNITrayHoverCollapseDelayMs * 1000 :: Int64
          case state of
            HoverIdle -> return False
            HoverPendingExpand since -> do
              inside <- pointerWithinWidget outerEventBox
              if not inside
                then do
                  writeIORef hoverPollStateRef HoverIdle
                  return False
                else
                  if now - since >= expandDelayUs
                    then do
                      setHoverExpanded True
                      writeIORef hoverPollStateRef HoverExpanded
                      return True
                    else return True
            HoverExpanded -> do
              inside <- pointerWithinWidget outerEventBox
              if inside
                then return True
                else do
                  writeIORef hoverPollStateRef (HoverPendingCollapse now)
                  return True
            HoverPendingCollapse since -> do
              inside <- pointerWithinWidget outerEventBox
              if inside
                then do
                  writeIORef hoverPollStateRef HoverExpanded
                  return True
                else
                  if now - since >= collapseDelayUs
                    then do
                      setHoverExpanded False
                      writeIORef hoverPollStateRef HoverIdle
                      return False
                    else return True

        cancelHoverExpansion = do
          writeIORef hoverPollStateRef HoverIdle
          writeIORef hoverExpandedRef False
          modifyIORef' animationSerialRef (+ 1)
          writeIORef animationActiveRef False

        refreshTray tray = do
          effectiveExpanded <- getEffectiveExpanded
          animationActive <- readIORef animationActiveRef
          orderedInfos <- readIORef orderedInfosRef
          reorderTrayChildrenByIdentities tray (map itemStableIdentity orderedInfos)
          children <- Gtk.containerGetChildren tray

          naturalVisibleCount <- computeNaturalVisibleCount (length children)
          priorities <- readIORef prioritiesRef
          processKeyMap <- readIORef processDisambiguationKeysRef
          let totalCount = length children
              visibleCount =
                max 0 (min totalCount naturalVisibleCount)
              hiddenCount = max 0 (totalCount - visibleCount)
              hiddenCountText = T.pack ('+' : show hiddenCount)
              priorityForInfo info =
                itemPriorityFromMap
                  priorityMin
                  priorityMax
                  defaultPriority
                  priorities
                  (processKeyForInfoFromMap processKeyMap info)
                  info
              orderedInfoByIdentity =
                M.fromList [(itemStableIdentity info, info) | info <- orderedInfos]
              describeChildIdentity index maybeIdentity =
                case maybeIdentity >>= (`M.lookup` orderedInfoByIdentity) of
                  Just info ->
                    printf
                      "%d:{%s}"
                      index
                      (describeItemForOrder priorityForInfo (processKeyForInfoFromMap processKeyMap) info)
                  Nothing ->
                    printf
                      "%d:{identity=%s}"
                      index
                      (formatMaybe maybeIdentity)
          childIdentities <- mapM Tray.getTrayItemIdentity children
          prioritizedTrayLog DEBUG $
            printf
              "Prioritized tray rendered order expanded=%s animating=%s visible=%d hidden=%d total=%d children=[%s]"
              (show effectiveExpanded)
              (show animationActive)
              visibleCount
              hiddenCount
              totalCount
              (intercalate " | " (zipWith describeChildIdentity [0 :: Int ..] childIdentities))

          forM_ (zip [0 :: Int ..] children) $ \(childIndex, child) -> do
            let shouldShow = animationActive || childIndex < visibleCount
            isVisible <- Gtk.widgetGetVisible child
            when (isVisible /= shouldShow) $
              if shouldShow
                then Gtk.widgetShow child
                else Gtk.widgetHide child
          unless animationActive $ do
            visibleExtent <- preferredTrayExtentForCount tray children visibleCount
            setTrayClipperExtent visibleExtent
          writeIORef hiddenCountRef hiddenCount

          if hiddenCount > 0
            then do
              Gtk.labelSetText overflowCountLabel hiddenCountText
              Gtk.widgetShow overflowCountLabel
            else do
              Gtk.labelSetText overflowCountLabel ""
              Gtk.widgetHide overflowCountLabel

          if effectiveExpanded
            then addClassIfMissing "sni-tray-collapsible-expanded" outer
            else removeClassIfPresent "sni-tray-collapsible-expanded" outer

          hoverExpanded <- readIORef hoverExpandedRef
          if hoverExpanded
            then addClassIfMissing "sni-tray-hover-expanded" outer
            else removeClassIfPresent "sni-tray-hover-expanded" outer

          return hiddenCount

        refresh = do
          maybeTray <- readIORef trayRef
          case maybeTray of
            Nothing -> return 0
            Just tray -> refreshTray tray

        queueRefresh updateType _ =
          case updateType of
            H.ItemAdded -> scheduleRefresh True True updateType
            H.ItemRemoved -> scheduleRefresh True True updateType
            H.IconUpdated -> scheduleRefresh False False updateType
            H.TitleUpdated -> scheduleRefresh False False updateType
            H.OverlayIconUpdated -> return ()
            H.ToolTipUpdated -> return ()
            H.StatusUpdated -> return ()

        installUpdateHandler = do
          maybeHandlerId <- readIORef updateHandlerRef
          case maybeHandlerId of
            Just handlerId ->
              prioritizedTrayLog DEBUG $
                printf
                  "installUpdateHandler: handler already registered id=%d"
                  (hashUnique handlerId)
            Nothing -> do
              handlerId <- H.addUpdateHandler host queueRefresh
              prioritizedTrayLog INFO $
                printf
                  "Registered prioritized tray host update handler id=%d"
                  (hashUnique handlerId)
              writeIORef updateHandlerRef (Just handlerId)

        buildTrayForPrioritizedWrapper = do
          let baseHooks = trayEventHooks sniTrayTrayParams
              baseClickHook = trayClickHook baseHooks
              combinedClickHook clickContext = do
                editMode <- readIORef priorityEditModeRef
                if editMode
                  then do
                    editPriorityForClick clickContext
                    return ConsumeClick
                  else case baseClickHook of
                    Just clickHook -> clickHook clickContext
                    Nothing -> return UseDefaultClickAction
              trayParams =
                -- This wrapper owns ordering and visibility. Keep the inner
                -- tray as a widget factory with straightforward child packing.
                sniTrayTrayParams
                  { trayAlignment = Beginning,
                    trayPriorityConfig = Tray.defaultTrayPriorityConfig,
                    trayEventHooks =
                      baseHooks {trayClickHook = Just combinedClickHook},
                    trayShowNewIconsImmediately = False
                  }
          tray <- buildTray host client trayParams
          _ <- widgetSetClassGI tray "sni-tray"
          return tray

    _ <- Gtk.onWidgetButtonPressEvent settingsToggle $ \event -> do
      eventType <- Gdk.getEventButtonType event
      button <- Gdk.getEventButtonButton event
      if eventType == Gdk.EventTypeButtonPress && button == 1
        then do
          showPriorityControlsMenuWithExplicitCollapse
            settingsToggle
            priorityMin
            priorityMax
            prioritizedCollapsibleSNITrayAlwaysShowExpandToggle
            prioritizedCollapsibleSNITrayPriorityModeLabel
            expandedRef
            priorityEditModeRef
            hiddenCountRef
            maxVisibleIconsRef
            visibilityThresholdRef
            cancelHoverExpansion
            (refreshPriorityModeToggle >> void refresh)
            (persistCurrentState >> scheduleRefresh False False H.ToolTipUpdated)
          return True
        else return False

    when prioritizedCollapsibleSNITrayHoverExpand $ do
      Gtk.widgetAddEvents settingsToggle [Gdk.EventMaskEnterNotifyMask]
      _ <- Gtk.onWidgetEnterNotifyEvent settingsToggle $ \_event -> do
        engageHoverPoll
        return False
      return ()

    _ <-
      Gtk.onWidgetDestroy outerEventBox $
        readIORef updateHandlerRef
          >>= traverse_
            ( \handlerId -> do
                prioritizedTrayLog INFO $
                  printf
                    "Removing prioritized tray host update handler id=%d"
                    (hashUnique handlerId)
                H.removeUpdateHandler host handlerId
            )

    _ <- updateOrderedInfos True
    tray <- buildTrayForPrioritizedWrapper
    Gtk.containerAdd trayClipper tray
    Gtk.boxPackStart trayContainer trayClipper False False 0
    writeIORef trayRef (Just tray)
    installUpdateHandler
    Gtk.widgetShow tray

    Gtk.widgetShowAll outerWidget
    refreshPriorityModeToggle
    _ <- refresh
    return outerWidget
