taffybar 7.2.4 → 7.2.5
raw patch · 17 files changed
+747/−243 lines, 17 filesdep −scottydep ~gtk-sni-traydep ~status-notifier-itemPVP: major bump suggested
API removals or changes: PVP suggests a major version bump
Dependencies removed: scotty
Dependency ranges changed: gtk-sni-tray, status-notifier-item
API changes (from Hackage documentation)
- System.Taffybar.Hooks: ChromeTabImageData :: Pixbuf -> Int -> ChromeTabImageData
- System.Taffybar.Hooks: [tabImageDataId] :: ChromeTabImageData -> Int
- System.Taffybar.Hooks: [tabImageData] :: ChromeTabImageData -> Pixbuf
- System.Taffybar.Hooks: data ChromeTabImageData
- System.Taffybar.Hooks: getChromeTabImageDataChannel :: TaffyIO (TChan ChromeTabImageData)
- System.Taffybar.Hooks: getChromeTabImageDataTable :: TaffyIO (MVar (Map Int ChromeTabImageData))
- System.Taffybar.Hooks: getX11WindowToChromeTabId :: TaffyIO X11WindowToChromeTabId
- System.Taffybar.Information.Chrome: ChromeFaviconServerPort :: Int -> ChromeFaviconServerPort
- System.Taffybar.Information.Chrome: ChromeTabImageData :: Pixbuf -> Int -> ChromeTabImageData
- System.Taffybar.Information.Chrome: ChromeTabImageDataState :: (MVar (Map Int ChromeTabImageData), TChan ChromeTabImageData) -> ChromeTabImageDataState
- System.Taffybar.Information.Chrome: X11WindowToChromeTabId :: MVar (Map X11Window Int) -> X11WindowToChromeTabId
- System.Taffybar.Information.Chrome: [tabImageDataId] :: ChromeTabImageData -> Int
- System.Taffybar.Information.Chrome: [tabImageData] :: ChromeTabImageData -> Pixbuf
- System.Taffybar.Information.Chrome: addTabIdEntry :: Map X11Window Int -> (X11Window, String) -> Map X11Window Int
- System.Taffybar.Information.Chrome: data ChromeTabImageData
- System.Taffybar.Information.Chrome: getChromeTabImageDataChannel :: TaffyIO (TChan ChromeTabImageData)
- System.Taffybar.Information.Chrome: getChromeTabImageDataState :: TaffyIO ChromeTabImageDataState
- System.Taffybar.Information.Chrome: getChromeTabImageDataTable :: TaffyIO (MVar (Map Int ChromeTabImageData))
- System.Taffybar.Information.Chrome: getTabIdFromTitle :: String -> Maybe Int
- System.Taffybar.Information.Chrome: getX11WindowToChromeTabId :: TaffyIO X11WindowToChromeTabId
- System.Taffybar.Information.Chrome: listenForChromeFaviconUpdates :: Int -> TaffyIO ChromeTabImageDataState
- System.Taffybar.Information.Chrome: logIO :: Priority -> String -> IO ()
- System.Taffybar.Information.Chrome: maintainX11WindowToChromeTabId :: TaffyIO (MVar (Map X11Window Int))
- System.Taffybar.Information.Chrome: newtype ChromeFaviconServerPort
- System.Taffybar.Information.Chrome: newtype ChromeTabImageDataState
- System.Taffybar.Information.Chrome: newtype X11WindowToChromeTabId
- System.Taffybar.Information.Chrome: tabIDRegex :: Regex
- System.Taffybar.Information.Chrome: updateTabMap :: Map X11Window Int -> TaffyIO (Map X11Window Int)
- System.Taffybar.Widget.Workspaces: getWindowIconPixbufFromChrome :: WindowIconPixbufGetter
- System.Taffybar.WindowIcon: getPixBufFromChromeData :: X11Window -> TaffyIO (Maybe Pixbuf)
+ System.Taffybar.Context: getMonitorAtPoint :: Display -> Int32 -> Int32 -> IO (Maybe Monitor)
+ System.Taffybar.Information.AnthropicUsage: [anthropicUsageEndpoint] :: AnthropicUsageConfig -> String
+ System.Taffybar.Information.AnthropicUsage: [anthropicUsageOAuthMaxBackoff] :: AnthropicUsageConfig -> NominalDiffTime
+ System.Taffybar.Information.AnthropicUsage: [anthropicUsageOAuthMinInterval] :: AnthropicUsageConfig -> NominalDiffTime
+ System.Taffybar.Information.AnthropicUsage: [anthropicUsageUserAgent] :: AnthropicUsageConfig -> String
+ System.Taffybar.Information.AnthropicUsage: [anthropicUsageWindowUtilizationPercent] :: AnthropicUsageWindow -> Maybe Double
+ System.Taffybar.Information.AnthropicUsage: instance Data.Aeson.Types.FromJSON.FromJSON System.Taffybar.Information.AnthropicUsage.AnthropicOAuthUsage
+ System.Taffybar.Information.AnthropicUsage: instance Data.Aeson.Types.FromJSON.FromJSON System.Taffybar.Information.AnthropicUsage.AnthropicOAuthWindow
+ System.Taffybar.Information.AnthropicUsage: instance GHC.Classes.Eq System.Taffybar.Information.AnthropicUsage.AnthropicOAuthUsage
+ System.Taffybar.Information.AnthropicUsage: instance GHC.Classes.Eq System.Taffybar.Information.AnthropicUsage.AnthropicOAuthWindow
+ System.Taffybar.Information.AnthropicUsage: instance GHC.Internal.Show.Show System.Taffybar.Information.AnthropicUsage.AnthropicOAuthUsage
+ System.Taffybar.Information.AnthropicUsage: instance GHC.Internal.Show.Show System.Taffybar.Information.AnthropicUsage.AnthropicOAuthWindow
+ System.Taffybar.SimpleConfig: setWidgetPriority :: (MonadIO m, IsObject o) => Int -> o -> m ()
+ System.Taffybar.SimpleConfig: withPriority :: MonadIO m => Int -> m Widget -> m Widget
+ System.Taffybar.Widget.SNITray.PrioritizedCollapsible: showPriorityControlsMenuWithExplicitCollapse :: EventBox -> Int -> Int -> Bool -> (Bool -> Text) -> IORef Bool -> IORef Bool -> IORef Int -> IORef Int -> IORef (Maybe Int) -> IO () -> IO () -> IO () -> IO ()
+ System.Taffybar.WidgetPriority: DynamicHidingConfig :: Int32 -> Text -> Maybe Word -> DynamicHidingConfig
+ System.Taffybar.WidgetPriority: [hiddenCssClass] :: DynamicHidingConfig -> Text
+ System.Taffybar.WidgetPriority: [recheckIntervalMs] :: DynamicHidingConfig -> Maybe Word
+ System.Taffybar.WidgetPriority: [reshowSlackPx] :: DynamicHidingConfig -> Int32
+ System.Taffybar.WidgetPriority: data DynamicHidingConfig
+ System.Taffybar.WidgetPriority: defaultDynamicHidingConfig :: DynamicHidingConfig
+ System.Taffybar.WidgetPriority: getWidgetPriority :: (MonadIO m, IsObject o) => o -> m (Maybe Int)
+ System.Taffybar.WidgetPriority: instance Data.Default.Internal.Default System.Taffybar.WidgetPriority.DynamicHidingConfig
+ System.Taffybar.WidgetPriority: setWidgetPriority :: (MonadIO m, IsObject o) => Int -> o -> m ()
+ System.Taffybar.WidgetPriority: setupDynamicHiding :: DynamicHidingConfig -> Int32 -> Box -> [Widget] -> IO ()
+ System.Taffybar.WidgetPriority: withPriority :: MonadIO m => Int -> m Widget -> m Widget
- System.Taffybar.Information.AnthropicUsage: AnthropicUsageConfig :: Double -> Maybe FilePath -> Maybe FilePath -> Maybe FilePath -> NominalDiffTime -> Maybe Int -> Maybe Int -> AnthropicUsageConfig
+ System.Taffybar.Information.AnthropicUsage: AnthropicUsageConfig :: Double -> String -> String -> NominalDiffTime -> NominalDiffTime -> Maybe FilePath -> Maybe FilePath -> Maybe FilePath -> NominalDiffTime -> Maybe Int -> Maybe Int -> AnthropicUsageConfig
- System.Taffybar.Information.AnthropicUsage: AnthropicUsageWindow :: Text -> UTCTime -> UTCTime -> Maybe Int -> AnthropicUsageTotals -> AnthropicUsageWindow
+ System.Taffybar.Information.AnthropicUsage: AnthropicUsageWindow :: Text -> UTCTime -> UTCTime -> Maybe Int -> Maybe Double -> AnthropicUsageTotals -> AnthropicUsageWindow
Files
- CHANGELOG.md +31/−0
- README.md +18/−1
- doc/index.md +18/−1
- src/System/Taffybar/Context.hs +44/−23
- src/System/Taffybar/DBus/Toggle.hs +5/−8
- src/System/Taffybar/Hooks.hs +0/−5
- src/System/Taffybar/Information/AnthropicUsage.hs +260/−31
- src/System/Taffybar/Information/Chrome.hs +0/−137
- src/System/Taffybar/Information/Workspaces/Support.hs +0/−8
- src/System/Taffybar/SimpleConfig.hs +12/−6
- src/System/Taffybar/Widget/AnthropicUsage.hs +10/−3
- src/System/Taffybar/Widget/SNITray/PrioritizedCollapsible.hs +42/−3
- src/System/Taffybar/Widget/Workspaces.hs +0/−2
- src/System/Taffybar/WidgetPriority.hs +269/−0
- src/System/Taffybar/WindowIcon.hs +0/−10
- taffybar.cabal +5/−5
- test/unit/System/Taffybar/WidgetPrioritySpec.hs +33/−0
CHANGELOG.md view
@@ -1,3 +1,34 @@+# Unreleased++# 7.2.5++## Features++* Add `System.Taffybar.WidgetPriority`, which supports priority-based dynamic+ hiding of bar widgets when the bar runs out of horizontal space. Wrapping a+ widget constructor with `withPriority` (re-exported from+ `System.Taffybar.SimpleConfig`) marks it as hideable; when the natural+ widths of the bar's widgets exceed the available width, prioritized widgets+ are hidden lowest-priority-first and shown again (with a hysteresis margin)+ when space frees up. Widgets without a priority are never hidden, and bars+ with no prioritized widgets behave exactly as before. Hidden widgets get the+ `priority-hidden` CSS class.++* The Anthropic usage widget now reports rate-limit utilization percentages+ and reset times from the OAuth usage endpoint that Claude Code itself polls,+ authenticated with the access token from Claude Code's local credentials+ file. Window labels display clean percentages (matching the OpenAI usage+ widget) whenever the endpoint is reachable, falling back to the existing+ transcript-derived token counts otherwise.++## Fixes++* Require `status-notifier-item >= 0.3.2.15` and `gtk-sni-tray >= 0.2.1.3`,+ which bound the DBus calls made during SNI tray host and watcher startup. A+ single unresponsive tray item (a process that owns its `StatusNotifierItem`+ bus name but never services its connection) could previously hang the tray+ widget build, and with it the entire bar, indefinitely.+ # 7.2.4 ## Packaging
README.md view
@@ -1,6 +1,6 @@ # Taffybar -[](https://github.com/taffybar/taffybar/actions/workflows/nix.yml) [](https://hackage.haskell.org/package/taffybar) [](https://github.com/taffybar/taffybar/compare/latest-release...master) [](http://stackage.org/lts/package/taffybar) [](http://stackage.org/nightly/package/taffybar) [](https://matrix.to/#/#taffybar:matrix.org) [](https://gitter.im/taffybar/Lobby) [](https://github.com/taffybar/taffybar/blob/master/LICENSE)+[](https://github.com/taffybar/taffybar/actions/workflows/nix.yml) [](https://hackage.haskell.org/package/taffybar) [](https://github.com/taffybar/taffybar/releases/latest) [](http://stackage.org/lts/package/taffybar) [](http://stackage.org/nightly/package/taffybar) [](https://matrix.to/#/#taffybar:matrix.org) [](https://gitter.im/taffybar/Lobby) [](https://github.com/taffybar/taffybar/blob/master/LICENSE) ## Summary @@ -14,6 +14,23 @@ workspaces, windows, and layout widgets available. Many widgets still rely on X11/EWMH, so check the widget docs and examples (including `example/taffybar-wayland.hs`) for what works on your setup.++## Package Release Status++The unreleased commit badges are path-scoped to each package directory. The+root `taffybar` badge counts non-`packages/` changes.++| Package | Hackage | Unreleased commits |+| --- | --- | --- |+| `taffybar` | [](https://hackage.haskell.org/package/taffybar) | [](https://github.com/taffybar/taffybar/releases/latest) |+| `dbus-hslogger` | [](https://hackage.haskell.org/package/dbus-hslogger) | [](https://github.com/taffybar/taffybar/releases?q=dbus-hslogger) |+| `dbus-menu` | [](https://hackage.haskell.org/package/dbus-menu) | [](https://github.com/taffybar/taffybar/releases?q=dbus-menu) |+| `gi-wireplumber` | [](https://hackage.haskell.org/package/gi-wireplumber) | [](https://github.com/taffybar/taffybar/releases?q=gi-wireplumber) |+| `gtk-scaling-image` | [](https://hackage.haskell.org/package/gtk-scaling-image) | [](https://github.com/taffybar/taffybar/releases?q=gtk-scaling-image) |+| `gtk-sni-tray` | [](https://hackage.haskell.org/package/gtk-sni-tray) | [](https://github.com/taffybar/taffybar/releases?q=gtk-sni-tray) |+| `gtk-strut` | [](https://hackage.haskell.org/package/gtk-strut) | [](https://github.com/taffybar/taffybar/releases?q=gtk-strut) |+| `status-notifier-item` | [](https://hackage.haskell.org/package/status-notifier-item) | [](https://github.com/taffybar/taffybar/releases?q=status-notifier-item) |+| `xdg-desktop-entry` | [](https://hackage.haskell.org/package/xdg-desktop-entry) | [](https://github.com/taffybar/taffybar/releases?q=xdg-desktop-entry) | [](https://github.com/taffybar/taffybar/blob/master/doc/screenshot.png)
doc/index.md view
@@ -1,6 +1,6 @@ # Taffybar -[](https://github.com/taffybar/taffybar/actions/workflows/nix.yml) [](https://hackage.haskell.org/package/taffybar) [](https://github.com/taffybar/taffybar/compare/latest-release...master) [](http://stackage.org/lts/package/taffybar) [](http://stackage.org/nightly/package/taffybar) [](https://matrix.to/#/#taffybar:matrix.org) [](https://gitter.im/taffybar/Lobby) [](https://github.com/taffybar/taffybar/blob/master/LICENSE)+[](https://github.com/taffybar/taffybar/actions/workflows/nix.yml) [](https://hackage.haskell.org/package/taffybar) [](https://github.com/taffybar/taffybar/releases/latest) [](http://stackage.org/lts/package/taffybar) [](http://stackage.org/nightly/package/taffybar) [](https://matrix.to/#/#taffybar:matrix.org) [](https://gitter.im/taffybar/Lobby) [](https://github.com/taffybar/taffybar/blob/master/LICENSE) ## Summary @@ -14,6 +14,23 @@ workspaces, windows, and layout widgets available. Many widgets still rely on X11/EWMH, so check the widget docs and examples (including `example/taffybar-wayland.hs`) for what works on your setup.++## Package Release Status++The unreleased commit badges are path-scoped to each package directory. The+root `taffybar` badge counts non-`packages/` changes.++| Package | Hackage | Unreleased commits |+| --- | --- | --- |+| `taffybar` | [](https://hackage.haskell.org/package/taffybar) | [](https://github.com/taffybar/taffybar/releases/latest) |+| `dbus-hslogger` | [](https://hackage.haskell.org/package/dbus-hslogger) | [](https://github.com/taffybar/taffybar/releases?q=dbus-hslogger) |+| `dbus-menu` | [](https://hackage.haskell.org/package/dbus-menu) | [](https://github.com/taffybar/taffybar/releases?q=dbus-menu) |+| `gi-wireplumber` | [](https://hackage.haskell.org/package/gi-wireplumber) | [](https://github.com/taffybar/taffybar/releases?q=gi-wireplumber) |+| `gtk-scaling-image` | [](https://hackage.haskell.org/package/gtk-scaling-image) | [](https://github.com/taffybar/taffybar/releases?q=gtk-scaling-image) |+| `gtk-sni-tray` | [](https://hackage.haskell.org/package/gtk-sni-tray) | [](https://github.com/taffybar/taffybar/releases?q=gtk-sni-tray) |+| `gtk-strut` | [](https://hackage.haskell.org/package/gtk-strut) | [](https://github.com/taffybar/taffybar/releases?q=gtk-strut) |+| `status-notifier-item` | [](https://hackage.haskell.org/package/status-notifier-item) | [](https://github.com/taffybar/taffybar/releases?q=status-notifier-item) |+| `xdg-desktop-entry` | [](https://hackage.haskell.org/package/xdg-desktop-entry) | [](https://github.com/taffybar/taffybar/releases?q=xdg-desktop-entry) | [](https://github.com/taffybar/taffybar/blob/master/doc/screenshot.png)
src/System/Taffybar/Context.hs view
@@ -58,6 +58,7 @@ -- * X11 runX11, runX11Def,+ getMonitorAtPoint, -- ** Event subscription subscribeToAll,@@ -77,7 +78,7 @@ import Control.Concurrent (forkIO, threadDelay) import qualified Control.Concurrent.MVar as MV import Control.Concurrent.STM.TChan (TChan, readTChan)-import Control.Exception (SomeException, try)+import Control.Exception (SomeException, catch, try) import Control.Exception.Enclosed (catchAny) import Control.Monad import Control.Monad.IO.Class@@ -90,7 +91,7 @@ import Data.Char (toLower) import Data.Data import Data.Default (Default (..))-import Data.GI.Base (castTo)+import Data.GI.Base (UnexpectedNullPointerReturn (..), castTo) import Data.IORef import Data.Int import Data.List@@ -142,6 +143,7 @@ import System.Taffybar.Information.X11DesktopInfo import System.Taffybar.Util import System.Taffybar.Widget.Util+import System.Taffybar.WidgetPriority (defaultDynamicHidingConfig, setupDynamicHiding) import System.Taffybar.Window.FocusedMonitor ( FocusedMonitorHooks (..), setupFocusedMonitorClassUpdates,@@ -621,20 +623,27 @@ seat <- lift $ GI.Gdk.displayGetDefaultSeat display pointer <- MaybeT $ GI.Gdk.seatGetPointer seat (_, x, y) <- lift $ GI.Gdk.deviceGetPosition pointer- MaybeT $ Just <$> GI.Gdk.displayGetMonitorAtPoint display x y+ MaybeT $ getMonitorAtPoint display x y +getMonitorAtPoint :: GI.Gdk.Display -> Int32 -> Int32 -> IO (Maybe GI.Gdk.Monitor)+getMonitorAtPoint display x y =+ catch+ (Just <$> GI.Gdk.displayGetMonitorAtPoint display x y)+ $ \unexpectedNull -> do+ logIO WARNING $+ printf+ "displayGetMonitorAtPoint returned null for point (%d, %d): %s"+ x+ y+ (T.unpack $ nullPtrErrorMsg unexpectedNull)+ pure Nothing+ getFocusedMonitorX11 :: Context -> IO (Maybe GI.Gdk.Monitor) getFocusedMonitorX11 context = runMaybeT $ do display <- MaybeT GI.Gdk.displayGetDefault maybeCenterPoint <- lift $ runReaderT getActiveWindowCenterPoint context case maybeCenterPoint of- Just (x, y) ->- MaybeT $- Just- <$> GI.Gdk.displayGetMonitorAtPoint- display- (fromIntegral x)- (fromIntegral y)+ Just (x, y) -> MaybeT $ getMonitorAtPoint display (fromIntegral x) (fromIntegral y) Nothing -> MaybeT $ getPointerMonitor display getFocusedMonitorWayland :: Context -> IO (Maybe GI.Gdk.Monitor)@@ -642,13 +651,7 @@ display <- MaybeT GI.Gdk.displayGetDefault maybeFocusedMonitorPosition <- lift $ getFocusedMonitorPosition (hyprlandClient context) case maybeFocusedMonitorPosition of- Just (x, y) ->- MaybeT $- Just- <$> GI.Gdk.displayGetMonitorAtPoint- display- (fromIntegral x)- (fromIntegral y)+ Just (x, y) -> MaybeT $ getMonitorAtPoint display (fromIntegral x) (fromIntegral y) Nothing -> MaybeT $ getPointerMonitor display withHyprlandEventChan :: Context -> IO HyprlandEventChan@@ -744,21 +747,30 @@ addToStart count widget = do _ <- addIndexedClass "left" count widget Gtk.boxPackStart box widget False False 0+ return widget addToEnd count widget = do _ <- addIndexedClass "right" count widget _ <- addEndPaletteClasses count widget Gtk.boxPackEnd box widget False False 0+ return widget addToCenter count widget = do _ <- addIndexedClass "center" count widget Gtk.boxPackStart centerBox widget False False 0+ return widget logIO DEBUG "Building start widgets"- mapM_ (addWidgetWith addToStart) $ zip [1 ..] (startWidgets barConfig)+ builtStart <- mapM (addWidgetWith addToStart) $ zip [1 ..] (startWidgets barConfig) logIO DEBUG "Building center widgets"- mapM_ (addWidgetWith addToCenter) $ zip [1 ..] (centerWidgets barConfig)+ builtCenter <- mapM (addWidgetWith addToCenter) $ zip [1 ..] (centerWidgets barConfig) logIO DEBUG "Building end widgets"- mapM_ (addWidgetWith addToEnd) $ zip [1 ..] (endWidgets barConfig)+ builtEnd <- mapM (addWidgetWith addToEnd) $ zip [1 ..] (endWidgets barConfig) + setupDynamicHiding+ defaultDynamicHidingConfig+ (widgetSpacing barConfig)+ box+ (builtStart ++ builtCenter ++ builtEnd)+ return [box, centerBox] Just levels -> do levelsBox <- Gtk.boxNew Gtk.OrientationVertical 0@@ -800,20 +812,29 @@ addToStart count widget = do _ <- addIndexedClass "left" count widget Gtk.boxPackStart box widget False False 0+ return widget addToEnd count widget = do _ <- addIndexedClass "right" count widget _ <- addEndPaletteClasses count widget Gtk.boxPackEnd box widget False False 0+ return widget addToCenter count widget = do _ <- addIndexedClass "center" count widget Gtk.boxPackStart centerBox widget False False 0+ return widget logIO DEBUG $ printf "Building level %d start widgets" (levelCount :: Int)- mapM_ (addWidgetWith addToStart) $ zip [1 ..] starts+ builtStart <- mapM (addWidgetWith addToStart) $ zip [1 ..] starts logIO DEBUG $ printf "Building level %d center widgets" (levelCount :: Int)- mapM_ (addWidgetWith addToCenter) $ zip [1 ..] centers+ builtCenter <- mapM (addWidgetWith addToCenter) $ zip [1 ..] centers logIO DEBUG $ printf "Building level %d end widgets" (levelCount :: Int)- mapM_ (addWidgetWith addToEnd) $ zip [1 ..] ends+ builtEnd <- mapM (addWidgetWith addToEnd) $ zip [1 ..] ends++ setupDynamicHiding+ defaultDynamicHidingConfig+ (widgetSpacing barConfig)+ box+ (builtStart ++ builtCenter ++ builtEnd) return (box, centerBox)
src/System/Taffybar/DBus/Toggle.hs view
@@ -69,20 +69,17 @@ display <- MaybeT Gdk.displayGetDefault seat <- lift $ Gdk.displayGetDefaultSeat display device <- MaybeT $ Gdk.seatGetPointer seat- lift $ do- (_, x, y) <- Gdk.deviceGetPosition device- Gdk.displayGetMonitorAtPoint display x y >>= getMonitorNumber+ (_, x, y) <- lift $ Gdk.deviceGetPosition device+ monitor <- MaybeT $ getMonitorAtPoint display x y+ lift $ getMonitorNumber monitor getActiveMonitorNumberWayland :: Context -> MaybeT IO Int getActiveMonitorNumberWayland ctx = do (x, y) <- MaybeT $ getFocusedMonitorPosition (hyprlandClient ctx) display <- MaybeT Gdk.displayGetDefault monitor <-- lift $- Gdk.displayGetMonitorAtPoint- display- (fromIntegral x)- (fromIntegral y)+ MaybeT $+ getMonitorAtPoint display (fromIntegral x) (fromIntegral y) lift $ getMonitorNumber monitor getMonitorNumber :: Gdk.Monitor -> IO Int
src/System/Taffybar/Hooks.hs view
@@ -17,10 +17,6 @@ ( module System.Taffybar.DBus, module System.Taffybar.Hooks, module System.Taffybar.LogLevels,- ChromeTabImageData (..),- getChromeTabImageDataChannel,- getChromeTabImageDataTable,- getX11WindowToChromeTabId, refreshBatteriesOnPropChange, ) where@@ -43,7 +39,6 @@ import System.Taffybar.Context import System.Taffybar.DBus import System.Taffybar.Information.Battery-import System.Taffybar.Information.Chrome import System.Taffybar.Information.Network import System.Taffybar.LogFormatter import System.Taffybar.LogLevels
src/System/Taffybar/Information/AnthropicUsage.hs view
@@ -2,10 +2,11 @@ -- | Shared Claude Code subscription usage information. ----- Claude Code currently stores local transcript JSONL files under--- @~/.claude/projects@. This module derives usage from those local transcripts--- and reads subscription metadata from Claude Code's local state files. It does--- not call an Anthropic billing endpoint.+-- Rate-limit utilization percentages and reset times come from the OAuth usage+-- endpoint that Claude Code itself polls, authenticated with the access token+-- from Claude Code's local credentials file. Token totals are still derived+-- from the local transcript JSONL files under @~/.claude/projects@, and serve+-- as a fallback display when the endpoint is unreachable. module System.Taffybar.Information.AnthropicUsage ( AnthropicUsageConfig (..), defaultAnthropicUsageConfig,@@ -31,13 +32,17 @@ import Control.Monad.IO.Class (liftIO) import Data.Aeson import Data.Aeson.Types (Parser)+import qualified Data.ByteString.Char8 as BS8 import qualified Data.ByteString.Lazy.Char8 as LBS+import Data.IORef (IORef, newIORef, readIORef, writeIORef) import Data.List (sortOn) import qualified Data.List as List-import Data.Maybe (fromMaybe, mapMaybe)+import Data.Maybe (fromMaybe, listToMaybe, mapMaybe) import qualified Data.Set as Set import qualified Data.Text as T+import qualified Data.Text.Encoding as TE import Data.Time.Clock+import Network.HTTP.Simple import System.Directory ( doesDirectoryExist, doesFileExist,@@ -49,9 +54,24 @@ import System.Log.Logger (Priority (WARNING), logM) import System.Taffybar.Context (TaffyIO, getStateDefault) import System.Taffybar.Information.Wakeup (getWakeupChannelForDelay)+import Text.Read (readMaybe) data AnthropicUsageConfig = AnthropicUsageConfig- { anthropicUsagePollInterval :: Double,+ { -- | How often the poll loop wakes. Drives the cheap local transcript read;+ -- the rate-limited OAuth endpoint is governed separately by+ -- 'anthropicUsageOAuthMinInterval' and the backoff state, so this can be+ -- set low for snappy local token counts without abusing the endpoint.+ anthropicUsagePollInterval :: Double,+ anthropicUsageEndpoint :: String,+ anthropicUsageUserAgent :: String,+ -- | Minimum spacing between successful OAuth endpoint fetches. Even if the+ -- poll loop wakes more often, the endpoint is not hit again until this much+ -- time has elapsed since the last success.+ anthropicUsageOAuthMinInterval :: NominalDiffTime,+ -- | Upper bound on the exponential backoff applied after failed OAuth+ -- fetches (429s, auth errors, network errors). A server-supplied+ -- @Retry-After@ longer than this is still honored.+ anthropicUsageOAuthMaxBackoff :: NominalDiffTime, anthropicUsageStatePath :: Maybe FilePath, anthropicUsageCredentialsPath :: Maybe FilePath, anthropicUsageProjectsPath :: Maybe FilePath,@@ -64,6 +84,10 @@ defaultAnthropicUsageConfig = AnthropicUsageConfig { anthropicUsagePollInterval = 60 * 5,+ anthropicUsageEndpoint = "https://api.anthropic.com/api/oauth/usage",+ anthropicUsageUserAgent = "taffybar-anthropic-usage",+ anthropicUsageOAuthMinInterval = 60 * 5,+ anthropicUsageOAuthMaxBackoff = 60 * 60, anthropicUsageStatePath = Nothing, anthropicUsageCredentialsPath = Nothing, anthropicUsageProjectsPath = Nothing,@@ -94,6 +118,8 @@ anthropicUsageWindowStart :: UTCTime, anthropicUsageWindowEnd :: UTCTime, anthropicUsageWindowBudgetTokens :: Maybe Int,+ -- | Used percentage reported by the OAuth usage endpoint, when available.+ anthropicUsageWindowUtilizationPercent :: Maybe Double, anthropicUsageWindowTotals :: AnthropicUsageTotals } deriving (Eq, Show)@@ -148,14 +174,15 @@ data AnthropicCredentials = AnthropicCredentials { anthropicCredentialsSubscriptionType :: Maybe T.Text,- anthropicCredentialsRateLimitTier :: Maybe T.Text+ anthropicCredentialsRateLimitTier :: Maybe T.Text,+ anthropicCredentialsAccessToken :: Maybe T.Text } instance FromJSON AnthropicCredentials where parseJSON = withObject "AnthropicCredentials" $ \root -> do oauth <- root .:? "claudeAiOauth" case oauth of- Nothing -> return $ AnthropicCredentials Nothing Nothing+ Nothing -> return $ AnthropicCredentials Nothing Nothing Nothing Just value -> withObject "ClaudeAiOauth"@@ -163,9 +190,66 @@ AnthropicCredentials <$> o .:? "subscriptionType" <*> o .:? "rateLimitTier"+ <*> o .:? "accessToken" ) value +-- | Window utilization as reported by the OAuth usage endpoint.+data AnthropicOAuthWindow = AnthropicOAuthWindow+ { anthropicOAuthWindowUtilization :: Maybe Double,+ anthropicOAuthWindowResetsAt :: Maybe UTCTime+ }+ deriving (Eq, Show)++instance FromJSON AnthropicOAuthWindow where+ parseJSON = withObject "AnthropicOAuthWindow" $ \o ->+ AnthropicOAuthWindow+ <$> o .:? "utilization"+ <*> o .:? "resets_at"++data AnthropicOAuthUsage = AnthropicOAuthUsage+ { anthropicOAuthFiveHour :: Maybe AnthropicOAuthWindow,+ anthropicOAuthSevenDay :: Maybe AnthropicOAuthWindow+ }+ deriving (Eq, Show)++instance FromJSON AnthropicOAuthUsage where+ parseJSON = withObject "AnthropicOAuthUsage" $ \o ->+ AnthropicOAuthUsage+ <$> o .:? "five_hour"+ <*> o .:? "seven_day"++-- | Persistent state for OAuth endpoint polling, carried across poll+-- iterations so we can space out and back off endpoint requests independently+-- of the (cheap, local) transcript reads.+data OAuthFetchState = OAuthFetchState+ { -- | Earliest time we are allowed to hit the endpoint again. 'Nothing'+ -- means "fetch on next poll".+ oauthNextAllowedFetch :: Maybe UTCTime,+ -- | Consecutive failures, used to grow the exponential backoff.+ oauthConsecutiveFailures :: Int,+ -- | Last successful response, shown while we are within a backoff/spacing+ -- window so the widget keeps real utilization instead of dropping to the+ -- transcript-derived fallback.+ oauthLastGood :: Maybe AnthropicOAuthUsage,+ -- | Access token used on the last attempt. A changed token (e.g. after+ -- Claude Code refreshes its credentials) bypasses the backoff so a+ -- recovered token is picked up immediately rather than after a long wait.+ oauthLastTriedToken :: Maybe T.Text+ }++emptyOAuthFetchState :: OAuthFetchState+emptyOAuthFetchState = OAuthFetchState Nothing 0 Nothing Nothing++-- | Outcome of a single HTTP attempt against the OAuth usage endpoint.+data OAuthFetchResult+ = -- | 2xx with a decodable body.+ OAuthFetchSuccess AnthropicOAuthUsage+ | -- | HTTP 429, with the parsed @Retry-After@ delay when present.+ OAuthFetchRateLimited (Maybe NominalDiffTime)+ | -- | Any other non-success (auth error, 5xx, decode failure, network error).+ OAuthFetchError+ data AnthropicState = AnthropicState { anthropicStateHasAvailableSubscription :: Maybe Bool, anthropicStateExtraUsageDisabledReason :: Maybe T.Text,@@ -235,25 +319,36 @@ anthropicUsageEstimatedCostUSD = Nothing } +-- | One-shot snapshot with no persistent backoff state. Convenience for+-- callers and tests; the poll loop uses 'getAnthropicUsageInfoWith' so backoff+-- and last-good caching survive across iterations. getAnthropicUsageInfo :: AnthropicUsageConfig -> IO AnthropicUsageInfo-getAnthropicUsageInfo config = do+getAnthropicUsageInfo config =+ newIORef emptyOAuthFetchState >>= getAnthropicUsageInfoWith config++getAnthropicUsageInfoWith :: AnthropicUsageConfig -> IORef OAuthFetchState -> IO AnthropicUsageInfo+getAnthropicUsageInfoWith config oauthStateRef = do now <- getCurrentTime- metadata <- readAnthropicUsageMetadata config+ credentials <- decodeFileIfExists =<< maybe defaultClaudeCredentialsPath return (anthropicUsageCredentialsPath config)+ metadata <- readAnthropicUsageMetadata config credentials+ oauthUsage <- fetchAnthropicOAuthUsageWithBackoff config oauthStateRef now (credentials >>= anthropicCredentialsAccessToken) entries <- readAnthropicTranscriptEntries config now let fiveHourWindow =- buildActiveBlockWindow- now- "5h"- (5 * 60 * 60)- (anthropicUsageFiveHourBudgetTokens config)- entries+ applyOAuthWindow (oauthUsage >>= anthropicOAuthFiveHour) $+ buildActiveBlockWindow+ now+ "5h"+ (5 * 60 * 60)+ (anthropicUsageFiveHourBudgetTokens config)+ entries weeklyWindow =- buildRollingWindow- now- "7d"- (7 * 24 * 60 * 60)- (anthropicUsageWeeklyBudgetTokens config)- entries+ applyOAuthWindow (oauthUsage >>= anthropicOAuthSevenDay) $+ buildRollingWindow+ now+ "7d"+ (7 * 24 * 60 * 60)+ (anthropicUsageWeeklyBudgetTokens config)+ entries return $ AnthropicUsageInfo { anthropicUsageGeneratedAt = now,@@ -267,8 +362,12 @@ } updateAnthropicUsage :: AnthropicUsageConfig -> IO AnthropicUsageSnapshot-updateAnthropicUsage config = do- result <- try $ getAnthropicUsageInfo config+updateAnthropicUsage config =+ newIORef emptyOAuthFetchState >>= updateAnthropicUsageWith config++updateAnthropicUsageWith :: AnthropicUsageConfig -> IORef OAuthFetchState -> IO AnthropicUsageSnapshot+updateAnthropicUsageWith config oauthStateRef = do+ result <- try $ getAnthropicUsageInfoWith config oauthStateRef case result of Right info -> return $ AnthropicUsageAvailable info Left (err :: SomeException) -> do@@ -276,9 +375,8 @@ logM logName WARNING $ "Anthropic usage update failed: " <> show err return $ AnthropicUsageUnavailable message -readAnthropicUsageMetadata :: AnthropicUsageConfig -> IO AnthropicUsageMetadata-readAnthropicUsageMetadata config = do- credentials <- decodeFileIfExists =<< maybe defaultClaudeCredentialsPath return (anthropicUsageCredentialsPath config)+readAnthropicUsageMetadata :: AnthropicUsageConfig -> Maybe AnthropicCredentials -> IO AnthropicUsageMetadata+readAnthropicUsageMetadata config credentials = do state <- decodeFileIfExists =<< maybe defaultClaudeStatePath return (anthropicUsageStatePath config) return $ AnthropicUsageMetadata@@ -289,6 +387,130 @@ anthropicMetadataOrganizationName = state >>= anthropicStateOrganizationName } +-- | Fetch utilization from the OAuth usage endpoint, honoring a persistent+-- backoff carried in the 'IORef'. Returns the value to display: a fresh+-- response on success, or the last good response while spacing out / backing+-- off, or 'Nothing' when nothing is cached (the widget then falls back to+-- transcript-derived token counts).+--+-- The endpoint is rate-limited, so we (a) never hit it more often than+-- 'anthropicUsageOAuthMinInterval' after a success, (b) apply exponential+-- backoff (honoring a server @Retry-After@) after failures, and (c) bypass the+-- backoff when the access token changes, so a refreshed credential recovers+-- immediately instead of after the full backoff.+fetchAnthropicOAuthUsageWithBackoff ::+ AnthropicUsageConfig ->+ IORef OAuthFetchState ->+ UTCTime ->+ Maybe T.Text ->+ IO (Maybe AnthropicOAuthUsage)+fetchAnthropicOAuthUsageWithBackoff _ _ _ Nothing = return Nothing+fetchAnthropicOAuthUsageWithBackoff config oauthStateRef now (Just token) = do+ st <- readIORef oauthStateRef+ let tokenChanged = oauthLastTriedToken st /= Just token+ withinBackoff = maybe False (now <) (oauthNextAllowedFetch st)+ -- A changed token restarts the failure schedule from scratch.+ priorFailures = if tokenChanged then 0 else oauthConsecutiveFailures st+ if withinBackoff && not tokenChanged+ then return (oauthLastGood st)+ else do+ outcome <- performOAuthFetch config token+ case outcome of+ OAuthFetchSuccess usage -> do+ writeIORef oauthStateRef $+ st+ { oauthConsecutiveFailures = 0,+ oauthLastGood = Just usage,+ oauthLastTriedToken = Just token,+ oauthNextAllowedFetch =+ Just (addUTCTime (anthropicUsageOAuthMinInterval config) now)+ }+ return (Just usage)+ OAuthFetchRateLimited retryAfter ->+ backOff st (priorFailures + 1) retryAfter+ OAuthFetchError ->+ backOff st (priorFailures + 1) Nothing+ where+ backOff st failures retryAfter = do+ let delay = oauthBackoffDelay config failures retryAfter+ writeIORef oauthStateRef $+ st+ { oauthConsecutiveFailures = failures,+ oauthLastTriedToken = Just token,+ oauthNextAllowedFetch = Just (addUTCTime delay now)+ }+ return (oauthLastGood st)++-- | A single HTTP attempt against the OAuth usage endpoint, classified into an+-- 'OAuthFetchResult'. Network and decode errors are logged and reported as+-- 'OAuthFetchError'.+performOAuthFetch :: AnthropicUsageConfig -> T.Text -> IO OAuthFetchResult+performOAuthFetch config token = do+ result <- try $ do+ request0 <- parseRequest $ anthropicUsageEndpoint config+ let request =+ setRequestHeader "Authorization" ["Bearer " <> TE.encodeUtf8 token] $+ setRequestHeader "anthropic-beta" ["oauth-2025-04-20"] $+ setRequestHeader "Accept" ["application/json"] $+ setRequestHeader "User-Agent" [TE.encodeUtf8 (T.pack (anthropicUsageUserAgent config))] request0+ response <- httpLBS request+ return+ ( getResponseStatusCode response,+ getResponseHeader "Retry-After" response,+ getResponseBody response+ )+ case result of+ Left (err :: SomeException) -> do+ logM logName WARNING $ "Anthropic OAuth usage fetch failed: " <> show err+ return OAuthFetchError+ Right (statusCode, retryAfterHeaders, body)+ | statusCode >= 200 && statusCode < 300 ->+ case eitherDecode body of+ Right usage -> return (OAuthFetchSuccess usage)+ Left err -> do+ logM logName WARNING $ "Anthropic OAuth usage decode failed: " <> err+ return OAuthFetchError+ | statusCode == 429 -> do+ let retryAfter = parseRetryAfter retryAfterHeaders+ logM logName WARNING $+ "Anthropic usage endpoint returned HTTP 429"+ <> maybe+ ""+ (\s -> "; Retry-After " <> show (round s :: Integer) <> "s")+ retryAfter+ return (OAuthFetchRateLimited retryAfter)+ | otherwise -> do+ logM logName WARNING $ "Anthropic usage endpoint returned HTTP " <> show statusCode+ return OAuthFetchError++-- | Exponential backoff that doubles from the configured min interval and is+-- capped at the configured max, but is never shorter than a server-supplied+-- @Retry-After@.+oauthBackoffDelay :: AnthropicUsageConfig -> Int -> Maybe NominalDiffTime -> NominalDiffTime+oauthBackoffDelay config failures retryAfter =+ max (fromMaybe 0 retryAfter) capped+ where+ base = anthropicUsageOAuthMinInterval config+ shift = min (max 0 (failures - 1)) 6+ capped = min (anthropicUsageOAuthMaxBackoff config) (base * fromInteger (2 ^ shift))++-- | Parse a @Retry-After@ header expressed as integer delta-seconds. The+-- HTTP-date form is not handled and falls back to exponential backoff.+parseRetryAfter :: [BS8.ByteString] -> Maybe NominalDiffTime+parseRetryAfter headers = do+ raw <- listToMaybe headers+ seconds <- readMaybe (BS8.unpack raw) :: Maybe Integer+ if seconds >= 0 then Just (fromInteger seconds) else Nothing++applyOAuthWindow :: Maybe AnthropicOAuthWindow -> AnthropicUsageWindow -> AnthropicUsageWindow+applyOAuthWindow Nothing window = window+applyOAuthWindow (Just oauthWindow) window =+ window+ { anthropicUsageWindowUtilizationPercent = anthropicOAuthWindowUtilization oauthWindow,+ anthropicUsageWindowEnd =+ fromMaybe (anthropicUsageWindowEnd window) (anthropicOAuthWindowResetsAt oauthWindow)+ }+ decodeFileIfExists :: (FromJSON a) => FilePath -> IO (Maybe a) decodeFileIfExists path = do exists <- doesFileExist path@@ -402,6 +624,7 @@ anthropicUsageWindowStart = now, anthropicUsageWindowEnd = addUTCTime duration now, anthropicUsageWindowBudgetTokens = budget,+ anthropicUsageWindowUtilizationPercent = Nothing, anthropicUsageWindowTotals = mempty } Just (start, blockEntries) ->@@ -410,6 +633,7 @@ anthropicUsageWindowStart = start, anthropicUsageWindowEnd = addUTCTime duration start, anthropicUsageWindowBudgetTokens = budget,+ anthropicUsageWindowUtilizationPercent = Nothing, anthropicUsageWindowTotals = foldMap transcriptUsageTotals blockEntries } @@ -446,6 +670,7 @@ anthropicUsageWindowStart = windowStart, anthropicUsageWindowEnd = windowEnd, anthropicUsageWindowBudgetTokens = budget,+ anthropicUsageWindowUtilizationPercent = Nothing, anthropicUsageWindowTotals = foldMap transcriptUsageTotals windowEntries } @@ -479,7 +704,10 @@ setupAnthropicUsageChanVar config = getStateDefault $ do chan <- liftIO newBroadcastTChanIO refreshChan <- liftIO newTChanIO- initial <- liftIO $ updateAnthropicUsage config+ -- Persistent OAuth backoff/last-good state, shared by the initial fetch and+ -- every poll iteration so spacing and backoff survive across wakeups.+ oauthStateRef <- liftIO $ newIORef emptyOAuthFetchState+ initial <- liftIO $ updateAnthropicUsageWith config oauthStateRef var <- liftIO $ newMVar initial wakeupChan <- getWakeupChannelForDelay (anthropicUsagePollInterval config) ourWakeupChan <- liftIO $ atomically $ dupTChan wakeupChan@@ -490,16 +718,17 @@ atomically $ void (readTChan refreshChan) `orElse` void (readTChan ourWakeupChan)- refreshAnthropicUsageState config chan var+ refreshAnthropicUsageState config oauthStateRef chan var return $ AnthropicUsageChanVar (chan, var, refreshChan) refreshAnthropicUsageState :: AnthropicUsageConfig ->+ IORef OAuthFetchState -> TChan AnthropicUsageSnapshot -> MVar AnthropicUsageSnapshot -> IO ()-refreshAnthropicUsageState config chan var = do- snapshot <- updateAnthropicUsage config+refreshAnthropicUsageState config oauthStateRef chan var = do+ snapshot <- updateAnthropicUsageWith config oauthStateRef void $ swapMVar var snapshot atomically $ writeTChan chan snapshot
− src/System/Taffybar/Information/Chrome.hs
@@ -1,137 +0,0 @@-{-# LANGUAGE OverloadedStrings #-}---- | Track Chrome tab favicon updates and map them to X11 windows.-module System.Taffybar.Information.Chrome where--import Control.Concurrent-import Control.Concurrent.STM.TChan-import Control.Monad-import Control.Monad.IO.Class-import Control.Monad.STM (atomically)-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-import qualified GI.GdkPixbuf as Gdk-import System.Log.Logger-import System.Taffybar.Context-import System.Taffybar.Information.EWMHDesktopInfo-import System.Taffybar.Information.SafeX11-import Text.Read hiding (lift)-import Text.Regex-import Web.Scotty---- | Module logger.-logIO :: System.Log.Logger.Priority -> String -> IO ()-logIO = logM "System.Taffybar.Information.Chrome"---- | Favicon image data associated with a Chrome tab id.-data ChromeTabImageData = ChromeTabImageData- { tabImageData :: Gdk.Pixbuf,- tabImageDataId :: Int- }---- | Shared favicon table and broadcast update channel.-newtype ChromeTabImageDataState- = ChromeTabImageDataState- (MVar (M.Map Int ChromeTabImageData), TChan ChromeTabImageData)---- | Get or initialize Chrome favicon state.-getChromeTabImageDataState :: TaffyIO ChromeTabImageDataState-getChromeTabImageDataState = do- ChromeFaviconServerPort port <- fromMaybe (ChromeFaviconServerPort 5000) <$> getState- getStateDefault (listenForChromeFaviconUpdates port)---- | Get the broadcast channel for favicon updates.-getChromeTabImageDataChannel :: TaffyIO (TChan ChromeTabImageData)-getChromeTabImageDataChannel = do- ChromeTabImageDataState (_, chan) <- getChromeTabImageDataState- return chan---- | Get the mutable favicon table keyed by tab id.-getChromeTabImageDataTable :: TaffyIO (MVar (M.Map Int ChromeTabImageData))-getChromeTabImageDataTable = do- ChromeTabImageDataState (table, _) <- getChromeTabImageDataState- return table---- | TCP port used by the local Chrome favicon update server.-newtype ChromeFaviconServerPort = ChromeFaviconServerPort Int---- | Start an HTTP listener that receives favicon updates from browser helpers.-listenForChromeFaviconUpdates :: Int -> TaffyIO ChromeTabImageDataState-listenForChromeFaviconUpdates port = do- infoVar <- lift $ newMVar M.empty- inChan <- liftIO newBroadcastTChanIO- outChan <- liftIO . atomically $ dupTChan inChan- _ <- lift $- forkIO $- scotty port $- post "/setTabImageData/:tabID" $ do- tabID <- queryParam "tabID"- imageData <- LBS.toStrict <$> body- when (BS.length imageData > 0) $ lift $ do- loader <- Gdk.pixbufLoaderNew- Gdk.pixbufLoaderWriteBytes loader =<< Gdk.bytesNew (Just imageData)- Gdk.pixbufLoaderClose loader- let updateChannelAndMVar pixbuf =- let chromeTabImageData =- ChromeTabImageData- { tabImageData = pixbuf,- tabImageDataId = tabID- }- in modifyMVar_ infoVar $ \currentMap ->- do- _ <- atomically $ writeTChan inChan chromeTabImageData- return $ M.insert tabID chromeTabImageData currentMap- Gdk.pixbufLoaderGetPixbuf loader >>= maybe (return ()) updateChannelAndMVar- return $ ChromeTabImageDataState (infoVar, outChan)---- | Mapping from X11 window ids to parsed Chrome tab ids.-newtype X11WindowToChromeTabId = X11WindowToChromeTabId (MVar (M.Map X11Window Int))---- | Get or initialize the X11-window to tab-id mapping.-getX11WindowToChromeTabId :: TaffyIO X11WindowToChromeTabId-getX11WindowToChromeTabId =- getStateDefault $ X11WindowToChromeTabId <$> maintainX11WindowToChromeTabId---- | Maintain and update the X11-window to tab-id mapping from title changes.-maintainX11WindowToChromeTabId :: TaffyIO (MVar (M.Map X11Window Int))-maintainX11WindowToChromeTabId = do- startTabMap <- updateTabMap M.empty- tabMapVar <- lift $ newMVar startTabMap- let handleEvent PropertyEvent {ev_window = window} =- do- title <- runX11Def "" $ getWindowTitle window- lift $ modifyMVar_ tabMapVar $ \currentMap -> do- let newMap = addTabIdEntry currentMap (window, title)- logIO DEBUG (show newMap)- return newMap- handleEvent _ = return ()- _ <- subscribeToPropertyEvents [ewmhWMName] handleEvent- return tabMapVar---- | Regex for tab-id markers embedded in window titles.-tabIDRegex :: Regex-tabIDRegex = mkRegexWithOpts "[|]%([0-9]*)%[|]" True True---- | Extract a tab id from a window title, if present.-getTabIdFromTitle :: String -> Maybe Int-getTabIdFromTitle title =- matchRegex tabIDRegex title >>= listToMaybe >>= readMaybe---- | Insert or update a window->tab mapping based on a title string.-addTabIdEntry :: M.Map X11Window Int -> (X11Window, String) -> M.Map X11Window Int-addTabIdEntry theMap (win, title) =- maybe theMap ((flip $ M.insert win) theMap) $ getTabIdFromTitle title---- | Rebuild the window->tab map by scanning all current X11 windows.-updateTabMap :: M.Map X11Window Int -> TaffyIO (M.Map X11Window Int)-updateTabMap tabMap =- runX11Def tabMap $ do- wins <- getWindows- titles <- mapM getWindowTitle wins- let winsWithTitles = zip wins titles- return $ List.foldl' addTabIdEntry tabMap winsWithTitles
src/System/Taffybar/Information/Workspaces/Support.hs view
@@ -23,7 +23,6 @@ getWindowIconPixbufFromDesktopEntry, getWindowIconPixbufFromClass, getWindowIconPixbufByClassHints,- getWindowIconPixbufFromChrome, getWindowIconPixbufFromEWMH, defaultGetWindowIconPixbuf, unscaledDefaultGetWindowIconPixbuf,@@ -63,7 +62,6 @@ ( getCachedIconPixBufFromEWMH, getCachedWindowIconFromClasses, getCachedWindowIconFromDesktopEntryByClasses,- getPixBufFromChromeData, ) type WindowIconPixbufGetter = Int32 -> WindowInfo -> TaffyIO (Maybe Gdk.Pixbuf)@@ -124,12 +122,6 @@ getWindowIconPixbufByClassHints :: WindowIconPixbufGetter getWindowIconPixbufByClassHints = getWindowIconPixbufFromClassHints--getWindowIconPixbufFromChrome :: WindowIconPixbufGetter-getWindowIconPixbufFromChrome _ windowData =- case windowIdentity windowData of- X11WindowIdentity wid -> getPixBufFromChromeData (fromIntegral wid)- HyprlandWindowIdentity _ -> pure Nothing getWindowIconPixbufFromEWMH :: WindowIconPixbufGetter getWindowIconPixbufFromEWMH = handleIconGetterException $ \size windowData ->
src/System/Taffybar/SimpleConfig.hs view
@@ -27,6 +27,8 @@ toTaffybarConfig, useAllMonitors, usePrimaryMonitor,+ withPriority,+ setWidgetPriority, StrutSize, pattern ExactSize, pattern ScreenRatio,@@ -48,6 +50,7 @@ import System.Taffybar.Context hiding (BarConfig (..), TaffybarConfig (..)) import qualified System.Taffybar.Context as BC (BarConfig (..), TaffybarConfig (..)) import System.Taffybar.Util+import System.Taffybar.WidgetPriority (setWidgetPriority, withPriority) -- | Size of a bar strut reservation. This is an alias for -- 'Graphics.UI.GIGtkStrut.StrutSize'.@@ -206,13 +209,16 @@ simpleTaffybar conf = startTaffybar $ toTaffybarConfig conf getMonitorCount :: IO Int-getMonitorCount =+getMonitorCount = do+ maybeDisplay <- displayGetDefault fromIntegral- <$> ( screenGetDefault- >>= maybe- (return 0)- (screenGetDisplay >=> displayGetNMonitors)- )+ <$> case maybeDisplay of+ Just display -> displayGetNMonitors display+ Nothing ->+ screenGetDefault+ >>= maybe+ (return 0)+ (screenGetDisplay >=> displayGetNMonitors) -- | Supply this value for 'monitorsAction' to display the taffybar window on -- all monitors.
src/System/Taffybar/Widget/AnthropicUsage.hs view
@@ -495,9 +495,16 @@ formatWindowValue :: AnthropicUsageDisplayMode -> AnthropicUsageWindow -> T.Text formatWindowValue displayMode window =- case anthropicUsageWindowBudgetTokens window of- Nothing -> formatCount $ displayTokens displayMode window- Just budget -> T.pack $ printf "%d%%" $ displayPercent displayMode budget window+ case anthropicUsageWindowUtilizationPercent window of+ Just utilization -> T.pack $ printf "%d%%" $ utilizationPercent displayMode utilization+ Nothing ->+ case anthropicUsageWindowBudgetTokens window of+ Nothing -> formatCount $ displayTokens displayMode window+ Just budget -> T.pack $ printf "%d%%" $ displayPercent displayMode budget window++utilizationPercent :: AnthropicUsageDisplayMode -> Double -> Int+utilizationPercent AnthropicUsageDisplayUsed utilization = round utilization+utilizationPercent AnthropicUsageDisplayRemaining utilization = max 0 (100 - round utilization) formatWindowValueWithIndicator :: AnthropicUsageDisplayMode -> AnthropicUsageWindow -> T.Text formatWindowValueWithIndicator displayMode window =
src/System/Taffybar/Widget/SNITray/PrioritizedCollapsible.hs view
@@ -678,7 +678,36 @@ IO () -> IO () -> IO ()-showPriorityControlsMenu+showPriorityControlsMenu anchor priorityMin priorityMax alwaysShowExpandControl priorityModeLabel expandedRef priorityEditModeRef hiddenCountRef maxVisibleRef thresholdRef =+ showPriorityControlsMenuWithExplicitCollapse+ anchor+ priorityMin+ priorityMax+ alwaysShowExpandControl+ priorityModeLabel+ expandedRef+ priorityEditModeRef+ hiddenCountRef+ maxVisibleRef+ thresholdRef+ (return ())++showPriorityControlsMenuWithExplicitCollapse ::+ Gtk.EventBox ->+ Int ->+ Int ->+ Bool ->+ (Bool -> T.Text) ->+ IORef Bool ->+ IORef Bool ->+ IORef Int ->+ IORef Int ->+ IORef (Maybe Int) ->+ IO () ->+ IO () ->+ IO () ->+ IO ()+showPriorityControlsMenuWithExplicitCollapse anchor priorityMin priorityMax@@ -689,6 +718,7 @@ hiddenCountRef maxVisibleRef thresholdRef+ onExplicitCollapse onControlStateChanged onSettingsChanged = do currentEvent <- Gtk.getCurrentEvent@@ -710,7 +740,9 @@ else "Show all tray icons" expandItem <- Gtk.menuItemNewWithLabel expandLabel void $ Gtk.onMenuItemActivate expandItem $ do- modifyIORef' expandedRef not+ let newExpanded = not currentExpanded+ writeIORef expandedRef newExpanded+ unless newExpanded onExplicitCollapse onControlStateChanged Gtk.menuShellAppend menu expandItem @@ -1127,6 +1159,12 @@ (setHoverExpanded shouldExpand) return False + cancelHoverExpansion = do+ modifyIORef' hoverSerialRef (+ 1)+ writeIORef hoverExpandedRef False+ modifyIORef' animationSerialRef (+ 1)+ writeIORef animationActiveRef False+ refreshTray tray = do effectiveExpanded <- getEffectiveExpanded animationActive <- readIORef animationActiveRef@@ -1269,7 +1307,7 @@ button <- Gdk.getEventButtonButton event if eventType == Gdk.EventTypeButtonPress && button == 1 then do- showPriorityControlsMenu+ showPriorityControlsMenuWithExplicitCollapse settingsToggle priorityMin priorityMax@@ -1280,6 +1318,7 @@ hiddenCountRef maxVisibleIconsRef visibilityThresholdRef+ cancelHoverExpansion (refreshPriorityModeToggle >> void refresh) (persistCurrentState >> scheduleRefresh False False H.ToolTipUpdated) return True
src/System/Taffybar/Widget/Workspaces.hs view
@@ -33,7 +33,6 @@ getWindowIconPixbufFromDesktopEntry, getWindowIconPixbufFromClass, getWindowIconPixbufByClassHints,- getWindowIconPixbufFromChrome, getWindowIconPixbufFromEWMH, defaultGetWindowIconPixbuf, unscaledDefaultGetWindowIconPixbuf,@@ -88,7 +87,6 @@ defaultOnWorkspaceClick, defaultOnWorkspaceClickEWMH, getWindowIconPixbufByClassHints,- getWindowIconPixbufFromChrome, getWindowIconPixbufFromClass, getWindowIconPixbufFromClassHints, getWindowIconPixbufFromDesktopEntry,
+ src/System/Taffybar/WidgetPriority.hs view
@@ -0,0 +1,269 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TupleSections #-}++-----------------------------------------------------------------------------++-----------------------------------------------------------------------------++-- |+-- Module : System.Taffybar.WidgetPriority+-- Copyright : (c) Ivan A. Malison+-- License : BSD3-style (see LICENSE)+--+-- Maintainer : Ivan A. Malison+-- Stability : unstable+-- Portability : unportable+--+-- Priority-based dynamic hiding of bar widgets when the bar runs out of+-- horizontal space.+--+-- Wrap any widget constructor with 'withPriority' to make it hideable:+--+-- > endWidgets = [clock, withPriority 10 battery, withPriority 3 weather]+--+-- Widgets without a priority are never hidden. When the natural widths of+-- all widgets exceed the width allocated to the bar, prioritized widgets+-- are hidden lowest-priority-first until everything fits. Hidden widgets+-- are shown again when enough space (plus a small hysteresis margin)+-- becomes available. The mechanism is entirely opt-in: bars that contain+-- no prioritized widgets get no visibility controller at all.+module System.Taffybar.WidgetPriority+ ( -- * Assigning priorities+ withPriority,+ setWidgetPriority,+ getWidgetPriority,++ -- * Hiding configuration+ DynamicHidingConfig (..),+ defaultDynamicHidingConfig,++ -- * Bar wiring (used by "System.Taffybar.Context")+ setupDynamicHiding,+ )+where++import Control.Monad (filterM, forM, forM_, unless, void, when)+import Control.Monad.IO.Class (MonadIO)+import Data.Default (Default (..))+import Data.IORef+import Data.Int (Int32)+import Data.List (sortOn)+import Data.Maybe (isJust)+import Data.Ord (Down (..))+import qualified Data.Text as T+import Foreign.Ptr (Ptr, intPtrToPtr, ptrToIntPtr)+import qualified GI.GLib as GLib+import qualified GI.GObject as GObject+import qualified GI.Gtk as Gtk+import System.Log.Logger (Priority (DEBUG), logM)+import Text.Printf (printf)++priorityLog :: Priority -> String -> IO ()+priorityLog = logM "System.Taffybar.WidgetPriority"++-- | GObject data key under which a widget's priority is stored.+priorityDataKey :: T.Text+priorityDataKey = "taffy-widget-priority"++-- | GObject data key marking widgets that were hidden by the visibility+-- controller (as opposed to widgets that hid themselves).+hiddenByControllerKey :: T.Text+hiddenByControllerKey = "taffy-priority-hidden"++-- Priorities are smuggled through g_object_set_data's @Ptr ()@ payload.+-- 0 (the null pointer) means "no priority set", so non-negative priorities+-- are stored shifted up by one.+encodePriority :: Int -> Ptr ()+encodePriority p = intPtrToPtr $ fromIntegral $ if p >= 0 then p + 1 else p++decodePriority :: Ptr () -> Maybe Int+decodePriority ptr =+ case fromIntegral (ptrToIntPtr ptr) :: Int of+ 0 -> Nothing+ v+ | v > 0 -> Just (v - 1)+ | otherwise -> Just v++-- | Annotate an already-built widget with a hiding priority. The annotation+-- mechanism works on any 'GObject.Object', though the bar only consults it on+-- top-level section widgets.+setWidgetPriority :: (MonadIO m, GObject.IsObject o) => Int -> o -> m ()+setWidgetPriority p widget = do+ object <- GObject.toObject widget+ GObject.objectSetData object priorityDataKey (encodePriority p)++-- | Read back a priority set with 'setWidgetPriority' or 'withPriority'.+getWidgetPriority :: (MonadIO m, GObject.IsObject o) => o -> m (Maybe Int)+getWidgetPriority widget = do+ object <- GObject.toObject widget+ decodePriority <$> GObject.objectGetData object priorityDataKey++-- | Give a hiding priority to the widget produced by the given constructor.+-- Lower priorities are hidden first when the bar runs out of space; widgets+-- built without 'withPriority' are never hidden. This combinator does not+-- change the constructor's type, so prioritized and raw widgets mix freely+-- in the same widget list. Apply it as the outermost wrapper, after any+-- combinators that rebuild the widget inside a new container.+withPriority :: (MonadIO m) => Int -> m Gtk.Widget -> m Gtk.Widget+withPriority p buildWidget = do+ widget <- buildWidget+ setWidgetPriority p widget+ return widget++setHiddenByController :: (MonadIO m, GObject.IsObject o) => Bool -> o -> m ()+setHiddenByController flag widget = do+ object <- GObject.toObject widget+ GObject.objectSetData object hiddenByControllerKey $+ intPtrToPtr (if flag then 1 else 0)++getHiddenByController :: (MonadIO m, GObject.IsObject o) => o -> m Bool+getHiddenByController widget = do+ object <- GObject.toObject widget+ (/= 0) . ptrToIntPtr <$> GObject.objectGetData object hiddenByControllerKey++-- | Configuration for the dynamic hiding controller.+data DynamicHidingConfig = DynamicHidingConfig+ { -- | Extra pixels that must be available before a hidden widget is shown+ -- again. This hysteresis margin prevents widgets from flapping between+ -- hidden and shown when the bar is right at the edge of fitting.+ reshowSlackPx :: Int32,+ -- | CSS class added to widgets while they are hidden by the controller.+ hiddenCssClass :: T.Text,+ -- | How often (in milliseconds) to re-evaluate visibility even without a+ -- size-allocation event. Hidden widgets do not trigger relayout when+ -- their natural size changes, so without this they could stay hidden+ -- after shrinking enough to fit. 'Nothing' disables the periodic check.+ recheckIntervalMs :: Maybe Word+ }++-- | 'DynamicHidingConfig' with a 20px reshow margin and a 1s periodic check.+defaultDynamicHidingConfig :: DynamicHidingConfig+defaultDynamicHidingConfig =+ DynamicHidingConfig+ { reshowSlackPx = 20,+ hiddenCssClass = "priority-hidden",+ recheckIntervalMs = Just 1000+ }++instance Default DynamicHidingConfig where+ def = defaultDynamicHidingConfig++-- | Install a visibility controller on a bar box. The widget list should+-- contain the box's top-level section widgets in visual order. Does nothing+-- when no widget in the list carries a priority, so it is safe to call+-- unconditionally.+setupDynamicHiding ::+ DynamicHidingConfig -> Int32 -> Gtk.Box -> [Gtk.Widget] -> IO ()+setupDynamicHiding config spacing box widgets = do+ anyPrioritized <- not . null <$> filterM (fmap isJust . getWidgetPriority) widgets+ when anyPrioritized $ do+ priorityLog DEBUG $+ printf "Enabling dynamic widget hiding for a bar with %d widgets" (length widgets)+ destroyedRef <- newIORef False+ recheckPendingRef <- newIORef False++ let recompute = do+ destroyed <- readIORef destroyedRef+ unless destroyed $ applyVisibilityPass config spacing box widgets++ scheduleRecompute = do+ pending <- atomicModifyIORef' recheckPendingRef (True,)+ unless pending $+ void $+ GLib.idleAdd GLib.PRIORITY_DEFAULT_IDLE $ do+ writeIORef recheckPendingRef False+ recompute+ return False++ void $ Gtk.onWidgetSizeAllocate box $ const scheduleRecompute+ scheduleRecompute++ timeoutId <- forM (recheckIntervalMs config) $ \intervalMs ->+ GLib.timeoutAdd GLib.PRIORITY_DEFAULT_IDLE (fromIntegral intervalMs) $ do+ recompute+ return True++ void $ Gtk.onWidgetDestroy box $ do+ writeIORef destroyedRef True+ forM_ timeoutId GLib.sourceRemove++data WidgetInfo = WidgetInfo+ { wiWidget :: Gtk.Widget,+ wiPriority :: Maybe Int,+ wiVisible :: Bool,+ wiHiddenByUs :: Bool,+ wiNaturalWidth :: Int32+ }++-- | A widget is under the controller's authority when it has a priority and+-- is either visible or was hidden by the controller itself. Prioritized+-- widgets that hid themselves are left alone until they reappear.+wiManaged :: WidgetInfo -> Bool+wiManaged info =+ isJust (wiPriority info) && (wiVisible info || wiHiddenByUs info)++applyVisibilityPass ::+ DynamicHidingConfig -> Int32 -> Gtk.Box -> [Gtk.Widget] -> IO ()+applyVisibilityPass config spacing box widgets = do+ available <- Gtk.widgetGetAllocatedWidth box+ when (available > 1) $ do+ infos <- forM widgets $ \widget -> do+ priority <- getWidgetPriority widget+ visible <- Gtk.widgetGetVisible widget+ hiddenByUs <- getHiddenByController widget+ natural <- snd <$> Gtk.widgetGetPreferredWidth widget+ return+ WidgetInfo+ { wiWidget = widget,+ wiPriority = priority,+ wiVisible = visible,+ wiHiddenByUs = hiddenByUs,+ wiNaturalWidth = natural+ }++ let (managed, unmanaged) = (filter wiManaged infos, filter (not . wiManaged) infos)+ unmanagedVisible = filter wiVisible unmanaged+ -- Every visible widget is charged one unit of box spacing. This+ -- slightly overestimates the gaps GTK actually inserts, which only+ -- errs toward hiding a touch early.+ widthWithGap info = wiNaturalWidth info + spacing+ baseline = sum (map widthWithGap unmanagedVisible)++ -- Strict priority order: walk from highest priority down and cut+ -- off at the first widget that does not fit. sortOn is stable, so+ -- widgets with equal priority keep their visual order.+ ordered = sortOn (Down . wiPriority) managed++ decide _ [] = []+ decide used (info : rest)+ | required <= available =+ (info, True) : decide (used + widthWithGap info) rest+ | otherwise = map (,False) (info : rest)+ where+ slack = if wiVisible info then 0 else reshowSlackPx config+ required = used + widthWithGap info + slack++ decisions = decide baseline ordered++ forM_ decisions $ \(info, shouldShow) ->+ when (wiVisible info /= shouldShow) $ do+ let widget = wiWidget info+ styleContext <- Gtk.widgetGetStyleContext widget+ if shouldShow+ then do+ priorityLog DEBUG $+ printf "Showing widget with priority %s" (show $ wiPriority info)+ setHiddenByController False widget+ Gtk.widgetSetNoShowAll widget False+ Gtk.styleContextRemoveClass styleContext (hiddenCssClass config)+ Gtk.widgetShow widget+ else do+ priorityLog DEBUG $+ printf "Hiding widget with priority %s" (show $ wiPriority info)+ setHiddenByController True widget+ -- Some widgets refresh themselves with widgetShowAll on a+ -- parent container; no-show-all keeps those refreshes from+ -- undoing the controller's decision.+ Gtk.widgetSetNoShowAll widget True+ Gtk.styleContextAddClass styleContext (hiddenCssClass config)+ Gtk.widgetHide widget
src/System/Taffybar/WindowIcon.hs view
@@ -5,7 +5,6 @@ -- desktop entries, icon themes, and browser tab image hooks. module System.Taffybar.WindowIcon where -import Control.Concurrent import qualified Control.Concurrent.MVar as MV import Control.Monad import Control.Monad.IO.Class@@ -33,7 +32,6 @@ import System.Log.Logger import System.Taffybar.Context import System.Taffybar.Hooks-import System.Taffybar.Information.Chrome import System.Taffybar.Information.EWMHDesktopInfo import System.Taffybar.Information.SafeX11 (Event (PropertyEvent)) import System.Taffybar.Information.X11DesktopInfo@@ -271,11 +269,3 @@ getCachedWindowIcon (ClassIconCacheKey size klass) (liftIO $ getWindowIconFromClasses size klass)---- | Resolve a window icon from cached Chrome tab image data.-getPixBufFromChromeData :: X11Window -> TaffyIO (Maybe Gdk.Pixbuf)-getPixBufFromChromeData window = do- imageData <- getChromeTabImageDataTable >>= lift . readMVar- X11WindowToChromeTabId x11LookupMapVar <- getX11WindowToChromeTabId- x11LookupMap <- lift $ readMVar x11LookupMapVar- return $ tabImageData <$> (M.lookup window x11LookupMap >>= flip M.lookup imageData)
taffybar.cabal view
@@ -1,6 +1,6 @@ cabal-version: 3.4 name: taffybar-version: 7.2.4+version: 7.2.5 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.@@ -96,7 +96,7 @@ , gi-gtk-hs >= 0.3.17 && < 0.4 , gi-pango >= 1.0 && < 1.1 , gtk-scaling-image >= 0.1.0.1 && < 0.2- , gtk-sni-tray >= 0.2.1.2 && < 0.3+ , gtk-sni-tray >= 0.2.1.3 && < 0.3 , gtk-strut >= 0.1.4.1 && < 0.2 , haskell-gi-base >= 0.24 && < 0.27 , hslogger >= 1.2 && < 1.4@@ -111,9 +111,8 @@ , 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 && < 0.3- , status-notifier-item >= 0.3.2.14 && < 0.4+ , status-notifier-item >= 0.3.2.15 && < 0.4 , stm >= 2.5 && < 2.6 , template-haskell >= 2.17 && < 2.24 , text >= 1.2 && < 2.2@@ -153,7 +152,6 @@ , System.Taffybar.Information.Battery , System.Taffybar.Information.Bluetooth , System.Taffybar.Information.CPU2- , System.Taffybar.Information.Chrome , System.Taffybar.Information.ChromeWindowInfo , System.Taffybar.Information.Crypto , System.Taffybar.Information.DiskIO@@ -188,6 +186,7 @@ , System.Taffybar.LogLevels , System.Taffybar.SimpleConfig , System.Taffybar.Util+ , System.Taffybar.WidgetPriority , System.Taffybar.Widget , System.Taffybar.Widget.Audio , System.Taffybar.Widget.PulseAudio@@ -403,6 +402,7 @@ , System.Taffybar.Information.X11DesktopInfoSpec , System.Taffybar.Information.WakeupSpec , System.Taffybar.SimpleConfigSpec+ , System.Taffybar.WidgetPrioritySpec , System.Taffybar.Widget.SNITray.PrioritizedCollapsibleSpec , System.Taffybar.Widget.Workspaces.ChannelSpec , System.Taffybar.Widget.WindowsSpec
+ test/unit/System/Taffybar/WidgetPrioritySpec.hs view
@@ -0,0 +1,33 @@+{-# LANGUAGE OverloadedStrings #-}++module System.Taffybar.WidgetPrioritySpec (spec) where++import GI.Gtk qualified as Gtk+import System.Taffybar.WidgetPriority+import Test.Hspec++-- GtkAdjustment is a plain GObject with no display dependency, so the+-- annotation round-trip can be tested without initializing GTK. The bar+-- applies the same mechanism to widgets.+newTestObject :: IO Gtk.Adjustment+newTestObject = Gtk.adjustmentNew 0 0 100 1 10 10++spec :: Spec+spec =+ describe "widget priority annotations" $ do+ it "round-trips priorities, including zero and negative values" $ do+ object <- newTestObject+ getWidgetPriority object `shouldReturn` Nothing+ setWidgetPriority 5 object+ getWidgetPriority object `shouldReturn` Just 5+ setWidgetPriority 0 object+ getWidgetPriority object `shouldReturn` Just 0+ setWidgetPriority (-3) object+ getWidgetPriority object `shouldReturn` Just (-3)++ it "keeps annotations on separate objects independent" $ do+ annotated <- newTestObject+ plain <- newTestObject+ setWidgetPriority 7 annotated+ getWidgetPriority annotated `shouldReturn` Just 7+ getWidgetPriority plain `shouldReturn` Nothing