taffybar 7.1.0 → 7.2.0

raw patch · 55 files changed

+3752/−504 lines, 55 filesdep +gi-gobjectdep +gi-wireplumberdep ~JuicyPixelsdep ~QuickCheckdep ~X11

Dependencies added: gi-gobject, gi-wireplumber

Dependency ranges changed: JuicyPixels, QuickCheck, X11, aeson, ansi-terminal, attoparsec, bytestring, conduit, containers, data-default, dbus, dbus-hslogger, dbus-menu, dhall, directory, disk-free-space, either, enclosed-exceptions, extra, filepath, gi-cairo-connector, gi-cairo-render, gi-glib, gi-gtk-layer-shell, gi-pango, gtk-scaling-image, gtk-sni-tray, gtk-strut, haskell-gi-base, hslogger, hspec, http-client, http-client-tls, http-conduit, http-types, monad-control, multimap, network, optparse-applicative, parsec, process, rate-limit, regex-compat, split, status-notifier-item, stm, template-haskell, text, time, time-units, transformers, tuple, typed-process, unix, unliftio, unliftio-core, utf8-string, xdg-desktop-entry, xml, xml-helpers, xmonad, xmonad-contrib, yaml

Files

• CHANGELOG.md +54/−1
• dbus-xml/org.imalison.ChromeWindowInfo.xml +22/−0
• src/System/Taffybar.hs +52/−1
• src/System/Taffybar/Context.hs +170/−40
• src/System/Taffybar/Context/Backend.hs +120/−30
• src/System/Taffybar/DBus/Client/ChromeWindowInfo.hs +17/−0
• src/System/Taffybar/DBus/Client/Params.hs +23/−3
• src/System/Taffybar/Hooks.hs +12/−4
• src/System/Taffybar/Information/AnthropicUsage.hs +3/−2
• src/System/Taffybar/Information/Audio.hs +195/−0
• src/System/Taffybar/Information/Battery.hs +16/−3
• src/System/Taffybar/Information/CPU2.hs +3/−1
• src/System/Taffybar/Information/Chrome.hs +2/−1
• src/System/Taffybar/Information/ChromeWindowInfo.hs +90/−0
• src/System/Taffybar/Information/Hyprland.hs +2/−3
• src/System/Taffybar/Information/Hyprland/API.hs +24/−4
• src/System/Taffybar/Information/Hyprland/Types.hs +2/−0
• src/System/Taffybar/Information/HyprlandWorkspaceHistory.hs +102/−0
• src/System/Taffybar/Information/Memory.hs +2/−1
• src/System/Taffybar/Information/Network.hs +1/−1
• src/System/Taffybar/Information/NetworkManager.hs +6/−6
• src/System/Taffybar/Information/OpenAIUsage.hs +203/−7
• src/System/Taffybar/Information/Privacy.hs +1/−5
• src/System/Taffybar/Information/PulseAudio.hs +9/−1
• src/System/Taffybar/Information/Wakeup/Manager.hs +5/−3
• src/System/Taffybar/Information/WirePlumber.hs +479/−72
• src/System/Taffybar/Information/Workspaces/EWMH.hs +13/−7
• src/System/Taffybar/Information/Workspaces/Hyprland.hs +177/−16
• src/System/Taffybar/Information/Workspaces/Model.hs +70/−1
• src/System/Taffybar/Information/Workspaces/Refresh.hs +75/−0
• src/System/Taffybar/Information/XDG/Protocol.hs +16/−6
• src/System/Taffybar/Util.hs +1/−1
• src/System/Taffybar/Widget.hs +4/−0
• src/System/Taffybar/Widget/AnthropicUsage.hs +120/−30
• src/System/Taffybar/Widget/Audio.hs +275/−0
• src/System/Taffybar/Widget/BatteryTextIcon.hs +2/−1
• src/System/Taffybar/Widget/FreedesktopNotifications.hs +1/−1
• src/System/Taffybar/Widget/Generic/Graph.hs +5/−1
• src/System/Taffybar/Widget/MPRIS2.hs +2/−2
• src/System/Taffybar/Widget/OmniMenu.hs +213/−0
• src/System/Taffybar/Widget/OpenAIUsage.hs +199/−45
• src/System/Taffybar/Widget/SNITray/PrioritizedCollapsible.hs +344/−83
• src/System/Taffybar/Widget/WakeupDebug.hs +6/−2
• src/System/Taffybar/Widget/Weather.hs +12/−4
• src/System/Taffybar/Widget/Windows.hs +27/−13
• src/System/Taffybar/Widget/Workspaces.hs +53/−19
• src/System/Taffybar/Widget/WttrIn.hs +1/−3
• src/System/Taffybar/Window/FocusedMonitor.hs +14/−3
• src/System/Taffybar/WindowIcon.hs +8/−5
• taffybar.cabal +88/−71
• test/data/appearance-hyprland-bar.png binary
• test/unit/System/Taffybar/ContextSpec.hs +144/−0
• test/unit/System/Taffybar/Information/Workspaces/HyprlandSpec.hs +124/−0
• test/unit/System/Taffybar/Widget/SNITray/PrioritizedCollapsibleSpec.hs +115/−0
• test/unit/System/Taffybar/Widget/Workspaces/ChannelSpec.hs +28/−1

@@ -1,22 +1,75 @@+# 7.2.0++## New Features++* Add the OmniMenu widget and supporting desktop-entry parsing updates.+* Add WirePlumber-backed audio information and expose it through the audio+  widget fallback path.+* Add Hyprland workspace history ordering, pinned-window tracking, special+  workspace remapping, and external workspace icon refresh support.+* Use the generated ChromeWindowInfo DBus client.++## Fixes++* Prefer live Hyprland backends over stale X11/Wayland environment state.+* Improve Hyprland lifecycle recovery, workspace redraws, workspace sorting,+  and workspace icon activation.+* Fix HiDPI scaled-image rendering and normalize menu icon sizing.+* Stabilize SNI tray ordering and prioritized tray hover expansion.+* Clean up Stan/compiler diagnostics across the monorepo.++## Packaging++* Bump companion-package lower bounds for the refreshed monorepo package+  releases.+* Add and depend on `gi-wireplumber >= 0.5.14.1`.+* Bump the package version to 7.2.0.+ # 7.1.0  ## New Features  * Add structured OpenAI usage information and an OpenAI usage widget. * Add Anthropic usage information and an Anthropic usage widget.+* Expose the new OpenAI and Anthropic usage information/widget modules from+  the library.  ## Fixes  * Refresh window state after Hyprland reconnects.-* Fix backend detection and X11 strut sizing.+* Fix backend detection by preparing display environment variables before GTK+  initialization, preferring explicit X11 sessions over stale Wayland sockets,+  validating live Hyprland sockets, and detecting the backend from the GDK+  display when possible.+* Fix X11 strut/window handling by safely checking that realized GTK windows+  are X11 windows before lowering them. * Handle non-X11 GDK windows safely. * Stabilize CSS loading for themed end widgets.+* Apply end-widget pill palettes directly at runtime and use+  `nth-last-child` selectors for end pill rotation.  ## Refactors  * Decouple layout and workspace/window information providers from widget   rendering, and move shared workspace/window support helpers out of widget   modules.+* Clean up imports and internal helper code in the Hyprland layout and+  workspaces modules.+* Refresh vendored companion-package code in the monorepo, including+  `dbus-hslogger`, `dbus-menu`, `gtk-sni-tray`, `gtk-strut`,+  `status-notifier-item`, `xdg-desktop-entry`, and `gtk-scaling-image`.++## Tests++* Add backend-detection coverage for explicit X11 sessions when ambient+  Wayland sockets are present.+* Add `network` to the unit-test dependencies for Unix socket test support.+* Clean up unit-test imports.++## Packaging++* Bump the package version to 7.1.0.+* Update `flake.lock`.  # 7.0.1 

@@ -0,0 +1,22 @@+<!DOCTYPE node PUBLIC "-//freedesktop//DTD D-BUS Object Introspection 1.0//EN"+"https://www.freedesktop.org/standards/dbus/1.0/introspect.dtd">+<node>+ <interface name="org.imalison.ChromeWindowInfo">+  <method name="GetLastPayload">+   <arg type="s" name="payload_json" direction="out"/>+  </method>+  <method name="GetWindowPayloads">+   <arg type="s" name="payloads_json" direction="out"/>+  </method>+  <method name="GetSchema">+   <arg type="s" name="schema" direction="out"/>+  </method>+  <signal name="Updated">+   <arg type="s" name="payload_json"/>+  </signal>+  <signal name="WindowUpdated">+   <arg type="s" name="window_id"/>+   <arg type="s" name="payload_json"/>+  </signal>+ </interface>+</node>

@@ -130,13 +130,16 @@  import qualified Config.Dyre as Dyre import qualified Config.Dyre.Params as Dyre+import Control.Concurrent (threadDelay) import qualified Control.Concurrent.MVar as MV import Control.Exception (finally)+import Control.Exception.Enclosed (catchAny) import Control.Monad import Data.Char (toLower) import Data.Function (on) import qualified Data.GI.Gtk.Threading as GIThreading import Data.List (groupBy, isPrefixOf, sort)+import Data.Maybe (isJust) import qualified Data.Text as T import Data.Word (Word32) import qualified GI.GLib as G@@ -152,6 +155,7 @@ import System.FilePath (normalise, splitSearchPath, takeDirectory, takeFileName, (</>)) import qualified System.IO as IO import System.Log.Logger+import System.Posix.Files (getFileStatus, isSocket) import System.Taffybar.Context import System.Taffybar.Context.Backend (prepareBackendEnvironment) import System.Taffybar.Hooks@@ -343,7 +347,7 @@    -- Fix up stale session-manager environment before GTK/GDK choose a display,   -- then use GDK's actual opened display as the source of truth.-  prepareBackendEnvironment+  waitForBackendEnvironment   void initThreads    _ <- Gtk.init Nothing@@ -361,6 +365,53 @@         exitTaffybar context    logTaffy DEBUG "Exited normally"++waitForBackendEnvironment :: IO ()+waitForBackendEnvironment = do+  prepareBackendEnvironment+  shouldWait <- shouldWaitForWaylandDisplay+  when shouldWait $ do+    logTaffy NOTICE "Waiting for Wayland display before starting GTK"+    go (120 :: Int)+  where+    retryDelayMicros = 500000++    go 0 = do+      prepareBackendEnvironment+      stillWaiting <- shouldWaitForWaylandDisplay+      when stillWaiting $+        logTaffy WARNING "Starting GTK even though no Wayland display socket is available"+    go n = do+      threadDelay retryDelayMicros+      prepareBackendEnvironment+      shouldWait <- shouldWaitForWaylandDisplay+      when shouldWait $ go (n - 1)++shouldWaitForWaylandDisplay :: IO Bool+shouldWaitForWaylandDisplay = do+  mRuntime <- lookupEnv "XDG_RUNTIME_DIR"+  mDisplay <- lookupEnv "DISPLAY"+  mSessionType <- lookupEnv "XDG_SESSION_TYPE"+  mWaylandDisplay <- lookupEnv "WAYLAND_DISPLAY"+  let explicitX11Session =+        mSessionType == Just "x11" && maybe False (not . null) mDisplay+      expectsWayland =+        not explicitX11Session+          && (mSessionType == Just "wayland" || isJust mWaylandDisplay)+  if not expectsWayland+    then pure False+    else do+      waylandOk <- maybe (pure False) isWaylandDisplaySocket $ do+        runtime <- mRuntime+        waylandDisplay <- mWaylandDisplay+        pure (runtime </> waylandDisplay)+      pure $ not waylandOk++isWaylandDisplaySocket :: FilePath -> IO Bool+isWaylandDisplaySocket path =+  catchAny+    (isSocket <$> getFileStatus path)+    (const $ pure False)  logTaffy :: Priority -> String -> IO () logTaffy = logM "System.Taffybar"

@@ -87,6 +87,7 @@ import Control.Monad.Trans.Reader import qualified DBus as D import qualified DBus.Client as DBus+import Data.Char (toLower) import Data.Data import Data.Default (Default (..)) import Data.GI.Base (castTo)@@ -106,8 +107,17 @@ import qualified GI.GtkLayerShell as GtkLayerShell import Graphics.UI.GIGtkStrut import StatusNotifier.TransparentWindow+import System.Environment (getArgs, getExecutablePath, lookupEnv)+import System.Exit (ExitCode (ExitFailure, ExitSuccess)) import System.Log.Logger (Priority (..), logM)-import System.Taffybar.Context.Backend (Backend (..), detectBackend)+import System.Posix.Process (exitImmediately)+import System.Process+  ( CreateProcess (close_fds, new_session, std_err, std_in, std_out),+    StdStream (NoStream),+    createProcess,+    proc,+  )+import System.Taffybar.Context.Backend (Backend (..), detectBackend, prepareBackendEnvironment) import qualified System.Taffybar.DBus.Client.Params as DBusParams import System.Taffybar.Information.EWMHDesktopInfo   ( ewmhActiveWindow,@@ -137,7 +147,6 @@     setupFocusedMonitorClassUpdates,   ) import Text.Printf-import Unsafe.Coerce  logIO :: Priority -> String -> IO () logIO = logM "System.Taffybar.Context"@@ -159,12 +168,7 @@ data Value = forall t. (Typeable t) => Value t  fromValue :: forall t. (Typeable t) => Value -> Maybe t-fromValue (Value v) =-  if typeOf v == typeRep (Proxy :: Proxy t)-    then-      Just $ unsafeCoerce v-    else-      Nothing+fromValue (Value v) = cast v  -- | 'BarConfig' specifies the configuration for a single taffybar window. data BarLevelConfig = BarLevelConfig@@ -340,18 +344,22 @@               backend = backendType,               contextBarConfig = Nothing             }-    _ <--      runMaybeT $-        MaybeT GI.Gdk.displayGetDefault-          >>= (lift . GI.Gdk.displayGetDefaultScreen)-          >>= ( lift-                  . flip-                    GI.Gdk.afterScreenMonitorsChanged-                    -- XXX: We have to do a force refresh here because there is no-                    -- way to reliably move windows, since the window manager can do-                    -- whatever it pleases.-                    (runReaderT forceRefreshTaffyWindows context)-              )+    when (backendType == BackendX11) $+      void $+        runMaybeT $+          MaybeT GI.Gdk.displayGetDefault+            >>= (lift . GI.Gdk.displayGetDefaultScreen)+            >>= ( lift+                    . flip+                      GI.Gdk.afterScreenMonitorsChanged+                      -- XXX: We have to do a force refresh here because there is no+                      -- way to reliably move windows, since the window manager can do+                      -- whatever it pleases.+                      ( runReaderT+                          (forceRefreshTaffyWindowsBecause "gdk screen monitors changed")+                          context+                      )+                )      -- Some compositors/backends will keep the reserved space for a layer-shell     -- surface/strut window after suspend, but fail to properly re-display the@@ -396,7 +404,10 @@           threadDelay 1_000_000           _ <- MV.swapMVar pendingVar False           logIO NOTICE "Resumed from sleep - forcing taffybar window refresh"-          postGUIASync $ runReaderT forceRefreshTaffyWindows ctx+          postGUIASync $+            runReaderT+              (forceRefreshTaffyWindowsBecause "logind resume")+              ctx        callback :: D.Signal -> IO ()       callback sig =@@ -416,19 +427,25 @@           ++ show e     Right _ -> pure () --- | Recreate Wayland bar windows when the Hyprland event socket reconnects.+-- | Recover Wayland bars when the Hyprland event socket reconnects. -- -- Hyprland restarts can leave existing layer-shell surfaces invisible even -- though the taffybar process and widget state loops are still alive. The -- Hyprland event reader emits @taffybar-hyprland-connected@ after every event--- socket connection, so use reconnects as the compositor-lifecycle signal and--- force a top-level window refresh.+-- socket connection, so use reconnects as the compositor-lifecycle signal.+--+-- By default this re-execs taffybar. A full compositor restart can invalidate+-- GTK's Wayland display connection itself, so merely recreating Gtk.Window+-- values in the same process is not reliable. Set+-- @TAFFYBAR_HYPRLAND_RECONNECT_ACTION=refresh@ to keep the older window-only+-- refresh behavior while debugging. registerHyprlandReconnectRefresh :: Context -> IO () registerHyprlandReconnectRefresh ctx = do   eventChan <- withHyprlandEventChan ctx   events <- subscribeHyprlandEvents eventChan   readyVar <- MV.newMVar False-  pendingVar <- MV.newMVar False+  recoveryPendingVar <- MV.newMVar False+  monitorRefreshPendingVar <- MV.newMVar False   void $ forkIO $ do     -- The event reader also emits a connection event during normal startup.     -- Ignore early connection events so startup does not immediately rebuild@@ -436,29 +453,141 @@     threadDelay 2_000_000     void $ MV.swapMVar readyVar True -  let isConnectedEvent line =-        T.takeWhile (/= '>') line == "taffybar-hyprland-connected"+  let lifecycleEventName line =+        let hyprlandEventName = T.takeWhile (/= '>') line+         in if hyprlandEventName+              `elem` [ "taffybar-hyprland-connected",+                       "configreloaded"+                     ]+              then Just hyprlandEventName+              else Nothing -      scheduleRefresh = do-        wasPending <- MV.swapMVar pendingVar True+      monitorEventName line =+        let hyprlandEventName = T.takeWhile (/= '>') line+         in if hyprlandEventName+              `elem` [ "monitoradded",+                       "monitorremoved"+                     ]+              then Just hyprlandEventName+              else Nothing++      scheduleProcessRecovery reason = do+        wasPending <- MV.swapMVar recoveryPendingVar True         unless wasPending $ void $ forkIO $ do           -- Give Hyprland/GDK a short settling window before rebuilding           -- layer-shell surfaces.           threadDelay 1_000_000-          _ <- MV.swapMVar pendingVar False-          logIO NOTICE "Hyprland event socket reconnected - forcing taffybar window refresh"-          postGUIASync $ runReaderT forceRefreshTaffyWindows ctx+          _ <- MV.swapMVar recoveryPendingVar False+          action <- hyprlandReconnectAction+          case action of+            "refresh" -> do+              logIO NOTICE $ "Hyprland " ++ reason ++ " - forcing taffybar window refresh"+              postGUIASync $+                runReaderT+                  (forceRefreshTaffyWindowsBecause $ "hyprland " ++ reason)+                  ctx+            _ -> restartTaffybarProcess ctx reason -      handleConnectedEvent = do+      scheduleMonitorRefresh reason = do+        wasPending <- MV.swapMVar monitorRefreshPendingVar True+        unless wasPending $ void $ forkIO $ do+          -- Output topology updates can arrive in small batches; wait briefly+          -- so bar configs are rebuilt against the settled monitor list.+          threadDelay 500_000+          _ <- MV.swapMVar monitorRefreshPendingVar False+          logIO NOTICE $ "Hyprland " ++ reason ++ " - forcing taffybar window refresh"+          postGUIASync $+            runReaderT+              (forceRefreshTaffyWindowsBecause $ "hyprland " ++ reason)+              ctx++      handleLifecycleEvent hyprlandEventName = do         ready <- MV.readMVar readyVar         if ready-          then scheduleRefresh+          then+            if hyprlandEventName == "configreloaded"+              then scheduleProcessRecovery "config reloaded"+              else scheduleProcessRecovery "event socket reconnected"           else logIO DEBUG "Ignoring Hyprland event socket connection during startup" +      handleMonitorEvent hyprlandEventName = do+        ready <- MV.readMVar readyVar+        if ready+          then scheduleMonitorRefresh $ T.unpack hyprlandEventName+          else logIO DEBUG "Ignoring Hyprland monitor event during startup"+   void $ forkIO $ forever $ do     line <- atomically $ readTChan events-    when (isConnectedEvent line) handleConnectedEvent+    maybe (pure ()) handleLifecycleEvent (lifecycleEventName line)+    maybe (pure ()) handleMonitorEvent (monitorEventName line) +hyprlandReconnectAction :: IO String+hyprlandReconnectAction = do+  mAction <- lookupEnv "TAFFYBAR_HYPRLAND_RECONNECT_ACTION"+  pure $ maybe "restart" (map toLower) mAction++restartTaffybarProcess :: Context -> String -> IO ()+restartTaffybarProcess ctx reason = do+  prepareBackendEnvironment+  executable <- getExecutablePath+  args <- getArgs+  logIO NOTICE $+    "Hyprland "+      ++ reason+      ++ " - re-executing taffybar process: "+      ++ executable+  underSystemd <- isSystemdService+  if underSystemd+    then exitImmediately (ExitFailure 75)+    else do+      disconnectClient "session" (sessionDBusClient ctx)+      disconnectClient "system" (systemDBusClient ctx)+      result <- try $ spawnDetachedRestart executable args+      case result of+        Left (e :: SomeException) ->+          logIO WARNING $+            "Failed to restart taffybar process: "+              ++ show e+        Right _ ->+          exitImmediately ExitSuccess+  where+    isSystemdService = maybe False (not . null) <$> lookupEnv "INVOCATION_ID"++    spawnDetachedRestart executable args =+      createProcess+        (proc "sh" (["-c", "sleep 1; exec \"$@\"", "taffybar-restart", executable] ++ args))+          { close_fds = True,+            new_session = True,+            std_in = NoStream,+            std_out = NoStream,+            std_err = NoStream+          }++    disconnectClient name client =+      DBus.disconnect client+        `catchAny` \e ->+          logIO WARNING $+            "Failed to disconnect "+              ++ name+              ++ " DBus client before restart: "+              ++ show e++taffybarWaylandLayer :: IO GtkLayerShell.Layer+taffybarWaylandLayer = do+  mLayer <- lookupEnv "TAFFYBAR_WAYLAND_LAYER"+  case fmap (map toLower) mLayer of+    Just "background" -> pure GtkLayerShell.LayerBackground+    Just "bottom" -> pure GtkLayerShell.LayerBottom+    Just "overlay" -> pure GtkLayerShell.LayerOverlay+    Just "top" -> pure GtkLayerShell.LayerTop+    Just invalid -> do+      logIO WARNING $+        "Invalid TAFFYBAR_WAYLAND_LAYER="+          ++ invalid+          ++ "; using top"+      pure GtkLayerShell.LayerTop+    Nothing -> pure GtkLayerShell.LayerTop+ -- | Build an empty taffybar context. This function is mostly useful for -- invoking functions that yield 'TaffyIO' values in a testing setting (e.g. in -- a repl).@@ -785,10 +914,10 @@     del :: Gtk.Window -> TaffyIO ()     del = Gtk.widgetDestroy --- | Forcibly refresh taffybar windows, even if there are existing windows that--- correspond to the uniques in the bar configs yielded by 'barConfigGetter'.-forceRefreshTaffyWindows :: TaffyIO ()-forceRefreshTaffyWindows = removeTaffyWindows >> refreshTaffyWindows+-- | Forcibly refresh taffybar windows.+forceRefreshTaffyWindowsBecause :: String -> TaffyIO ()+forceRefreshTaffyWindowsBecause _reason = do+  removeTaffyWindows >> refreshTaffyWindows  -- | Destroys all top-level windows belonging to Taffybar, then -- requests the GTK main loop to exit.@@ -1001,7 +1130,8 @@               GtkLayerShell.setMargin window GtkLayerShell.EdgeTop ypadding               GtkLayerShell.setMargin window GtkLayerShell.EdgeBottom ypadding -              GtkLayerShell.setLayer window GtkLayerShell.LayerTop+              layer <- taffybarWaylandLayer+              GtkLayerShell.setLayer window layer                let setAnchor = GtkLayerShell.setAnchor window 

@@ -31,17 +31,21 @@  import Control.Exception.Enclosed (catchAny) import Control.Monad+import Data.Char (toLower) import Data.GI.Base (castTo)-import Data.List (isPrefixOf, isSuffixOf)-import Data.Maybe (isJust)+import Data.List (isInfixOf, isPrefixOf, isSuffixOf, sortOn)+import Data.Maybe (fromMaybe, isJust, listToMaybe)+import Data.Ord (Down (..)) import qualified Data.Text as T import qualified GI.Gdk as Gdk import qualified GI.GdkX11.Objects.X11Display as GdkX11+import qualified Network.Socket as NS import System.Directory (doesPathExist, listDirectory) import System.Environment (lookupEnv, setEnv, unsetEnv) import System.FilePath ((</>)) import System.Log.Logger (Priority (..), logM) import System.Posix.Files (getFileStatus, isSocket)+import Text.Read (readMaybe)  logIO :: Priority -> String -> IO () logIO = logM "System.Taffybar.Context.Backend"@@ -89,13 +93,21 @@     then pure Nothing     else do       entries <- listDirectory hyprDir-      go hyprDir entries-  where-    go _ [] = pure Nothing-    go hyprDir (e : es) = do-      isSig <- isLiveHyprlandSignature (hyprDir </> e)-      if isSig then pure (Just e) else go hyprDir es+      liveEntries <- filterM (isLiveHyprlandSignature . (hyprDir </>)) entries+      pure $ listToMaybe $ sortOn hyprlandSignatureSortKey liveEntries +hyprlandSignatureSortKey :: String -> (Down Integer, Down String)+hyprlandSignatureSortKey signature =+  ( Down $ fromMaybe (-1) $ hyprlandSignatureStartTime signature,+    Down signature+  )++hyprlandSignatureStartTime :: String -> Maybe Integer+hyprlandSignatureStartTime signature =+  case drop 1 $ dropWhile (/= '_') signature of+    "" -> Nothing+    rest -> readMaybe $ takeWhile (/= '_') rest+ isSocketPath :: FilePath -> IO Bool isSocketPath path =   catchAny@@ -105,12 +117,46 @@ isLiveHyprlandSignature :: FilePath -> IO Bool isLiveHyprlandSignature dir =   (||)-    <$> isSocketPath (dir </> ".socket.sock")-    <*> isSocketPath (dir </> ".socket2.sock")+    <$> canConnectUnixSocket (dir </> ".socket.sock")+    <*> canConnectUnixSocket (dir </> ".socket2.sock") +canConnectUnixSocket :: FilePath -> IO Bool+canConnectUnixSocket path = do+  sock <- NS.socket NS.AF_UNIX NS.Stream NS.defaultProtocol+  ( do+      NS.connect sock (NS.SockAddrUnix path)+      NS.close sock+      pure True+    )+    `catchAny` \_ -> do+      void $ NS.close sock `catchAny` \_ -> pure ()+      pure False+ envIsNonEmpty :: Maybe String -> Bool envIsNonEmpty = maybe False (not . null) +envIsX11GdkBackend :: Maybe String -> Bool+envIsX11GdkBackend = maybe False ((== "x11") . map toLower)++envContainsWaylandDesktop :: Maybe String -> Bool+envContainsWaylandDesktop =+  maybe False $+    \value ->+      let lowered = map toLower value+       in "hyprland" `isInfixOf` lowered++waylandSocketAvailable :: FilePath -> Maybe String -> IO Bool+waylandSocketAvailable runtime mWaylandDisplay =+  case mWaylandDisplay of+    Just wl | not (null wl) -> isSocketPath (runtime </> wl)+    _ -> pure False++hyprlandSignatureAvailable :: FilePath -> Maybe String -> IO Bool+hyprlandSignatureAvailable runtime mSignature =+  case mSignature of+    Just sig | not (null sig) -> isLiveHyprlandSignature (runtime </> "hypr" </> sig)+    _ -> pure False+ -- | Detect the display-server backend, compensating for stale or missing -- environment variables. --@@ -126,52 +172,96 @@ --   from an X11 session). -- -- This function probes @XDG_RUNTIME_DIR@ only when the current process--- environment does not already identify an active X11 session, then fixes up--- the process environment so GDK sees consistent display variables.+-- context already points at Wayland, or when there is no explicit X display to+-- compete with. This avoids choosing a Wayland compositor merely because one+-- exists somewhere in the user's runtime directory. prepareBackendEnvironment :: IO () prepareBackendEnvironment = do   mRuntime <- lookupEnv "XDG_RUNTIME_DIR"   mDisplay <- lookupEnv "DISPLAY"   mSessionType <- lookupEnv "XDG_SESSION_TYPE"+  mGdkBackend <- lookupEnv "GDK_BACKEND"+  mCurrentDesktop <- lookupEnv "XDG_CURRENT_DESKTOP"+  mDesktopSession <- lookupEnv "DESKTOP_SESSION"+  rawHyprlandSignature <- lookupEnv "HYPRLAND_INSTANCE_SIGNATURE"   rawWaylandDisplay <- lookupEnv "WAYLAND_DISPLAY"    let hasDisplay = envIsNonEmpty mDisplay-      explicitX11Session = mSessionType == Just "x11" && hasDisplay+      explicitlyRequestedX11 =+        envIsX11GdkBackend mGdkBackend +  currentWaylandOk <- case mRuntime of+    Just runtime -> waylandSocketAvailable runtime rawWaylandDisplay+    Nothing -> pure False+  currentHyprlandOk <- case mRuntime of+    Just runtime -> hyprlandSignatureAvailable runtime rawHyprlandSignature+    Nothing -> pure False+  discoveredHyprlandSignature <- case mRuntime of+    Just runtime | not explicitlyRequestedX11 -> discoverHyprlandSignature runtime+    _ -> pure Nothing++  let hasHyprlandEvidence =+        currentHyprlandOk+          || envIsNonEmpty rawHyprlandSignature+          || envIsNonEmpty discoveredHyprlandSignature+          || envContainsWaylandDesktop mCurrentDesktop+          || envContainsWaylandDesktop mDesktopSession+      staleSessionTypeClaimsX11 =+        mSessionType == Just "x11"+          && hasDisplay+          && not currentWaylandOk+          && not hasHyprlandEvidence+      explicitX11Session =+        explicitlyRequestedX11 || staleSessionTypeClaimsX11+      processContextExpectsWayland =+        currentWaylandOk+          || mSessionType == Just "wayland"+          || hasHyprlandEvidence+      shouldDiscoverAmbientWayland =+        not explicitX11Session && (processContextExpectsWayland || not hasDisplay)+   -- If the process environment identifies the active session as X11, trust it-  -- over ambient Wayland sockets in XDG_RUNTIME_DIR. Those sockets can outlive-  -- or coexist with a different login session and are not sufficient evidence-  -- that this process should initialize GTK as Wayland.+  -- over ambient Wayland sockets in XDG_RUNTIME_DIR. A live WAYLAND_DISPLAY+  -- from the process environment is stronger evidence than XDG_SESSION_TYPE,+  -- because user shells can retain a stale session type.   when explicitX11Session $ do     unsetEnv "WAYLAND_DISPLAY"     unsetEnv "HYPRLAND_INSTANCE_SIGNATURE"+    setEnv "GDK_BACKEND" "x11"     logIO DEBUG "X11 session detected; ignoring ambient Wayland sockets" -  -- Discover and fix up WAYLAND_DISPLAY if it is missing or empty.-  void $ do+  -- Discover and fix up WAYLAND_DISPLAY if it is missing, empty, or stale.+  repairedWaylandDisplay <- do     case (mRuntime, rawWaylandDisplay) of       _ | explicitX11Session -> pure Nothing-      (Just runtime, val) | maybe True null val -> do+      (Just _, val) | currentWaylandOk -> pure val+      (Just runtime, _) | shouldDiscoverAmbientWayland -> do         mSock <- discoverWaylandSocket runtime         case mSock of           Just sock -> do             logIO INFO $ "Discovered wayland socket: " ++ sock             setEnv "WAYLAND_DISPLAY" sock             pure (Just sock)-          Nothing -> pure rawWaylandDisplay-      _ -> pure rawWaylandDisplay+          Nothing -> pure Nothing+      _ -> pure Nothing -  -- Discover and fix up HYPRLAND_INSTANCE_SIGNATURE if it is missing or empty.-  unless explicitX11Session $ do+  when (not explicitX11Session && envIsNonEmpty repairedWaylandDisplay) $ do+    setEnv "GDK_BACKEND" "wayland"+    when (mSessionType /= Just "wayland") $+      setEnv "XDG_SESSION_TYPE" "wayland"++  -- Discover and fix up HYPRLAND_INSTANCE_SIGNATURE if it is missing, empty, or stale.+  when (processContextExpectsWayland || envIsNonEmpty repairedWaylandDisplay) $ do     raw <- lookupEnv "HYPRLAND_INSTANCE_SIGNATURE"     case (mRuntime, raw) of-      (Just runtime, val) | maybe True null val -> do-        mSig <- discoverHyprlandSignature runtime-        case mSig of-          Just sig -> do-            logIO INFO $ "Discovered Hyprland signature: " ++ sig-            setEnv "HYPRLAND_INSTANCE_SIGNATURE" sig-          Nothing -> pure ()+      (Just runtime, val) -> do+        currentOk <- hyprlandSignatureAvailable runtime val+        unless currentOk $ do+          case discoveredHyprlandSignature of+            Just sig -> do+              logIO INFO $ "Discovered Hyprland signature: " ++ sig+              setEnv "HYPRLAND_INSTANCE_SIGNATURE" sig+            Nothing -> pure ()       _ -> pure ()  -- | Detect the backend from the display that GDK actually opened.

@@ -0,0 +1,17 @@+{-# LANGUAGE TemplateHaskell #-}++module System.Taffybar.DBus.Client.ChromeWindowInfo where++import DBus.Generation ()+import System.FilePath+import System.Taffybar.DBus.Client.Params+import System.Taffybar.DBus.Client.Util++generateClientFromFile+  defaultRecordGenerationParams+    { recordName = Just "ChromeWindowInfo",+      recordPrefix = "chromeWindowInfo"+    }+  chromeWindowInfoGenerationParams+  False+  $ "dbus-xml" </> "org.imalison.ChromeWindowInfo.xml"

@@ -8,6 +8,26 @@ import Language.Haskell.TH import System.Taffybar.DBus.Client.Util +-- | The bus name for chrome-favicon-dbus.+chromeWindowInfoBusName :: BusName+chromeWindowInfoBusName = "org.imalison.ChromeWindowInfo"++-- | The object path exposed by chrome-favicon-dbus.+chromeWindowInfoObjectPath :: ObjectPath+chromeWindowInfoObjectPath = "/org/imalison/ChromeWindowInfo"++-- | The interface name exposed by chrome-favicon-dbus.+chromeWindowInfoInterfaceName :: InterfaceName+chromeWindowInfoInterfaceName = "org.imalison.ChromeWindowInfo"++chromeWindowInfoGenerationParams :: GenerationParams+chromeWindowInfoGenerationParams =+  defaultGenerationParams+    { genTakeSignalErrorHandler = True,+      genBusName = Just chromeWindowInfoBusName,+      genObjectPath = Just chromeWindowInfoObjectPath+    }+ playerGenerationParams :: GenerationParams playerGenerationParams =   defaultGenerationParams@@ -139,7 +159,7 @@   | BatteryTypeKeyboard   | BatteryTypePda   | BatteryTypePhone-  deriving (Show, Ord, Eq, Enum)+  deriving (Show, Ord, Eq, Enum, Bounded)  -- | UPower battery charging state enum. data BatteryState@@ -150,7 +170,7 @@   | BatteryStateFullyCharged   | BatteryStatePendingCharge   | BatteryStatePendingDischarge-  deriving (Show, Ord, Eq, Enum)+  deriving (Show, Ord, Eq, Enum, Bounded)  -- | UPower battery chemistry enum. data BatteryTechnology@@ -161,7 +181,7 @@   | BatteryTechnologyLeadAcid   | BatteryTechnologyNickelCadmium   | BatteryTechnologyNickelMetalHydride-  deriving (Show, Ord, Eq, Enum)+  deriving (Show, Ord, Eq, Enum, Bounded)  batteryTypeForName :: GetTypeForName batteryTypeForName name = const $

@@ -33,12 +33,12 @@ import Control.Monad.STM (atomically) import Control.Monad.Trans.Class import Control.Monad.Trans.Reader-import Data.List (isSuffixOf, nub) import qualified Data.MultiMap as MM+import qualified Data.Set as Set import System.Directory (doesDirectoryExist) import System.Environment.XDG.DesktopEntry import System.FSNotify (Event (eventIsDirectory, eventPath), EventIsDirectory (IsFile), startManager, watchDir)-import System.FilePath ((</>))+import System.FilePath (takeExtension, (</>)) import System.Log.Logger import System.Taffybar.Context import System.Taffybar.DBus@@ -151,12 +151,20 @@  isDesktopEntryEvent :: Event -> Bool isDesktopEntryEvent event =-  eventIsDirectory event == IsFile && ".desktop" `isSuffixOf` eventPath event+  eventIsDirectory event == IsFile && takeExtension (eventPath event) == ".desktop"  getDesktopEntryApplicationDirs :: IO [FilePath] getDesktopEntryApplicationDirs = do   xdgDataDirs <- getXDGDataDirs-  filterM doesDirectoryExist $ map (</> "applications") $ nub xdgDataDirs+  filterM doesDirectoryExist $ map (</> "applications") $ dedupe xdgDataDirs++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  -- | Read 'DesktopEntry' values into a 'MM.Multimap', where they are indexed by -- the class name specified in the 'DesktopEntry'.

@@ -33,6 +33,7 @@ import Data.Aeson.Types (Parser) import qualified Data.ByteString.Lazy.Char8 as LBS import Data.List (sortOn)+import qualified Data.List as List import Data.Maybe (fromMaybe, mapMaybe) import qualified Data.Set as Set import qualified Data.Text as T@@ -377,7 +378,7 @@ dedupeTranscriptEntries :: [TranscriptUsageEntry] -> [TranscriptUsageEntry] dedupeTranscriptEntries =   snd-    . foldl+    . List.foldl'       ( \(seen, entries) entry ->           let requestId = transcriptUsageRequestId entry            in if Set.member requestId seen@@ -414,7 +415,7 @@  activeBlock :: UTCTime -> NominalDiffTime -> [TranscriptUsageEntry] -> Maybe (UTCTime, [TranscriptUsageEntry]) activeBlock now duration entries =-  case foldl addToBlock Nothing (sortOn transcriptUsageTimestamp entries) of+  case List.foldl' addToBlock Nothing (sortOn transcriptUsageTimestamp entries) of     Nothing -> Nothing     Just (start, blockEntries)       | addUTCTime duration start >= now -> Just (start, blockEntries)

@@ -0,0 +1,195 @@+{-# LANGUAGE AllowAmbiguousTypes #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE KindSignatures #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeApplications #-}++-- |+-- Module      : System.Taffybar.Information.Audio+-- Copyright   : (c) Ivan A. Malison+-- License     : BSD3-style (see LICENSE)+--+-- Maintainer  : Ivan A. Malison+-- Stability   : unstable+-- Portability : unportable+--+-- Unified audio information for PulseAudio and PipeWire/WirePlumber systems.+--+-- PulseAudio is preferred when its DBus protocol is available. On modern+-- PipeWire systems where @pipewire-pulse@ does not expose that DBus protocol,+-- this module falls back to the WirePlumber backend.+module System.Taffybar.Information.Audio+  ( AudioBackend (..),+    AudioInfo (..),+    defaultAudioPulseSink,+    defaultAudioWirePlumberNode,+    audioBackendAvailable,+    getAudioInfo,+    getAudioInfoChan,+    getAudioInfoState,+    getAudioInfoChanAndVar,+    getAudioInfoChanFor,+    getAudioInfoStateFor,+    toggleAudioMute,+    adjustAudioVolume,+    pulseSinkToWirePlumberNode,+  )+where++import Control.Concurrent (forkIO)+import Control.Concurrent.MVar+import Control.Concurrent.STM.TChan+import Control.Monad (forever, when)+import Control.Monad.IO.Class (liftIO)+import Control.Monad.STM (atomically)+import Data.Proxy (Proxy (..))+import qualified Data.Text as T+import GHC.TypeLits (KnownSymbol, SomeSymbol (..), Symbol, someSymbolVal, symbolVal)+import System.Taffybar.Context (TaffyIO)+import qualified System.Taffybar.Information.PulseAudio as PulseAudio+import qualified System.Taffybar.Information.WirePlumber as WirePlumber++data AudioBackend+  = PulseAudioBackend+  | WirePlumberBackend+  deriving (Eq, Show)++data AudioInfo = AudioInfo+  { audioVolumePercent :: Maybe Int,+    audioMuted :: Maybe Bool,+    audioNodeName :: String,+    audioBackend :: AudioBackend+  }+  deriving (Eq, Show)++defaultAudioPulseSink :: String+defaultAudioPulseSink = "@DEFAULT_SINK@"++defaultAudioWirePlumberNode :: String+defaultAudioWirePlumberNode = "@DEFAULT_AUDIO_SINK@"++newtype AudioInfoChanVar (a :: Symbol)+  = AudioInfoChanVar (TChan (Maybe AudioInfo), MVar (Maybe AudioInfo))++audioBackendAvailable :: IO AudioBackend+audioBackendAvailable = do+  pulseAvailable <- PulseAudio.pulseAudioAvailable+  pure $+    if pulseAvailable+      then PulseAudioBackend+      else WirePlumberBackend++getAudioInfo :: String -> String -> IO (Maybe AudioInfo)+getAudioInfo pulseSink wirePlumberNode = do+  backend <- audioBackendAvailable+  case backend of+    PulseAudioBackend -> fmap fromPulseAudioInfo <$> PulseAudio.getPulseAudioInfo pulseSink+    WirePlumberBackend -> fmap fromWirePlumberInfo <$> WirePlumber.getWirePlumberInfo wirePlumberNode++getAudioInfoChan :: String -> String -> TaffyIO (TChan (Maybe AudioInfo))+getAudioInfoChan pulseSink wirePlumberNode =+  case someSymbolVal $ encodeAudioSpecs pulseSink wirePlumberNode of+    SomeSymbol (Proxy :: Proxy sym) -> getAudioInfoChanFor @sym++getAudioInfoState :: String -> String -> TaffyIO (Maybe AudioInfo)+getAudioInfoState pulseSink wirePlumberNode =+  case someSymbolVal $ encodeAudioSpecs pulseSink wirePlumberNode of+    SomeSymbol (Proxy :: Proxy sym) -> getAudioInfoStateFor @sym++getAudioInfoChanAndVar :: String -> String -> TaffyIO (TChan (Maybe AudioInfo), MVar (Maybe AudioInfo))+getAudioInfoChanAndVar pulseSink wirePlumberNode =+  case someSymbolVal $ encodeAudioSpecs pulseSink wirePlumberNode of+    SomeSymbol (Proxy :: Proxy sym) -> do+      AudioInfoChanVar pair <- getAudioInfoChanVarFor @sym+      pure pair++getAudioInfoChanFor :: forall a. (KnownSymbol a) => TaffyIO (TChan (Maybe AudioInfo))+getAudioInfoChanFor = do+  AudioInfoChanVar (chan, _) <- getAudioInfoChanVarFor @a+  pure chan++getAudioInfoStateFor :: forall a. (KnownSymbol a) => TaffyIO (Maybe AudioInfo)+getAudioInfoStateFor = do+  AudioInfoChanVar (_, var) <- getAudioInfoChanVarFor @a+  liftIO $ readMVar var++getAudioInfoChanVarFor :: forall a. (KnownSymbol a) => TaffyIO (AudioInfoChanVar a)+getAudioInfoChanVarFor = do+  let (pulseSink, wirePlumberNode) = decodeAudioSpecs $ symbolVal (Proxy @a)+  backend <- liftIO audioBackendAvailable+  case backend of+    PulseAudioBackend -> do+      (pulseChan, pulseVar) <- PulseAudio.getPulseAudioInfoChanAndVar pulseSink+      buildMappedChanVar fromPulseAudioInfo pulseChan pulseVar+    WirePlumberBackend -> do+      (wireChan, wireVar) <- WirePlumber.getWirePlumberInfoChanAndVar wirePlumberNode+      buildMappedChanVar fromWirePlumberInfo wireChan wireVar++toggleAudioMute :: String -> String -> IO Bool+toggleAudioMute pulseSink wirePlumberNode = do+  backend <- audioBackendAvailable+  case backend of+    PulseAudioBackend -> PulseAudio.togglePulseAudioMute pulseSink+    WirePlumberBackend -> WirePlumber.toggleWirePlumberMute wirePlumberNode++adjustAudioVolume :: String -> String -> Int -> IO Bool+adjustAudioVolume pulseSink wirePlumberNode deltaPercent = do+  backend <- audioBackendAvailable+  case backend of+    PulseAudioBackend -> PulseAudio.adjustPulseAudioVolume pulseSink deltaPercent+    WirePlumberBackend -> WirePlumber.adjustWirePlumberVolume wirePlumberNode deltaPercent++pulseSinkToWirePlumberNode :: String -> String+pulseSinkToWirePlumberNode "" = defaultAudioWirePlumberNode+pulseSinkToWirePlumberNode sink+  | sink == defaultAudioPulseSink = defaultAudioWirePlumberNode+  | otherwise = sink++buildMappedChanVar ::+  (backendInfo -> AudioInfo) ->+  TChan (Maybe backendInfo) ->+  MVar (Maybe backendInfo) ->+  TaffyIO (AudioInfoChanVar a)+buildMappedChanVar convert backendChan backendVar = do+  initialInfo <- liftIO $ fmap convert <$> readMVar backendVar+  liftIO $ do+    chan <- newBroadcastTChanIO+    var <- newMVar initialInfo+    atomically $ writeTChan chan initialInfo+    _ <- forkIO $ do+      ourChan <- atomically $ dupTChan backendChan+      forever $ do+        info <- fmap convert <$> atomically (readTChan ourChan)+        oldInfo <- swapMVar var info+        when (oldInfo /= info) $+          atomically $+            writeTChan chan info+    pure $ AudioInfoChanVar (chan, var)++fromPulseAudioInfo :: PulseAudio.PulseAudioInfo -> AudioInfo+fromPulseAudioInfo info =+  AudioInfo+    { audioVolumePercent = PulseAudio.pulseAudioVolumePercent info,+      audioMuted = PulseAudio.pulseAudioMuted info,+      audioNodeName = PulseAudio.pulseAudioSinkName info,+      audioBackend = PulseAudioBackend+    }++fromWirePlumberInfo :: WirePlumber.WirePlumberInfo -> AudioInfo+fromWirePlumberInfo info =+  AudioInfo+    { audioVolumePercent = Just $ round $ WirePlumber.wirePlumberVolume info * 100,+      audioMuted = Just $ WirePlumber.wirePlumberMuted info,+      audioNodeName = T.unpack $ WirePlumber.wirePlumberNodeName info,+      audioBackend = WirePlumberBackend+    }++encodeAudioSpecs :: String -> String -> String+encodeAudioSpecs pulseSink wirePlumberNode = pulseSink ++ "\n" ++ wirePlumberNode++decodeAudioSpecs :: String -> (String, String)+decodeAudioSpecs encoded =+  case break (== '\n') encoded of+    (pulseSink, '\n' : wirePlumberNode) -> (pulseSink, wirePlumberNode)+    (pulseSink, _) -> (pulseSink, pulseSinkToWirePlumberNode pulseSink)

@@ -104,6 +104,12 @@     f :: (Num a, IsVariant a) => Variant -> a     f = fromMaybe (fromIntegral dflt) . fromVariant +boundedEnumFromInt :: (Bounded a, Enum a) => a -> Int -> a+boundedEnumFromInt fallback value+  | value < fromEnum (minBound `asTypeOf` fallback) = fallback+  | value > fromEnum (maxBound `asTypeOf` fallback) = fallback+  | otherwise = toEnum value+ -- XXX: Remove this once it is exposed in haskell-dbus  -- | Placeholder 'MethodError' used when required reply payload is missing.@@ -137,7 +143,10 @@       batteryVendor = readDict dict "Vendor" "",       batteryModel = readDict dict "Model" "",       batterySerial = readDict dict "Serial" "",-      batteryType = toEnum $ fromIntegral $ readDictIntegral dict "Type" 0,+      batteryType =+        boundedEnumFromInt BatteryTypeUnknown $+          fromIntegral $+            readDictIntegral dict "Type" 0,       batteryPowerSupply = readDict dict "PowerSupply" False,       batteryHasHistory = readDict dict "HasHistory" False,       batteryHasStatistics = readDict dict "HasStatistics" False,@@ -152,11 +161,15 @@       batteryTimeToFull = readDict dict "TimeToFull" 0,       batteryPercentage = readDict dict "Percentage" 0.0,       batteryIsPresent = readDict dict "IsPresent" False,-      batteryState = toEnum $ readDictIntegral dict "State" 0,+      batteryState =+        boundedEnumFromInt BatteryStateUnknown $+          readDictIntegral dict "State" 0,       batteryIsRechargeable = readDict dict "IsRechargable" True,       batteryCapacity = readDict dict "Capacity" 0.0,       batteryTechnology =-        toEnum $ fromIntegral $ readDictIntegral dict "Technology" 0,+        boundedEnumFromInt BatteryTechnologyUnknown $+          fromIntegral $+            readDictIntegral dict "Technology" 0,       batteryUpdateTime = readDict dict "UpdateTime" 0,       batteryLuminosity = readDict dict "Luminosity" 0.0,       batteryTemperature = readDict dict "Temperature" 0.0,

@@ -34,6 +34,7 @@ import System.Taffybar.Context (TaffyIO) import System.Taffybar.Information.StreamInfo import System.Taffybar.Information.Wakeup (getWakeupChannelForDelay)+import Text.Read (readMaybe)  -- | Relative CPU load values, expressed as ratios in [0,1]. data CPULoad = CPULoad@@ -131,7 +132,8 @@ -- | Read one core-temperature file from sysfs and convert milli-degrees to -- degrees Celsius. readCPUTempFile :: FilePath -> IO Double-readCPUTempFile cpuTempFilePath = (/ 1000) . read <$> readFile cpuTempFilePath+readCPUTempFile cpuTempFilePath =+  maybe 0 (/ 1000) . readMaybe <$> readFile cpuTempFilePath  -- | List core-temperature input files in a hwmon directory. getAllTemperatureFiles :: FilePath -> IO [FilePath]

@@ -11,6 +11,7 @@ import Control.Monad.Trans.Class import qualified Data.ByteString as BS import qualified Data.ByteString.Lazy as LBS+import qualified Data.List as List import qualified Data.Map as M import Data.Maybe import qualified GI.GLib as Gdk@@ -133,4 +134,4 @@     wins <- getWindows     titles <- mapM getWindowTitle wins     let winsWithTitles = zip wins titles-    return $ foldl addTabIdEntry tabMap winsWithTitles+    return $ List.foldl' addTabIdEntry tabMap winsWithTitles

@@ -0,0 +1,90 @@+{-# LANGUAGE OverloadedStrings #-}++-- | Event source for the chrome-favicon-bridge D-Bus service.+module System.Taffybar.Information.ChromeWindowInfo+  ( registerChromeWindowInfoRefreshRequests,+  )+where++import Control.Exception.Enclosed (catchAny)+import Control.Monad.IO.Class (liftIO)+import Control.Monad.Trans.Reader (ask, asks, runReaderT)+import qualified DBus as D+import qualified DBus.Client as DBus+import qualified Data.Text as T+import System.Log.Logger (Priority (..), logM)+import System.Taffybar.Context (TaffyIO, getStateDefault, sessionDBusClient)+import qualified System.Taffybar.DBus.Client.ChromeWindowInfo as ChromeWindowInfoDBus+import System.Taffybar.Information.Workspaces.Model+  ( WindowIdentity (..),+    WorkspacesRefreshTarget (..),+  )+import System.Taffybar.Information.Workspaces.Refresh (requestWorkspacesRefresh)++data ChromeWindowInfoRefreshSubscription+  = ChromeWindowInfoRefreshSubscription++registerChromeWindowInfoRefreshRequests :: TaffyIO ()+registerChromeWindowInfoRefreshRequests = do+  _ <-+    getStateDefault $+      buildChromeWindowInfoRefreshSubscription+        >> return ChromeWindowInfoRefreshSubscription+  return ()++buildChromeWindowInfoRefreshSubscription :: TaffyIO ()+buildChromeWindowInfoRefreshSubscription = do+  ctx <- ask+  client <- asks sessionDBusClient+  let requestRefresh target =+        runReaderT (requestWorkspacesRefresh target) ctx+  liftIO $+    ( do+        registerChromeWindowInfoSignals client requestRefresh+        logM+          "System.Taffybar.Information.ChromeWindowInfo"+          DEBUG+          "Subscribed to Chrome window info signals"+    )+      `catchAny` \err ->+        chromeWindowInfoLog+          WARNING+          ("Failed to subscribe to Chrome window info signals: " <> show err)++registerChromeWindowInfoSignals ::+  DBus.Client ->+  (WorkspacesRefreshTarget -> IO ()) ->+  IO ()+registerChromeWindowInfoSignals client requestRefresh = do+  _ <-+    ChromeWindowInfoDBus.registerForWindowUpdated+      client+      DBus.matchAny+      (emitWindowRefresh requestRefresh)+      logMalformedWindowUpdatedSignal+  return ()++emitWindowRefresh :: (WorkspacesRefreshTarget -> IO ()) -> D.Signal -> String -> String -> IO ()+emitWindowRefresh requestRefresh _signal windowId _payload =+  requestRefresh $+    RefreshWindow $+      HyprlandWindowIdentity $+        normalizeHyprlandWindowId $+          T.pack windowId++logMalformedWindowUpdatedSignal :: D.Signal -> IO ()+logMalformedWindowUpdatedSignal signal =+  chromeWindowInfoLog+    WARNING+    ("Ignoring malformed ChromeWindowInfo WindowUpdated signal: " <> show (D.signalBody signal))++chromeWindowInfoLog :: Priority -> String -> IO ()+chromeWindowInfoLog =+  logM "System.Taffybar.Information.ChromeWindowInfo"++normalizeHyprlandWindowId :: T.Text -> T.Text+normalizeHyprlandWindowId address =+  let trimmed = T.strip address+   in if "0x" `T.isPrefixOf` trimmed || T.null trimmed+        then trimmed+        else "0x" <> trimmed

@@ -79,7 +79,6 @@ import Control.Monad.Trans.Reader (ReaderT, ask, runReaderT) import Data.Aeson (FromJSON (..), eitherDecode', withObject, (.:)) import qualified Data.ByteString as BS-import qualified Data.ByteString.Char8 as BS8 import qualified Data.ByteString.Lazy as BL import Data.List (sortOn) import Data.Ord (Down (..))@@ -419,8 +418,8 @@ hyprlandCommandToSocketCommand :: HyprlandCommand -> Either HyprlandError BS.ByteString hyprlandCommandToSocketCommand HyprlandCommand {commandArgs = args, commandJson = isJson}   | null args = Left $ HyprlandCommandBuildFailed "No Hyprland command provided"-  | isJson = Right $ BS8.pack $ "j/" ++ unwords args-  | otherwise = Right $ BS8.pack $ unwords args+  | isJson = Right $ TE.encodeUtf8 $ T.pack $ "j/" ++ unwords args+  | otherwise = Right $ TE.encodeUtf8 $ T.pack $ unwords args  -- | Run a Hyprland command, preferring the command socket if enabled. --

@@ -111,9 +111,9 @@   | otherwise = Right $ HyprlandAddress t  data HyprlandDispatch-  = -- | @hyprctl dispatch workspace <name-or-id>@+  = -- | @hyprctl dispatch 'hl.dsp.focus({ workspace = "<name-or-id>" })'@     DispatchWorkspace HyprlandWorkspaceTarget-  | -- | @hyprctl dispatch focuswindow address:<addr>@+  | -- | @hyprctl dispatch 'hl.dsp.focus({ window = "address:<addr>" })'@     DispatchFocusWindowAddress HyprlandAddress   deriving (Show, Eq) @@ -124,6 +124,26 @@ dispatchToArgs :: HyprlandDispatch -> [String] dispatchToArgs action =   case action of-    DispatchWorkspace ws -> ["dispatch", "workspace", T.unpack (hyprlandWorkspaceTargetText ws)]+    DispatchWorkspace ws ->+      [ "dispatch",+        "hl.dsp.focus({ workspace = "+          <> luaString (hyprlandWorkspaceTargetText ws)+          <> " })"+      ]     DispatchFocusWindowAddress addr ->-      ["dispatch", "focuswindow", "address:" <> T.unpack (hyprlandAddressText addr)]+      [ "dispatch",+        "hl.dsp.focus({ window = "+          <> luaString ("address:" <> hyprlandAddressText addr)+          <> " })"+      ]++luaString :: Text -> String+luaString text =+  "\"" <> concatMap escapeChar (T.unpack text) <> "\""+  where+    escapeChar '"' = "\\\""+    escapeChar '\\' = "\\\\"+    escapeChar '\n' = "\\n"+    escapeChar '\r' = "\\r"+    escapeChar '\t' = "\\t"+    escapeChar c = [c]

@@ -105,6 +105,7 @@     hyprClientHidden :: Bool,     hyprClientMapped :: Bool,     hyprClientUrgent :: Bool,+    hyprClientPinned :: Bool,     hyprClientAt :: Maybe (Int, Int)   }   deriving (Show, Eq)@@ -123,6 +124,7 @@       <*> v .:? "hidden" .!= False       <*> v .:? "mapped" .!= True       <*> v .:? "urgent" .!= False+      <*> v .:? "pinned" .!= False       <*> pure at  -- | Result from @hyprctl -j activeworkspace@.

@@ -0,0 +1,102 @@+{-# LANGUAGE OverloadedStrings #-}++-----------------------------------------------------------------------------++-----------------------------------------------------------------------------++-- |+-- Module      : System.Taffybar.Information.HyprlandWorkspaceHistory+-- Copyright   : (c) Ivan A. Malison+-- License     : BSD3-style (see LICENSE)+--+-- Maintainer  : Ivan A. Malison+-- Stability   : unstable+-- Portability : unportable+--+-- Reader for the runtime JSON snapshot written by the hypr-workspace-history+-- Hyprland plugin.+module System.Taffybar.Information.HyprlandWorkspaceHistory+  ( HyprlandWorkspaceHistoryMonitor (..),+    HyprlandWorkspaceHistorySnapshot (..),+    workspaceHistoryStateFileName,+    workspaceHistoryStatePath,+    readHyprlandWorkspaceHistorySnapshot,+    workspaceHistoryOrderForMonitor,+    workspaceHistoryOrderForActiveMonitor,+  )+where++import Control.Exception.Enclosed (catchAny)+import Data.Aeson (FromJSON (..), eitherDecodeStrict', withObject, (.:), (.:?))+import qualified Data.ByteString as BS+import qualified Data.Map.Strict as M+import Data.Text (Text)+import Data.Word (Word64)+import System.Directory (doesFileExist)+import System.Environment (lookupEnv)+import System.FilePath ((</>))++newtype HyprlandWorkspaceHistoryMonitor = HyprlandWorkspaceHistoryMonitor+  { hwhMonitorHistory :: [Int]+  }+  deriving (Eq, Show)++instance FromJSON HyprlandWorkspaceHistoryMonitor where+  parseJSON = withObject "HyprlandWorkspaceHistoryMonitor" $ \v ->+    HyprlandWorkspaceHistoryMonitor+      <$> v .: "history"++data HyprlandWorkspaceHistorySnapshot = HyprlandWorkspaceHistorySnapshot+  { hwhVersion :: Int,+    hwhRevision :: Word64,+    hwhActiveMonitor :: Maybe Text,+    hwhActiveWorkspace :: Maybe Int,+    hwhMonitors :: M.Map Text HyprlandWorkspaceHistoryMonitor+  }+  deriving (Eq, Show)++instance FromJSON HyprlandWorkspaceHistorySnapshot where+  parseJSON = withObject "HyprlandWorkspaceHistorySnapshot" $ \v ->+    HyprlandWorkspaceHistorySnapshot+      <$> v .: "version"+      <*> v .: "revision"+      <*> v .:? "active_monitor"+      <*> v .:? "active_workspace"+      <*> v .: "monitors"++workspaceHistoryStateFileName :: FilePath+workspaceHistoryStateFileName = "hyprland-workspace-history.json"++workspaceHistoryStatePath :: IO (Maybe FilePath)+workspaceHistoryStatePath = do+  mRuntimeDir <- lookupEnv "XDG_RUNTIME_DIR"+  pure $ (</> workspaceHistoryStateFileName) <$> mRuntimeDir++readHyprlandWorkspaceHistorySnapshot :: IO (Either String (Maybe HyprlandWorkspaceHistorySnapshot))+readHyprlandWorkspaceHistorySnapshot =+  ( do+      mPath <- workspaceHistoryStatePath+      case mPath of+        Nothing -> pure $ Right Nothing+        Just path -> do+          exists <- doesFileExist path+          if not exists+            then pure $ Right Nothing+            else do+              bytes <- BS.readFile path+              pure $ Just <$> eitherDecodeStrict' bytes+  )+    `catchAny` \err -> pure $ Left (show err)++workspaceHistoryOrderForMonitor ::+  Text ->+  HyprlandWorkspaceHistorySnapshot ->+  Maybe [Int]+workspaceHistoryOrderForMonitor monitor snapshot =+  hwhMonitorHistory <$> M.lookup monitor (hwhMonitors snapshot)++workspaceHistoryOrderForActiveMonitor ::+  HyprlandWorkspaceHistorySnapshot ->+  Maybe [Int]+workspaceHistoryOrderForActiveMonitor snapshot =+  hwhActiveMonitor snapshot >>= (`workspaceHistoryOrderForMonitor` snapshot)

@@ -7,9 +7,10 @@ where  import qualified Data.ByteString.Char8 as BS8+import Text.Read (readMaybe)  toMB :: String -> Double-toMB size = (read size :: Double) / 1024+toMB size = maybe 0 (/ 1024) (readMaybe size)  safeRatio :: Double -> Double -> Double safeRatio

@@ -158,6 +158,6 @@  -- | Sum download/upload speeds across interfaces. sumSpeeds :: [(Rational, Rational)] -> (Rational, Rational)-sumSpeeds = foldr1 sumOne+sumSpeeds = foldr sumOne (0, 0)   where     sumOne (d1, u1) (d2, u2) = (d1 + d2, u1 + u2)

@@ -44,7 +44,7 @@ import DBus.Internal.Types (Serial (..)) import qualified DBus.TH as DBus import qualified Data.ByteString as BS-import Data.List (minimumBy)+import qualified Data.List as List import Data.Map (Map) import qualified Data.Map as M import Data.Maybe (fromMaybe, listToMaybe)@@ -461,17 +461,17 @@  pickBestActiveConnection :: [ActiveConnectionInfo] -> Maybe ActiveConnectionInfo pickBestActiveConnection [] = Nothing-pickBestActiveConnection infos =+pickBestActiveConnection (firstInfo : restInfos) =   let rank t         | t == "802-3-ethernet" = 0 :: Int         | t == "802-11-wireless" = 1         | t == "vpn" = 2         | T.null t = 99         | otherwise = 50-   in Just $-        minimumBy-          (\a b -> compare (rank (activeConnectionType a)) (rank (activeConnectionType b)))-          infos+      betterActiveConnection a b+        | rank (activeConnectionType a) <= rank (activeConnectionType b) = a+        | otherwise = b+   in Just $ List.foldl' betterActiveConnection firstInfo restInfos  toNetworkType :: Text -> NetworkType toNetworkType t

@@ -5,6 +5,9 @@ -- This module currently reads the ChatGPT OAuth token file written by Codex and -- calls ChatGPT's Codex usage endpoint. That endpoint is not part of OpenAI's -- public API, so callers can override the endpoint, auth path, and user agent.+-- Local Codex transcript JSONL files are used to derive actual token counts,+-- because the remote endpoint currently exposes percentages and reset times but+-- not token totals. module System.Taffybar.Information.OpenAIUsage   ( OpenAIUsageConfig (..),     defaultOpenAIUsageConfig,@@ -14,6 +17,7 @@     OpenAIUsageAdditionalRateLimit (..),     OpenAIUsageRateLimit (..),     OpenAIUsageWindow (..),+    OpenAIUsageTotals (..),     OpenAIUsageCredits (..),     getOpenAIUsageInfo,     updateOpenAIUsage,@@ -31,13 +35,24 @@ import Control.Monad (forever, void) import Control.Monad.IO.Class (liftIO) import Data.Aeson+import Data.Aeson.Types (Parser) import qualified Data.ByteString.Lazy as LBS+import qualified Data.ByteString.Lazy.Char8 as LBS8+import Data.Maybe (mapMaybe) import qualified Data.Text as T import qualified Data.Text.Encoding as TE+import Data.Time.Clock+import Data.Time.Clock.POSIX (posixSecondsToUTCTime) import Network.HTTP.Simple-import System.Directory (doesFileExist, getHomeDirectory)+import System.Directory+  ( doesDirectoryExist,+    doesFileExist,+    getHomeDirectory,+    getModificationTime,+    listDirectory,+  ) import System.Environment (lookupEnv)-import System.FilePath ((</>))+import System.FilePath (takeExtension, (</>)) import System.Log.Logger (Priority (WARNING), logM) import System.Taffybar.Context (TaffyIO, getStateDefault) import System.Taffybar.Information.Wakeup (getWakeupChannelForDelay)@@ -46,7 +61,9 @@   { openAIUsagePollInterval :: Double,     openAIUsageEndpoint :: String,     openAIUsageUserAgent :: String,-    openAIUsageAuthPath :: Maybe FilePath+    openAIUsageAuthPath :: Maybe FilePath,+    openAIUsageSessionsPath :: Maybe FilePath,+    openAIUsageFileLookbackSeconds :: NominalDiffTime   }  defaultOpenAIUsageConfig :: OpenAIUsageConfig@@ -55,7 +72,9 @@     { openAIUsagePollInterval = 60 * 15,       openAIUsageEndpoint = "https://chatgpt.com/backend-api/codex/usage",       openAIUsageUserAgent = "taffybar-openai-usage",-      openAIUsageAuthPath = Nothing+      openAIUsageAuthPath = Nothing,+      openAIUsageSessionsPath = Nothing,+      openAIUsageFileLookbackSeconds = 8 * 24 * 60 * 60     }  data OpenAIUsageAuth = OpenAIUsageAuth@@ -124,17 +143,71 @@ data OpenAIUsageWindow = OpenAIUsageWindow   { openAIUsageUsedPercent :: Int,     openAIUsageWindowDurationSeconds :: Maybe Int,-    openAIUsageResetAfterSeconds :: Maybe Int+    openAIUsageResetAfterSeconds :: Maybe Int,+    openAIUsageResetAt :: Maybe UTCTime,+    openAIUsageWindowTotals :: Maybe OpenAIUsageTotals   }   deriving (Eq, Show)  instance FromJSON OpenAIUsageWindow where-  parseJSON = withObject "OpenAIUsageWindow" $ \o ->+  parseJSON = withObject "OpenAIUsageWindow" $ \o -> do+    resetAt <- (o .:? "reset_at" :: Parser (Maybe Int))     OpenAIUsageWindow       <$> o .: "used_percent"       <*> o .:? "limit_window_seconds"       <*> o .:? "reset_after_seconds"+      <*> pure (posixSecondsToUTCTime . realToFrac <$> (resetAt :: Maybe Int))+      <*> pure Nothing +data OpenAIUsageTotals = OpenAIUsageTotals+  { openAIUsageRequestCount :: Int,+    openAIUsageInputTokens :: Int,+    openAIUsageCachedInputTokens :: Int,+    openAIUsageOutputTokens :: Int,+    openAIUsageReasoningOutputTokens :: Int,+    openAIUsageTotalTokens :: Int+  }+  deriving (Eq, Show)++instance Semigroup OpenAIUsageTotals where+  a <> b =+    OpenAIUsageTotals+      { openAIUsageRequestCount = openAIUsageRequestCount a + openAIUsageRequestCount b,+        openAIUsageInputTokens = openAIUsageInputTokens a + openAIUsageInputTokens b,+        openAIUsageCachedInputTokens = openAIUsageCachedInputTokens a + openAIUsageCachedInputTokens b,+        openAIUsageOutputTokens = openAIUsageOutputTokens a + openAIUsageOutputTokens b,+        openAIUsageReasoningOutputTokens = openAIUsageReasoningOutputTokens a + openAIUsageReasoningOutputTokens b,+        openAIUsageTotalTokens = openAIUsageTotalTokens a + openAIUsageTotalTokens b+      }++instance Monoid OpenAIUsageTotals where+  mempty =+    OpenAIUsageTotals+      { openAIUsageRequestCount = 0,+        openAIUsageInputTokens = 0,+        openAIUsageCachedInputTokens = 0,+        openAIUsageOutputTokens = 0,+        openAIUsageReasoningOutputTokens = 0,+        openAIUsageTotalTokens = 0+      }++instance FromJSON OpenAIUsageTotals where+  parseJSON = withObject "OpenAIUsageTotals" $ \o -> do+    input <- o .:? "input_tokens" .!= 0+    cachedInput <- o .:? "cached_input_tokens" .!= 0+    outputTokens <- o .:? "output_tokens" .!= 0+    reasoningOutput <- o .:? "reasoning_output_tokens" .!= 0+    total <- o .:? "total_tokens" .!= (input + outputTokens)+    return $+      OpenAIUsageTotals+        { openAIUsageRequestCount = 1,+          openAIUsageInputTokens = input,+          openAIUsageCachedInputTokens = cachedInput,+          openAIUsageOutputTokens = outputTokens,+          openAIUsageReasoningOutputTokens = reasoningOutput,+          openAIUsageTotalTokens = total+        }+ data OpenAIUsageCredits = OpenAIUsageCredits   { openAIUsageHasCredits :: Bool,     openAIUsageCreditsUnlimited :: Bool,@@ -151,8 +224,11 @@  getOpenAIUsageInfo :: OpenAIUsageConfig -> IO OpenAIUsageInfo getOpenAIUsageInfo config = do+  now <- getCurrentTime   auth <- readOpenAIUsageAuth config-  fetchOpenAIUsage config auth+  info <- fetchOpenAIUsage config auth+  entries <- readOpenAITranscriptEntries config now+  return $ addOpenAITranscriptTotals entries info  updateOpenAIUsage :: OpenAIUsageConfig -> IO OpenAIUsageSnapshot updateOpenAIUsage config = do@@ -197,6 +273,126 @@   if statusCode >= 200 && statusCode < 300     then either fail return $ eitherDecode body     else fail $ "OpenAI usage endpoint returned HTTP " <> show statusCode++data OpenAITranscriptEntry = OpenAITranscriptEntry+  { openAITranscriptTimestamp :: UTCTime,+    openAITranscriptTotals :: OpenAIUsageTotals+  }+  deriving (Eq, Show)++data OpenAITranscriptJSON = OpenAITranscriptJSON+  { openAITranscriptJSONTimestamp :: Maybe UTCTime,+    openAITranscriptJSONUsage :: Maybe OpenAIUsageTotals+  }++instance FromJSON OpenAITranscriptJSON where+  parseJSON = withObject "OpenAITranscriptJSON" $ \o -> do+    payload <- o .:? "payload"+    usage <- maybe (return Nothing) parseTokenCountPayload payload+    OpenAITranscriptJSON+      <$> o .:? "timestamp"+      <*> pure usage++parseTokenCountPayload :: Value -> Parser (Maybe OpenAIUsageTotals)+parseTokenCountPayload =+  withObject "TokenCountPayload" $ \payload -> do+    payloadType <- payload .:? "type" :: Parser (Maybe T.Text)+    case payloadType of+      Just "token_count" -> payload .:? "info" >>= traverse parseTokenCountInfo+      _ -> return Nothing++parseTokenCountInfo :: Value -> Parser OpenAIUsageTotals+parseTokenCountInfo =+  withObject "TokenCountInfo" $ \info ->+    info .: "last_token_usage"++readOpenAITranscriptEntries :: OpenAIUsageConfig -> UTCTime -> IO [OpenAITranscriptEntry]+readOpenAITranscriptEntries config now = do+  sessionsPath <- maybe defaultCodexSessionsPath return (openAIUsageSessionsPath config)+  exists <- doesDirectoryExist sessionsPath+  if not exists+    then return []+    else do+      files <- jsonlFilesModifiedSince (addUTCTime (negate $ openAIUsageFileLookbackSeconds config) now) sessionsPath+      concat <$> mapM readTranscriptFile files++defaultCodexSessionsPath :: IO FilePath+defaultCodexSessionsPath = do+  codexHome <- lookupEnv "CODEX_HOME"+  case codexHome of+    Just dir -> return $ dir </> "sessions"+    Nothing -> do+      home <- getHomeDirectory+      return $ home </> ".codex" </> "sessions"++jsonlFilesModifiedSince :: UTCTime -> FilePath -> IO [FilePath]+jsonlFilesModifiedSince cutoff path = do+  entries <- listDirectory path+  concat+    <$> mapM+      ( \entry -> do+          let child = path </> entry+          isDirectory <- doesDirectoryExist child+          isFile <- doesFileExist child+          if isDirectory+            then jsonlFilesModifiedSince cutoff child+            else+              if isFile && takeExtension child == ".jsonl"+                then do+                  modified <- getModificationTime child+                  return [child | modified >= cutoff]+                else return []+      )+      entries++readTranscriptFile :: FilePath -> IO [OpenAITranscriptEntry]+readTranscriptFile path = do+  bytes <- LBS8.readFile path+  return $ mapMaybe transcriptLineToEntry (LBS8.lines bytes)++transcriptLineToEntry :: LBS.ByteString -> Maybe OpenAITranscriptEntry+transcriptLineToEntry bytes = do+  decoded <- either (const Nothing) Just $ eitherDecode bytes+  timestamp <- openAITranscriptJSONTimestamp decoded+  usage <- openAITranscriptJSONUsage decoded+  return $+    OpenAITranscriptEntry+      { openAITranscriptTimestamp = timestamp,+        openAITranscriptTotals = usage+      }++addOpenAITranscriptTotals :: [OpenAITranscriptEntry] -> OpenAIUsageInfo -> OpenAIUsageInfo+addOpenAITranscriptTotals entries info =+  info+    { openAIUsageRateLimit = addRateLimitTranscriptTotals entries (openAIUsageRateLimit info)+    }++addRateLimitTranscriptTotals :: [OpenAITranscriptEntry] -> OpenAIUsageRateLimit -> OpenAIUsageRateLimit+addRateLimitTranscriptTotals entries limit =+  limit+    { openAIUsagePrimaryWindow = addWindowTranscriptTotals entries <$> openAIUsagePrimaryWindow limit,+      openAIUsageSecondaryWindow = addWindowTranscriptTotals entries <$> openAIUsageSecondaryWindow limit+    }++addWindowTranscriptTotals :: [OpenAITranscriptEntry] -> OpenAIUsageWindow -> OpenAIUsageWindow+addWindowTranscriptTotals entries window =+  window+    { openAIUsageWindowTotals =+        foldMap openAITranscriptTotals <$> windowEntries window entries+    }++windowEntries :: OpenAIUsageWindow -> [OpenAITranscriptEntry] -> Maybe [OpenAITranscriptEntry]+windowEntries window entries = do+  duration <- openAIUsageWindowDurationSeconds window+  end <- openAIUsageResetAt window+  let start = addUTCTime (negate $ fromIntegral duration) end+  return $+    filter+      ( \entry ->+          let timestamp = openAITranscriptTimestamp entry+           in timestamp >= start && timestamp < end+      )+      entries  newtype OpenAIUsageChanVar   = OpenAIUsageChanVar

@@ -38,6 +38,7 @@   ) where +import Control.Applicative ((<|>)) import Control.Concurrent.MVar import Control.Concurrent.STM.TChan import Control.Exception (SomeException, catch)@@ -240,11 +241,6 @@                 nodeName = nName,                 isMonitor = monitor               }-  where-    (<|>) :: Maybe a -> Maybe a -> Maybe a-    (<|>) ma mb = case ma of-      Nothing -> mb-      just -> just  -- | Map media.class to NodeType. classToNodeType :: Text -> Maybe NodeType

@@ -35,6 +35,7 @@     getPulseAudioInfoChanFor,     getPulseAudioInfoStateFor,     connectPulseAudio,+    pulseAudioAvailable,     togglePulseAudioMute,     adjustPulseAudioVolume,   )@@ -412,6 +413,13 @@         Left (_ :: SomeException) -> return Nothing         Right client -> return (Just client) +pulseAudioAvailable :: IO Bool+pulseAudioAvailable = do+  mClient <- connectPulseAudio+  case mClient of+    Nothing -> pure False+    Just client -> disconnect client >> pure True+ withPulseAudio :: (Client -> IO a) -> IO (Maybe a) withPulseAudio action = do   mClient <- connectPulseAudio@@ -469,7 +477,7 @@       paServerLookupInterfaceName   case propsResult of     Left err -> do-      audioLogF WARNING "Failed to read PulseAudio ServerLookup1 properties: %s" err+      audioLogF DEBUG "Failed to read PulseAudio ServerLookup1 properties: %s" err       return Nothing     Right props -> case readDictMaybe props "Address" of       Just addr | not (null addr) -> return (Just addr)

@@ -47,6 +47,7 @@     writeTChan,   ) import Control.Exception.Enclosed (catchAny)+import qualified Data.List as List import qualified Data.Map.Strict as M import Data.Maybe (mapMaybe) import Data.Time.Clock.POSIX (getPOSIXTime)@@ -216,9 +217,10 @@         )  nextDueNs :: M.Map Word64 IntervalRegistration -> Maybe Word64-nextDueNs registrations-  | M.null registrations = Nothing-  | otherwise = Just $ minimum $ intervalNextDueNs <$> M.elems registrations+nextDueNs registrations =+  case intervalNextDueNs <$> M.elems registrations of+    [] -> Nothing+    firstDue : restDue -> Just $ List.foldl' min firstDue restDue  secondsToNanoseconds :: Int -> Either String Word64 secondsToNanoseconds seconds

@@ -1,5 +1,6 @@ {-# LANGUAGE AllowAmbiguousTypes #-} {-# LANGUAGE DataKinds #-}+{-# LANGUAGE ForeignFunctionInterface #-} {-# LANGUAGE KindSignatures #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ScopedTypeVariables #-}@@ -18,16 +19,19 @@ -- Stability   : unstable -- Portability : unportable ----- WirePlumber/PipeWire audio information using the @wpctl@ command-line tool.+-- WirePlumber/PipeWire audio information using libwireplumber through+-- GObject introspection. ----- This module provides access to audio volume and mute state for the default--- audio sink or source via WirePlumber's command-line interface.+-- This module keeps a WirePlumber core and object manager open, reads the+-- current node state from cached PipeWire params, and refreshes when+-- WirePlumber emits object or param change signals. module System.Taffybar.Information.WirePlumber   ( WirePlumberInfo (..),     NodeType (..),     getWirePlumberInfo,     getWirePlumberInfoChan,     getWirePlumberInfoState,+    getWirePlumberInfoChanAndVar,     getWirePlumberInfoChanFor,     getWirePlumberInfoStateFor,     toggleWirePlumberMute,@@ -36,22 +40,50 @@   ) where +import Control.Concurrent (forkOS, runInBoundThread) import Control.Concurrent.MVar import Control.Concurrent.STM.TChan-import Control.Exception (SomeException, try)-import Control.Monad (void)+import Control.Exception (SomeException, finally, try)+import Control.Monad (forM, forM_, unless, when) import Control.Monad.IO.Class (MonadIO, liftIO) import Control.Monad.STM (atomically)-import Data.List (isInfixOf)+import Data.Aeson (decodeStrict)+import Data.Aeson.Types (parseMaybe, withObject, (.:))+import qualified Data.ByteString.Char8 as B+import Data.Char (isDigit)+import qualified Data.GI.Base.BasicTypes as GI+import qualified Data.GI.Base.GValue as GValue+import qualified Data.GI.Base.GVariant as GVariant+import qualified Data.GI.Base.ManagedPtr as ManagedPtr+import Data.IORef+import Data.Maybe (catMaybes, fromMaybe, listToMaybe, mapMaybe) import Data.Proxy (Proxy (..)) import Data.Text (Text) import qualified Data.Text as T+import qualified Data.Text.Encoding as T+import Foreign+import Foreign.C.String+import Foreign.C.Types import GHC.TypeLits (KnownSymbol, SomeSymbol (..), Symbol, someSymbolVal, symbolVal)+import qualified GI.GLib.Structs.MainContext as MainContext+import qualified GI.GLib.Structs.MainLoop as MainLoop+import qualified GI.GObject.Objects.Object as GObject+import qualified GI.Wp.Enums as Wp+import qualified GI.Wp.Flags as Wp+import qualified GI.Wp.Functions as Wp+import qualified GI.Wp.Interfaces.PipewireObject as PipewireObject+import qualified GI.Wp.Objects.Conf as Conf+import qualified GI.Wp.Objects.Core as Core+import qualified GI.Wp.Objects.Metadata as Metadata+import qualified GI.Wp.Objects.Node as Node+import qualified GI.Wp.Objects.ObjectManager as ObjectManager+import qualified GI.Wp.Structs.Iterator as Iterator+import qualified GI.Wp.Structs.ObjectInterest as ObjectInterest+import qualified GI.Wp.Structs.SpaPod as SpaPod+import System.IO.Unsafe (unsafePerformIO) import System.Log.Logger (Priority (..)) import System.Taffybar.Context (TaffyIO, getStateDefault)-import System.Taffybar.Information.Wakeup (taffyForeverWithDelay) import System.Taffybar.Util (logPrintF, runCommand)-import Text.Read (readMaybe)  -- | Type of audio node. data NodeType@@ -67,24 +99,62 @@     wirePlumberVolume :: Double,     -- | Whether the node is muted     wirePlumberMuted :: Bool,-    -- | Name of the node (e.g., "@DEFAULT_AUDIO_SINK@")+    -- | PipeWire node name     wirePlumberNodeName :: Text   }   deriving (Eq, Show) +data WirePlumberSelector+  = DefaultNode NodeType+  | NodeName Text+  | NodeId Text+  deriving (Eq, Show)++data WirePlumberObjectRefs = WirePlumberObjectRefs+  { wirePlumberObjectRef :: GObject.Object,+    wirePlumberNodeRef :: Maybe Node.Node,+    wirePlumberMetadataRef :: Maybe Metadata.Metadata+  }++newtype WirePlumberInfoChanVar (a :: Symbol)+  = WirePlumberInfoChanVar (TChan (Maybe WirePlumberInfo), MVar (Maybe WirePlumberInfo))+ wpLogPath :: String wpLogPath = "System.Taffybar.Information.WirePlumber"  wpLogF :: (MonadIO m, Show t) => Priority -> String -> t -> m () wpLogF = logPrintF wpLogPath -newtype WirePlumberInfoChanVar (a :: Symbol)-  = WirePlumberInfoChanVar (TChan (Maybe WirePlumberInfo), MVar (Maybe WirePlumberInfo))+foreign import ccall "wp_spa_pod_get_property"+  c_wp_spa_pod_get_property ::+    Ptr SpaPod.SpaPod ->+    Ptr CString ->+    Ptr (Ptr SpaPod.SpaPod) ->+    IO CInt +foreign import ccall "wp_metadata_find"+  c_wp_metadata_find ::+    Ptr Metadata.Metadata ->+    Word32 ->+    CString ->+    Ptr CString ->+    IO CString++wpInitialized :: MVar Bool+wpInitialized = unsafePerformIO $ newMVar False+{-# NOINLINE wpInitialized #-}++initWirePlumber :: IO ()+initWirePlumber =+  modifyMVar_ wpInitialized $ \initialized -> do+    unless initialized $+      Wp.init [Wp.InitFlagsAll]+    pure True+ -- | Get a broadcast channel for WirePlumber info for the provided node spec. ----- The first call for a given node spec will start a monitoring thread that--- polls @wpctl@ periodically and broadcasts updates.+-- The first call for a given node spec starts a monitoring thread that keeps a+-- WirePlumber connection open and refreshes on PipeWire object/param changes. -- Subsequent calls return the already created channel. getWirePlumberInfoChan :: String -> TaffyIO (TChan (Maybe WirePlumberInfo)) getWirePlumberInfoChan nodeSpec =@@ -92,13 +162,19 @@     SomeSymbol (Proxy :: Proxy sym) -> getWirePlumberInfoChanFor @sym  -- | Read the current WirePlumber info state for the provided node spec.------ See 'getWirePlumberInfoChan' for monitoring behavior. getWirePlumberInfoState :: String -> TaffyIO (Maybe WirePlumberInfo) getWirePlumberInfoState nodeSpec =   case someSymbolVal nodeSpec of     SomeSymbol (Proxy :: Proxy sym) -> getWirePlumberInfoStateFor @sym +-- | Get both the broadcast channel and current state MVar for WirePlumber info.+getWirePlumberInfoChanAndVar :: String -> TaffyIO (TChan (Maybe WirePlumberInfo), MVar (Maybe WirePlumberInfo))+getWirePlumberInfoChanAndVar nodeSpec =+  case someSymbolVal nodeSpec of+    SomeSymbol (Proxy :: Proxy sym) -> do+      WirePlumberInfoChanVar pair <- getWirePlumberInfoChanVarFor @sym+      pure pair+ -- | Get a broadcast channel for WirePlumber info for a node spec given as a -- type-level string. getWirePlumberInfoChanFor :: forall a. (KnownSymbol a) => TaffyIO (TChan (Maybe WirePlumberInfo))@@ -117,75 +193,406 @@ getWirePlumberInfoChanVarFor =   getStateDefault $ do     let nodeSpec = symbolVal (Proxy @a)-    chan <- liftIO newBroadcastTChanIO-    var <- liftIO $ newMVar Nothing-    liftIO $ refreshWirePlumberInfo nodeSpec chan var-    let pollIntervalSeconds :: Double-        pollIntervalSeconds = fromIntegral pollIntervalMicros / 1000000-    void $-      taffyForeverWithDelay pollIntervalSeconds $-        liftIO $-          refreshWirePlumberInfo nodeSpec chan var-    pure $ WirePlumberInfoChanVar (chan, var)---- | Polling interval in microseconds (1 second).-pollIntervalMicros :: Int-pollIntervalMicros = 1_000_000+    liftIO $ do+      chan <- newBroadcastTChanIO+      var <- newMVar Nothing+      _ <- forkOS $ monitorWirePlumberInfo nodeSpec chan var+      pure $ WirePlumberInfoChanVar (chan, var) -refreshWirePlumberInfo ::+monitorWirePlumberInfo ::   String ->   TChan (Maybe WirePlumberInfo) ->   MVar (Maybe WirePlumberInfo) ->   IO ()-refreshWirePlumberInfo nodeSpec chan var = do-  result <- try $ getWirePlumberInfo nodeSpec-  let info = case result of-        Left (_ :: SomeException) -> Nothing-        Right i -> i-  _ <- swapMVar var info-  atomically $ writeTChan chan info+monitorWirePlumberInfo nodeSpec chan var = do+  result <- try $ do+    context <- MainContext.mainContextNew+    MainContext.mainContextPushThreadDefault (Just context)+    ( do+        initWirePlumber+        loop <- MainLoop.mainLoopNew (Just context) False+        core <- Core.coreNew (Just context) (Nothing :: Maybe Conf.Conf) Nothing+        manager <- buildObjectManager nodeSpec+        refreshLock <- newMVar ()+        connectedSignalRefs <- newIORef []+        connectedObjectRefs <- newIORef [] --- | Query volume and mute state for the provided node spec.------ The node spec can be:--- * "@DEFAULT_AUDIO_SINK@" or "" for the default output--- * "@DEFAULT_AUDIO_SOURCE@" for the default input--- * A numeric node ID------ Returns 'Nothing' if wpctl is not available or fails.+        let writeInfo info = do+              oldInfo <- swapMVar var info+              when (oldInfo /= info) $+                atomically $+                  writeTChan chan info++            refresh = withMVar refreshLock $ \_ ->+              readWirePlumberInfoFromRefs connectedObjectRefs nodeSpec >>= writeInfo++            rememberSignal ref = modifyIORef' connectedSignalRefs (ref :)++            rememberObject object maybeNode maybeMetadata =+              modifyIORef'+                connectedObjectRefs+                (WirePlumberObjectRefs object maybeNode maybeMetadata :)++            connectNode object = do+              maybeNode <- ManagedPtr.castTo Node.Node object+              forM_ maybeNode $ \node -> do+                mediaClass <- PipewireObject.pipewireObjectGetProperty node "media.class"+                when (mediaClass `elem` [Just "Audio/Sink", Just "Audio/Source"]) $ do+                  handler <-+                    PipewireObject.onPipewireObjectParamsChanged node $ \param ->+                      when (param == "Props") refresh+                  rememberSignal handler+              pure maybeNode++            connectMetadata object = do+              maybeMetadata <- ManagedPtr.castTo Metadata.Metadata object+              forM_ maybeMetadata $ \metadata -> do+                handler <-+                  Metadata.onMetadataChanged metadata $ \subject key _type _value ->+                    when (subject == 0 && key `elem` defaultMetadataKeys) refresh+                rememberSignal handler+              pure maybeMetadata++            connectObject object = do+              maybeNode <- connectNode object+              maybeMetadata <- connectMetadata object+              rememberObject object maybeNode maybeMetadata++        _ <- ObjectManager.onObjectManagerInstalled manager $ do+          objects <- getManagedObjects manager+          mapM_ connectObject objects+          refresh++        _ <- ObjectManager.onObjectManagerObjectAdded manager $ \object -> do+          connectObject object+          refresh++        _ <- ObjectManager.onObjectManagerObjectRemoved manager $ const refresh+        _ <- ObjectManager.onObjectManagerObjectsChanged manager refresh++        Core.coreInstallObjectManager core manager+        connected <- Core.coreConnect core+        unless connected $ fail "failed to connect WirePlumber core"+        MainLoop.mainLoopRun loop+        ManagedPtr.touchManagedPtr core+        ManagedPtr.touchManagedPtr manager+        ManagedPtr.touchManagedPtr loop+      )+      `finally` MainContext.mainContextPopThreadDefault (Just context)+  case result of+    Right () -> pure ()+    Left (e :: SomeException) -> do+      wpLogF WARNING "WirePlumber monitor failed: %s" e+      _ <- swapMVar var Nothing+      atomically $ writeTChan chan Nothing++buildObjectManager :: String -> IO ObjectManager.ObjectManager+buildObjectManager nodeSpec = do+  manager <- ObjectManager.objectManagerNew+  nodeType <- GI.glibType @Node.Node+  metadataType <- GI.glibType @Metadata.Metadata++  nodeInterest <- ObjectInterest.objectInterestNewType nodeType+  forM_ (selectorMediaClass $ parseNodeSpec nodeSpec) $ \mediaClass -> do+    mediaClassVariant <- GVariant.gvariantFromText mediaClass+    ObjectInterest.objectInterestAddConstraint+      nodeInterest+      Wp.ConstraintTypePwProperty+      "media.class"+      Wp.ConstraintVerbEquals+      (Just mediaClassVariant)+  ObjectManager.objectManagerAddInterestFull manager nodeInterest+  ObjectManager.objectManagerRequestObjectFeatures+    manager+    nodeType+    (fromIntegral $ fromEnum Wp.ProxyFeaturesPipewireObjectFeaturesAll)++  metadataInterest <- ObjectInterest.objectInterestNewType metadataType+  ObjectManager.objectManagerAddInterestFull manager metadataInterest+  ObjectManager.objectManagerRequestObjectFeatures+    manager+    metadataType+    (fromIntegral $ fromEnum Wp.ProxyFeaturesPipewireObjectFeaturesMinimal)++  pure manager++-- | Query volume and mute state for the provided node spec once. getWirePlumberInfo :: String -> IO (Maybe WirePlumberInfo)-getWirePlumberInfo nodeSpec = do-  let node = if null nodeSpec then "@DEFAULT_AUDIO_SINK@" else nodeSpec-  result <- runCommand "wpctl" ["get-volume", node]+getWirePlumberInfo nodeSpec = runInBoundThread $ do+  result <- try $ do+    context <- MainContext.mainContextNew+    MainContext.mainContextPushThreadDefault (Just context)+    ( do+        initWirePlumber+        loop <- MainLoop.mainLoopNew (Just context) False+        core <- Core.coreNew (Just context) (Nothing :: Maybe Conf.Conf) Nothing+        manager <- buildObjectManager nodeSpec+        var <- newMVar Nothing++        _ <- ObjectManager.onObjectManagerInstalled manager $ do+          objects <- getManagedObjects manager+          refs <- mapM buildWirePlumberObjectRefs objects+          info <- readWirePlumberInfoFromObjectRefs refs nodeSpec+          _ <- swapMVar var info+          MainLoop.mainLoopQuit loop++        _ <- Core.coreTimeoutAdd core 5000 $ do+          MainLoop.mainLoopQuit loop+          pure False++        Core.coreInstallObjectManager core manager+        connected <- Core.coreConnect core+        unless connected $ fail "failed to connect WirePlumber core"+        MainLoop.mainLoopRun loop+        info <- readMVar var+        ManagedPtr.touchManagedPtr core+        ManagedPtr.touchManagedPtr manager+        ManagedPtr.touchManagedPtr loop+        pure info+      )+      `finally` MainContext.mainContextPopThreadDefault (Just context)   case result of-    Left err -> do-      wpLogF WARNING "wpctl get-volume failed: %s" err-      return Nothing-    Right output -> return $ parseWpctlOutput node output+    Right info -> pure info+    Left (e :: SomeException) -> do+      wpLogF WARNING "WirePlumber query failed: %s" e+      pure Nothing --- | Parse the output of @wpctl get-volume@.------ Expected formats:--- * "Volume: 0.50"--- * "Volume: 0.50 [MUTED]"-parseWpctlOutput :: String -> String -> Maybe WirePlumberInfo-parseWpctlOutput nodeSpec output = do-  let trimmed = dropWhile (== ' ') output-  -- Check if it starts with "Volume:"-  volumeStr <--    if "Volume:" `isInfixOf` trimmed-      then Just $ drop 7 $ dropWhile (/= ':') trimmed-      else Nothing-  -- Parse the volume value and mute state-  let isMuted = "[MUTED]" `isInfixOf` volumeStr-      cleanVolStr = takeWhile (\c -> c /= '[' && c /= '\n') $ dropWhile (== ' ') volumeStr-  volume <- readMaybe cleanVolStr-  return+readWirePlumberInfoFromRefs ::+  IORef [WirePlumberObjectRefs] ->+  String ->+  IO (Maybe WirePlumberInfo)+readWirePlumberInfoFromRefs refs nodeSpec =+  readIORef refs >>= flip readWirePlumberInfoFromObjectRefs nodeSpec++readWirePlumberInfoFromObjectRefs ::+  [WirePlumberObjectRefs] ->+  String ->+  IO (Maybe WirePlumberInfo)+readWirePlumberInfoFromObjectRefs refs nodeSpec =+  ( do+      let metadata = mapMaybe wirePlumberMetadataRef refs+          nodes = mapMaybe wirePlumberNodeRef refs+      selectedNode <- selectNode metadata nodes (parseNodeSpec nodeSpec)+      maybe (pure Nothing) (fmap Just . readNodeInfo) selectedNode+  )+    `finally` mapM_ touchWirePlumberObjectRefs refs++touchWirePlumberObjectRefs :: WirePlumberObjectRefs -> IO ()+touchWirePlumberObjectRefs refs = do+  ManagedPtr.touchManagedPtr $ wirePlumberObjectRef refs+  mapM_ ManagedPtr.touchManagedPtr $ wirePlumberNodeRef refs+  mapM_ ManagedPtr.touchManagedPtr $ wirePlumberMetadataRef refs++buildWirePlumberObjectRefs :: GObject.Object -> IO WirePlumberObjectRefs+buildWirePlumberObjectRefs object =+  WirePlumberObjectRefs object+    <$> objectToNode object+    <*> objectToMetadata object++getManagedObjects :: ObjectManager.ObjectManager -> IO [GObject.Object]+getManagedObjects manager = do+  iterator <- ObjectManager.objectManagerNewIterator manager+  catMaybes <$> iteratorValues @(Maybe GObject.Object) iterator++objectToNode :: GObject.Object -> IO (Maybe Node.Node)+objectToNode = ManagedPtr.castTo Node.Node++objectToMetadata :: GObject.Object -> IO (Maybe Metadata.Metadata)+objectToMetadata = ManagedPtr.castTo Metadata.Metadata++selectNode ::+  [Metadata.Metadata] ->+  [Node.Node] ->+  WirePlumberSelector ->+  IO (Maybe Node.Node)+selectNode metadata nodes selector =+  case selector of+    DefaultNode nodeType -> do+      maybeDefaultName <- readDefaultNodeName metadata nodeType+      case maybeDefaultName of+        Just defaultName -> findM (nodeNameMatches defaultName) =<< filterNodesByType nodeType nodes+        Nothing -> listToMaybe <$> filterNodesByType nodeType nodes+    NodeName name -> findM (nodeNameMatches name) nodes+    NodeId nodeId -> findM (nodeIdMatches nodeId) nodes++filterNodesByType :: NodeType -> [Node.Node] -> IO [Node.Node]+filterNodesByType nodeType =+  filterMIO $ \node ->+    (== Just (nodeTypeMediaClass nodeType))+      <$> PipewireObject.pipewireObjectGetProperty node "media.class"++nodeNameMatches :: Text -> Node.Node -> IO Bool+nodeNameMatches expected node =+  (== Just expected) <$> PipewireObject.pipewireObjectGetProperty node "node.name"++nodeIdMatches :: Text -> Node.Node -> IO Bool+nodeIdMatches expected node =+  (== Just expected) <$> PipewireObject.pipewireObjectGetProperty node "object.id"++readDefaultNodeName :: [Metadata.Metadata] -> NodeType -> IO (Maybe Text)+readDefaultNodeName metadata nodeType = do+  names <-+    forM metadata $ \m -> do+      result <- metadataFindNoFree m 0 (defaultMetadataKey nodeType)+      pure $ result >>= parseDefaultNodeName . fst+  pure $ listToMaybe $ catMaybes names++readNodeInfo :: Node.Node -> IO WirePlumberInfo+readNodeInfo node = do+  nodeName <- fromMaybe "" <$> PipewireObject.pipewireObjectGetProperty node "node.name"+  props <- readNodeProps node+  maybeRawVolume <-+    maybe (pure Nothing) podArrayChildNumber $+      lookup "channelVolumes" props+  maybeMuted <-+    maybe (pure Nothing) podBool $+      lookup "mute" props+  let volume = pipeWireRawVolumeToLinear $ fromMaybe 0 maybeRawVolume+      muted = fromMaybe False maybeMuted+  pure $     WirePlumberInfo       { wirePlumberVolume = volume,-        wirePlumberMuted = isMuted,-        wirePlumberNodeName = T.pack nodeSpec+        wirePlumberMuted = muted,+        wirePlumberNodeName = nodeName       }++readNodeProps :: Node.Node -> IO [(Text, SpaPod.SpaPod)]+readNodeProps node = do+  maybeParams <- PipewireObject.pipewireObjectEnumParamsSync node "Props" Nothing+  case maybeParams of+    Nothing -> pure []+    Just params -> do+      pods <- catMaybes <$> iteratorValues @(Maybe SpaPod.SpaPod) params+      fmap concat $+        forM pods $ \pod -> do+          iterator <- SpaPod.spaPodNewIterator pod+          props <- catMaybes <$> iteratorValues @(Maybe SpaPod.SpaPod) iterator+          fmap catMaybes $+            forM props $ \propPod -> do+              (ok, key, value) <- spaPodGetPropertyNoFree propPod+              pure $ if ok then Just (key, value) else Nothing++spaPodGetPropertyNoFree :: SpaPod.SpaPod -> IO (Bool, Text, SpaPod.SpaPod)+spaPodGetPropertyNoFree pod =+  ManagedPtr.withManagedPtr pod $ \podPtr ->+    alloca $ \keyPtr ->+      alloca $ \valuePtr -> do+        result <- c_wp_spa_pod_get_property podPtr keyPtr valuePtr+        keyPtrValue <- peek keyPtr+        valuePtrValue <- peek valuePtr+        key <-+          if keyPtrValue == nullPtr+            then pure ""+            else T.pack <$> peekCString keyPtrValue+        value <- ManagedPtr.wrapBoxed SpaPod.SpaPod valuePtrValue+        pure (result /= 0, key, value)++metadataFindNoFree :: Metadata.Metadata -> Word32 -> Text -> IO (Maybe (Text, Text))+metadataFindNoFree metadata subject key =+  ManagedPtr.withManagedPtr metadata $ \metadataPtr ->+    B.useAsCString (T.encodeUtf8 key) $ \keyPtr ->+      alloca $ \typePtr -> do+        valuePtr <- c_wp_metadata_find metadataPtr subject keyPtr typePtr+        if valuePtr == nullPtr+          then pure Nothing+          else do+            typePtrValue <- peek typePtr+            value <- T.pack <$> peekCString valuePtr+            type_ <-+              if typePtrValue == nullPtr+                then pure ""+                else T.pack <$> peekCString typePtrValue+            pure $ Just (value, type_)++podArrayChildNumber :: SpaPod.SpaPod -> IO (Maybe Double)+podArrayChildNumber pod =+  do+    isArray <- SpaPod.spaPodIsArray pod+    if isArray+      then SpaPod.spaPodGetArrayChild pod >>= podNumber+      else podNumber pod++podNumber :: SpaPod.SpaPod -> IO (Maybe Double)+podNumber pod = do+  isFloat <- SpaPod.spaPodIsFloat pod+  isDouble <- SpaPod.spaPodIsDouble pod+  if isFloat+    then do+      (ok, value) <- SpaPod.spaPodGetFloat pod+      pure $ if ok then Just (realToFrac value) else Nothing+    else+      if isDouble+        then do+          (ok, value) <- SpaPod.spaPodGetDouble pod+          pure $ if ok then Just value else Nothing+        else pure Nothing++podBool :: SpaPod.SpaPod -> IO (Maybe Bool)+podBool pod = do+  isBool <- SpaPod.spaPodIsBoolean pod+  if isBool+    then do+      (ok, value) <- SpaPod.spaPodGetBoolean pod+      pure $ if ok then Just value else Nothing+    else pure Nothing++parseDefaultNodeName :: Text -> Maybe Text+parseDefaultNodeName value =+  decodeStrict (T.encodeUtf8 value) >>= parseMaybe parseName+  where+    parseName = withObject "WirePlumber default audio target" (.: "name")++pipeWireRawVolumeToLinear :: Double -> Double+pipeWireRawVolumeToLinear rawVolume = rawVolume ** (1 / 3 :: Double)++parseNodeSpec :: String -> WirePlumberSelector+parseNodeSpec "" = DefaultNode Sink+parseNodeSpec "@DEFAULT_AUDIO_SINK@" = DefaultNode Sink+parseNodeSpec "@DEFAULT_SINK@" = DefaultNode Sink+parseNodeSpec "@DEFAULT_AUDIO_SOURCE@" = DefaultNode Source+parseNodeSpec "@DEFAULT_SOURCE@" = DefaultNode Source+parseNodeSpec spec+  | all isDigit spec = NodeId $ T.pack spec+  | otherwise = NodeName $ T.pack spec++selectorMediaClass :: WirePlumberSelector -> Maybe Text+selectorMediaClass (DefaultNode nodeType) = Just $ nodeTypeMediaClass nodeType+selectorMediaClass _ = Nothing++nodeTypeMediaClass :: NodeType -> Text+nodeTypeMediaClass Sink = "Audio/Sink"+nodeTypeMediaClass Source = "Audio/Source"++defaultMetadataKey :: NodeType -> Text+defaultMetadataKey Sink = "default.audio.sink"+defaultMetadataKey Source = "default.audio.source"++defaultMetadataKeys :: [Text]+defaultMetadataKeys =+  [ "default.audio.sink",+    "default.audio.source",+    "default.configured.audio.sink",+    "default.configured.audio.source"+  ]++findM :: (a -> IO Bool) -> [a] -> IO (Maybe a)+findM _ [] = pure Nothing+findM predicate (x : xs) = do+  matches <- predicate x+  if matches then pure $ Just x else findM predicate xs++filterMIO :: (a -> IO Bool) -> [a] -> IO [a]+filterMIO predicate = fmap (map fst . filter snd) . mapM (\x -> (x,) <$> predicate x)++iteratorValues :: (GValue.IsGValue a) => Iterator.Iterator -> IO [a]+iteratorValues iterator = do+  (hasNext, value) <- Iterator.iteratorNext iterator+  if hasNext+    then do+      item <- GValue.fromGValue value+      rest <- iteratorValues iterator+      pure (item : rest)+    else pure []  -- | Toggle mute for the provided node spec. Returns True on success. toggleWirePlumberMute :: String -> IO Bool

@@ -69,6 +69,7 @@   ) import System.Taffybar.Information.SafeX11 (safeGetGeometry) import System.Taffybar.Information.Workspaces.Model+import System.Taffybar.Information.Workspaces.Refresh (workspaceRefreshRequestLoop) import System.Taffybar.Information.X11DesktopInfo (X11Property, X11Window, getDisplay) import qualified System.Taffybar.Information.X11DesktopInfo as X11 @@ -168,6 +169,7 @@   eventChan <- liftIO newBroadcastTChanIO   stateVar <- liftIO $ newMVar defaultEWMHWorkspaceState   taffyFork $ ewmhWorkspaceStateLoop cfg stateChan eventChan stateVar+  taffyFork $ workspaceRefreshRequestLoop stateChan eventChan stateVar   return $ EWMHWorkspaceStateChanVar (stateChan, eventChan, stateVar)  ewmhWorkspaceStateLoop ::@@ -223,12 +225,13 @@         return (False, snapshotWorkspaces previous)   let nextRevision = snapshotRevision previous + 1       next =-        WorkspaceSnapshot-          { snapshotBackend = WorkspaceBackendEWMH,-            snapshotRevision = nextRevision,-            snapshotWindowDataComplete = complete,-            snapshotWorkspaces = workspaces-          }+        preserveWorkspaceUpdateRevisions previous $+          WorkspaceSnapshot+            { snapshotBackend = WorkspaceBackendEWMH,+              snapshotRevision = nextRevision,+              snapshotWindowDataComplete = complete,+              snapshotWorkspaces = workspaces+            }       eventBatch =         WorkspaceEventBatch           { eventBatchBackend = WorkspaceBackendEWMH,@@ -277,6 +280,7 @@                   { workspaceNumericId = Just idx,                     workspaceName = T.pack name                   },+              workspaceUpdateRevision = 0,               workspaceState = wsViewState,               workspaceHasUrgentWindow = any windowUrgent windowsInfo,               workspaceIsSpecial = isSpecialWorkspaceName name,@@ -310,12 +314,14 @@   return     WindowInfo       { windowIdentity = X11WindowIdentity (fromIntegral window),+        windowUpdateRevision = 0,         windowTitle = T.pack wTitle,         windowClassHints = map T.pack $ parseWindowClasses wClass,         windowPosition = wPosition,         windowUrgent = window `elem` urgentWindows,         windowActive = Just window == activeWindow,-        windowMinimized = wMinimized+        windowMinimized = wMinimized,+        windowPinned = False       }  getWindowPosition :: X11Window -> X11Property (Maybe (Int, Int))

@@ -16,7 +16,12 @@ -- Shared Hyprland workspace-state provider using a broadcast channel + state MVar. module System.Taffybar.Information.Workspaces.Hyprland   ( HyprlandWorkspaceProviderConfig (..),+    HyprlandSpecialWorkspaceWindowTarget (..),     defaultHyprlandWorkspaceProviderConfig,+    applySpecialWorkspaceWindowTargets,+    specialWorkspaceWindowsToNamed,+    specialWorkspaceWindowsToMinimized,+    sortWorkspaceInfos,     defaultHyprlandWorkspaceState,     isRelevantHyprlandWorkspaceEvent,     getHyprlandWorkspaceStateAndEventChansAndVar,@@ -33,15 +38,16 @@ where  import Control.Applicative ((<|>))+import Control.Concurrent (threadDelay) import Control.Concurrent.MVar-import Control.Concurrent.STM.TChan+import Control.Concurrent.STM.TChan (TChan, newBroadcastTChanIO, readTChan, tryReadTChan, writeTChan) import Control.Exception.Enclosed (catchAny) import Control.Monad (forever, when) import Control.Monad.IO.Class (MonadIO (..)) import Control.Monad.STM (atomically) import Data.Either (isRight) import qualified Data.Foldable as F-import Data.List (sortOn)+import Data.List (nub, sortOn) import qualified Data.Map.Strict as M import Data.Maybe (catMaybes, fromMaybe, listToMaybe) import qualified Data.Text as T@@ -52,17 +58,27 @@ import qualified System.Taffybar.Information.Hyprland.API as HyprAPI import qualified System.Taffybar.Information.Hyprland.Types as HyprTypes import System.Taffybar.Information.Workspaces.Model+import System.Taffybar.Information.Workspaces.Refresh (workspaceRefreshRequestLoop)  data HyprlandWorkspaceProviderConfig = HyprlandWorkspaceProviderConfig   { workspaceSnapshotGetter :: TaffyIO (Bool, [WorkspaceInfo]),-    workspaceEventFilter :: T.Text -> Bool+    workspaceEventFilter :: T.Text -> Bool,+    specialWorkspaceWindowTarget ::+      WorkspaceInfo ->+      Maybe HyprlandSpecialWorkspaceWindowTarget   } +data HyprlandSpecialWorkspaceWindowTarget = HyprlandSpecialWorkspaceWindowTarget+  { targetWorkspaceName :: T.Text,+    targetWindowModifier :: WindowInfo -> WindowInfo+  }+ defaultHyprlandWorkspaceProviderConfig :: HyprlandWorkspaceProviderConfig defaultHyprlandWorkspaceProviderConfig =   HyprlandWorkspaceProviderConfig     { workspaceSnapshotGetter = buildHyprlandWorkspaceSnapshot,-      workspaceEventFilter = isRelevantHyprlandWorkspaceEvent+      workspaceEventFilter = isRelevantHyprlandWorkspaceEvent,+      specialWorkspaceWindowTarget = const Nothing     }  defaultHyprlandWorkspaceState :: WorkspaceSnapshot@@ -97,6 +113,7 @@                  "movewindow",                  "movewindowv2",                  "moveworkspace",+                 "pin",                  "renameworkspace",                  "createworkspace",                  "destroyworkspace",@@ -174,6 +191,7 @@   eventChan <- liftIO newBroadcastTChanIO   var <- liftIO $ newMVar defaultHyprlandWorkspaceState   taffyFork $ hyprlandWorkspaceStateLoop cfg stateChan eventChan var+  taffyFork $ workspaceRefreshRequestLoop stateChan eventChan var   return $ HyprlandWorkspaceStateChanVar (stateChan, eventChan, var)  hyprlandWorkspaceStateLoop ::@@ -186,9 +204,19 @@   refreshHyprlandWorkspaceState cfg stateChan workspaceEventChan var   hyprlandEventChan <- getHyprlandEventChan   events <- liftIO $ Hypr.subscribeHyprlandEvents hyprlandEventChan+  let collectPendingRelevantEvents = do+        maybeLine <- tryReadTChan events+        case maybeLine of+          Nothing -> return []+          Just line ->+            if workspaceEventFilter cfg line+              then (line :) <$> collectPendingRelevantEvents+              else collectPendingRelevantEvents   forever $ do     line <- liftIO $ atomically $ readTChan events-    when (workspaceEventFilter cfg line) $+    when (workspaceEventFilter cfg line) $ do+      liftIO $ threadDelay 25_000+      _ <- liftIO $ atomically collectPendingRelevantEvents       refreshHyprlandWorkspaceState cfg stateChan workspaceEventChan var  refreshHyprlandWorkspaceState ::@@ -199,18 +227,23 @@   TaffyIO () refreshHyprlandWorkspaceState cfg stateChan workspaceEventChan var = do   previous <- liftIO $ readMVar var-  (complete, workspaces) <-+  (complete, rawWorkspaces) <-     workspaceSnapshotGetter cfg       `catchAny` \err -> do         wLog WARNING $ "Hyprland workspace snapshot update failed: " <> show err         return (False, snapshotWorkspaces previous)-  let next =-        WorkspaceSnapshot-          { snapshotBackend = WorkspaceBackendHyprland,-            snapshotRevision = snapshotRevision previous + 1,-            snapshotWindowDataComplete = complete,-            snapshotWorkspaces = workspaces-          }+  let workspaces =+        applySpecialWorkspaceWindowTargets+          (specialWorkspaceWindowTarget cfg)+          rawWorkspaces+      next =+        preserveWorkspaceUpdateRevisions previous $+          WorkspaceSnapshot+            { snapshotBackend = WorkspaceBackendHyprland,+              snapshotRevision = snapshotRevision previous + 1,+              snapshotWindowDataComplete = complete,+              snapshotWorkspaces = workspaces+            }       eventBatch =         WorkspaceEventBatch           { eventBatchBackend = snapshotBackend next,@@ -256,7 +289,6 @@        in return $ if T.null address then Nothing else Just address    let windowsByWorkspace = collectWorkspaceWindows activeWindowAddress clients-      sortedWorkspaces = sortOn HyprTypes.hyprWorkspaceId workspaces       visibleWorkspaceIds =         [ HyprTypes.hyprWorkspaceRefId wsRef         | monitor <- monitors,@@ -289,18 +321,134 @@                     { workspaceNumericId = Just wsId,                       workspaceName = wsName                     },+                workspaceUpdateRevision = 0,                 workspaceState = wsState,                 workspaceHasUrgentWindow = any windowUrgent wsWindows,                 workspaceIsSpecial = isSpecialWorkspace wsId wsName,                 workspaceWindows = wsWindows               }-  return (clientsOk, map toWorkspace sortedWorkspaces)+  return (clientsOk, sortWorkspaceInfos $ map toWorkspace workspaces)  isSpecialWorkspace :: Int -> T.Text -> Bool isSpecialWorkspace wsId wsName =   let lowered = T.toLower wsName    in wsId < 0 || T.isPrefixOf "special" lowered +sortWorkspaceInfos :: [WorkspaceInfo] -> [WorkspaceInfo]+sortWorkspaceInfos =+  sortOn $ \workspace ->+    let identity = workspaceIdentity workspace+     in ( workspaceIsSpecial workspace,+          fromMaybe maxBound $ workspaceNumericId identity,+          workspaceName identity+        )++workspaceInfoName :: WorkspaceInfo -> T.Text+workspaceInfoName =+  workspaceName . workspaceIdentity++workspaceInfoIsMinimized :: WorkspaceInfo -> Bool+workspaceInfoIsMinimized workspace =+  let name = T.toLower $ workspaceInfoName workspace+   in name == "minimized" || name == "special:minimized"++specialWorkspaceWindowsToNamed ::+  T.Text ->+  (WindowInfo -> WindowInfo) ->+  WorkspaceInfo ->+  Maybe HyprlandSpecialWorkspaceWindowTarget+specialWorkspaceWindowsToNamed targetName modifyWindow workspace+  | workspaceIsSpecial workspace && workspaceInfoName workspace /= targetName =+      Just $+        HyprlandSpecialWorkspaceWindowTarget+          { targetWorkspaceName = targetName,+            targetWindowModifier = modifyWindow+          }+  | otherwise = Nothing++specialWorkspaceWindowsToMinimized ::+  WorkspaceInfo ->+  Maybe HyprlandSpecialWorkspaceWindowTarget+specialWorkspaceWindowsToMinimized workspace+  | workspaceIsSpecial workspace && not (workspaceInfoIsMinimized workspace) =+      Just $+        HyprlandSpecialWorkspaceWindowTarget+          { targetWorkspaceName = "special:minimized",+            targetWindowModifier = \window -> window {windowMinimized = True}+          }+  | otherwise = Nothing++applySpecialWorkspaceWindowTargets ::+  (WorkspaceInfo -> Maybe HyprlandSpecialWorkspaceWindowTarget) ->+  [WorkspaceInfo] ->+  [WorkspaceInfo]+applySpecialWorkspaceWindowTargets targetForWorkspace workspaces =+  map addTargetWindows withMissingTargets+  where+    workspaceWasMoved workspace =+      workspaceIdentity workspace `elem` movedSourceIdentities+    sourceName workspace = workspaceName $ workspaceIdentity workspace+    moves =+      [ (workspaceIdentity workspace, targetWorkspaceName target, movedWindows)+      | workspace <- workspaces,+        Just target <- [targetForWorkspace workspace],+        targetWorkspaceName target /= sourceName workspace,+        let movedWindows = map (targetWindowModifier target) (workspaceWindows workspace),+        not (null movedWindows)+      ]+    movedSourceIdentities =+      [sourceIdentity | (sourceIdentity, _, _) <- moves]+    targetNamesInOrder =+      nub [targetName | (_, targetName, _) <- moves]+    targetWindowsByName =+      M.fromListWith+        (flip (++))+        [(targetName, movedWindows) | (_, targetName, movedWindows) <- moves]+    clearMovedSource workspace+      | workspaceWasMoved workspace =+          workspace+            { workspaceState = WorkspaceEmpty,+              workspaceHasUrgentWindow = False,+              workspaceWindows = []+            }+      | otherwise = workspace+    baseWorkspaces = map clearMovedSource workspaces+    existingNames = map sourceName baseWorkspaces+    withMissingTargets =+      baseWorkspaces+        ++ [ emptyTargetWorkspace targetName+           | targetName <- targetNamesInOrder,+             targetName `notElem` existingNames+           ]+    emptyTargetWorkspace targetName =+      WorkspaceInfo+        { workspaceIdentity =+            WorkspaceIdentity+              { workspaceNumericId = Nothing,+                workspaceName = targetName+              },+          workspaceUpdateRevision = 0,+          workspaceState = WorkspaceEmpty,+          workspaceHasUrgentWindow = False,+          workspaceIsSpecial = True,+          workspaceWindows = []+        }+    addTargetWindows workspace =+      let addedWindows = M.findWithDefault [] (sourceName workspace) targetWindowsByName+       in if null addedWindows+            then workspace+            else+              workspace+                { workspaceState =+                    if workspaceState workspace == WorkspaceEmpty+                      then WorkspaceHidden+                      else workspaceState workspace,+                  workspaceHasUrgentWindow =+                    workspaceHasUrgentWindow workspace+                      || any windowUrgent addedWindows,+                  workspaceWindows = workspaceWindows workspace ++ addedWindows+                }+ collectWorkspaceWindows ::   Maybe T.Text ->   [HyprTypes.HyprlandClientInfo] ->@@ -313,6 +461,16 @@           windowData = windowFromClient activeAddr client        in M.insertWith (++) wsId [windowData] windowsMap +clientIsOnMinimizedWorkspace :: HyprTypes.HyprlandClientInfo -> Bool+clientIsOnMinimizedWorkspace =+  workspaceRefIsMinimized . HyprTypes.hyprClientWorkspace++workspaceRefIsMinimized :: HyprTypes.HyprlandWorkspaceRef -> Bool+workspaceRefIsMinimized workspace =+  let name = T.toLower $ HyprTypes.hyprWorkspaceRefName workspace+   in name == "minimized"+        || name == "special:minimized"+ windowFromClient :: Maybe T.Text -> HyprTypes.HyprlandClientInfo -> WindowInfo windowFromClient activeAddr client =   let rawTitle = HyprTypes.hyprClientTitle client@@ -326,8 +484,10 @@       minimized =         HyprTypes.hyprClientHidden client           || not (HyprTypes.hyprClientMapped client)+          || clientIsOnMinimizedWorkspace client    in WindowInfo         { windowIdentity = HyprlandWindowIdentity (HyprTypes.hyprClientAddress client),+          windowUpdateRevision = 0,           windowTitle = title,           windowClassHints =             catMaybes@@ -337,5 +497,6 @@           windowPosition = HyprTypes.hyprClientAt client,           windowUrgent = HyprTypes.hyprClientUrgent client,           windowActive = active,-          windowMinimized = minimized+          windowMinimized = minimized,+          windowPinned = HyprTypes.hyprClientPinned client         }

@@ -24,6 +24,9 @@     WorkspaceInfo (..),     WindowIdentity (..),     WindowInfo (..),+    WorkspacesRefreshTarget (..),+    bumpWorkspaceRefreshTarget,+    preserveWorkspaceUpdateRevisions,   ) where @@ -90,6 +93,7 @@ -- | Backend-neutral workspace information. data WorkspaceInfo = WorkspaceInfo   { workspaceIdentity :: WorkspaceIdentity,+    workspaceUpdateRevision :: Word64,     workspaceState :: WorkspaceViewState,     workspaceHasUrgentWindow :: Bool,     workspaceIsSpecial :: Bool,@@ -105,6 +109,7 @@ -- | Backend-neutral window information. data WindowInfo = WindowInfo   { windowIdentity :: WindowIdentity,+    windowUpdateRevision :: Word64,     windowTitle :: Text,     -- | Ordered class/app-id hints used for icon lookup.     windowClassHints :: [Text],@@ -112,9 +117,73 @@     windowPosition :: Maybe (Int, Int),     windowUrgent :: Bool,     windowActive :: Bool,-    windowMinimized :: Bool+    windowMinimized :: Bool,+    windowPinned :: Bool   }   deriving (Eq, Show)++data WorkspacesRefreshTarget+  = RefreshAllWorkspaces+  | RefreshWorkspace WorkspaceIdentity+  | RefreshWindow WindowIdentity+  deriving (Eq, Show)++bumpWorkspaceRefreshTarget :: WorkspacesRefreshTarget -> WorkspaceSnapshot -> WorkspaceSnapshot+bumpWorkspaceRefreshTarget target snapshot =+  snapshot {snapshotWorkspaces = map bumpWorkspaceForTarget (snapshotWorkspaces snapshot)}+  where+    bumpWorkspaceRevision workspace =+      workspace {workspaceUpdateRevision = workspaceUpdateRevision workspace + 1}+    bumpWindowRevision window =+      window {windowUpdateRevision = windowUpdateRevision window + 1}+    bumpWorkspaceAndWindows workspace =+      bumpWorkspaceRevision+        workspace+          { workspaceWindows = map bumpWindowRevision (workspaceWindows workspace)+          }+    bumpWindowForTarget targetWindow window+      | windowIdentity window == targetWindow = bumpWindowRevision window+      | otherwise = window+    bumpWorkspaceForTarget workspace =+      case target of+        RefreshAllWorkspaces -> bumpWorkspaceAndWindows workspace+        RefreshWorkspace targetWorkspace+          | workspaceIdentity workspace == targetWorkspace -> bumpWorkspaceAndWindows workspace+          | otherwise -> workspace+        RefreshWindow targetWindow ->+          workspace {workspaceWindows = map (bumpWindowForTarget targetWindow) (workspaceWindows workspace)}++preserveWorkspaceUpdateRevisions :: WorkspaceSnapshot -> WorkspaceSnapshot -> WorkspaceSnapshot+preserveWorkspaceUpdateRevisions previous next =+  next {snapshotWorkspaces = map preserveWorkspaceRevision (snapshotWorkspaces next)}+  where+    previousWorkspaces =+      M.fromList+        [ (workspaceIdentity workspace, workspace)+        | workspace <- snapshotWorkspaces previous+        ]+    previousWindows =+      M.fromList+        [ (windowIdentity window, window)+        | workspace <- snapshotWorkspaces previous,+          window <- workspaceWindows workspace+        ]+    preserveWindowRevision window =+      case M.lookup (windowIdentity window) previousWindows of+        Just previousWindow ->+          window {windowUpdateRevision = windowUpdateRevision previousWindow}+        Nothing -> window+    preserveWorkspaceRevision workspace =+      let withWindows =+            workspace+              { workspaceWindows = map preserveWindowRevision (workspaceWindows workspace)+              }+       in case M.lookup (workspaceIdentity workspace) previousWorkspaces of+            Just previousWorkspace ->+              withWindows+                { workspaceUpdateRevision = workspaceUpdateRevision previousWorkspace+                }+            Nothing -> withWindows  -- | Produce incremental events that describe the change from an old snapshot to -- a new one.

@@ -0,0 +1,75 @@+-- | Shared workspace refresh requests.+module System.Taffybar.Information.Workspaces.Refresh+  ( getWorkspacesRefreshRequestChan,+    requestWorkspacesRefresh,+    workspaceRefreshRequestLoop,+  )+where++import Control.Concurrent.MVar (MVar, modifyMVar_)+import Control.Concurrent.STM.TChan+  ( TChan,+    dupTChan,+    newBroadcastTChanIO,+    readTChan,+    writeTChan,+  )+import Control.Monad (forever, when)+import Control.Monad.IO.Class (liftIO)+import Control.Monad.STM (atomically)+import System.Taffybar.Context (TaffyIO, getStateDefault)+import System.Taffybar.Information.Workspaces.Model++newtype WorkspacesRefreshRequestChan+  = WorkspacesRefreshRequestChan (TChan WorkspacesRefreshTarget)++getWorkspacesRefreshRequestChan :: TaffyIO (TChan WorkspacesRefreshTarget)+getWorkspacesRefreshRequestChan = do+  WorkspacesRefreshRequestChan chan <-+    getStateDefault $+      WorkspacesRefreshRequestChan <$> liftIO newBroadcastTChanIO+  return chan++requestWorkspacesRefresh :: WorkspacesRefreshTarget -> TaffyIO ()+requestWorkspacesRefresh target = do+  chan <- getWorkspacesRefreshRequestChan+  liftIO $ atomically $ writeTChan chan target++workspaceRefreshRequestLoop ::+  TChan WorkspaceSnapshot ->+  TChan WorkspaceEventBatch ->+  MVar WorkspaceSnapshot ->+  TaffyIO ()+workspaceRefreshRequestLoop stateChan eventChan stateVar = do+  requestChan <- getWorkspacesRefreshRequestChan+  requests <- liftIO $ atomically $ dupTChan requestChan+  forever $ do+    target <- liftIO $ atomically $ readTChan requests+    liftIO $ publishRefreshTarget stateChan eventChan stateVar target++publishRefreshTarget ::+  TChan WorkspaceSnapshot ->+  TChan WorkspaceEventBatch ->+  MVar WorkspaceSnapshot ->+  WorkspacesRefreshTarget ->+  IO ()+publishRefreshTarget stateChan eventChan stateVar target =+  modifyMVar_ stateVar $ \previous -> do+    let refreshed = bumpWorkspaceRefreshTarget target previous+        changed = snapshotWorkspaces refreshed /= snapshotWorkspaces previous+        next =+          refreshed+            { snapshotRevision = snapshotRevision previous + 1+            }+        eventBatch =+          WorkspaceEventBatch+            { eventBatchBackend = snapshotBackend next,+              eventBatchRevision = snapshotRevision next,+              eventBatchWindowDataComplete = snapshotWindowDataComplete next,+              eventBatchEvents = diffWorkspaceSnapshots previous next+            }+    when changed $+      atomically $ do+        writeTChan stateChan next+        writeTChan eventChan eventBatch+    return $ if changed then next else previous

@@ -37,7 +37,6 @@ import Data.Char (toLower) import Data.List import Data.Maybe-import qualified Debug.Trace as D import GHC.IO.Encoding import Safe (headMay) import System.Directory@@ -67,9 +66,20 @@       (getXdgDirectory XdgConfig "")       (getXdgDirectoryList XdgConfigDirs)   maybePrefix <- (mMenuPrefix <|>) <$> getXDGMenuPrefix-  let maybeAddDash t = if last t == '-' then t else t ++ "-"-      dashedPrefix = maybe "" maybeAddDash maybePrefix-  return $ map (</> "menus" </> dashedPrefix ++ "applications.menu") configDirs+  let maybeAddDash "" = ""+      maybeAddDash t =+        case unsnoc t of+          Just (_, '-') -> t+          _ -> t ++ "-"+      prefixes =+        case maybePrefix of+          Nothing -> [""]+          Just prefix ->+            let dashedPrefix = maybeAddDash prefix+             in if null dashedPrefix then [""] else [dashedPrefix, ""]+      menuFilename prefix dir =+        dir </> "menus" </> (prefix ++ "applications.menu")+  return [menuFilename prefix dir | prefix <- prefixes, dir <- configDirs]  -- | XDG Menu, cf. "Desktop Menu Specification". data XDGMenu = XDGMenu@@ -187,7 +197,7 @@             mapMaybe parseSingleItem $               elChildren e       "Not" -> Not <$> (parseSingleItem =<< listToMaybe (elChildren e))-      unknown -> D.trace ("Unknown Condition item: " ++ unknown) Nothing+      _ -> Nothing  -- | Combinable conditions for Include and Exclude statements. data DesktopEntryCondition@@ -209,7 +219,7 @@     parseLayoutItem e = case qName (elName e) of       "Separator" -> Just XliSeparator       "Filename" -> Just $ XliFile $ strContent e-      unknown -> D.trace ("Unknown layout item: " ++ unknown) Nothing+      _ -> Nothing  -- | Determine whether a desktop entry fulfils a condition. matchesCondition :: DesktopEntry -> DesktopEntryCondition -> Bool

@@ -157,7 +157,7 @@ -- | Text variant of 'truncateString'. truncateText :: Int -> T.Text -> T.Text truncateText n incoming-  | T.length incoming <= n = incoming+  | T.compareLength incoming n /= GT = incoming   | otherwise = T.append (T.take n incoming) "…"  -- | Run the provided command with the provided arguments.

@@ -70,6 +70,9 @@   -- * "System.Taffybar.Widget.NetworkManager"   , module System.Taffybar.Widget.NetworkManager +  -- * "System.Taffybar.Widget.OmniMenu"+  , module System.Taffybar.Widget.OmniMenu+   -- * "System.Taffybar.Widget.PowerProfiles"   , module System.Taffybar.Widget.PowerProfiles @@ -128,6 +131,7 @@ import System.Taffybar.Widget.MPRIS2 import System.Taffybar.Widget.NetworkGraph import System.Taffybar.Widget.NetworkManager+import System.Taffybar.Widget.OmniMenu import System.Taffybar.Widget.PowerProfiles import System.Taffybar.Widget.SNITray import System.Taffybar.Widget.SNITray.PrioritizedCollapsible

@@ -13,6 +13,7 @@     anthropicUsageLabelNewWith,     anthropicUsageFiveHourWindowLabelNew,     anthropicUsageWeeklyWindowLabelNew,+    anthropicUsageSectionNewWith,     anthropicUsageStackNew,     anthropicUsageStackNewWith,     anthropicUsageNew,@@ -37,7 +38,7 @@ import System.Taffybar.Context (TaffyIO, getStateDefault) import System.Taffybar.Information.AnthropicUsage import System.Taffybar.Util (postGUIASync)-import System.Taffybar.Widget.Util (widgetSetClassGI)+import System.Taffybar.Widget.Util (buildIconLabelBox, widgetSetClassGI) import Text.Printf (printf)  data AnthropicUsageDisplayMode@@ -49,6 +50,15 @@   = AnthropicUsageDisplayModeState       (MVar AnthropicUsageDisplayMode, TChan AnthropicUsageDisplayMode) +data AnthropicUsageLabelParts = AnthropicUsageLabelParts+  { anthropicUsageLabelWidget :: Gtk.Widget,+    anthropicUsageLabel :: Gtk.Label,+    anthropicUsageLabelDisplayState :: AnthropicUsageDisplayModeState,+    anthropicUsageLabelSnapshotVar :: MVar AnthropicUsageSnapshot,+    anthropicUsageLabelUsageChan :: TChan AnthropicUsageSnapshot,+    anthropicUsageLabelRefreshNow :: IO ()+  }+ data AnthropicUsageLabelConfig = AnthropicUsageLabelConfig   { anthropicUsageLabelInfoConfig :: AnthropicUsageConfig,     anthropicUsageLabelDefaultDisplayMode :: AnthropicUsageDisplayMode,@@ -114,15 +124,38 @@  anthropicUsageStackNewWith :: AnthropicUsageStackConfig -> TaffyIO Gtk.Widget anthropicUsageStackNewWith config = do-  fiveHour <- anthropicUsageLabelNewWith $ windowLabelConfig AnthropicUsageFiveHourWindow config-  weekly <- anthropicUsageLabelNewWith $ windowLabelConfig AnthropicUsageWeeklyWindow config+  (stack, fiveHourParts) <- anthropicUsageStackPartsNewWith config+  liftIO $+    wrapAnthropicUsageMenu+      "anthropic-usage"+      stack+      (windowLabelConfig AnthropicUsageFiveHourWindow config)+      fiveHourParts++anthropicUsageSectionNewWith :: Gtk.Widget -> AnthropicUsageStackConfig -> TaffyIO Gtk.Widget+anthropicUsageSectionNewWith iconWidget config = do+  (stack, fiveHourParts) <- anthropicUsageStackPartsNewWith config   liftIO $ do+    section <- buildIconLabelBox iconWidget stack+    _ <- widgetSetClassGI section "usage-section"+    wrapAnthropicUsageMenu+      "anthropic-usage"+      section+      (windowLabelConfig AnthropicUsageFiveHourWindow config)+      fiveHourParts++anthropicUsageStackPartsNewWith :: AnthropicUsageStackConfig -> TaffyIO (Gtk.Widget, AnthropicUsageLabelParts)+anthropicUsageStackPartsNewWith config = do+  fiveHourParts <- anthropicUsageLabelPartsNewWith $ windowLabelConfig AnthropicUsageFiveHourWindow config+  weeklyParts <- anthropicUsageLabelPartsNewWith $ windowLabelConfig AnthropicUsageWeeklyWindow config+  liftIO $ do     box <- Gtk.boxNew Gtk.OrientationVertical 0     _ <- widgetSetClassGI box "anthropic-usage-stack"-    Gtk.boxPackStart box fiveHour False False 0-    Gtk.boxPackStart box weekly False False 0+    Gtk.boxPackStart box (anthropicUsageLabelWidget fiveHourParts) False False 0+    Gtk.boxPackStart box (anthropicUsageLabelWidget weeklyParts) False False 0     Gtk.widgetShowAll box-    Gtk.toWidget box+    widget <- Gtk.toWidget box+    return (widget, fiveHourParts)  windowLabelConfig :: AnthropicUsageWindowSelector -> AnthropicUsageStackConfig -> AnthropicUsageLabelConfig windowLabelConfig selector stackConfig =@@ -137,6 +170,11 @@  anthropicUsageLabelNewWith :: AnthropicUsageLabelConfig -> TaffyIO Gtk.Widget anthropicUsageLabelNewWith config = do+  parts <- anthropicUsageLabelPartsNewWith config+  liftIO $ wrapAnthropicUsageMenu "anthropic-usage" (anthropicUsageLabelWidget parts) config parts++anthropicUsageLabelPartsNewWith :: AnthropicUsageLabelConfig -> TaffyIO AnthropicUsageLabelParts+anthropicUsageLabelPartsNewWith config = do   let infoConfig = anthropicUsageLabelInfoConfig config   usageChan <- getAnthropicUsageChan infoConfig   initialSnapshot <- getAnthropicUsageState infoConfig@@ -145,29 +183,53 @@    liftIO $ do     label <- Gtk.labelNew (Just (anthropicUsageLabelFallbackText config))-    ebox <- Gtk.eventBoxNew     snapshotVar <- newMVar initialSnapshot     let refreshNow = runReaderT (forceAnthropicUsageRefresh infoConfig) ctx     _ <- widgetSetClassGI label (anthropicUsageLabelClass config)-    _ <- widgetSetClassGI ebox "anthropic-usage"-    Gtk.containerAdd ebox label     updateLabelFromState config label displayState initialSnapshot -    void $ Gtk.onWidgetRealize ebox $ do+    void $ Gtk.onWidgetRealize label $ do       usageThread <- forkUsageListener config label displayState snapshotVar usageChan       modeThread <- forkDisplayModeListener config label displayState snapshotVar-      void $ Gtk.onWidgetUnrealize ebox $ do+      void $ Gtk.onWidgetUnrealize label $ do         killThread usageThread         killThread modeThread -    void $-      Gtk.onWidgetButtonPressEvent ebox $ \_event -> do-        refreshNow-        showUsageMenu ebox config label displayState snapshotVar refreshNow-        return True+    Gtk.widgetShowAll label+    widget <- Gtk.toWidget label+    return $+      AnthropicUsageLabelParts+        { anthropicUsageLabelWidget = widget,+          anthropicUsageLabel = label,+          anthropicUsageLabelDisplayState = displayState,+          anthropicUsageLabelSnapshotVar = snapshotVar,+          anthropicUsageLabelUsageChan = usageChan,+          anthropicUsageLabelRefreshNow = refreshNow+        } -    Gtk.widgetShowAll ebox-    Gtk.toWidget ebox+wrapAnthropicUsageMenu ::+  T.Text ->+  Gtk.Widget ->+  AnthropicUsageLabelConfig ->+  AnthropicUsageLabelParts ->+  IO Gtk.Widget+wrapAnthropicUsageMenu klass child config parts = do+  ebox <- Gtk.eventBoxNew+  _ <- widgetSetClassGI ebox klass+  Gtk.containerAdd ebox child+  void $+    Gtk.onWidgetButtonPressEvent ebox $ \_event -> do+      showUsageMenu+        ebox+        config+        (anthropicUsageLabel parts)+        (anthropicUsageLabelDisplayState parts)+        (anthropicUsageLabelSnapshotVar parts)+        (anthropicUsageLabelUsageChan parts)+        (anthropicUsageLabelRefreshNow parts)+      return True+  Gtk.widgetShowAll ebox+  Gtk.toWidget ebox  getAnthropicUsageDisplayModeState :: AnthropicUsageDisplayMode -> TaffyIO AnthropicUsageDisplayModeState getAnthropicUsageDisplayModeState defaultMode =@@ -276,15 +338,50 @@   Gtk.Label ->   AnthropicUsageDisplayModeState ->   MVar AnthropicUsageSnapshot ->+  TChan AnthropicUsageSnapshot ->   IO () ->   IO ()-showUsageMenu anchor config label displayState snapshotVar refreshNow = do+showUsageMenu anchor config label displayState snapshotVar usageChan refreshNow = do   currentEvent <- Gtk.getCurrentEvent-  snapshot <- readMVar snapshotVar-  displayMode <- readDisplayMode displayState   menu <- Gtk.menuNew   Gtk.menuAttachToWidget menu anchor Nothing+  populateUsageMenu menu config label displayState snapshotVar refreshNow +  ourUsageChan <- atomically $ dupTChan usageChan+  menuThread <-+    forkIO $+      forever $ do+        snapshot <- atomically $ readTChan ourUsageChan+        void $ swapMVar snapshotVar snapshot+        postGUIASync $ populateUsageMenu menu config label displayState snapshotVar refreshNow++  void $+    Gtk.onWidgetHide menu $+      void $+        GLib.idleAdd GLib.PRIORITY_LOW $ do+          killThread menuThread+          Gtk.widgetDestroy menu+          return False++  Gtk.widgetShowAll menu+  Gtk.menuPopupAtPointer menu currentEvent+  void $ forkIO refreshNow++populateUsageMenu ::+  Gtk.Menu ->+  AnthropicUsageLabelConfig ->+  Gtk.Label ->+  AnthropicUsageDisplayModeState ->+  MVar AnthropicUsageSnapshot ->+  IO () ->+  IO ()+populateUsageMenu menu config label displayState snapshotVar refreshNow = do+  children <- Gtk.containerGetChildren menu+  forM_ children $ \item -> do+    Gtk.containerRemove menu item+    Gtk.widgetDestroy item+  snapshot <- readMVar snapshotVar+  displayMode <- readDisplayMode displayState   appendInfoItem menu "Claude Code usage"   appendSnapshotMenuItems menu displayMode snapshot @@ -298,21 +395,14 @@     Gtk.onMenuItemActivate toggleItem $ do       setDisplayMode displayState (toggleDisplayMode displayMode)       readMVar snapshotVar >>= updateLabelFromState config label displayState+      populateUsageMenu menu config label displayState snapshotVar refreshNow   Gtk.menuShellAppend menu toggleItem    refreshItem <- Gtk.menuItemNewWithLabel ("Refresh" :: T.Text)-  void $ Gtk.onMenuItemActivate refreshItem refreshNow+  void $ Gtk.onMenuItemActivate refreshItem $ void $ forkIO refreshNow   Gtk.menuShellAppend menu refreshItem -  void $-    Gtk.onWidgetHide menu $-      void $-        GLib.idleAdd GLib.PRIORITY_LOW $ do-          Gtk.widgetDestroy menu-          return False-   Gtk.widgetShowAll menu-  Gtk.menuPopupAtPointer menu currentEvent  appendInfoItem :: Gtk.Menu -> T.Text -> IO () appendInfoItem menu text = do

@@ -0,0 +1,275 @@+{-# LANGUAGE OverloadedStrings #-}++-- |+-- Module      : System.Taffybar.Widget.Audio+-- Copyright   : (c) Ivan A. Malison+-- License     : BSD3-style (see LICENSE)+--+-- Maintainer  : Ivan A. Malison+-- Stability   : unstable+-- Portability : unportable+--+-- Audio widget that automatically uses PulseAudio DBus when available and+-- falls back to WirePlumber/PipeWire through libwireplumber otherwise.+module System.Taffybar.Widget.Audio+  ( AudioWidgetConfig (..),+    defaultAudioWidgetConfig,+    audioIconNew,+    audioIconNewWith,+    audioLabelNew,+    audioLabelNewWith,+    audioNew,+    audioNewWith,+  )+where++import Control.Concurrent.MVar (MVar, readMVar)+import Control.Concurrent.STM.TChan (TChan)+import Control.Monad (void, when)+import Control.Monad.IO.Class+import Data.Char (ord)+import Data.Default (Default (..))+import qualified Data.Text as T+import qualified GI.GLib as G+import qualified GI.Gdk.Enums as Gdk+import qualified GI.Gdk.Structs.EventScroll as GdkEvent+import qualified GI.Gtk as Gtk+import System.Taffybar.Context (TaffyIO)+import System.Taffybar.Information.Audio+import System.Taffybar.Util (postGUIASync)+import System.Taffybar.Widget.Generic.ChannelWidget+import System.Taffybar.Widget.Util (buildIconLabelBox, widgetSetClassGI)+import Text.StringTemplate++data AudioWidgetConfig = AudioWidgetConfig+  { audioPulseSink :: String,+    audioWirePlumberNode :: String,+    audioFormat :: String,+    audioMuteFormat :: String,+    audioUnknownFormat :: String,+    audioTooltipFormat :: Maybe String,+    audioScrollStepPercent :: Maybe Int,+    audioToggleMuteOnClick :: Bool+  }++defaultAudioWidgetConfig :: AudioWidgetConfig+defaultAudioWidgetConfig =+  AudioWidgetConfig+    { audioPulseSink = defaultAudioPulseSink,+      audioWirePlumberNode = defaultAudioWirePlumberNode,+      audioFormat = "$volume$%",+      audioMuteFormat = "muted",+      audioUnknownFormat = "n/a",+      audioTooltipFormat =+        Just "Backend: $backend$\nNode: $node$\nVolume: $volume$%\nMuted: $muted$",+      audioScrollStepPercent = Just 5,+      audioToggleMuteOnClick = True+    }++instance Default AudioWidgetConfig where+  def = defaultAudioWidgetConfig++audioIconNew :: TaffyIO Gtk.Widget+audioIconNew = audioIconNewWith defaultAudioWidgetConfig++audioIconNewWith :: AudioWidgetConfig -> TaffyIO Gtk.Widget+audioIconNewWith config = do+  let pulseSink = audioPulseSink config+      wirePlumberNode = audioWirePlumberNode config+  (chan, var) <- getAudioInfoChanAndVar pulseSink wirePlumberNode+  audioIconNewWithState chan var++audioIconNewWithState ::+  TChan (Maybe AudioInfo) ->+  MVar (Maybe AudioInfo) ->+  TaffyIO Gtk.Widget+audioIconNewWithState chan var =+  liftIO $ do+    label <- Gtk.labelNew Nothing+    _ <- widgetSetClassGI label "audio-icon"+    let updateIcon info = do+          let iconText = case info of+                Nothing -> T.pack "\xF026"+                Just i -> audioTextIcon (audioMuted i) (audioVolumePercent i)+          markup <- escapeIconText iconText+          postGUIASync $ Gtk.labelSetMarkup label $ T.pack markup+    void $ Gtk.onWidgetRealize label $ readMVar var >>= updateIcon+    Gtk.widgetShowAll label+    (Gtk.toWidget =<< channelWidgetNew label chan updateIcon)+      >>= (`widgetSetClassGI` "audio-icon")++audioLabelNew :: TaffyIO Gtk.Widget+audioLabelNew = audioLabelNewWith defaultAudioWidgetConfig++audioLabelNewWith :: AudioWidgetConfig -> TaffyIO Gtk.Widget+audioLabelNewWith config = do+  let pulseSink = audioPulseSink config+      wirePlumberNode = audioWirePlumberNode config+  (chan, var) <- getAudioInfoChanAndVar pulseSink wirePlumberNode+  audioLabelNewWithState config chan var++audioLabelNewWithState ::+  AudioWidgetConfig ->+  TChan (Maybe AudioInfo) ->+  MVar (Maybe AudioInfo) ->+  TaffyIO Gtk.Widget+audioLabelNewWithState config chan var = do+  let pulseSink = audioPulseSink config+      wirePlumberNode = audioWirePlumberNode config++  liftIO $ do+    label <- Gtk.labelNew Nothing+    _ <- widgetSetClassGI label "audio-label"++    let updateLabel info = do+          (labelText, tooltipText) <- formatAudioWidget config info+          postGUIASync $ do+            Gtk.labelSetMarkup label labelText+            Gtk.widgetSetTooltipMarkup label tooltipText++        refreshNow = getAudioInfo pulseSink wirePlumberNode >>= updateLabel++        whenToggleMute widget =+          when (audioToggleMuteOnClick config) $+            void $+              Gtk.onWidgetButtonPressEvent widget $ \_ -> do+                void $ toggleAudioMute pulseSink wirePlumberNode+                refreshNow+                return True++        whenScrollAdjust widget =+          case audioScrollStepPercent config of+            Nothing -> return ()+            Just step | step <= 0 -> return ()+            Just step -> do+              _ <- Gtk.onWidgetScrollEvent widget $ \scrollEvent -> do+                dir <- GdkEvent.getEventScrollDirection scrollEvent+                let doAdjust delta = do+                      void $ adjustAudioVolume pulseSink wirePlumberNode delta+                      refreshNow+                      return True+                case dir of+                  Gdk.ScrollDirectionUp -> doAdjust step+                  Gdk.ScrollDirectionDown -> doAdjust (-step)+                  Gdk.ScrollDirectionLeft -> doAdjust step+                  Gdk.ScrollDirectionRight -> doAdjust (-step)+                  _ -> return False+              return ()++    void $ Gtk.onWidgetRealize label $ readMVar var >>= updateLabel++    whenToggleMute label+    whenScrollAdjust label++    Gtk.widgetShowAll label+    (Gtk.toWidget =<< channelWidgetNew label chan updateLabel)+      >>= (`widgetSetClassGI` "audio-label")++audioNew :: TaffyIO Gtk.Widget+audioNew = audioNewWith defaultAudioWidgetConfig++audioNewWith :: AudioWidgetConfig -> TaffyIO Gtk.Widget+audioNewWith config = do+  let pulseSink = audioPulseSink config+      wirePlumberNode = audioWirePlumberNode config+  (chan, var) <- getAudioInfoChanAndVar pulseSink wirePlumberNode+  iconWidget <- audioIconNewWithState chan var+  labelWidget <- audioLabelNewWithState config chan var+  liftIO $+    buildIconLabelBox iconWidget labelWidget+      >>= (`widgetSetClassGI` "audio")++formatAudioWidget ::+  AudioWidgetConfig ->+  Maybe AudioInfo ->+  IO (T.Text, Maybe T.Text)+formatAudioWidget config info = do+  attrs <- maybe buildUnknownAttrs buildAttrs info+  let labelTemplate =+        case info of+          Nothing -> audioUnknownFormat config+          Just audio ->+            case audioMuted audio of+              Just True -> audioMuteFormat config+              _ -> audioFormat config+      labelText = renderTemplate labelTemplate attrs+      tooltipText = fmap (`renderTemplate` attrs) (audioTooltipFormat config)+  return (T.pack labelText, T.pack <$> tooltipText)++buildAttrs :: AudioInfo -> IO [(String, String)]+buildAttrs info = do+  let volumeText = maybe "?" show (audioVolumePercent info)+      mutedText = case audioMuted info of+        Just True -> "yes"+        Just False -> "no"+        Nothing -> "unknown"+      nodeText = audioNodeName info+      backendText = case audioBackend info of+        PulseAudioBackend -> "pulseaudio"+        WirePlumberBackend -> "wireplumber"+      iconText = audioTextIcon (audioMuted info) (audioVolumePercent info)+  volume <- escapeText $ T.pack volumeText+  muted <- escapeText $ T.pack mutedText+  node <- escapeText $ T.pack nodeText+  backend <- escapeText $ T.pack backendText+  icon <- escapeIconText iconText+  return+    [ ("volume", volume),+      ("muted", muted),+      ("node", node),+      ("backend", backend),+      ("icon", icon)+    ]++buildUnknownAttrs :: IO [(String, String)]+buildUnknownAttrs = do+  icon <- escapeIconText (T.pack "\xF026")+  return+    [ ("volume", "?"),+      ("muted", "unknown"),+      ("node", "unknown"),+      ("backend", "unknown"),+      ("icon", icon)+    ]++audioTextIcon :: Maybe Bool -> Maybe Int -> T.Text+audioTextIcon muted volumePercent =+  case muted of+    Just True -> T.pack "\xF026"+    _ ->+      case volumePercent of+        Just v | v <= 0 -> T.pack "\xF026"+        Just v | v <= 33 -> T.pack "\xF027"+        _ -> T.pack "\xF028"++renderTemplate :: String -> [(String, String)] -> String+renderTemplate template attrs = render $ setManyAttrib attrs (newSTMP template)++escapeText :: T.Text -> IO String+escapeText input = T.unpack <$> G.markupEscapeText input (-1)++escapeIconText :: T.Text -> IO String+escapeIconText input =+  let iconSpan s =+        "<span font_family=\"Iosevka Nerd Font\" font_weight=\"normal\" size=\"large\">" ++ s ++ "</span>"+   in do+        rendered <-+          concat+            <$> mapM+              ( \c -> do+                  esc <- escapeText (T.singleton c)+                  pure $+                    if isPUA c+                      then iconSpan esc+                      else esc+              )+              (T.unpack input)+        pure $+          if any isPUA (T.unpack input)+            then rendered ++ iconSpan "&#x2004;"+            else rendered++isPUA :: Char -> Bool+isPUA c =+  let o = ord c+   in o >= 0xE000 && o <= 0xF8FF

@@ -29,6 +29,7 @@ import Control.Monad.IO.Class import Control.Monad.Trans.Reader import Data.Default (Default (..))+import Data.Maybe (fromMaybe, listToMaybe) import qualified Data.Text as T import GI.Gtk as Gtk import System.Taffybar.Context@@ -92,7 +93,7 @@ selectGlyph glyphs pct =   let n = length glyphs       idx = min (n - 1) $ floor (pct / 100.0 * fromIntegral n)-   in glyphs !! max 0 idx+   in fromMaybe "?" $ listToMaybe $ drop (max 0 idx) glyphs  -- | A battery icon widget that uses text glyphs (e.g. Nerd Font icons) to -- display battery state. The glyph changes based on charge level and

@@ -106,7 +106,7 @@ noteFreshId :: NotifyState -> IO Word32 noteFreshId NotifyState {noteIdSource} = atomically $ do   nId <- readTVar noteIdSource-  writeTVar noteIdSource (succ nId)+  writeTVar noteIdSource (nId + 1)   return nId  --------------------------------------------------------------------------------

@@ -273,7 +273,11 @@   styleContext <- C.liftIO $ Gtk.widgetGetStyleContext drawArea   dataColors <-     if graphColorsFromCss cfg-      then C.liftIO $ forM [1 .. length hist] (getDataColorFromCss styleContext)+      then+        C.liftIO $+          forM+            (take (length hist) [1 :: Int ..])+            (getDataColorFromCss styleContext)       else return $ graphDataColors cfg   let -- Subtract 1 here since the first data point doesn't require       -- any movement in the X direction

@@ -297,7 +297,7 @@     WARNING     "widget update called with no widget or %s"     ("nowplaying" :: String)-    >> return undefined+    >> error "simplePlayerWidget: impossible widget update state"  -- | This player widget constructor extends the default MPRIS2 row with previous, -- play/pause, and next buttons.@@ -406,7 +406,7 @@     WARNING     "widget update called with no widget or %s"     ("nowplaying" :: String)-    >> return undefined+    >> error "simplePlayerWidgetWithControls: impossible widget update state"  -- | Construct a new MPRIS2 widget using the `simplePlayerWidget` constructor. mpris2New :: TaffyIO Gtk.Widget

@@ -0,0 +1,213 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RecordWildCards #-}++-- |+-- Module      : System.Taffybar.Widget.OmniMenu+-- Copyright   : (c) Ivan A. Malison+-- License     : BSD3-style (see LICENSE)+--+-- Maintainer  : Ivan A. Malison+-- Stability   : unstable+-- Portability : unportable+--+-- A menu button for launcher and session-control commands. The button can wrap+-- any widget, so callers can use an icon from a theme, a file image, a label, or+-- their own composed image widget as the visible trigger.+module System.Taffybar.Widget.OmniMenu+  ( OmniMenuConfig (..),+    OmniMenuItem (..),+    OmniMenuSection (..),+    defaultOmniMenuConfig,+    omniMenuNew,+    omniMenuNewFromFile,+    omniMenuNewFromIconName,+    omniMenuNewWithConfig,+  )+where++import Control.Monad (unless, void, when)+import Control.Monad.IO.Class+import Data.Foldable (foldlM)+import Data.Int (Int32)+import qualified Data.Text as T+import qualified GI.GdkPixbuf.Objects.Pixbuf as Gdk+import qualified GI.Gtk as Gtk+import System.Log.Logger+import System.Process+import System.Taffybar.Widget.Generic.AutoFillImage+import System.Taffybar.Widget.Generic.DynamicMenu+import System.Taffybar.Widget.Util+import System.Taffybar.Widget.XDGMenu.Menu++data OmniMenuItem = OmniMenuItem+  { omniMenuItemLabel :: T.Text,+    omniMenuItemCommand :: T.Text,+    omniMenuItemIcon :: Maybe T.Text,+    omniMenuItemTooltip :: Maybe T.Text+  }++data OmniMenuSection = OmniMenuSection+  { omniMenuSectionLabel :: T.Text,+    omniMenuSectionItems :: [OmniMenuItem]+  }++data OmniMenuConfig = OmniMenuConfig+  { omniMenuClickWidget :: Gtk.Widget,+    omniMenuIncludeApplications :: Bool,+    omniMenuXDGMenuPrefix :: Maybe String,+    omniMenuSections :: [OmniMenuSection]+  }++defaultOmniMenuConfig :: Gtk.Widget -> OmniMenuConfig+defaultOmniMenuConfig clickWidget =+  OmniMenuConfig+    { omniMenuClickWidget = clickWidget,+      omniMenuIncludeApplications = True,+      omniMenuXDGMenuPrefix = Nothing,+      omniMenuSections = []+    }++omniMenuNew :: (MonadIO m) => Gtk.Widget -> [OmniMenuSection] -> m Gtk.Widget+omniMenuNew clickWidget sections =+  omniMenuNewWithConfig $+    (defaultOmniMenuConfig clickWidget)+      { omniMenuSections = sections+      }++omniMenuNewFromFile :: (MonadIO m) => FilePath -> [OmniMenuSection] -> m Gtk.Widget+omniMenuNewFromFile path sections = do+  image <- Gtk.imageNewFromFile path+  clickWidget <- Gtk.toWidget image+  omniMenuNew clickWidget sections++omniMenuNewFromIconName :: (MonadIO m) => T.Text -> [OmniMenuSection] -> m Gtk.Widget+omniMenuNewFromIconName iconName sections = do+  image <-+    Gtk.imageNewFromIconName+      (Just iconName)+      (fromIntegral $ fromEnum Gtk.IconSizeMenu)+  clickWidget <- Gtk.toWidget image+  omniMenuNew clickWidget sections++omniMenuNewWithConfig :: (MonadIO m) => OmniMenuConfig -> m Gtk.Widget+omniMenuNewWithConfig OmniMenuConfig {..} = do+  menuButton <-+    dynamicMenuNew+      DynamicMenuConfig+        { dmClickWidget = omniMenuClickWidget,+          dmPopulateMenu = populateOmniMenu+        }+  _ <- widgetSetClassGI menuButton "omni-menu-button"+  return menuButton+  where+    populateOmniMenu menu = do+      applicationsAdded <-+        if omniMenuIncludeApplications+          then addApplicationsMenu menu omniMenuXDGMenuPrefix+          else pure False+      void $ foldlM (addSection menu) applicationsAdded omniMenuSections+      Gtk.widgetShowAll menu++omniMenuLog :: Priority -> String -> IO ()+omniMenuLog = logM "System.Taffybar.Widget.OmniMenu"++omniMenuImageMenuItemNew ::+  T.Text -> (Int32 -> IO (Maybe Gdk.Pixbuf)) -> IO Gtk.MenuItem+omniMenuImageMenuItemNew labelText pixbufGetter = do+  box <- Gtk.boxNew Gtk.OrientationHorizontal 6+  iconSlot <- Gtk.boxNew Gtk.OrientationHorizontal 0+  label <- Gtk.labelNew $ Just labelText+  image <- autoFillImageNew pixbufGetter Gtk.OrientationHorizontal+  item <- Gtk.menuItemNew+  Gtk.widgetSetSizeRequest iconSlot omniMenuIconSize omniMenuIconSize+  Gtk.containerAdd iconSlot image+  Gtk.containerAdd box iconSlot+  Gtk.containerAdd box label+  Gtk.containerAdd item box+  Gtk.widgetSetHalign box Gtk.AlignStart+  Gtk.widgetSetHalign iconSlot Gtk.AlignCenter+  Gtk.widgetSetValign iconSlot Gtk.AlignCenter+  Gtk.widgetSetHalign image Gtk.AlignCenter+  Gtk.widgetSetValign image Gtk.AlignCenter+  Gtk.widgetSetValign label Gtk.AlignCenter+  Gtk.widgetSetValign box Gtk.AlignFill+  return item++omniMenuIconSize :: Int32+omniMenuIconSize = 16++addApplicationsMenu :: (Gtk.IsMenuShell menuShell) => menuShell -> Maybe String -> IO Bool+addApplicationsMenu menuShell menuPrefix = do+  xdgMenu <- buildMenu menuPrefix+  if isEmptyXDGMenu xdgMenu+    then pure False+    else do+      item <- Gtk.menuItemNewWithLabel "Applications"+      submenu <- Gtk.menuNew+      Gtk.menuItemSetSubmenu item (Just submenu)+      addXDGMenuContents submenu xdgMenu+      Gtk.menuShellAppend menuShell item+      pure True++isEmptyXDGMenu :: Menu -> Bool+isEmptyXDGMenu Menu {..} =+  null fmEntries && all isEmptyXDGMenu fmSubmenus++addXDGMenuContents :: (Gtk.IsMenuShell menuShell) => menuShell -> Menu -> IO ()+addXDGMenuContents menuShell Menu {..} = do+  mapM_ (addXDGSubmenu menuShell) fmSubmenus+  mapM_ (addXDGEntry menuShell) fmEntries++addXDGSubmenu :: (Gtk.IsMenuShell menuShell) => menuShell -> Menu -> IO ()+addXDGSubmenu menuShell menu@Menu {..} =+  unless (null fmEntries && null fmSubmenus) $ do+    item <-+      omniMenuImageMenuItemNew+        (T.pack fmName)+        (getImageForMaybeIconName (T.pack <$> fmIcon))+    submenu <- Gtk.menuNew+    Gtk.menuItemSetSubmenu item (Just submenu)+    addXDGMenuContents submenu menu+    Gtk.menuShellAppend menuShell item++addXDGEntry :: (Gtk.IsMenuShell menuShell) => menuShell -> MenuEntry -> IO ()+addXDGEntry menuShell MenuEntry {..} = do+  item <- omniMenuImageMenuItemNew feName (getImageForMaybeIconName feIcon)+  Gtk.widgetSetTooltipText item (Just feComment)+  Gtk.menuShellAppend menuShell item+  void $ Gtk.onMenuItemActivate item $ do+    omniMenuLog DEBUG $ "Launching '" ++ feCommand ++ "'"+    void $ spawnCommand feCommand++addSection :: (Gtk.IsMenuShell menuShell) => menuShell -> Bool -> OmniMenuSection -> IO Bool+addSection menuShell hasPrevious OmniMenuSection {..} =+  if null omniMenuSectionItems+    then pure hasPrevious+    else do+      when hasPrevious $ addSeparator menuShell+      addSectionHeader menuShell omniMenuSectionLabel+      mapM_ (addCommandItem menuShell) omniMenuSectionItems+      pure True++addSeparator :: (Gtk.IsMenuShell menuShell) => menuShell -> IO ()+addSeparator menuShell = do+  separator <- Gtk.separatorMenuItemNew+  Gtk.menuShellAppend menuShell separator++addSectionHeader :: (Gtk.IsMenuShell menuShell) => menuShell -> T.Text -> IO ()+addSectionHeader menuShell label = do+  item <- Gtk.menuItemNewWithLabel label+  Gtk.widgetSetSensitive item False+  Gtk.menuShellAppend menuShell item++addCommandItem :: (Gtk.IsMenuShell menuShell) => menuShell -> OmniMenuItem -> IO ()+addCommandItem menuShell OmniMenuItem {..} = do+  item <-+    omniMenuImageMenuItemNew+      omniMenuItemLabel+      (getImageForMaybeIconName omniMenuItemIcon)+  Gtk.widgetSetTooltipText item omniMenuItemTooltip+  Gtk.menuShellAppend menuShell item+  void $ Gtk.onMenuItemActivate item $ do+    omniMenuLog DEBUG $ "Launching '" ++ T.unpack omniMenuItemCommand ++ "'"+    void $ spawnCommand $ T.unpack omniMenuItemCommand

@@ -13,6 +13,7 @@     openAIUsageLabelNewWith,     openAIUsagePrimaryWindowLabelNew,     openAIUsageSecondaryWindowLabelNew,+    openAIUsageSectionNewWith,     openAIUsageStackNew,     openAIUsageStackNewWith,     openAIUsageNew,@@ -24,7 +25,7 @@  import Control.Concurrent (ThreadId, forkIO, killThread) import Control.Concurrent.MVar (MVar, newMVar, readMVar, swapMVar)-import Control.Concurrent.STM (atomically)+import Control.Concurrent.STM (atomically, newTVarIO, readTVarIO, writeTVar) import Control.Concurrent.STM.TChan (TChan, dupTChan, newBroadcastTChanIO, readTChan, writeTChan) import Control.Monad (forM_, forever, void) import Control.Monad.IO.Class (liftIO)@@ -36,7 +37,7 @@ import System.Taffybar.Context (TaffyIO, getStateDefault) import System.Taffybar.Information.OpenAIUsage import System.Taffybar.Util (postGUIASync)-import System.Taffybar.Widget.Util (widgetSetClassGI)+import System.Taffybar.Widget.Util (buildIconLabelBox, widgetSetClassGI) import Text.Printf (printf)  data OpenAIUsageDisplayMode@@ -48,6 +49,15 @@   = OpenAIUsageDisplayModeState       (MVar OpenAIUsageDisplayMode, TChan OpenAIUsageDisplayMode) +data OpenAIUsageLabelParts = OpenAIUsageLabelParts+  { openAIUsageLabelWidget :: Gtk.Widget,+    openAIUsageLabel :: Gtk.Label,+    openAIUsageLabelDisplayState :: OpenAIUsageDisplayModeState,+    openAIUsageLabelSnapshotVar :: MVar OpenAIUsageSnapshot,+    openAIUsageLabelUsageChan :: TChan OpenAIUsageSnapshot,+    openAIUsageLabelRefreshNow :: IO ()+  }+ data OpenAIUsageLabelConfig = OpenAIUsageLabelConfig   { openAIUsageLabelInfoConfig :: OpenAIUsageConfig,     openAIUsageLabelDefaultDisplayMode :: OpenAIUsageDisplayMode,@@ -113,15 +123,38 @@  openAIUsageStackNewWith :: OpenAIUsageStackConfig -> TaffyIO Gtk.Widget openAIUsageStackNewWith config = do-  primary <- openAIUsageLabelNewWith $ windowLabelConfig OpenAIUsagePrimaryWindow config-  secondary <- openAIUsageLabelNewWith $ windowLabelConfig OpenAIUsageSecondaryWindow config+  (stack, primaryParts) <- openAIUsageStackPartsNewWith config+  liftIO $+    wrapOpenAIUsageMenu+      "openai-usage"+      stack+      (windowLabelConfig OpenAIUsagePrimaryWindow config)+      primaryParts++openAIUsageSectionNewWith :: Gtk.Widget -> OpenAIUsageStackConfig -> TaffyIO Gtk.Widget+openAIUsageSectionNewWith iconWidget config = do+  (stack, primaryParts) <- openAIUsageStackPartsNewWith config   liftIO $ do+    section <- buildIconLabelBox iconWidget stack+    _ <- widgetSetClassGI section "usage-section"+    wrapOpenAIUsageMenu+      "openai-usage"+      section+      (windowLabelConfig OpenAIUsagePrimaryWindow config)+      primaryParts++openAIUsageStackPartsNewWith :: OpenAIUsageStackConfig -> TaffyIO (Gtk.Widget, OpenAIUsageLabelParts)+openAIUsageStackPartsNewWith config = do+  primaryParts <- openAIUsageLabelPartsNewWith $ windowLabelConfig OpenAIUsagePrimaryWindow config+  secondaryParts <- openAIUsageLabelPartsNewWith $ windowLabelConfig OpenAIUsageSecondaryWindow config+  liftIO $ do     box <- Gtk.boxNew Gtk.OrientationVertical 0     _ <- widgetSetClassGI box "openai-usage-stack"-    Gtk.boxPackStart box primary False False 0-    Gtk.boxPackStart box secondary False False 0+    Gtk.boxPackStart box (openAIUsageLabelWidget primaryParts) False False 0+    Gtk.boxPackStart box (openAIUsageLabelWidget secondaryParts) False False 0     Gtk.widgetShowAll box-    Gtk.toWidget box+    widget <- Gtk.toWidget box+    return (widget, primaryParts)  windowLabelConfig :: OpenAIUsageWindowSelector -> OpenAIUsageStackConfig -> OpenAIUsageLabelConfig windowLabelConfig selector stackConfig =@@ -136,6 +169,11 @@  openAIUsageLabelNewWith :: OpenAIUsageLabelConfig -> TaffyIO Gtk.Widget openAIUsageLabelNewWith config = do+  parts <- openAIUsageLabelPartsNewWith config+  liftIO $ wrapOpenAIUsageMenu "openai-usage" (openAIUsageLabelWidget parts) config parts++openAIUsageLabelPartsNewWith :: OpenAIUsageLabelConfig -> TaffyIO OpenAIUsageLabelParts+openAIUsageLabelPartsNewWith config = do   let infoConfig = openAIUsageLabelInfoConfig config   usageChan <- getOpenAIUsageChan infoConfig   initialSnapshot <- getOpenAIUsageState infoConfig@@ -144,30 +182,104 @@    liftIO $ do     label <- Gtk.labelNew (Just (openAIUsageLabelFallbackText config))-    ebox <- Gtk.eventBoxNew     snapshotVar <- newMVar initialSnapshot     let refreshNow = runReaderT (forceOpenAIUsageRefresh infoConfig) ctx     _ <- widgetSetClassGI label (openAIUsageLabelClass config)-    _ <- widgetSetClassGI ebox "openai-usage"-    Gtk.containerAdd ebox label     updateLabelFromState config label displayState initialSnapshot -    void $ Gtk.onWidgetRealize ebox $ do+    void $ Gtk.onWidgetRealize label $ do       usageThread <- forkUsageListener config label displayState snapshotVar usageChan       modeThread <- forkDisplayModeListener config label displayState snapshotVar-      void $ Gtk.onWidgetUnrealize ebox $ do+      void $ Gtk.onWidgetUnrealize label $ do         killThread usageThread         killThread modeThread -    void $-      Gtk.onWidgetButtonPressEvent ebox $ \_event -> do-        refreshNow-        showUsageMenu ebox config label displayState snapshotVar refreshNow-        return True+    Gtk.widgetShowAll label+    widget <- Gtk.toWidget label+    return $+      OpenAIUsageLabelParts+        { openAIUsageLabelWidget = widget,+          openAIUsageLabel = label,+          openAIUsageLabelDisplayState = displayState,+          openAIUsageLabelSnapshotVar = snapshotVar,+          openAIUsageLabelUsageChan = usageChan,+          openAIUsageLabelRefreshNow = refreshNow+        } -    Gtk.widgetShowAll ebox-    Gtk.toWidget ebox+wrapOpenAIUsageMenu ::+  T.Text ->+  Gtk.Widget ->+  OpenAIUsageLabelConfig ->+  OpenAIUsageLabelParts ->+  IO Gtk.Widget+wrapOpenAIUsageMenu klass child config parts = do+  ebox <- Gtk.eventBoxNew+  _ <- widgetSetClassGI ebox klass+  Gtk.containerAdd ebox child+  initialSnapshot <- readMVar (openAIUsageLabelSnapshotVar parts)+  menu <-+    buildUsageMenu+      ebox+      config+      (openAIUsageLabel parts)+      (openAIUsageLabelDisplayState parts)+      (openAIUsageLabelSnapshotVar parts)+      (openAIUsageLabelRefreshNow parts)+      initialSnapshot+  menuVar <- newTVarIO menu +  let rebuildMenu snapshot =+        buildUsageMenu+          ebox+          config+          (openAIUsageLabel parts)+          (openAIUsageLabelDisplayState parts)+          (openAIUsageLabelSnapshotVar parts)+          (openAIUsageLabelRefreshNow parts)+          snapshot+          >>= atomically . writeTVar menuVar++  void $ Gtk.onWidgetRealize ebox $ do+    menuThread <-+      forkCachedMenuUpdater+        rebuildMenu+        (openAIUsageLabelSnapshotVar parts)+        (openAIUsageLabelUsageChan parts)+    void $ Gtk.onWidgetUnrealize ebox $ killThread menuThread++  void $+    Gtk.onWidgetButtonPressEvent ebox $ \_event -> do+      currentEvent <- Gtk.getCurrentEvent+      readyMenu <- readTVarIO menuVar+      Gtk.widgetShowAll readyMenu+      Gtk.menuPopupAtPointer readyMenu currentEvent+      void $ forkIO (openAIUsageLabelRefreshNow parts)+      return True+  Gtk.widgetShowAll ebox+  Gtk.toWidget ebox++buildUsageMenu ::+  Gtk.EventBox ->+  OpenAIUsageLabelConfig ->+  Gtk.Label ->+  OpenAIUsageDisplayModeState ->+  MVar OpenAIUsageSnapshot ->+  IO () ->+  OpenAIUsageSnapshot ->+  IO Gtk.Menu+buildUsageMenu anchor config label displayState snapshotVar refreshNow snapshot = do+  menu <- Gtk.menuNew+  Gtk.menuAttachToWidget menu anchor Nothing+  appendUsageMenuContents+    menu+    config+    label+    displayState+    snapshotVar+    refreshNow+    snapshot+  return menu+ getOpenAIUsageDisplayModeState :: OpenAIUsageDisplayMode -> TaffyIO OpenAIUsageDisplayModeState getOpenAIUsageDisplayModeState defaultMode =   getStateDefault $ liftIO $ do@@ -270,21 +382,33 @@               ("Reached: " <>) <$> openAIUsageReachedType info             ] -showUsageMenu ::-  Gtk.EventBox ->+forkCachedMenuUpdater ::+  (OpenAIUsageSnapshot -> IO ()) ->+  MVar OpenAIUsageSnapshot ->+  TChan OpenAIUsageSnapshot ->+  IO ThreadId+forkCachedMenuUpdater rebuildMenu snapshotVar usageChan = do+  ourUsageChan <- atomically $ dupTChan usageChan+  forkIO $+    forever $ do+      snapshot <- atomically $ readTChan ourUsageChan+      void $ swapMVar snapshotVar snapshot+      void $+        GLib.idleAdd GLib.PRIORITY_LOW $ do+          rebuildMenu snapshot+          return False++appendUsageMenuContents ::+  Gtk.Menu ->   OpenAIUsageLabelConfig ->   Gtk.Label ->   OpenAIUsageDisplayModeState ->   MVar OpenAIUsageSnapshot ->   IO () ->+  OpenAIUsageSnapshot ->   IO ()-showUsageMenu anchor config label displayState snapshotVar refreshNow = do-  currentEvent <- Gtk.getCurrentEvent-  snapshot <- readMVar snapshotVar+appendUsageMenuContents menu config label displayState snapshotVar refreshNow snapshot = do   displayMode <- readDisplayMode displayState-  menu <- Gtk.menuNew-  Gtk.menuAttachToWidget menu anchor Nothing-   appendInfoItem menu "OpenAI Codex usage"   appendSnapshotMenuItems menu displayMode snapshot @@ -297,23 +421,14 @@   void $     Gtk.onMenuItemActivate toggleItem $ do       setDisplayMode displayState (toggleDisplayMode displayMode)-      readMVar snapshotVar >>= updateLabelFromState config label displayState+      snapshot' <- readMVar snapshotVar+      updateLabelFromState config label displayState snapshot'   Gtk.menuShellAppend menu toggleItem    refreshItem <- Gtk.menuItemNewWithLabel ("Refresh" :: T.Text)-  void $ Gtk.onMenuItemActivate refreshItem refreshNow+  void $ Gtk.onMenuItemActivate refreshItem $ void $ forkIO refreshNow   Gtk.menuShellAppend menu refreshItem -  void $-    Gtk.onWidgetHide menu $-      void $-        GLib.idleAdd GLib.PRIORITY_LOW $ do-          Gtk.widgetDestroy menu-          return False--  Gtk.widgetShowAll menu-  Gtk.menuPopupAtPointer menu currentEvent- appendInfoItem :: Gtk.Menu -> T.Text -> IO () appendInfoItem menu text = do   item <- Gtk.menuItemNewWithLabel text@@ -368,17 +483,37 @@     [ formatWindowMenuLine displayMode "5h" <$> openAIUsagePrimaryWindow limit,       formatWindowMenuLine displayMode "7d" <$> openAIUsageSecondaryWindow limit     ]+    <> concat+      ( catMaybes+          [ formatWindowTokenMenuLines "5h" <$> openAIUsagePrimaryWindow limit,+            formatWindowTokenMenuLines "7d" <$> openAIUsageSecondaryWindow limit+          ]+      )     <> [formatRateLimitStatus limit]  formatWindowMenuLine :: OpenAIUsageDisplayMode -> T.Text -> OpenAIUsageWindow -> T.Text formatWindowMenuLine displayMode fallbackName window =   formatWindowName fallbackName window     <> ": "-    <> formatWindowPercent displayMode window+    <> formatWindowValue displayMode window     <> " "     <> displayModeText displayMode+    <> formatWindowPercentSuffix displayMode window     <> maybe "" ((", resets in " <>) . formatDuration) (openAIUsageResetAfterSeconds window) +formatWindowTokenMenuLines :: T.Text -> OpenAIUsageWindow -> [T.Text]+formatWindowTokenMenuLines fallbackName window =+  case openAIUsageWindowTotals window of+    Nothing -> []+    Just totals ->+      [ formatWindowName fallbackName window <> " tokens: " <> formatTotalTokens totals,+        formatWindowName fallbackName window <> " requests: " <> T.pack (show $ openAIUsageRequestCount totals),+        formatWindowName fallbackName window <> " input: " <> formatCount (openAIUsageInputTokens totals),+        formatWindowName fallbackName window <> " cached input: " <> formatCount (openAIUsageCachedInputTokens totals),+        formatWindowName fallbackName window <> " output: " <> formatCount (openAIUsageOutputTokens totals),+        formatWindowName fallbackName window <> " reasoning output: " <> formatCount (openAIUsageReasoningOutputTokens totals)+      ]+ formatRateLimitStatus :: OpenAIUsageRateLimit -> T.Text formatRateLimitStatus limit   | openAIUsageLimitReached limit = "Status: reached"@@ -419,9 +554,10 @@   Just $     formatWindowName name window       <> " "-      <> formatWindowPercent displayMode window+      <> formatWindowValue displayMode window       <> " "       <> displayModeText displayMode+      <> formatWindowPercentSuffix displayMode window       <> maybe "" ((" / " <>) . formatDuration) (openAIUsageWindowDurationSeconds window)       <> maybe "" ((", resets in " <>) . formatDuration) (openAIUsageResetAfterSeconds window) @@ -429,7 +565,7 @@ formatWindowLabel displayMode fallbackName window =   formatWindowName fallbackName window     <> " "-    <> formatWindowPercentWithIndicator displayMode window+    <> formatWindowValueWithIndicator displayMode window  formatWindowName :: T.Text -> OpenAIUsageWindow -> T.Text formatWindowName fallbackName window =@@ -439,10 +575,18 @@ formatWindowPercent displayMode window =   T.pack $ printf "%d%%" $ displayPercent displayMode window -formatWindowPercentWithIndicator :: OpenAIUsageDisplayMode -> OpenAIUsageWindow -> T.Text-formatWindowPercentWithIndicator displayMode window =-  formatWindowPercent displayMode window <> displayModeIndicator displayMode+formatWindowValue :: OpenAIUsageDisplayMode -> OpenAIUsageWindow -> T.Text+formatWindowValue = formatWindowPercent +formatWindowValueWithIndicator :: OpenAIUsageDisplayMode -> OpenAIUsageWindow -> T.Text+formatWindowValueWithIndicator displayMode window =+  formatWindowValue displayMode window <> displayModeIndicator displayMode++formatWindowPercentSuffix :: OpenAIUsageDisplayMode -> OpenAIUsageWindow -> T.Text+formatWindowPercentSuffix OpenAIUsageDisplayUsed window+  | isJust (openAIUsageWindowTotals window) = " (tokens in menu)"+formatWindowPercentSuffix _ _ = ""+ displayPercent :: OpenAIUsageDisplayMode -> OpenAIUsageWindow -> Int displayPercent OpenAIUsageDisplayUsed = openAIUsageUsedPercent displayPercent OpenAIUsageDisplayRemaining = max 0 . (100 -) . openAIUsageUsedPercent@@ -463,6 +607,16 @@            else fromMaybeText "0" (openAIUsageCreditsBalance credits)        )     <> if openAIUsageHasCredits credits then " available" else ""++formatTotalTokens :: OpenAIUsageTotals -> T.Text+formatTotalTokens = formatCount . openAIUsageTotalTokens++formatCount :: Int -> T.Text+formatCount count+  | count >= 1_000_000 = T.pack $ printf "%.1fM" (fromIntegral count / 1_000_000 :: Double)+  | count >= 10_000 = T.pack $ printf "%dk" (count `div` 1_000)+  | count >= 1_000 = T.pack $ printf "%.1fk" (fromIntegral count / 1_000 :: Double)+  | otherwise = T.pack $ show count  selectedWindow :: OpenAIUsageWindowSelector -> OpenAIUsageRateLimit -> Maybe OpenAIUsageWindow selectedWindow OpenAIUsagePrimaryWindow = openAIUsagePrimaryWindow

@@ -19,7 +19,7 @@ where  import Control.Applicative ((<|>))-import Control.Monad (forM_, guard, void, when)+import Control.Monad (forM_, guard, unless, void, when) import Control.Monad.Trans.Class import Control.Monad.Trans.Reader import qualified DBus as D@@ -33,11 +33,12 @@ import Data.Char (isAlphaNum, isDigit, toLower) import Data.Foldable (traverse_) import Data.IORef-import Data.Int (Int32)-import Data.List (isSuffixOf, nub, sortOn, stripPrefix)+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)@@ -45,7 +46,7 @@ import qualified GI.GLib as GLib import qualified GI.Gdk as Gdk import qualified GI.Gtk as Gtk-import Graphics.UI.GIGtkStrut (StrutAlignment (End))+import Graphics.UI.GIGtkStrut (StrutAlignment (Beginning)) import qualified StatusNotifier.Host.Service as H import StatusNotifier.Tray import qualified StatusNotifier.Tray as Tray@@ -159,6 +160,14 @@     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@.@@ -182,6 +191,10 @@       prioritizedCollapsibleSNITrayVisibilityThreshold = Nothing,       prioritizedCollapsibleSNITrayStartPriorityEditMode = False,       prioritizedCollapsibleSNITrayAlwaysShowExpandToggle = True,+      prioritizedCollapsibleSNITrayHoverExpand = False,+      prioritizedCollapsibleSNITrayHoverExpandDelayMs = 120,+      prioritizedCollapsibleSNITrayHoverCollapseDelayMs = 500,+      prioritizedCollapsibleSNITrayHoverAnimationDurationMs = 320,       prioritizedCollapsibleSNITrayPriorityModeLabel = defaultPrioritizedCollapsibleSNITrayPriorityModeLabel     } @@ -282,6 +295,16 @@ 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@@ -295,6 +318,9 @@ 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@@ -325,6 +351,33 @@   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@@ -355,7 +408,7 @@  processIdentityTokenFromArg :: String -> Maybe String processIdentityTokenFromArg arg-  | ".asar" `isSuffixOf` arg =+  | takeExtension arg == ".asar" =       nonEmptyString (takeBaseName (takeDirectory arg))   | otherwise = Nothing @@ -412,15 +465,21 @@   pairs <- mapM withKey infos   return $ M.fromList (catMaybes pairs)   where-    withKey info-      | not (isLikelySharedItemIdForInfo info) = return Nothing-      | otherwise = do-          processKey <- processDisambiguationKeyForItem client info-          return $ fmap (itemStableIdentity info,) processKey+    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 =-  nub $+  dedupe $     concat       [ maybeToList maybeProcessKey,         map ("icon-name:" ++) (maybeToList (nonEmptyString (H.iconName info))),@@ -434,7 +493,7 @@  priorityEditableKeyCandidates :: Maybe String -> H.ItemInfo -> [String] priorityEditableKeyCandidates maybeProcessKey info =-  nub $+  dedupe $     concat       [ maybeToList maybeProcessKey,         map ("icon-name:" ++) (maybeToList (nonEmptyString (H.iconName info))),@@ -465,34 +524,40 @@           mapMaybe (`M.lookup` priorities) (priorityLookupKeyCandidates maybeProcessKey info)    in clampPriority (fromMaybe defaultPriority matchedPriority) -itemIdentityMatcher :: H.ItemInfo -> Tray.TrayItemMatcher-itemIdentityMatcher info =-  let stableIdentity = itemStableIdentity info-   in mkTrayItemMatcher-        ("priority:identity:" <> stableIdentity)-        (\candidate -> itemStableIdentity candidate == stableIdentity)+formatMaybe :: Maybe String -> String+formatMaybe = fromMaybe "-" -priorityMatchersFromMapAndItems ::-  Bool ->-  Int ->-  Int ->-  Int ->-  SNIPriorityMap ->+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] ->-  [Tray.TrayItemMatcher]-priorityMatchersFromMapAndItems highPriorityFirstInMatcherOrder priorityMin priorityMax defaultPriority priorities processKeyForInfo infos =-  let sortedInfos =-        sortedInfosByPriority-          highPriorityFirstInMatcherOrder-          priorityMin-          priorityMax-          defaultPriority-          priorities-          processKeyForInfo-          infos-      fallbackMatcher = mkTrayItemMatcher "priority:identity:fallback" (const True)-   in map itemIdentityMatcher sortedInfos ++ [fallbackMatcher]+  String+describeOrderedInfos priorityForInfo processKeyForInfo infos =+  intercalate+    " | "+    [ printf+        "%d:{%s}"+        index+        (describeItemForOrder priorityForInfo processKeyForInfo info)+    | (index, info) <- zip [0 :: Int ..] infos+    ]  sortedInfosByPriority ::   Bool ->@@ -503,7 +568,7 @@   (H.ItemInfo -> Maybe String) ->   [H.ItemInfo] ->   [H.ItemInfo]-sortedInfosByPriority highPriorityFirstInMatcherOrder priorityMin priorityMax defaultPriority priorities processKeyForInfo infos =+sortedInfosByPriority highPriorityFirstInTrayOrder priorityMin priorityMax defaultPriority priorities processKeyForInfo infos =   let itemPriority info =         itemPriorityFromMap           priorityMin@@ -513,13 +578,11 @@           (processKeyForInfo info)           info       prioritySortKey info =-        if highPriorityFirstInMatcherOrder+        if highPriorityFirstInTrayOrder           then negate (itemPriority info)           else itemPriority info-   in -- Matchers may need to be reversed to keep higher numeric priorities on the-      -- visual left when the tray is end-aligned.-      sortOn-        (\info -> (prioritySortKey info, itemStableIdentity info))+   in sortOn+        (\info -> (prioritySortKey info, itemOrderingKey (processKeyForInfo info) info))         infos  lookupExplicitPriority ::@@ -746,10 +809,7 @@         defaultPriority = clampPriority prioritizedCollapsibleSNITrayDefaultPriority         visibilityThreshold = clampPriority <$> prioritizedCollapsibleSNITrayVisibilityThreshold         trayOrientation' = trayOrientation sniTrayTrayParams-        highPriorityFirstInMatcherOrder =-          case trayAlignment sniTrayTrayParams of-            End -> False-            _ -> True+        highPriorityFirstInTrayOrder = True      statePath <- resolveSNIPriorityStateFile prioritizedCollapsibleSNITrayPriorityStateFile     persistedPriorityFile <- loadSNIPriorityFileFromFile statePath@@ -768,6 +828,11 @@             Just persistedThreshold -> clampPriority <$> persistedThreshold     prioritiesRef <- newIORef persistedPriorities     expandedRef <- newIORef collapsibleSNITrayStartExpanded+    hoverExpandedRef <- newIORef False+    hoverInsideRef <- newIORef False+    hoverSerialRef <- newIORef (0 :: Int)+    animationSerialRef <- newIORef (0 :: Int)+    animationActiveRef <- newIORef False     priorityEditModeRef <- newIORef prioritizedCollapsibleSNITrayStartPriorityEditMode     maxVisibleIconsRef <- newIORef initialMaxVisibleIcons     visibilityThresholdRef <- newIORef initialVisibilityThreshold@@ -780,10 +845,23 @@     outer <- Gtk.boxNew trayOrientation' 0     _ <- widgetSetClassGI outer "sni-tray-collapsible"     _ <- widgetSetClassGI outer "sni-tray-prioritized-collapsible"-    outerWidget <- Gtk.toWidget outer+    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"@@ -826,9 +904,17 @@           when recomputeProcessKeys $             writeIORef processDisambiguationKeysRef processKeyMap           priorities <- readIORef prioritiesRef-          let orderedInfos =+          let priorityForInfo info =+                itemPriorityFromMap+                  priorityMin+                  priorityMax+                  defaultPriority+                  priorities+                  (processKeyForInfoFromMap processKeyMap info)+                  info+              orderedInfos =                 sortedInfosByPriority-                  highPriorityFirstInMatcherOrder+                  highPriorityFirstInTrayOrder                   priorityMin                   priorityMax                   defaultPriority@@ -836,6 +922,12 @@                   (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@@ -897,16 +989,18 @@             else do               removeClassIfPresent "sni-tray-editing" outer -        refreshTray tray = do+        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-          reorderTrayChildrenByIdentities tray (map itemStableIdentity orderedInfos)-          children <- Gtk.containerGetChildren tray-           let itemPriority info =                 itemPriorityFromMap                   priorityMin@@ -915,7 +1009,6 @@                   priorities                   (processKeyForInfoFromMap processKeyMap info)                   info-              totalCount = length children               collapsedThresholdVisibleCount =                 case thresholdValue of                   Nothing -> totalCount@@ -927,19 +1020,171 @@                 | maxVisibleIcons > 0 =                     min collapsedThresholdVisibleCount maxVisibleIcons                 | otherwise = collapsedThresholdVisibleCount-              visibleCount-                | expanded = totalCount-                | otherwise = collapsedVisibleCount+          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++        scheduleHoverExpanded shouldExpand delayMs = do+          modifyIORef' hoverSerialRef (+ 1)+          hoverSerial <- readIORef hoverSerialRef+          void $+            GLib.timeoutAdd GLib.PRIORITY_DEFAULT delayMs $ do+              currentSerial <- readIORef hoverSerialRef+              hoverInside <- readIORef hoverInsideRef+              when+                ( currentSerial == hoverSerial+                    && hoverInside == shouldExpand+                )+                (setHoverExpanded shouldExpand)+              return 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 = childIndex < visibleCount+            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@@ -950,10 +1195,15 @@               Gtk.labelSetText overflowCountLabel ""               Gtk.widgetHide overflowCountLabel -          if expanded+          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@@ -988,20 +1238,8 @@                   (hashUnique handlerId)               writeIORef updateHandlerRef (Just handlerId) -        buildTrayWithPriorities priorities processKeyMap infos = do-          let priorityConfig =-                sniTrayPriorityConfig-                  { trayPriorityMatchers =-                      priorityMatchersFromMapAndItems-                        highPriorityFirstInMatcherOrder-                        priorityMin-                        priorityMax-                        defaultPriority-                        priorities-                        (processKeyForInfoFromMap processKeyMap)-                        infos-                  }-              baseHooks = trayEventHooks sniTrayTrayParams+        buildTrayForPrioritizedWrapper = do+          let baseHooks = trayEventHooks sniTrayTrayParams               baseClickHook = trayClickHook baseHooks               combinedClickHook clickContext = do                 editMode <- readIORef priorityEditModeRef@@ -1013,12 +1251,16 @@                     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-                  { trayEventHooks =+                  { trayAlignment = Beginning,+                    trayPriorityConfig = Tray.defaultTrayPriorityConfig,+                    trayEventHooks =                       baseHooks {trayClickHook = Just combinedClickHook},                     trayShowNewIconsImmediately = False                   }-          tray <- buildTray host client trayParams {trayPriorityConfig = priorityConfig}+          tray <- buildTray host client trayParams           _ <- widgetSetClassGI tray "sni-tray"           return tray @@ -1043,8 +1285,28 @@           return True         else return False +    when prioritizedCollapsibleSNITrayHoverExpand $ do+      Gtk.widgetAddEvents+        outerEventBox+        [ Gdk.EventMaskEnterNotifyMask,+          Gdk.EventMaskLeaveNotifyMask+        ]+      Gtk.widgetAddEvents settingsToggle [Gdk.EventMaskEnterNotifyMask]+      _ <- Gtk.onWidgetEnterNotifyEvent outerEventBox $ \_event -> do+        writeIORef hoverInsideRef True+        return False+      _ <- Gtk.onWidgetLeaveNotifyEvent outerEventBox $ \_event -> do+        writeIORef hoverInsideRef False+        scheduleHoverExpanded False prioritizedCollapsibleSNITrayHoverCollapseDelayMs+        return False+      _ <- Gtk.onWidgetEnterNotifyEvent settingsToggle $ \_event -> do+        writeIORef hoverInsideRef True+        scheduleHoverExpanded True prioritizedCollapsibleSNITrayHoverExpandDelayMs+        return False+      return ()+     _ <--      Gtk.onWidgetDestroy outer $+      Gtk.onWidgetDestroy outerEventBox $         readIORef updateHandlerRef           >>= traverse_             ( \handlerId -> do@@ -1055,16 +1317,15 @@                 H.removeUpdateHandler host handlerId             ) -    orderedInfos <- updateOrderedInfos True-    priorities <- readIORef prioritiesRef-    processKeyMap <- readIORef processDisambiguationKeysRef-    tray <- buildTrayWithPriorities priorities processKeyMap orderedInfos-    Gtk.boxPackStart trayContainer tray False False 0+    _ <- 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 outer+    Gtk.widgetShowAll outerWidget     refreshPriorityModeToggle     _ <- refresh     return outerWidget

@@ -16,7 +16,7 @@ import Control.Monad.IO.Class (liftIO) import Control.Monad.Trans.Reader (ask, runReaderT) import Data.IORef (IORef, atomicModifyIORef', newIORef, readIORef)-import Data.List (nub, sort)+import qualified Data.Set as Set import qualified Data.Text as T import Data.Word (Word64) import qualified GI.Gdk as Gdk@@ -191,7 +191,11 @@ formatIntervals :: [Word64] -> T.Text formatIntervals intervals   | null intervals = "none"-  | otherwise = T.intercalate ", " $ fmap formatIntervalNanoseconds (sort (nub intervals))+  | otherwise =+      T.intercalate ", " $+        fmap formatIntervalNanoseconds $+          Set.toAscList $+            Set.fromList intervals  formatIntervalNanoseconds :: Word64 -> T.Text formatIntervalNanoseconds nanoseconds

@@ -88,6 +88,7 @@ import System.Taffybar.Widget.Util (widgetSetClassGI) import Text.Parsec import Text.Printf+import Text.Read (readMaybe) import Text.StringTemplate  -- | Parsed NOAA weather report values used by the weather widget.@@ -132,20 +133,27 @@   _ <- manyTill anyChar $ char '('   c <- manyTill num $ char ' '   _ <- skipRestOfLine-  return (floor (read c :: Double), floor (read f :: Double))+  parsedTempC <- parseNumber "temperature Celsius" c :: Parser Double+  parsedTempF <- parseNumber "temperature Fahrenheit" f :: Parser Double+  return (floor parsedTempC, floor parsedTempF)  pRh :: Parser Int pRh = do   s <- manyTill digit $ char '%' <|> char '.'-  return $ read s+  parseNumber "relative humidity" s  pPressure :: Parser Int pPressure = do   _ <- manyTill anyChar $ char '('   s <- manyTill digit $ char ' '   _ <- skipRestOfLine-  return $ read s+  parseNumber "pressure" s +parseNumber :: (Read a) => String -> String -> Parser a+parseNumber valueLabel raw =+  maybe (fail $ "Could not parse " ++ valueLabel ++ ": " ++ raw) return $+    readMaybe raw+ parseData :: Parser WeatherInfo parseData = do   st <- getAllBut ','@@ -327,7 +335,7 @@               noHttp = fromMaybe str $ stripPrefix "http://" str               (phost, pport) = case span (':' /=) noHttp of                 (h, "") -> (strToBs h, 80) -- HTTP seems to assume 80 to be the default-                (h, ':' : p) -> (strToBs h, read p)+                (h, ':' : p) -> (strToBs h, fromMaybe 80 (readMaybe p))                 _ -> error "unreachable: broken span"            in useProxy $ Proxy phost pport   mgr <- newManager $ managerSetProxy usedProxy tlsManagerSettings

@@ -29,11 +29,13 @@ import Data.IORef (IORef, newIORef, readIORef, writeIORef) import Data.Int (Int32) import Data.List (find)+import qualified Data.List as List import qualified Data.Set as Set import qualified Data.Text as T import qualified GI.GdkPixbuf.Objects.Pixbuf as Gdk import qualified GI.Gtk as Gtk import qualified GI.Pango as Pango+import qualified Graphics.UI.GIGtkScalingImage as Scaling import System.Taffybar.Context import System.Taffybar.Information.EWMHDesktopInfo   ( ewmhWMIcon,@@ -218,19 +220,14 @@     forM_ windows $ \windowInfo ->       lift $ do         labelText <- runReaderT (getMenuLabel config windowInfo) context-        iconPixbuf <--          case getActiveWindowIconPixbuf config of-            Nothing -> pure Nothing-            Just getIcon -> runReaderT (getIcon windowsMenuIconSize windowInfo) context         let focusCallback =               runReaderT (onMenuWindowClick config windowInfo) context                 >> return True         item <- Gtk.menuItemNew         content <- Gtk.boxNew Gtk.OrientationHorizontal 6-        forM_ iconPixbuf $ \pixbuf -> do-          icon <- Gtk.imageNewFromPixbuf (Just pixbuf)+        forM_ (getActiveWindowIconPixbuf config) $ \getIcon -> do+          icon <- buildMenuIcon context getIcon windowInfo           Gtk.boxPackStart content icon False False 0-          pure icon         label <- Gtk.labelNew (Just labelText)         Gtk.labelSetXalign label 0         Gtk.boxPackStart content label True True 0@@ -244,22 +241,39 @@   Gtk.containerForeach menu $ \item ->     Gtk.containerRemove menu item >> Gtk.widgetDestroy item +buildMenuIcon ::+  Context ->+  (Int32 -> WindowInfo -> TaffyIO (Maybe Gdk.Pixbuf)) ->+  WindowInfo ->+  IO Gtk.DrawingArea+buildMenuIcon context getIcon windowInfo = do+  icon <- Gtk.drawingAreaNew+  Gtk.widgetSetSizeRequest icon windowsMenuIconSize windowsMenuIconSize+  Gtk.setWidgetHalign icon Gtk.AlignCenter+  Gtk.setWidgetValign icon Gtk.AlignCenter+  void $+    Scaling.autoFillImage+      icon+      (\size -> runReaderT (getIcon size windowInfo) context)+      Gtk.OrientationHorizontal+  return icon+ windowsMenuIconSize :: Int32-windowsMenuIconSize = fromIntegral $ fromEnum Gtk.IconSizeMenu+windowsMenuIconSize = 16  getWindows :: WorkspaceSnapshot -> [WindowInfo]-getWindows snapshot = reverse ordered+getWindows snapshot = orderedBuilder []   where     allWindows =       [ win       | wsInfo <- snapshotWorkspaces snapshot,         win <- workspaceWindows wsInfo       ]-    (_, ordered) = foldl keepFirst (Set.empty, []) allWindows-    keepFirst (seen, acc) windowInfo-      | windowIdentity windowInfo `Set.member` seen = (seen, acc)+    (_, orderedBuilder) = List.foldl' keepFirst (Set.empty, id) allWindows+    keepFirst (seen, build) windowInfo+      | windowIdentity windowInfo `Set.member` seen = (seen, build)       | otherwise =-          (Set.insert (windowIdentity windowInfo) seen, windowInfo : acc)+          (Set.insert (windowIdentity windowInfo) seen, build . (windowInfo :))  getActiveWindow :: WorkspaceSnapshot -> Maybe WindowInfo getActiveWindow snapshot =

@@ -55,6 +55,7 @@ import Data.Int (Int32) import Data.List (elemIndex) import qualified Data.Map.Strict as M+import Data.Maybe (listToMaybe) import qualified Data.Text as T import Data.Word (Word64) import qualified GI.Gdk.Enums as Gdk@@ -72,7 +73,9 @@     workspaceUpdateEvents,   ) import System.Taffybar.Information.Workspaces.Hyprland-  ( getHyprlandWorkspaceStateChanAndVar,+  ( HyprlandWorkspaceProviderConfig,+    defaultHyprlandWorkspaceProviderConfig,+    getHyprlandWorkspaceStateChanAndVarWith,   ) import System.Taffybar.Information.Workspaces.Model import System.Taffybar.Information.Workspaces.Support@@ -112,7 +115,6 @@     mkWindowIconWidgetBase,     syncWidgetPool,     updateWidgetClasses,-    updateWindowIconWidgetState,     widgetSetClassGI,     windowStatusClassFromFlags,   )@@ -139,6 +141,7 @@     labelSetter :: WorkspaceInfo -> TaffyIO String,     showWorkspaceFn :: WorkspaceInfo -> Bool,     iconSort :: [WindowInfo] -> TaffyIO [WindowInfo],+    hyprlandWorkspaceProviderConfig :: HyprlandWorkspaceProviderConfig,     urgentWorkspaceState :: Bool,     onWorkspaceClick :: WorkspaceInfo -> TaffyIO (),     onWindowClick :: WindowInfo -> TaffyIO ()@@ -241,11 +244,11 @@ defaultEWMHWorkspaceStateSource =   getEWMHWorkspaceStateChanAndVarWith defaultChannelEWMHWorkspaceProviderConfig -autoWorkspaceStateSource :: TaffyIO (TChan WorkspaceSnapshot, MV.MVar WorkspaceSnapshot)-autoWorkspaceStateSource = do+autoWorkspaceStateSource :: WorkspacesConfig -> TaffyIO (TChan WorkspaceSnapshot, MV.MVar WorkspaceSnapshot)+autoWorkspaceStateSource cfg = do   backendType <- asks backend   case backendType of-    BackendWayland -> getHyprlandWorkspaceStateChanAndVar+    BackendWayland -> getHyprlandWorkspaceStateChanAndVarWith (hyprlandWorkspaceProviderConfig cfg)     BackendX11 -> defaultEWMHWorkspaceStateSource  defaultWorkspacesConfig :: WorkspacesConfig@@ -260,6 +263,7 @@       labelSetter = return . T.unpack . workspaceName . workspaceIdentity,       showWorkspaceFn = \ws -> hideEmpty ws && not (workspaceIsSpecial ws),       iconSort = pure . sortWindowsByPosition,+      hyprlandWorkspaceProviderConfig = defaultHyprlandWorkspaceProviderConfig,       urgentWorkspaceState = False,       onWorkspaceClick = defaultOnWorkspaceClick,       onWindowClick = defaultOnWindowClick@@ -284,6 +288,7 @@         liftIO $ writeIORef wsRef newWs         labelText <- labelSetter cfg newWs         let wsState = toCSSState cfg newWs+            windowsChanged = workspaceWindows oldWs /= workspaceWindows newWs         liftIO $ Gtk.labelSetMarkup label (T.pack labelText)         setWorkspaceWidgetStatusClass wsState contents         setWorkspaceWidgetStatusClass wsState label@@ -291,11 +296,14 @@         let needsIconUpdate =               forceIcons                 || null currentIcons-                || workspaceWindows oldWs /= workspaceWindows newWs+                || windowsChanged         updatedIcons <-           if needsIconUpdate             then updateWorkspaceIcons cfg wsRef iconsBox currentIcons newWs             else return currentIcons+        when forceIcons $+          liftIO $+            forM_ updatedIcons iconForceUpdate         liftIO $ writeIORef iconsRef updatedIcons         liftIO $ writeIORef lastWorkspaceRef newWs       controller =@@ -320,7 +328,7 @@   cont <- liftIO $ Gtk.boxNew Gtk.OrientationHorizontal (fromIntegral $ widgetGap cfg)   _ <- widgetSetClassGI cont "workspaces"   cacheVar <- liftIO $ MV.newMVar (WorkspaceCache M.empty [] [] 0)-  (chan, snapshotVar) <- autoWorkspaceStateSource+  (chan, snapshotVar) <- autoWorkspaceStateSource cfg   initialSnapshot <- liftIO $ MV.readMVar snapshotVar   renderWorkspaces cfg cont cacheVar initialSnapshot   _ <-@@ -493,7 +501,7 @@         let total = length identities         guard (total > 0)         let wrappedIndex = (idx + step + total) `mod` total-        return (identities !! wrappedIndex)+        listToMaybe $ drop wrappedIndex identities   case getTargetIdentity >>= (`M.lookup` cacheEntries cache) of     Nothing -> return False     Just targetEntry -> do@@ -501,6 +509,17 @@       onWorkspaceClick cfg targetWorkspace       return True +activateWorkspaceIcon ::+  WorkspacesConfig ->+  WorkspaceInfo ->+  Maybe WindowInfo ->+  TaffyIO ()+activateWorkspaceIcon cfg currentWs maybeWindow = do+  backendType <- asks backend+  case (backendType, maybeWindow) of+    (BackendX11, Just windowInfo) -> onWindowClick cfg windowInfo+    _ -> onWorkspaceClick cfg currentWs+ updateWorkspaceIcons ::   WorkspacesConfig ->   IORef WorkspaceInfo ->@@ -541,21 +560,36 @@       Gtk.onWidgetButtonPressEvent (iconContainer iconWidget) $         const $ do           maybeWindow <- MV.readMVar (iconWindow iconWidget)-          case maybeWindow of-            Just windowInfo -> runReaderT (onWindowClick cfg windowInfo) ctx-            Nothing -> do-              currentWs <- readIORef workspaceRef-              runReaderT (onWorkspaceClick cfg currentWs) ctx+          currentWs <- readIORef workspaceRef+          runReaderT (activateWorkspaceIcon cfg currentWs maybeWindow) ctx           return True   return iconWidget  updateIconWidget :: WindowIconWidget WindowInfo -> Maybe WindowInfo -> TaffyIO ()-updateIconWidget iconWidget windowData =-  updateWindowIconWidgetState-    iconWidget-    windowData-    windowTitle-    getWindowStatusString+updateIconWidget iconWidget windowData = do+  oldWindowData <- liftIO $ MV.swapMVar (iconWindow iconWidget) windowData+  Gtk.widgetSetTooltipText (iconContainer iconWidget) (windowTitle <$> windowData)+  let pixbufKeyChanged =+        (windowIconPixbufKey <$> oldWindowData) /= (windowIconPixbufKey <$> windowData)+  when pixbufKeyChanged $+    liftIO $+      iconForceUpdate iconWidget+  let statusString = maybe "inactive" getWindowStatusString windowData+      stateClasses =+        case windowData of+          Just windowInfo | windowPinned windowInfo -> [statusString, "pinned"]+          _ -> [statusString]+  updateWidgetClasses+    (iconContainer iconWidget)+    stateClasses+    windowIconStatusClasses++windowIconPixbufKey :: WindowInfo -> (WindowIdentity, Word64, [T.Text], T.Text)+windowIconPixbufKey windowInfo =+  (windowIdentity windowInfo, windowUpdateRevision windowInfo, windowClassHints windowInfo, windowTitle windowInfo)++windowIconStatusClasses :: [T.Text]+windowIconStatusClasses = ["active", "urgent", "minimized", "normal", "inactive", "pinned"]  getWindowStatusString :: WindowInfo -> T.Text getWindowStatusString windowInfo =

@@ -58,9 +58,7 @@ callWttr url =   let unknownLocation rsp =         -- checks for a common wttr.in bug-        case T.stripPrefix "Unknown location; please try" rsp of-          Nothing -> False-          Just strippedRsp -> T.length strippedRsp < T.length rsp+        isJust $ T.stripPrefix "Unknown location; please try" rsp       isImage = isJust . matchRegex (mkRegex ".png")       getResponseData r =         ( statusIsSuccessful $ responseStatus r,

@@ -20,8 +20,8 @@   ) where -import Control.Concurrent (forkIO, killThread)-import Control.Concurrent.STM.TChan (TChan, readTChan)+import Control.Concurrent (forkIO, killThread, threadDelay)+import Control.Concurrent.STM.TChan (TChan, readTChan, tryReadTChan) import Control.Monad (forever, when) import Control.Monad.STM (atomically) import Data.Int (Int32)@@ -125,9 +125,20 @@       { getFocusedMonitorHyprlandEvents = getEvents       } -> do         events <- getEvents+        let collectPendingRelevantEvents = do+              maybeEventLine <- tryReadTChan events+              case maybeEventLine of+                Nothing -> return []+                Just eventLine ->+                  if isRelevantFocusedMonitorHyprlandEvent eventLine+                    then (eventLine :) <$> collectPendingRelevantEvents+                    else collectPendingRelevantEvents         tid <- forkIO $ forever $ do           eventLine <- atomically $ readTChan events-          when (isRelevantFocusedMonitorHyprlandEvent eventLine) refresh+          when (isRelevantFocusedMonitorHyprlandEvent eventLine) $ do+            threadDelay 25_000+            _ <- atomically collectPendingRelevantEvents+            refresh         _ <- Gtk.onWidgetUnrealize window $ killThread tid         return ()   refresh

@@ -158,7 +158,7 @@     sortedIcons = sortBy (comparing ewmhHeight) icons     smallestLargerIcon =       take 1 $ dropWhile ((<= fromIntegral imgSize) . ewmhHeight) sortedIcons-    largestIcon = take 1 $ reverse sortedIcons+    largestIcon = take 1 $ sortBy (comparing (Down . ewmhHeight)) icons     prefIcon = smallestLargerIcon ++ largestIcon  -- | Create a pixbuf from the best matching EWMH icon for the requested size.@@ -200,7 +200,10 @@   (MonadIO m) =>   Int32 -> Word32 -> m Gdk.Pixbuf pixBufFromColor imgSize c = do-  pixbuf <- fromJust <$> Gdk.pixbufNew Gdk.ColorspaceRgb True 8 imgSize imgSize+  pixbuf <-+    fromMaybe+      (error "pixBufFromColor: failed to allocate pixbuf")+      <$> Gdk.pixbufNew Gdk.ColorspaceRgb True 8 imgSize imgSize   Gdk.pixbufFill pixbuf c   return pixbuf @@ -224,10 +227,10 @@   (Monad m) =>   (p -> String -> m (Maybe a)) -> p -> String -> m (Maybe a) getWindowIconForAllClasses doOnClass size klass =-  foldl combine (return Nothing) $ parseWindowClasses klass+  foldr combine (return Nothing) $ parseWindowClasses klass   where-    combine soFar theClass =-      maybeTCombine soFar (doOnClass size theClass)+    combine theClass =+      maybeTCombine (doOnClass size theClass)  -- | Resolve a window icon through desktop-entry icon metadata. getWindowIconFromDesktopEntryByClasses ::

@@ -1,7 +1,9 @@ cabal-version: 3.4 name: taffybar-version: 7.1.0+version: 7.2.0 synopsis: A desktop bar similar to xmobar, but with more GUI+description: Taffybar is a desktop status bar with GTK widgets for window+  manager state, system information, tray icons, and custom user modules. license: BSD-3-Clause license-file: LICENSE author: Ivan Malison@@ -14,6 +16,7 @@   taffybar.css   icons/*.svg extra-source-files:+  dbus-xml/org.imalison.ChromeWindowInfo.xml   dbus-xml/org.PulseAudio.ServerLookup1.xml   dbus-xml/org.PulseAudio.Core1.xml   dbus-xml/org.PulseAudio.Core1.Device.xml@@ -58,68 +61,70 @@     MonoLocalBinds    build-depends: HStringTemplate >= 0.8 && < 0.9-               , X11 >= 1.5.0.1-               , aeson-               , ansi-terminal-               , bytestring-               , conduit-               , containers-               , data-default-               , dbus >= 1.2.11 && < 2.0.0-               , dbus-hslogger >= 0.1.1.0 && < 0.2.0.0-               , dbus-menu >= 0.1.3.2-               , directory-               , disk-free-space >= 0.1.0.1+               , X11 >= 1.5.0.1 && < 1.11+               , aeson >= 1.4 && < 2.3+               , ansi-terminal >= 0.10 && < 1.2+               , bytestring >= 0.10 && < 0.13+               , conduit >= 1.3 && < 1.4+               , containers >= 0.5 && < 0.8+               , data-default >= 0.7 && < 0.9+               , dbus >= 1.2.11 && < 2+               , dbus-hslogger >= 0.1.1.1 && < 0.2+               , dbus-menu >= 0.1.3.3 && < 0.2+               , directory >= 1.3 && < 1.4+               , disk-free-space >= 0.1.0.1 && < 0.2                , dyre >= 0.9.0 && < 0.10-               , either >= 4.0.0.0-               , enclosed-exceptions >= 1.0.0.1-               , filepath+               , either >= 4.0.0.0 && < 5.1+               , enclosed-exceptions >= 1.0.0.1 && < 1.1+               , filepath >= 1.4 && < 1.6                , fsnotify >= 0.4 && < 0.5-               , monad-control-               , gi-cairo-connector-               , gi-cairo-render-                , gi-gdk3 >=3.0.30 && <3.1+               , monad-control >= 1.0 && < 1.1+               , gi-cairo-connector >= 0.1 && < 0.2+               , gi-cairo-render >= 0.1 && < 0.2+               , gi-gdk3 >=3.0.30 && <3.1                , gi-gdkpixbuf >=2.0.6 && <2.1                , gi-gdkx113 >=3.0.17 && < 4-               , gi-glib-               , gi-gtk-layer-shell >= 0.1.7+               , gi-glib >= 2.0 && < 2.1+               , gi-gobject >= 2.0 && < 2.1+               , gi-gtk-layer-shell >= 0.1.7 && < 0.2                , gi-gtk3 >= 3.0.44 && < 4                , gi-gtk-hs >= 0.3.17 && < 0.4-               , gi-pango-               , gtk-scaling-image >= 0.1.0.0 && < 0.2-               , gtk-sni-tray >= 0.2.1.1-               , gtk-strut >= 0.1.4.0-               , haskell-gi-base >= 0.24-               , hslogger-               , http-conduit-               , http-client >= 0.5-               , http-client-tls-               , http-types-               , multimap >= 1.2.1-               , network-               , parsec >= 3.1-               , process >= 1.0.1.1-               , rate-limit >= 1.1.1-               , regex-compat+               , gi-pango >= 1.0 && < 1.1+               , gi-wireplumber >= 0.5.14.1 && < 0.6+               , gtk-scaling-image >= 0.1.0.1 && < 0.2+               , gtk-sni-tray >= 0.2.1.2 && < 0.3+               , gtk-strut >= 0.1.4.1 && < 0.2+               , haskell-gi-base >= 0.24 && < 0.27+               , hslogger >= 1.2 && < 1.4+               , http-conduit >= 2.3 && < 2.4+               , http-client >= 0.5 && < 0.8+               , http-client-tls >= 0.3 && < 0.4+               , http-types >= 0.12 && < 0.13+               , multimap >= 1.2.1 && < 1.3+               , network >= 3.1 && < 3.3+               , parsec >= 3.1 && < 3.2+               , process >= 1.0.1.1 && < 1.7+               , rate-limit >= 1.1.1 && < 1.5+               , regex-compat >= 0.95 && < 0.96                , safe >= 0.3 && < 1                , scotty >= 0.20 && < 0.31-               , split >= 0.1.4.2-               , status-notifier-item >= 0.3.2.13-               , stm-               , template-haskell-               , text-               , time >= 1.9 && < 2.0+               , split >= 0.1.4.2 && < 0.3+               , status-notifier-item >= 0.3.2.14 && < 0.4+               , stm >= 2.5 && < 2.6+               , template-haskell >= 2.17 && < 2.24+               , text >= 1.2 && < 2.2+               , time >= 1.9 && < 2                , time-locale-compat >= 0.1 && < 0.2-               , time-units >= 1.0.0-               , transformers >= 0.3.0.0-               , tuple >= 0.3.0.2-               , unix-               , utf8-string-               , xdg-desktop-entry >= 0.1.1.4+               , time-units >= 1.0.0 && < 1.1+               , transformers >= 0.3.0.0 && < 0.7+               , tuple >= 0.3.0.2 && < 0.4+               , unix >= 2.7 && < 2.9+               , utf8-string >= 1.0 && < 1.1+               , xdg-desktop-entry >= 0.1.1.5 && < 0.2                , xdg-basedir >= 0.2 && < 0.3-               , xml-               , xml-helpers-               , yaml+               , xml >= 1.3 && < 1.4+               , xml-helpers >= 1.0 && < 1.1+               , yaml >= 0.11 && < 0.12    hs-source-dirs: src   pkgconfig-depends: gtk+-3.0@@ -134,7 +139,9 @@                  , System.Taffybar.Example                  , System.Taffybar.Hyprland                  , System.Taffybar.Hooks+                 , System.Taffybar.Information.Audio                  , System.Taffybar.Information.Hyprland+                 , System.Taffybar.Information.HyprlandWorkspaceHistory                  , System.Taffybar.Information.PulseAudio                  , System.Taffybar.Information.WirePlumber                  , System.Taffybar.Information.AnthropicUsage@@ -144,6 +151,7 @@                  , System.Taffybar.Information.Bluetooth                  , System.Taffybar.Information.CPU2                  , System.Taffybar.Information.Chrome+                 , System.Taffybar.Information.ChromeWindowInfo                  , System.Taffybar.Information.Crypto                  , System.Taffybar.Information.DiskIO                  , System.Taffybar.Information.DiskUsage@@ -168,6 +176,7 @@                  , System.Taffybar.Information.Workspaces.EWMH                  , System.Taffybar.Information.Workspaces.Hyprland                  , System.Taffybar.Information.Workspaces.Model+                 , System.Taffybar.Information.Workspaces.Refresh                  , System.Taffybar.Information.Wakeup                  , System.Taffybar.Information.Wlsunset                  , System.Taffybar.Information.X11DesktopInfo@@ -177,6 +186,7 @@                  , System.Taffybar.SimpleConfig                  , System.Taffybar.Util                  , System.Taffybar.Widget+                 , System.Taffybar.Widget.Audio                  , System.Taffybar.Widget.PulseAudio                  , System.Taffybar.Widget.AnthropicUsage                  , System.Taffybar.Widget.ASUS@@ -213,6 +223,7 @@                  , System.Taffybar.Widget.MPRIS2                  , System.Taffybar.Widget.NetworkGraph                  , System.Taffybar.Widget.NetworkManager+                 , System.Taffybar.Widget.OmniMenu                  , System.Taffybar.Widget.OpenAIUsage                  , System.Taffybar.Widget.PowerProfiles                  , System.Taffybar.Widget.Privacy@@ -240,10 +251,11 @@                  , System.Taffybar.WindowIcon    if flag(Deprecated-Pager-Hints)-    build-depends: xmonad+    build-depends: xmonad >= 0.17 && < 0.19     exposed-modules: System.Taffybar.Support.PagerHints    other-modules: Paths_taffybar+               , System.Taffybar.DBus.Client.ChromeWindowInfo                , System.Taffybar.DBus.Client.Login1Manager                , System.Taffybar.DBus.Client.MPRIS2                , System.Taffybar.DBus.Client.NetworkManager@@ -271,11 +283,11 @@ executable taffybar   import: haskell, exe   build-depends: data-default-               , dhall+               , dhall >= 1.40 && < 1.43                , directory                , gi-gtk3                , hslogger-               , optparse-applicative+               , optparse-applicative >= 0.17 && < 0.20                , taffybar                , text @@ -291,14 +303,14 @@   import: haskell, exe   hs-source-dirs: app   main-is: TestWM.hs-  build-depends: xmonad-               , xmonad-contrib+  build-depends: xmonad >= 0.17 && < 0.19+               , xmonad-contrib >= 0.17 && < 0.19  executable taffybar-appearance-snap   import: haskell, exe   hs-source-dirs: app   main-is: AppearanceSnap.hs-  build-depends: JuicyPixels+  build-depends: JuicyPixels >= 3.3 && < 3.4                , X11                , bytestring                , data-default@@ -311,15 +323,15 @@                , taffybar                , text                , transformers-               , typed-process+               , typed-process >= 0.2 && < 0.3                , unix-               , unliftio+               , unliftio >= 0.2 && < 0.3  executable taffybar-appearance-snap-hyprland   import: haskell, exe   hs-source-dirs: app   main-is: AppearanceSnapHyprland.hs-  build-depends: JuicyPixels+  build-depends: JuicyPixels >= 3.3 && < 3.4                , bytestring                , data-default                , directory@@ -328,9 +340,9 @@                , gtk-strut                , taffybar                , text-               , typed-process+               , typed-process >= 0.2 && < 0.3                , unix-               , unliftio+               , unliftio >= 0.2 && < 0.3                , transformers  common test@@ -349,22 +361,22 @@                  , System.Taffybar.Test.DBusSpec                  , System.Taffybar.Test.UtilSpec                  , System.Taffybar.Test.XvfbSpec-  build-depends: attoparsec+  build-depends: attoparsec >= 0.13 && < 0.15                , bytestring                , containers                , data-default                , dbus-               , extra+               , extra >= 1.7 && < 1.9                , filepath                , hslogger-               , hspec+               , hspec >= 2.8 && < 3                , taffybar                , text-               , typed-process+               , typed-process >= 0.2 && < 0.3                , unix-               , unliftio-               , unliftio-core-               , QuickCheck >= 2+               , unliftio >= 0.2 && < 0.3+               , unliftio-core >= 0.2 && < 0.3+               , QuickCheck >= 2 && < 2.16   build-tool-depends: hspec-discover:hspec-discover == 2.*  test-suite unit@@ -379,13 +391,17 @@                , System.Taffybar.Information.CryptoSpec                , System.Taffybar.Information.LayoutSpec                , System.Taffybar.Information.Workspaces.EWMHSpec+               , System.Taffybar.Information.Workspaces.HyprlandSpec                , System.Taffybar.Information.X11DesktopInfoSpec                , System.Taffybar.Information.WakeupSpec                , System.Taffybar.SimpleConfigSpec+               , System.Taffybar.Widget.SNITray.PrioritizedCollapsibleSpec                , System.Taffybar.Widget.Workspaces.ChannelSpec                , System.Taffybar.Widget.WindowsSpec   build-depends: data-default                , bytestring+               , containers+               , dbus                , directory                , JuicyPixels                , filepath@@ -395,6 +411,7 @@                , hspec-core                , hspec-golden                , network+               , status-notifier-item                , taffybar                , taffybar:testlib                , typed-process

binary file changed (3729 → 1559 bytes)

@@ -32,8 +32,10 @@ import GI.Gtk (Widget) import Network.Socket qualified as Socket import System.Directory (createDirectoryIfMissing, getTemporaryDirectory, removePathForcibly)+import System.Environment (lookupEnv) import System.FilePath ((</>)) import System.Taffybar.Context+import System.Taffybar.Context.Backend (prepareBackendEnvironment) import System.Taffybar.SimpleConfig import System.Taffybar.Test.DBusSpec (withTestDBus) import System.Taffybar.Test.UtilSpec (logSetup, withEnv, withSetEnv)@@ -97,6 +99,147 @@           detectBackend `shouldReturn` BackendX11       removePathForcibly runtime `catch` (\(_ :: SomeException) -> pure ()) +    it "discovers Wayland from live Hyprland sockets when only DISPLAY is inherited" $ do+      tmp <- getTemporaryDirectory+      let runtime = tmp </> "taffybar-test-runtime-display-with-hyprland"+          liveWayland = "wayland-live"+          oldSig = "abcdef_1000_old"+          liveSig = "abcdef_2000_new"+          oldDir = runtime </> "hypr" </> oldSig+          liveDir = runtime </> "hypr" </> liveSig+      removePathForcibly runtime `catch` (\(_ :: SomeException) -> pure ())+      createDirectoryIfMissing True oldDir+      createDirectoryIfMissing True liveDir+      withUnixSocket (runtime </> liveWayland)+        $ withUnixSocket (oldDir </> ".socket.sock")+        $ withUnixSocket (liveDir </> ".socket.sock")+        $ withEnv+          [ ("XDG_RUNTIME_DIR", const $ Just runtime),+            ("DISPLAY", const $ Just ":0"),+            ("WAYLAND_DISPLAY", const Nothing),+            ("HYPRLAND_INSTANCE_SIGNATURE", const Nothing),+            ("XDG_SESSION_TYPE", const $ Just "tty"),+            ("XDG_CURRENT_DESKTOP", const Nothing),+            ("DESKTOP_SESSION", const Nothing),+            ("GDK_BACKEND", const Nothing)+          ]+        $ do+          detectBackend `shouldReturn` BackendWayland+          lookupEnv "WAYLAND_DISPLAY" `shouldReturn` Just liveWayland+          lookupEnv "HYPRLAND_INSTANCE_SIGNATURE" `shouldReturn` Just liveSig+          lookupEnv "GDK_BACKEND" `shouldReturn` Just "wayland"+          lookupEnv "XDG_SESSION_TYPE" `shouldReturn` Just "wayland"+      removePathForcibly runtime `catch` (\(_ :: SomeException) -> pure ())++  describe "prepareBackendEnvironment" $ do+    it "replaces a stale WAYLAND_DISPLAY with a live discovered socket" $ do+      tmp <- getTemporaryDirectory+      let runtime = tmp </> "taffybar-test-runtime-repair-wayland"+          liveWayland = "wayland-live"+      removePathForcibly runtime `catch` (\(_ :: SomeException) -> pure ())+      createDirectoryIfMissing True runtime+      withUnixSocket (runtime </> liveWayland)+        $ withEnv+          [ ("XDG_RUNTIME_DIR", const $ Just runtime),+            ("WAYLAND_DISPLAY", const $ Just "wayland-stale"),+            ("XDG_SESSION_TYPE", const $ Just "wayland"),+            ("GDK_BACKEND", const Nothing)+          ]+        $ do+          prepareBackendEnvironment+          lookupEnv "WAYLAND_DISPLAY" `shouldReturn` Just liveWayland+      removePathForcibly runtime `catch` (\(_ :: SomeException) -> pure ())++    it "does not infer Wayland from an ambient socket when X11 is the only process context" $ do+      tmp <- getTemporaryDirectory+      let runtime = tmp </> "taffybar-test-runtime-ambient-wayland"+          liveWayland = "wayland-live"+      removePathForcibly runtime `catch` (\(_ :: SomeException) -> pure ())+      createDirectoryIfMissing True runtime+      withUnixSocket (runtime </> liveWayland)+        $ withEnv+          [ ("XDG_RUNTIME_DIR", const $ Just runtime),+            ("DISPLAY", const $ Just ":0"),+            ("WAYLAND_DISPLAY", const Nothing),+            ("HYPRLAND_INSTANCE_SIGNATURE", const Nothing),+            ("XDG_SESSION_TYPE", const Nothing),+            ("XDG_CURRENT_DESKTOP", const Nothing),+            ("DESKTOP_SESSION", const Nothing),+            ("GDK_BACKEND", const Nothing)+          ]+        $ do+          prepareBackendEnvironment+          lookupEnv "WAYLAND_DISPLAY" `shouldReturn` Nothing+          lookupEnv "GDK_BACKEND" `shouldReturn` Nothing+      removePathForcibly runtime `catch` (\(_ :: SomeException) -> pure ())++    it "steers GTK to Wayland when a live Wayland socket is selected" $ do+      tmp <- getTemporaryDirectory+      let runtime = tmp </> "taffybar-test-runtime-wayland-gdk-backend"+          liveWayland = "wayland-live"+      removePathForcibly runtime `catch` (\(_ :: SomeException) -> pure ())+      createDirectoryIfMissing True runtime+      withUnixSocket (runtime </> liveWayland)+        $ withEnv+          [ ("XDG_RUNTIME_DIR", const $ Just runtime),+            ("DISPLAY", const $ Just ":0"),+            ("WAYLAND_DISPLAY", const $ Just liveWayland),+            ("XDG_SESSION_TYPE", const $ Just "x11"),+            ("GDK_BACKEND", const Nothing)+          ]+        $ do+          prepareBackendEnvironment+          lookupEnv "GDK_BACKEND" `shouldReturn` Just "wayland"+          lookupEnv "XDG_SESSION_TYPE" `shouldReturn` Just "wayland"+      removePathForcibly runtime `catch` (\(_ :: SomeException) -> pure ())++    it "prefers a live Hyprland instance over stale X11 session variables" $ do+      tmp <- getTemporaryDirectory+      let runtime = tmp </> "taffybar-test-runtime-hyprland-over-x11"+          liveWayland = "wayland-live"+          liveSig = "hyprland-live"+          liveDir = runtime </> "hypr" </> liveSig+      removePathForcibly runtime `catch` (\(_ :: SomeException) -> pure ())+      createDirectoryIfMissing True liveDir+      withUnixSocket (runtime </> liveWayland)+        $ withUnixSocket (liveDir </> ".socket.sock")+        $ withEnv+          [ ("XDG_RUNTIME_DIR", const $ Just runtime),+            ("DISPLAY", const $ Just ":0"),+            ("WAYLAND_DISPLAY", const Nothing),+            ("HYPRLAND_INSTANCE_SIGNATURE", const $ Just liveSig),+            ("XDG_SESSION_TYPE", const $ Just "x11"),+            ("XDG_CURRENT_DESKTOP", const $ Just "none+xmonad"),+            ("DESKTOP_SESSION", const $ Just "none+xmonad"),+            ("GDK_BACKEND", const Nothing)+          ]+        $ do+          prepareBackendEnvironment+          lookupEnv "WAYLAND_DISPLAY" `shouldReturn` Just liveWayland+          lookupEnv "HYPRLAND_INSTANCE_SIGNATURE" `shouldReturn` Just liveSig+          lookupEnv "GDK_BACKEND" `shouldReturn` Just "wayland"+          lookupEnv "XDG_SESSION_TYPE" `shouldReturn` Just "wayland"+      removePathForcibly runtime `catch` (\(_ :: SomeException) -> pure ())++    it "replaces a stale HYPRLAND_INSTANCE_SIGNATURE with a live discovered signature" $ do+      tmp <- getTemporaryDirectory+      let runtime = tmp </> "taffybar-test-runtime-repair-hyprland"+          liveSig = "hyprland-live"+          liveDir = runtime </> "hypr" </> liveSig+      removePathForcibly runtime `catch` (\(_ :: SomeException) -> pure ())+      createDirectoryIfMissing True liveDir+      withUnixSocket (liveDir </> ".socket.sock")+        $ withEnv+          [ ("XDG_RUNTIME_DIR", const $ Just runtime),+            ("XDG_SESSION_TYPE", const $ Just "wayland"),+            ("HYPRLAND_INSTANCE_SIGNATURE", const $ Just "hyprland-stale"),+            ("GDK_BACKEND", const Nothing)+          ]+        $ do+          prepareBackendEnvironment+          lookupEnv "HYPRLAND_INSTANCE_SIGNATURE" `shouldReturn` Just liveSig+      removePathForcibly runtime `catch` (\(_ :: SomeException) -> pure ())+   describe "Fuzz tests" $ do     prop "eval generators" prop_genSimpleConfig     xprop "TaffybarConfig" prop_taffybarConfig@@ -110,6 +253,7 @@     Socket.close     $ \sock -> do       Socket.bind sock (Socket.SockAddrUnix path)+      Socket.listen sock 1       action  ------------------------------------------------------------------------

@@ -0,0 +1,124 @@+module System.Taffybar.Information.Workspaces.HyprlandSpec (spec) where++import Data.Text qualified as T+import System.Taffybar.Information.Workspaces.Hyprland+  ( applySpecialWorkspaceWindowTargets,+    sortWorkspaceInfos,+    specialWorkspaceWindowsToMinimized,+  )+import System.Taffybar.Information.Workspaces.Model+import Test.Hspec++mkWindow :: T.Text -> Bool -> WindowInfo+mkWindow title minimized =+  WindowInfo+    { windowIdentity = HyprlandWindowIdentity title,+      windowUpdateRevision = 0,+      windowTitle = title,+      windowClassHints = [],+      windowPosition = Nothing,+      windowUrgent = False,+      windowActive = False,+      windowMinimized = minimized,+      windowPinned = False+    }++mkWorkspace ::+  Maybe Int ->+  T.Text ->+  WorkspaceViewState ->+  Bool ->+  [WindowInfo] ->+  WorkspaceInfo+mkWorkspace idx name state special windows =+  WorkspaceInfo+    { workspaceIdentity =+        WorkspaceIdentity+          { workspaceNumericId = idx,+            workspaceName = name+          },+      workspaceUpdateRevision = 0,+      workspaceState = state,+      workspaceHasUrgentWindow = any windowUrgent windows,+      workspaceIsSpecial = special,+      workspaceWindows = windows+    }++workspaceByName :: T.Text -> [WorkspaceInfo] -> WorkspaceInfo+workspaceByName name workspaces =+  case filter ((== name) . workspaceName . workspaceIdentity) workspaces of+    [workspace] -> workspace+    [] -> error $ "Expected workspace named " <> T.unpack name+    _ -> error $ "Expected one workspace named " <> T.unpack name++spec :: Spec+spec = do+  describe "sortWorkspaceInfos" $+    it "orders normal numeric workspaces before special workspaces" $ do+      let specialMinimized =+            mkWorkspace (Just (-98)) "special:minimized" WorkspaceHidden True []+          specialScratch =+            mkWorkspace (Just (-99)) "special:scratchpad" WorkspaceHidden True []+          normal1 =+            mkWorkspace (Just 1) "1" WorkspaceActive False []+          normal2 =+            mkWorkspace (Just 2) "2" WorkspaceEmpty False []++      sortWorkspaceInfos [specialMinimized, normal2, specialScratch, normal1]+        `shouldBe` [normal1, normal2, specialScratch, specialMinimized]++  describe "applySpecialWorkspaceWindowTargets" $ do+    it "moves non-minimized special workspace windows into special:minimized" $ do+      let scratchWindow = mkWindow "scratch" False+          minimizedWindow = mkWindow "minimized" True+          scratch =+            mkWorkspace+              (Just (-99))+              "special:scratchpad"+              WorkspaceHidden+              True+              [scratchWindow]+          minimized =+            mkWorkspace+              (Just (-98))+              "special:minimized"+              WorkspaceHidden+              True+              [minimizedWindow]+          result =+            applySpecialWorkspaceWindowTargets+              specialWorkspaceWindowsToMinimized+              [scratch, minimized]+          movedScratch = workspaceByName "special:scratchpad" result+          minimizedBucket = workspaceByName "special:minimized" result+          movedWindow =+            case filter ((== HyprlandWindowIdentity "scratch") . windowIdentity) $+              workspaceWindows minimizedBucket of+              [window] -> window+              _ -> error "Expected scratch window in minimized bucket"++      workspaceWindows movedScratch `shouldBe` []+      workspaceState movedScratch `shouldBe` WorkspaceEmpty+      workspaceWindows minimizedBucket `shouldBe` [minimizedWindow, movedWindow]+      windowMinimized movedWindow `shouldBe` True++    it "creates a special:minimized bucket when the target workspace is missing" $ do+      let scratchWindow = mkWindow "scratch" False+          scratch =+            mkWorkspace+              (Just (-99))+              "special:scratchpad"+              WorkspaceHidden+              True+              [scratchWindow]+          result =+            applySpecialWorkspaceWindowTargets+              specialWorkspaceWindowsToMinimized+              [scratch]+          minimizedBucket = workspaceByName "special:minimized" result++      workspaceNumericId (workspaceIdentity minimizedBucket) `shouldBe` Nothing+      workspaceIsSpecial minimizedBucket `shouldBe` True+      workspaceState minimizedBucket `shouldBe` WorkspaceHidden+      map windowIdentity (workspaceWindows minimizedBucket)+        `shouldBe` [HyprlandWindowIdentity "scratch"]

@@ -0,0 +1,115 @@+module System.Taffybar.Widget.SNITray.PrioritizedCollapsibleSpec (spec) where++import DBus (busName_, formatBusName, objectPath_)+import Data.Map.Strict qualified as M+import StatusNotifier.Host.Service qualified as H+import System.Taffybar.Widget.SNITray.PrioritizedCollapsible+import Test.Hspec++spec :: Spec+spec =+  describe "sortedInfosByPriority" $ do+    it "uses stable metadata before D-Bus address for equal priorities" $ do+      let beta =+            testItem+              ":1.1"+              "/StatusNotifierItem"+              (Just "statusnotifieritem-1")+              "Zeta"+              "zeta-icon"+          alpha =+            testItem+              ":1.9"+              "/StatusNotifierItem"+              (Just "statusnotifieritem-9")+              "Alpha"+              "alpha-icon"+          sorted =+            sortedInfosByPriority+              True+              (-5)+              5+              0+              M.empty+              (const Nothing)+              [beta, alpha]++      map H.iconTitle sorted `shouldBe` ["Alpha", "Zeta"]++    it "uses process keys before D-Bus address" $ do+      let zeta =+            testItem+              ":1.1"+              "/StatusNotifierItem"+              (Just "systray_1")+              "Zeta"+              "same-icon"+          alpha =+            testItem+              ":1.9"+              "/StatusNotifierItem"+              (Just "systray_9")+              "Alpha"+              "same-icon"+          processKey info =+            case formatBusName (H.itemServiceName info) of+              ":1.1" -> Just "process:zeta"+              ":1.9" -> Just "process:alpha"+              _ -> Nothing+          sorted =+            sortedInfosByPriority+              True+              (-5)+              5+              0+              M.empty+              processKey+              [zeta, alpha]++      map H.iconTitle sorted `shouldBe` ["Alpha", "Zeta"]++    it "keeps priority ahead of the semantic tie-breaker" $ do+      let beta =+            testItem+              ":1.1"+              "/StatusNotifierItem"+              Nothing+              "Beta"+              "beta-icon"+          alpha =+            testItem+              ":1.9"+              "/StatusNotifierItem"+              Nothing+              "Alpha"+              "alpha-icon"+          sorted =+            sortedInfosByPriority+              True+              (-5)+              5+              0+              (M.fromList [("icon-title:Beta", 1)])+              (const Nothing)+              [alpha, beta]++      map H.iconTitle sorted `shouldBe` ["Beta", "Alpha"]++testItem :: String -> String -> Maybe String -> String -> String -> H.ItemInfo+testItem serviceName servicePath itemId iconTitle iconName =+  H.ItemInfo+    { H.itemServiceName = busName_ serviceName,+      H.itemServicePath = objectPath_ servicePath,+      H.itemId = itemId,+      H.itemStatus = Nothing,+      H.itemCategory = Nothing,+      H.itemToolTip = Nothing,+      H.iconTitle = iconTitle,+      H.iconName = iconName,+      H.overlayIconName = Nothing,+      H.iconThemePath = Nothing,+      H.iconPixmaps = [],+      H.overlayIconPixmaps = [],+      H.menuPath = Nothing,+      H.itemIsMenu = True+    }

@@ -10,12 +10,14 @@ mkX11Window wid minimized pos =   WindowInfo     { windowIdentity = X11WindowIdentity wid,+      windowUpdateRevision = 0,       windowTitle = T.pack (show wid),       windowClassHints = [],       windowPosition = pos,       windowUrgent = False,       windowActive = False,-      windowMinimized = minimized+      windowMinimized = minimized,+      windowPinned = False     }  mkWorkspace :: Int -> String -> WorkspaceViewState -> [WindowInfo] -> WorkspaceInfo@@ -26,6 +28,7 @@           { workspaceNumericId = Just idx,             workspaceName = T.pack name           },+      workspaceUpdateRevision = 0,       workspaceState = state,       workspaceHasUrgentWindow = any windowUrgent windows,       workspaceIsSpecial = False,@@ -76,3 +79,27 @@                 [WindowAdded newW2, WindowChanged newW1]             ]       diffWorkspaceSnapshots oldSnap newSnap `shouldBe` expectedEvents++    it "bumps update revisions for targeted window refreshes" $ do+      let w1 = mkX11Window 1 False (Just (0, 0))+          w2 = mkX11Window 2 False (Just (50, 50))+          ws1 = mkWorkspace 1 "1" WorkspaceActive [w1, w2]+          snap = mkSnapshot 10 [ws1]+          refreshed = bumpWorkspaceRefreshTarget (RefreshWindow $ X11WindowIdentity 2) snap+          refreshedRevisions =+            concatMap+              (map windowUpdateRevision . workspaceWindows)+              (snapshotWorkspaces refreshed)+      refreshedRevisions `shouldBe` [0, 1]++    it "preserves update revisions across backend snapshots" $ do+      let oldW1 = (mkX11Window 1 False (Just (0, 0))) {windowUpdateRevision = 3}+          oldWs1 = (mkWorkspace 1 "1" WorkspaceActive [oldW1]) {workspaceUpdateRevision = 4}+          previous = mkSnapshot 10 [oldWs1]+          newW1 = (mkX11Window 1 False (Just (5, 5))) {windowUpdateRevision = 0}+          newWs1 = (mkWorkspace 1 "1" WorkspaceHidden [newW1]) {workspaceUpdateRevision = 0}+          next = preserveWorkspaceUpdateRevisions previous $ mkSnapshot 11 [newWs1]+          preservedWorkspaces = snapshotWorkspaces next+          preservedWindows = concatMap workspaceWindows preservedWorkspaces+      map workspaceUpdateRevision preservedWorkspaces `shouldBe` [4]+      map windowUpdateRevision preservedWindows `shouldBe` [3]