diff --git a/CHANGELOG.md b/CHANGELOG.md
--- a/CHANGELOG.md
+++ b/CHANGELOG.md
@@ -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
diff --git a/dbus-xml/org.imalison.ChromeWindowInfo.xml b/dbus-xml/org.imalison.ChromeWindowInfo.xml
new file mode 100644
--- /dev/null
+++ b/dbus-xml/org.imalison.ChromeWindowInfo.xml
@@ -0,0 +1,22 @@
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
diff --git a/src/System/Taffybar.hs b/src/System/Taffybar.hs
--- a/src/System/Taffybar.hs
+++ b/src/System/Taffybar.hs
@@ -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"
diff --git a/src/System/Taffybar/Context.hs b/src/System/Taffybar/Context.hs
--- a/src/System/Taffybar/Context.hs
+++ b/src/System/Taffybar/Context.hs
@@ -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
diff --git a/src/System/Taffybar/Context/Backend.hs b/src/System/Taffybar/Context/Backend.hs
--- a/src/System/Taffybar/Context/Backend.hs
+++ b/src/System/Taffybar/Context/Backend.hs
@@ -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.
diff --git a/src/System/Taffybar/DBus/Client/ChromeWindowInfo.hs b/src/System/Taffybar/DBus/Client/ChromeWindowInfo.hs
new file mode 100644
--- /dev/null
+++ b/src/System/Taffybar/DBus/Client/ChromeWindowInfo.hs
@@ -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"
diff --git a/src/System/Taffybar/DBus/Client/Params.hs b/src/System/Taffybar/DBus/Client/Params.hs
--- a/src/System/Taffybar/DBus/Client/Params.hs
+++ b/src/System/Taffybar/DBus/Client/Params.hs
@@ -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 $
diff --git a/src/System/Taffybar/Hooks.hs b/src/System/Taffybar/Hooks.hs
--- a/src/System/Taffybar/Hooks.hs
+++ b/src/System/Taffybar/Hooks.hs
@@ -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'.
diff --git a/src/System/Taffybar/Information/AnthropicUsage.hs b/src/System/Taffybar/Information/AnthropicUsage.hs
--- a/src/System/Taffybar/Information/AnthropicUsage.hs
+++ b/src/System/Taffybar/Information/AnthropicUsage.hs
@@ -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)
diff --git a/src/System/Taffybar/Information/Audio.hs b/src/System/Taffybar/Information/Audio.hs
new file mode 100644
--- /dev/null
+++ b/src/System/Taffybar/Information/Audio.hs
@@ -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)
diff --git a/src/System/Taffybar/Information/Battery.hs b/src/System/Taffybar/Information/Battery.hs
--- a/src/System/Taffybar/Information/Battery.hs
+++ b/src/System/Taffybar/Information/Battery.hs
@@ -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,
diff --git a/src/System/Taffybar/Information/CPU2.hs b/src/System/Taffybar/Information/CPU2.hs
--- a/src/System/Taffybar/Information/CPU2.hs
+++ b/src/System/Taffybar/Information/CPU2.hs
@@ -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]
diff --git a/src/System/Taffybar/Information/Chrome.hs b/src/System/Taffybar/Information/Chrome.hs
--- a/src/System/Taffybar/Information/Chrome.hs
+++ b/src/System/Taffybar/Information/Chrome.hs
@@ -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
diff --git a/src/System/Taffybar/Information/ChromeWindowInfo.hs b/src/System/Taffybar/Information/ChromeWindowInfo.hs
new file mode 100644
--- /dev/null
+++ b/src/System/Taffybar/Information/ChromeWindowInfo.hs
@@ -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
diff --git a/src/System/Taffybar/Information/Hyprland.hs b/src/System/Taffybar/Information/Hyprland.hs
--- a/src/System/Taffybar/Information/Hyprland.hs
+++ b/src/System/Taffybar/Information/Hyprland.hs
@@ -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.
--
diff --git a/src/System/Taffybar/Information/Hyprland/API.hs b/src/System/Taffybar/Information/Hyprland/API.hs
--- a/src/System/Taffybar/Information/Hyprland/API.hs
+++ b/src/System/Taffybar/Information/Hyprland/API.hs
@@ -111,9 +111,9 @@
| otherwise = Right $ HyprlandAddress t
data HyprlandDispatch
- = -- | @hyprctl dispatch workspace @
+ = -- | @hyprctl dispatch 'hl.dsp.focus({ workspace = "" })'@
DispatchWorkspace HyprlandWorkspaceTarget
- | -- | @hyprctl dispatch focuswindow address:@
+ | -- | @hyprctl dispatch 'hl.dsp.focus({ window = "address:" })'@
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]
diff --git a/src/System/Taffybar/Information/Hyprland/Types.hs b/src/System/Taffybar/Information/Hyprland/Types.hs
--- a/src/System/Taffybar/Information/Hyprland/Types.hs
+++ b/src/System/Taffybar/Information/Hyprland/Types.hs
@@ -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@.
diff --git a/src/System/Taffybar/Information/HyprlandWorkspaceHistory.hs b/src/System/Taffybar/Information/HyprlandWorkspaceHistory.hs
new file mode 100644
--- /dev/null
+++ b/src/System/Taffybar/Information/HyprlandWorkspaceHistory.hs
@@ -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)
diff --git a/src/System/Taffybar/Information/Memory.hs b/src/System/Taffybar/Information/Memory.hs
--- a/src/System/Taffybar/Information/Memory.hs
+++ b/src/System/Taffybar/Information/Memory.hs
@@ -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
diff --git a/src/System/Taffybar/Information/Network.hs b/src/System/Taffybar/Information/Network.hs
--- a/src/System/Taffybar/Information/Network.hs
+++ b/src/System/Taffybar/Information/Network.hs
@@ -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)
diff --git a/src/System/Taffybar/Information/NetworkManager.hs b/src/System/Taffybar/Information/NetworkManager.hs
--- a/src/System/Taffybar/Information/NetworkManager.hs
+++ b/src/System/Taffybar/Information/NetworkManager.hs
@@ -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
diff --git a/src/System/Taffybar/Information/OpenAIUsage.hs b/src/System/Taffybar/Information/OpenAIUsage.hs
--- a/src/System/Taffybar/Information/OpenAIUsage.hs
+++ b/src/System/Taffybar/Information/OpenAIUsage.hs
@@ -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
diff --git a/src/System/Taffybar/Information/Privacy.hs b/src/System/Taffybar/Information/Privacy.hs
--- a/src/System/Taffybar/Information/Privacy.hs
+++ b/src/System/Taffybar/Information/Privacy.hs
@@ -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
diff --git a/src/System/Taffybar/Information/PulseAudio.hs b/src/System/Taffybar/Information/PulseAudio.hs
--- a/src/System/Taffybar/Information/PulseAudio.hs
+++ b/src/System/Taffybar/Information/PulseAudio.hs
@@ -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)
diff --git a/src/System/Taffybar/Information/Wakeup/Manager.hs b/src/System/Taffybar/Information/Wakeup/Manager.hs
--- a/src/System/Taffybar/Information/Wakeup/Manager.hs
+++ b/src/System/Taffybar/Information/Wakeup/Manager.hs
@@ -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
diff --git a/src/System/Taffybar/Information/WirePlumber.hs b/src/System/Taffybar/Information/WirePlumber.hs
--- a/src/System/Taffybar/Information/WirePlumber.hs
+++ b/src/System/Taffybar/Information/WirePlumber.hs
@@ -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
diff --git a/src/System/Taffybar/Information/Workspaces/EWMH.hs b/src/System/Taffybar/Information/Workspaces/EWMH.hs
--- a/src/System/Taffybar/Information/Workspaces/EWMH.hs
+++ b/src/System/Taffybar/Information/Workspaces/EWMH.hs
@@ -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))
diff --git a/src/System/Taffybar/Information/Workspaces/Hyprland.hs b/src/System/Taffybar/Information/Workspaces/Hyprland.hs
--- a/src/System/Taffybar/Information/Workspaces/Hyprland.hs
+++ b/src/System/Taffybar/Information/Workspaces/Hyprland.hs
@@ -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
}
diff --git a/src/System/Taffybar/Information/Workspaces/Model.hs b/src/System/Taffybar/Information/Workspaces/Model.hs
--- a/src/System/Taffybar/Information/Workspaces/Model.hs
+++ b/src/System/Taffybar/Information/Workspaces/Model.hs
@@ -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.
diff --git a/src/System/Taffybar/Information/Workspaces/Refresh.hs b/src/System/Taffybar/Information/Workspaces/Refresh.hs
new file mode 100644
--- /dev/null
+++ b/src/System/Taffybar/Information/Workspaces/Refresh.hs
@@ -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
diff --git a/src/System/Taffybar/Information/XDG/Protocol.hs b/src/System/Taffybar/Information/XDG/Protocol.hs
--- a/src/System/Taffybar/Information/XDG/Protocol.hs
+++ b/src/System/Taffybar/Information/XDG/Protocol.hs
@@ -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
diff --git a/src/System/Taffybar/Util.hs b/src/System/Taffybar/Util.hs
--- a/src/System/Taffybar/Util.hs
+++ b/src/System/Taffybar/Util.hs
@@ -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.
diff --git a/src/System/Taffybar/Widget.hs b/src/System/Taffybar/Widget.hs
--- a/src/System/Taffybar/Widget.hs
+++ b/src/System/Taffybar/Widget.hs
@@ -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
diff --git a/src/System/Taffybar/Widget/AnthropicUsage.hs b/src/System/Taffybar/Widget/AnthropicUsage.hs
--- a/src/System/Taffybar/Widget/AnthropicUsage.hs
+++ b/src/System/Taffybar/Widget/AnthropicUsage.hs
@@ -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
diff --git a/src/System/Taffybar/Widget/Audio.hs b/src/System/Taffybar/Widget/Audio.hs
new file mode 100644
--- /dev/null
+++ b/src/System/Taffybar/Widget/Audio.hs
@@ -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 =
+ "" ++ s ++ ""
+ 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 " "
+ else rendered
+
+isPUA :: Char -> Bool
+isPUA c =
+ let o = ord c
+ in o >= 0xE000 && o <= 0xF8FF
diff --git a/src/System/Taffybar/Widget/BatteryTextIcon.hs b/src/System/Taffybar/Widget/BatteryTextIcon.hs
--- a/src/System/Taffybar/Widget/BatteryTextIcon.hs
+++ b/src/System/Taffybar/Widget/BatteryTextIcon.hs
@@ -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
diff --git a/src/System/Taffybar/Widget/FreedesktopNotifications.hs b/src/System/Taffybar/Widget/FreedesktopNotifications.hs
--- a/src/System/Taffybar/Widget/FreedesktopNotifications.hs
+++ b/src/System/Taffybar/Widget/FreedesktopNotifications.hs
@@ -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
--------------------------------------------------------------------------------
diff --git a/src/System/Taffybar/Widget/Generic/Graph.hs b/src/System/Taffybar/Widget/Generic/Graph.hs
--- a/src/System/Taffybar/Widget/Generic/Graph.hs
+++ b/src/System/Taffybar/Widget/Generic/Graph.hs
@@ -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
diff --git a/src/System/Taffybar/Widget/MPRIS2.hs b/src/System/Taffybar/Widget/MPRIS2.hs
--- a/src/System/Taffybar/Widget/MPRIS2.hs
+++ b/src/System/Taffybar/Widget/MPRIS2.hs
@@ -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
diff --git a/src/System/Taffybar/Widget/OmniMenu.hs b/src/System/Taffybar/Widget/OmniMenu.hs
new file mode 100644
--- /dev/null
+++ b/src/System/Taffybar/Widget/OmniMenu.hs
@@ -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
diff --git a/src/System/Taffybar/Widget/OpenAIUsage.hs b/src/System/Taffybar/Widget/OpenAIUsage.hs
--- a/src/System/Taffybar/Widget/OpenAIUsage.hs
+++ b/src/System/Taffybar/Widget/OpenAIUsage.hs
@@ -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
diff --git a/src/System/Taffybar/Widget/SNITray/PrioritizedCollapsible.hs b/src/System/Taffybar/Widget/SNITray/PrioritizedCollapsible.hs
--- a/src/System/Taffybar/Widget/SNITray/PrioritizedCollapsible.hs
+++ b/src/System/Taffybar/Widget/SNITray/PrioritizedCollapsible.hs
@@ -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
diff --git a/src/System/Taffybar/Widget/WakeupDebug.hs b/src/System/Taffybar/Widget/WakeupDebug.hs
--- a/src/System/Taffybar/Widget/WakeupDebug.hs
+++ b/src/System/Taffybar/Widget/WakeupDebug.hs
@@ -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
diff --git a/src/System/Taffybar/Widget/Weather.hs b/src/System/Taffybar/Widget/Weather.hs
--- a/src/System/Taffybar/Widget/Weather.hs
+++ b/src/System/Taffybar/Widget/Weather.hs
@@ -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
diff --git a/src/System/Taffybar/Widget/Windows.hs b/src/System/Taffybar/Widget/Windows.hs
--- a/src/System/Taffybar/Widget/Windows.hs
+++ b/src/System/Taffybar/Widget/Windows.hs
@@ -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 =
diff --git a/src/System/Taffybar/Widget/Workspaces.hs b/src/System/Taffybar/Widget/Workspaces.hs
--- a/src/System/Taffybar/Widget/Workspaces.hs
+++ b/src/System/Taffybar/Widget/Workspaces.hs
@@ -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 =
diff --git a/src/System/Taffybar/Widget/WttrIn.hs b/src/System/Taffybar/Widget/WttrIn.hs
--- a/src/System/Taffybar/Widget/WttrIn.hs
+++ b/src/System/Taffybar/Widget/WttrIn.hs
@@ -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,
diff --git a/src/System/Taffybar/Window/FocusedMonitor.hs b/src/System/Taffybar/Window/FocusedMonitor.hs
--- a/src/System/Taffybar/Window/FocusedMonitor.hs
+++ b/src/System/Taffybar/Window/FocusedMonitor.hs
@@ -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
diff --git a/src/System/Taffybar/WindowIcon.hs b/src/System/Taffybar/WindowIcon.hs
--- a/src/System/Taffybar/WindowIcon.hs
+++ b/src/System/Taffybar/WindowIcon.hs
@@ -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 ::
diff --git a/taffybar.cabal b/taffybar.cabal
--- a/taffybar.cabal
+++ b/taffybar.cabal
@@ -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
diff --git a/test/data/appearance-hyprland-bar.png b/test/data/appearance-hyprland-bar.png
Binary files a/test/data/appearance-hyprland-bar.png and b/test/data/appearance-hyprland-bar.png differ
diff --git a/test/unit/System/Taffybar/ContextSpec.hs b/test/unit/System/Taffybar/ContextSpec.hs
--- a/test/unit/System/Taffybar/ContextSpec.hs
+++ b/test/unit/System/Taffybar/ContextSpec.hs
@@ -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
------------------------------------------------------------------------
diff --git a/test/unit/System/Taffybar/Information/Workspaces/HyprlandSpec.hs b/test/unit/System/Taffybar/Information/Workspaces/HyprlandSpec.hs
new file mode 100644
--- /dev/null
+++ b/test/unit/System/Taffybar/Information/Workspaces/HyprlandSpec.hs
@@ -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"]
diff --git a/test/unit/System/Taffybar/Widget/SNITray/PrioritizedCollapsibleSpec.hs b/test/unit/System/Taffybar/Widget/SNITray/PrioritizedCollapsibleSpec.hs
new file mode 100644
--- /dev/null
+++ b/test/unit/System/Taffybar/Widget/SNITray/PrioritizedCollapsibleSpec.hs
@@ -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
+ }
diff --git a/test/unit/System/Taffybar/Widget/Workspaces/ChannelSpec.hs b/test/unit/System/Taffybar/Widget/Workspaces/ChannelSpec.hs
--- a/test/unit/System/Taffybar/Widget/Workspaces/ChannelSpec.hs
+++ b/test/unit/System/Taffybar/Widget/Workspaces/ChannelSpec.hs
@@ -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]