taffybar 7.2.7 → 7.3.0

raw patch · 30 files changed

+744/−167 lines, 30 filesdep ~gtk-strutPVP ok

version bump matches the API change (PVP)

Dependency ranges changed: gtk-strut

API changes (from Hackage documentation)

Files

• CHANGELOG.md +43/−0
• app/AppearanceSnap.hs +3/−0
• app/AppearanceSnapHyprland.hs +2/−0
• src/System/Taffybar/Context.hs +4/−0
• src/System/Taffybar/Information/Backlight.hs +2/−1
• src/System/Taffybar/Information/CPU2.hs +23/−24
• src/System/Taffybar/Information/CPUFrequency.hs +3/−2
• src/System/Taffybar/Information/CPUPower.hs +224/−0
• src/System/Taffybar/Information/DiskUsage.hs +43/−16
• src/System/Taffybar/SimpleConfig.hs +59/−16
• src/System/Taffybar/Widget/AnthropicUsage.hs +3/−4
• src/System/Taffybar/Widget/CPUFrequency.hs +3/−2
• src/System/Taffybar/Widget/CPUMonitor.hs +96/−27
• src/System/Taffybar/Widget/CoordinatedClock.hs +3/−3
• src/System/Taffybar/Widget/DiskUsage.hs +38/−7
• src/System/Taffybar/Widget/Generic/ChannelGraph.hs +3/−2
• src/System/Taffybar/Widget/Generic/ChannelWidget.hs +3/−2
• src/System/Taffybar/Widget/Generic/Icon.hs +4/−5
• src/System/Taffybar/Widget/Generic/PollingBar.hs +10/−9
• src/System/Taffybar/Widget/Generic/PollingGraph.hs +6/−7
• src/System/Taffybar/Widget/Generic/PollingLabel.hs +2/−2
• src/System/Taffybar/Widget/MPRIS2.hs +20/−12
• src/System/Taffybar/Widget/OpenAIUsage.hs +6/−7
• src/System/Taffybar/Widget/Privacy.hs +5/−7
• src/System/Taffybar/Widget/Util.hs +30/−1
• src/System/Taffybar/Widget/WakeupDebug.hs +5/−5
• taffybar.cabal +4/−1
• test/unit/System/Taffybar/ContextSpec.hs +1/−0
• test/unit/System/Taffybar/Information/CPUPowerSpec.hs +22/−0
• test/unit/System/Taffybar/SimpleConfigSpec.hs +74/−5

@@ -1,3 +1,46 @@+# 7.3.0++## Breaking changes++* `BarConfig` and `SimpleTaffyConfig` gained a `barCssClasses` field. Record+  updates against `defaultSimpleTaffyConfig` are unaffected, but positional+  construction and exhaustive pattern matches need updating.++## Features++* Add per-monitor simple bar configuration. `toTaffybarConfigPerMonitor` takes+  a `SimpleMonitorConfig` per monitor, whose key identifies the bar: reusing a+  key reuses the existing bar, and changing it rebuilds only that monitor's bar.+* Apply user-specified CSS classes to bar windows via the new `barCssClasses`+  field, so per-monitor bars can be styled independently.+* Add channel-based CPU package power telemetry in the new+  `System.Taffybar.Information.CPUPower` module, along with+  `cpuMonitorNewWithHoverAndPower` for a CPU monitor that reports package+  wattage in its label and tooltip.+* Refresh the disk usage widget on click via `diskUsageLabelNewWithRefresh` and+  `forceDiskUsageRefresh`, so a stale reading can be updated on demand rather+  than only on the poll interval.+* Add `manageWidgetResource` and `manageWidgetThreads` to+  `System.Taffybar.Widget.Util`, which scope a widget's acquired resources and+  worker threads to its realized lifetime, releasing them on unrealize or+  destroy.++## Fixes++* Fix a segfault in `pollingGraphNew`. The tooltip was set directly from the+  sampling thread, which races GTK's tooltip bookkeeping in+  `gtk_widget_queue_tooltip_query` and eventually corrupts the tooltip window+  list. The update now goes through `postGUIASync` like its sibling widgets.+  Thanks to Isaac Shapira for the diagnosis and fix.+* Stop the MPRIS2 player icon from driving a resize feedback loop. The icon+  used the `ImageResize` path, so a player whose icon lookup fell back+  repeatedly (e.g. Chromium) re-entered size-allocate on every fallback pixbuf+  swap, growing the bar and pegging the CPU. It now routes through the+  strategy-aware `scalingImage`, which renders via a `DrawingArea` and cannot+  retrigger allocation.+* Populate backlight state before starting the monitoring thread, so the widget+  shows a real value immediately instead of waiting for the first sample.+ # 7.2.7  ## Features

@@ -204,6 +204,7 @@     LayoutSingleRow ->       BarConfig         { strutConfig = baseStrutConfig 40,+          barCssClasses = [],           widgetSpacing = 8,           startWidgets = [workspaceWidget],           centerWidgets = [testBoxWidget "test-center-box" 200 20],@@ -218,6 +219,7 @@     LayoutLevels ->       BarConfig         { strutConfig = baseStrutConfig 72,+          barCssClasses = [],           widgetSpacing = 8,           startWidgets = [testBoxWidget "test-ignored-old-left" 40 16],           centerWidgets = [testBoxWidget "test-ignored-old-center" 120 16],@@ -243,6 +245,7 @@     LayoutWindowsTitleStress ->       BarConfig         { strutConfig = baseStrutConfig 55,+          barCssClasses = [],           widgetSpacing = 8,           startWidgets = [workspaceWidget, Windows.windowsNew windowsCfg],           centerWidgets = [],

@@ -176,6 +176,7 @@     LayoutSingleRow ->       BarConfig         { strutConfig = baseStrutConfig 40,+          barCssClasses = [],           widgetSpacing = 8,           startWidgets = [startWidget],           centerWidgets = [testBoxWidget "test-center-box" 200 20],@@ -190,6 +191,7 @@     LayoutLevels ->       BarConfig         { strutConfig = baseStrutConfig 72,+          barCssClasses = [],           widgetSpacing = 8,           startWidgets = [testBoxWidget "test-ignored-old-left" 40 16],           centerWidgets = [testBoxWidget "test-ignored-old-center" 120 16],

@@ -186,6 +186,8 @@ data BarConfig = BarConfig   { -- | The strut configuration to use for the bar     strutConfig :: StrutConfig,+    -- | CSS classes applied to the bar window.+    barCssClasses :: [T.Text],     -- | The amount of spacing in pixels between bar widgets     widgetSpacing :: Int32,     -- | Constructors for widgets that should be placed at the beginning of the bar.@@ -678,6 +680,8 @@       (show $ strutConfig barConfig)    window <- Gtk.windowNew Gtk.WindowTypeToplevel++  mapM_ (widgetSetClassGI window) $ barCssClasses barConfig    void $ Gtk.onWidgetDestroy window $ do     let bId = showBarId barConfig

@@ -159,7 +159,8 @@     ourWakeupChan <- liftIO $ atomically $ dupTChan wakeupChan     liftIO $ do       chan <- newBroadcastTChanIO-      var <- newMVar Nothing+      initialInfo <- getBacklightInfo deviceOverride+      var <- newMVar initialInfo       _ <- forkIO $ monitorBacklightInfo deviceOverride intervalSeconds ourWakeupChan chan var       pure $ BacklightInfoChanVar (chan, var) 

@@ -1,3 +1,4 @@+{-# LANGUAGE LambdaCase #-} {-# LANGUAGE TupleSections #-}  -----------------------------------------------------------------------------@@ -169,34 +170,32 @@  acquireFastRefresh :: WakeupManager -> Word64 -> TChan () -> MVar FastRefreshState -> IO (IO ()) acquireFastRefresh manager intervalNs refreshChannel stateVar = do-  modifyMVar_ stateVar $ \state ->-    case state of-      FastRefreshActive count threadId subscription ->-        pure $ FastRefreshActive (count + 1) threadId subscription-      FastRefreshInactive -> do-        logM cpuLoadLogPath DEBUG $ "Acquiring fast CPU refresh lease at " <> show intervalNs <> "ns"-        subscription <- subscribeWakeupInterval manager intervalNs-        ourChannel <- atomically $ dupTChan $ wakeupSubscriptionChannel subscription-        threadId <--          forkIO $-            forever $-              atomically (readTChan ourChannel)-                >> atomically (writeTChan refreshChannel ())-        pure $ FastRefreshActive 1 threadId subscription+  modifyMVar_ stateVar $ \case+    FastRefreshActive count threadId subscription ->+      pure $ FastRefreshActive (count + 1) threadId subscription+    FastRefreshInactive -> do+      logM cpuLoadLogPath DEBUG $ "Acquiring fast CPU refresh lease at " <> show intervalNs <> "ns"+      subscription <- subscribeWakeupInterval manager intervalNs+      ourChannel <- atomically $ dupTChan $ wakeupSubscriptionChannel subscription+      threadId <-+        forkIO $+          forever $+            atomically (readTChan ourChannel)+              >> atomically (writeTChan refreshChannel ())+      pure $ FastRefreshActive 1 threadId subscription   releasedRef <- newIORef False   pure $ do     shouldRelease <- atomicModifyIORef' releasedRef $ \released -> (True, not released)     when shouldRelease $-      modifyMVar_ stateVar $ \state ->-        case state of-          FastRefreshInactive -> pure FastRefreshInactive-          FastRefreshActive count threadId subscription-            | count > 1 -> pure $ FastRefreshActive (count - 1) threadId subscription-            | otherwise -> do-                logM cpuLoadLogPath DEBUG $ "Releasing fast CPU refresh lease at " <> show intervalNs <> "ns"-                killThread threadId-                releaseWakeupSubscription subscription-                pure FastRefreshInactive+      modifyMVar_ stateVar $ \case+        FastRefreshInactive -> pure FastRefreshInactive+        FastRefreshActive count threadId subscription+          | count > 1 -> pure $ FastRefreshActive (count - 1) threadId subscription+          | otherwise -> do+              logM cpuLoadLogPath DEBUG $ "Releasing fast CPU refresh lease at " <> show intervalNs <> "ns"+              killThread threadId+              releaseWakeupSubscription subscription+              pure FastRefreshInactive  drainTChan :: TChan a -> STM () drainTChan chan = do

@@ -28,6 +28,7 @@ import Control.Monad.IO.Class (liftIO) import Control.Monad.STM (atomically) import qualified Data.ByteString.Char8 as BS8+import Data.Either (fromRight) import Data.List (isPrefixOf, sort) import Data.Maybe (catMaybes, mapMaybe) import System.Directory (doesDirectoryExist, doesFileExist, listDirectory)@@ -76,7 +77,7 @@ readCPUFrequencyInfo :: IO CPUFrequencyInfo readCPUFrequencyInfo = do   result <- try readCPUFrequencyInfoUnsafe-  pure $ either (const emptyCPUFrequencyInfo) id (result :: Either SomeException CPUFrequencyInfo)+  pure $ fromRight emptyCPUFrequencyInfo (result :: Either SomeException CPUFrequencyInfo)  readCPUFrequencyInfoUnsafe :: IO CPUFrequencyInfo readCPUFrequencyInfoUnsafe = do@@ -100,7 +101,7 @@   discoverFrequencyPaths     "/sys/devices/system/cpu/cpufreq"     ("policy" `isPrefixOf`)-    (\base entry -> base </> entry)+    (</>)  discoverCoreFrequencyPaths :: IO [[FilePath]] discoverCoreFrequencyPaths =

@@ -0,0 +1,224 @@+{-# LANGUAGE NumericUnderscores #-}++-- |+-- Module      : System.Taffybar.Information.CPUPower+-- Copyright   : (c) Ivan A. Malison+-- License     : BSD3-style (see LICENSE)+--+-- Linux CPU package-power information derived from the RAPL energy counter.+-- One process-wide sampler feeds all widgets through a broadcast channel.+module System.Taffybar.Information.CPUPower+  ( CPUPowerInfo (..),+    EnergySample (..),+    calculateCPUPowerWatts,+    readCPUPowerInfo,+    getCPUPowerInfoChan,+    getCPUPowerInfoState,+  )+where++import Control.Concurrent (forkIO)+import Control.Concurrent.MVar (MVar, newMVar, readMVar, swapMVar)+import Control.Concurrent.STM.TChan (TChan, dupTChan, newBroadcastTChanIO, readTChan, writeTChan)+import Control.Exception (SomeException, try)+import Control.Monad (filterM, forever, void, when)+import Control.Monad.IO.Class (liftIO)+import Control.Monad.STM (atomically)+import qualified Data.ByteString.Char8 as BS8+import Data.List (isPrefixOf, sort)+import Data.Maybe (catMaybes, listToMaybe)+import GHC.Clock (getMonotonicTimeNSec)+import System.Directory (doesDirectoryExist, doesFileExist, listDirectory)+import System.FilePath ((</>))+import System.Taffybar.Context (TaffyIO, getStateDefault)+import System.Taffybar.Information.Wakeup (getWakeupChannelForDelay)+import Text.Read (readMaybe)++data CPUPowerInfo = CPUPowerInfo+  { cpuPackagePowerWatts :: Maybe Double,+    cpuPowerDomainName :: Maybe String+  }+  deriving (Eq, Show)++data EnergySample = EnergySample+  { energySampleMicrojoules :: Integer,+    energySampleMonotonicNanoseconds :: Integer+  }+  deriving (Eq, Show)++data CPUPowerDomain = CPUPowerDomain+  { cpuPowerDomainPath :: FilePath,+    cpuPowerDomainLabel :: String,+    cpuPowerMaximumEnergyMicrojoules :: Integer+  }+  deriving (Eq, Show)++emptyCPUPowerInfo :: CPUPowerInfo+emptyCPUPowerInfo = CPUPowerInfo Nothing Nothing++-- | Calculate average package power between two energy samples. The maximum+-- energy range is used to account for the kernel counter wrapping around.+calculateCPUPowerWatts :: Integer -> EnergySample -> EnergySample -> Maybe Double+calculateCPUPowerWatts maximumEnergy previous current+  | elapsedNanoseconds <= 0 = Nothing+  | energyDelta < 0 = Nothing+  | otherwise =+      Just $+        fromIntegral energyDelta+          * 1_000+          / fromIntegral elapsedNanoseconds+  where+    previousEnergy = energySampleMicrojoules previous+    currentEnergy = energySampleMicrojoules current+    energyDelta+      | currentEnergy >= previousEnergy = currentEnergy - previousEnergy+      | maximumEnergy > previousEnergy = maximumEnergy - previousEnergy + currentEnergy+      | otherwise = -1+    elapsedNanoseconds =+      energySampleMonotonicNanoseconds current+        - energySampleMonotonicNanoseconds previous++-- | Take one package-power reading. The first reading has no wattage because+-- RAPL exposes accumulated energy; a second sample is needed to derive power.+readCPUPowerInfo :: IO CPUPowerInfo+readCPUPowerInfo = do+  maybeDomain <- discoverCPUPowerDomain+  pure $+    case maybeDomain of+      Nothing -> emptyCPUPowerInfo+      Just domain -> CPUPowerInfo Nothing (Just $ cpuPowerDomainLabel domain)++discoverCPUPowerDomain :: IO (Maybe CPUPowerDomain)+discoverCPUPowerDomain = do+  domains <- discoverDomainsInBases powercapBases+  pure $ listToMaybe domains+  where+    -- Prefer the MSR-backed package counter. The MMIO interface commonly+    -- exposes the same package and would otherwise double-count it.+    powercapBases =+      [ "/sys/devices/virtual/powercap/intel-rapl",+        "/sys/class/powercap"+      ]++discoverDomainsInBases :: [FilePath] -> IO [CPUPowerDomain]+discoverDomainsInBases [] = pure []+discoverDomainsInBases (base : rest) = do+  domains <- discoverDomainsInBase base+  if null domains then discoverDomainsInBases rest else pure domains++discoverDomainsInBase :: FilePath -> IO [CPUPowerDomain]+discoverDomainsInBase base = do+  exists <- doesDirectoryExist base+  if not exists+    then pure []+    else do+      entriesResult <- try $ listDirectory base+      case entriesResult :: Either SomeException [FilePath] of+        Left _ -> pure []+        Right entries -> do+          candidates <- filterM (doesFileExist . (</> "energy_uj")) $ map (base </>) $ sort entries+          catMaybes <$> mapM readPowerDomain candidates++readPowerDomain :: FilePath -> IO (Maybe CPUPowerDomain)+readPowerDomain path = do+  maybeName <- readStringFile $ path </> "name"+  maybeMaximum <- readIntegerFile $ path </> "max_energy_range_uj"+  pure $ case (maybeName, maybeMaximum) of+    (Just name, Just maximumEnergy)+      | "package-" `isPrefixOf` name ->+          Just $+            CPUPowerDomain+              { cpuPowerDomainPath = path,+                cpuPowerDomainLabel = name,+                cpuPowerMaximumEnergyMicrojoules = maximumEnergy+              }+    _ -> Nothing++readEnergySample :: CPUPowerDomain -> IO (Maybe EnergySample)+readEnergySample domain = do+  maybeEnergy <- readIntegerFile $ cpuPowerDomainPath domain </> "energy_uj"+  case maybeEnergy of+    Nothing -> pure Nothing+    Just energy -> do+      timestamp <- fromIntegral <$> getMonotonicTimeNSec+      pure $ Just $ EnergySample energy timestamp++readStringFile :: FilePath -> IO (Maybe String)+readStringFile path = do+  result <- try $ BS8.readFile path+  pure $ case result :: Either SomeException BS8.ByteString of+    Left _ -> Nothing+    Right contents -> Just $ BS8.unpack $ BS8.takeWhile (`notElem` ['\n', '\r']) contents++readIntegerFile :: FilePath -> IO (Maybe Integer)+readIntegerFile path = do+  maybeContents <- readStringFile path+  pure $ maybeContents >>= readMaybe++data CPUPowerSamplerState = CPUPowerSamplerState+  { samplerDomain :: Maybe CPUPowerDomain,+    samplerPreviousSample :: Maybe EnergySample+  }++newtype CPUPowerInfoChanVar+  = CPUPowerInfoChanVar (TChan CPUPowerInfo, MVar CPUPowerInfo)++-- | Return the process-wide package-power stream. The first caller's interval+-- wins; later widgets reuse the same sampler.+getCPUPowerInfoChan :: Double -> TaffyIO (TChan CPUPowerInfo)+getCPUPowerInfoChan interval = do+  CPUPowerInfoChanVar (chan, _) <- setupCPUPowerInfoChanVar interval+  pure chan++-- | Read the latest snapshot from the shared package-power sampler.+getCPUPowerInfoState :: Double -> TaffyIO CPUPowerInfo+getCPUPowerInfoState interval = do+  CPUPowerInfoChanVar (_, infoVar) <- setupCPUPowerInfoChanVar interval+  liftIO $ readMVar infoVar++setupCPUPowerInfoChanVar :: Double -> TaffyIO CPUPowerInfoChanVar+setupCPUPowerInfoChanVar interval = getStateDefault $ do+  wakeupChan <- getWakeupChannelForDelay $ max 0.000_001 interval+  ourWakeupChan <- liftIO $ atomically $ dupTChan wakeupChan+  liftIO $ do+    domain <- discoverCPUPowerDomain+    initialSample <- maybe (pure Nothing) readEnergySample domain+    let initialInfo = CPUPowerInfo Nothing (cpuPowerDomainLabel <$> domain)+        initialSamplerState = CPUPowerSamplerState domain initialSample+    chan <- newBroadcastTChanIO+    infoVar <- newMVar initialInfo+    samplerVar <- newMVar initialSamplerState+    void $ forkIO $ forever $ do+      void $ atomically $ readTChan ourWakeupChan+      oldSamplerState <- readMVar samplerVar+      (info, newSamplerState) <- sampleCPUPower oldSamplerState+      void $ swapMVar samplerVar newSamplerState+      oldInfo <- swapMVar infoVar info+      when (info /= oldInfo) $ atomically $ writeTChan chan info+    pure $ CPUPowerInfoChanVar (chan, infoVar)++sampleCPUPower :: CPUPowerSamplerState -> IO (CPUPowerInfo, CPUPowerSamplerState)+sampleCPUPower oldState = do+  domain <- maybe discoverCPUPowerDomain (pure . Just) $ samplerDomain oldState+  case domain of+    Nothing -> pure (emptyCPUPowerInfo, CPUPowerSamplerState Nothing Nothing)+    Just currentDomain -> do+      sample <- readEnergySample currentDomain+      case sample of+        Nothing ->+          pure+            ( CPUPowerInfo Nothing (Just $ cpuPowerDomainLabel currentDomain),+              CPUPowerSamplerState Nothing Nothing+            )+        Just currentSample -> do+          let watts =+                samplerPreviousSample oldState+                  >>= \previousSample ->+                    calculateCPUPowerWatts+                      (cpuPowerMaximumEnergyMicrojoules currentDomain)+                      previousSample+                      currentSample+          pure+            ( CPUPowerInfo watts (Just $ cpuPowerDomainLabel currentDomain),+              CPUPowerSamplerState (Just currentDomain) (Just currentSample)+            )

@@ -24,22 +24,24 @@ -- directly with 'pollingLabelNew'. module System.Taffybar.Information.DiskUsage   ( DiskUsageInfo (..),+    forceDiskUsageRefresh,     getDiskUsageInfo,     getDiskUsageInfoChan,     getDiskUsageInfoState,   ) where +import Control.Concurrent (forkIO) import Control.Concurrent.MVar import Control.Concurrent.STM.TChan import Control.Exception.Enclosed (catchAny)-import Control.Monad (void)+import Control.Monad (forever, void) import Control.Monad.IO.Class (liftIO)-import Control.Monad.STM (atomically)+import Control.Monad.STM (atomically, orElse) import System.DiskSpace (diskAvail, diskFree, diskTotal, getDiskUsage) import System.Log.Logger (Priority (..)) import System.Taffybar.Context (TaffyIO, getStateDefault)-import System.Taffybar.Information.Wakeup (taffyForeverWithDelay)+import System.Taffybar.Information.Wakeup (getWakeupChannelForDelay) import System.Taffybar.Util (logPrintF)  -- | Disk usage statistics for a single filesystem.@@ -89,37 +91,62 @@ -- Shared polling channel  newtype DiskUsageChanVar-  = DiskUsageChanVar (TChan DiskUsageInfo, MVar DiskUsageInfo)+  = DiskUsageChanVar+      ( TChan DiskUsageInfo,+        MVar DiskUsageInfo,+        TChan ()+      )  -- | Get a broadcast channel that is updated by a shared polling thread. -- The first call starts the poller; subsequent calls return the same channel. getDiskUsageInfoChan :: Double -> FilePath -> TaffyIO (TChan DiskUsageInfo) getDiskUsageInfoChan interval path = do-  DiskUsageChanVar (chan, _) <- setupDiskUsageChanVar interval path+  DiskUsageChanVar (chan, _, _) <- setupDiskUsageChanVar interval path   pure chan  -- | Read the latest cached 'DiskUsageInfo' from the shared poller. getDiskUsageInfoState :: Double -> FilePath -> TaffyIO DiskUsageInfo getDiskUsageInfoState interval path = do-  DiskUsageChanVar (_, var) <- setupDiskUsageChanVar interval path+  DiskUsageChanVar (_, var, _) <- setupDiskUsageChanVar interval path   liftIO $ readMVar var +-- | Request an immediate disk usage refresh.+forceDiskUsageRefresh :: Double -> FilePath -> TaffyIO ()+forceDiskUsageRefresh interval path = do+  DiskUsageChanVar (_, _, refreshChan) <- setupDiskUsageChanVar interval path+  liftIO $ atomically $ writeTChan refreshChan ()+ setupDiskUsageChanVar :: Double -> FilePath -> TaffyIO DiskUsageChanVar setupDiskUsageChanVar interval path = getStateDefault $ do   chan <- liftIO newBroadcastTChanIO+  refreshChan <- liftIO newTChanIO   info <- liftIO $ getDiskUsageInfo path   var <- liftIO $ newMVar info+  wakeupChan <- getWakeupChannelForDelay interval+  ourWakeupChan <- liftIO $ atomically $ dupTChan wakeupChan   void $-    taffyForeverWithDelay interval $-      liftIO $-        catchAny-          ( do-              newInfo <- getDiskUsageInfo path-              void $ swapMVar var newInfo-              atomically $ writeTChan chan newInfo-          )-          (logPrintF logName WARNING "DiskUsage poll failed: %s")-  pure $ DiskUsageChanVar (chan, var)+    liftIO $+      forkIO $+        forever $ do+          atomically $+            void (readTChan refreshChan)+              `orElse` void (readTChan ourWakeupChan)+          refreshDiskUsageState path chan var+  pure $ DiskUsageChanVar (chan, var, refreshChan)++refreshDiskUsageState ::+  FilePath ->+  TChan DiskUsageInfo ->+  MVar DiskUsageInfo ->+  IO ()+refreshDiskUsageState path chan var =+  catchAny+    ( do+        newInfo <- getDiskUsageInfo path+        void $ swapMVar var newInfo+        atomically $ writeTChan chan newInfo+    )+    (logPrintF logName WARNING "DiskUsage poll failed: %s")  logName :: String logName = "System.Taffybar.Information.DiskUsage"

@@ -18,6 +18,7 @@ -- offered in "System.Taffybar.Context". module System.Taffybar.SimpleConfig   ( SimpleTaffyConfig (..),+    SimpleMonitorConfig (..),     BarLevelConfig (..),     Position (..),     defaultSimpleTaffyConfig,@@ -25,6 +26,7 @@     simpleTaffybar,     toTaffyConfig,     toTaffybarConfig,+    toTaffybarConfigPerMonitor,     useAllMonitors,     usePrimaryMonitor,     withPriority,@@ -41,6 +43,7 @@ import Data.Default (Default (..)) import Data.List import Data.Maybe+import qualified Data.Text as T import Data.Unique import GI.Gdk import qualified GI.Gtk as Gtk@@ -49,7 +52,6 @@ import System.Taffybar 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@@ -79,6 +81,8 @@ data SimpleTaffyConfig = SimpleTaffyConfig   { -- | The monitor number to put the bar on (default: 'usePrimaryMonitor')     monitorsAction :: TaffyIO [Int],+    -- | CSS classes applied to each bar window.+    barCssClasses :: [T.Text],     -- | Number of pixels to reserve for the bar (default: 30)     barHeight :: StrutSize,     -- | Number of additional pixels to reserve for the bar strut (default: 0)@@ -109,6 +113,7 @@ defaultSimpleTaffyConfig =   SimpleTaffyConfig     { monitorsAction = useAllMonitors,+      barCssClasses = [],       barHeight = ScreenRatio $ 1 / 27,       barPadding = 0,       barPosition = Top,@@ -153,6 +158,7 @@   return     BC.BarConfig       { BC.strutConfig = strutConfig,+        BC.barCssClasses = barCssClasses config,         BC.widgetSpacing = fromIntegral $ widgetSpacing config,         BC.startWidgets = startWidgets config,         BC.centerWidgets = centerWidgets config,@@ -161,8 +167,22 @@         BC.barId = barId       } -newtype SimpleBarConfigs = SimpleBarConfigs (MV.MVar [(Int, BC.BarConfig)])+-- | A monitor-specific simple configuration and the key that identifies it.+-- Returning the same key lets Taffybar reuse the existing bar. Changing the+-- key causes that monitor's bar to be rebuilt.+data SimpleMonitorConfig = SimpleMonitorConfig+  { simpleMonitorConfigKey :: T.Text,+    simpleMonitorConfig :: SimpleTaffyConfig+  } +data SimpleBarConfigEntry = SimpleBarConfigEntry+  { simpleBarConfigMonitor :: Int,+    simpleBarConfigKey :: T.Text,+    simpleBarConfigValue :: BC.BarConfig+  }++newtype SimpleBarConfigs = SimpleBarConfigs (MV.MVar [SimpleBarConfigEntry])+ {-# DEPRECATED toTaffyConfig "Use toTaffybarConfig instead" #-}  -- | Deprecated alias for 'toTaffybarConfig'.@@ -173,6 +193,19 @@ -- with 'startTaffybar' or 'dyreTaffybar'. toTaffybarConfig :: SimpleTaffyConfig -> BC.TaffybarConfig toTaffybarConfig conf =+  toTaffybarConfigPerMonitor conf $ \_ ->+    pure $ SimpleMonitorConfig T.empty conf++-- | Convert a simple configuration using a monitor-specific configuration+-- builder. The base configuration supplies monitor selection, CSS paths, and+-- the startup hook. Per-monitor configurations supply bar geometry, classes,+-- and widgets. Bars are reused while their key is unchanged and rebuilt when+-- it changes.+toTaffybarConfigPerMonitor ::+  SimpleTaffyConfig ->+  (Int -> TaffyIO SimpleMonitorConfig) ->+  BC.TaffybarConfig+toTaffybarConfigPerMonitor conf configForMonitor =   def     { BC.getBarConfigsParam = configGetter,       BC.cssPaths = cssPaths conf,@@ -181,22 +214,32 @@   where     configGetter = do       SimpleBarConfigs configsVar <--        getStateDefault $ lift (SimpleBarConfigs <$> MV.newMVar [])+        getStateDefault $ lift $ SimpleBarConfigs <$> MV.newMVar []       monitorNumbers <- monitorsAction conf--      let lookupWithIndex barConfigs monitorNumber =-            (monitorNumber, lookup monitorNumber barConfigs)--          lookupAndUpdate barConfigs = do-            let (alreadyPresent, toCreate) =-                  partition (isJust . snd) $-                    map (lookupWithIndex barConfigs) monitorNumbers-                alreadyPresentConfigs = mapMaybe snd alreadyPresent+      requestedConfigs <-+        forM monitorNumbers $ \monitorNumber -> do+          monitorConfig <- configForMonitor monitorNumber+          pure (monitorNumber, monitorConfig) -            newlyCreated <--              mapM (forkM return (toBarConfig conf) . fst) toCreate-            let result = map snd newlyCreated ++ alreadyPresentConfigs-            return (barConfigs ++ newlyCreated, result)+      let lookupAndUpdate existingEntries = do+            activeEntries <-+              forM requestedConfigs $ \(monitorNumber, monitorConfig) ->+                case find+                  ( \entry ->+                      simpleBarConfigMonitor entry == monitorNumber+                        && simpleBarConfigKey entry == simpleMonitorConfigKey monitorConfig+                  )+                  existingEntries of+                  Just entry -> pure entry+                  Nothing -> do+                    barConfig <- toBarConfig (simpleMonitorConfig monitorConfig) monitorNumber+                    pure $+                      SimpleBarConfigEntry+                        { simpleBarConfigMonitor = monitorNumber,+                          simpleBarConfigKey = simpleMonitorConfigKey monitorConfig,+                          simpleBarConfigValue = barConfig+                        }+            pure (activeEntries, map simpleBarConfigValue activeEntries)        lift $ MV.modifyMVar configsVar lookupAndUpdate 

@@ -44,6 +44,7 @@   ( UsageWindowLabelParts (..),     UsageWindowPosition (..),     buildIconLabelBox,+    manageWidgetThreads,     widgetSetClassGI,   ) import Text.Printf (printf)@@ -213,7 +214,7 @@     _ <- widgetSetClassGI label (anthropicUsageLabelClass config)     updateLabelFromState config label displayState initialSnapshot -    void $ Gtk.onWidgetRealize label $ do+    manageWidgetThreads label $ do       -- The usage listener only runs while the label is realized (e.g. the       -- visible page of a GtkStack), so broadcasts that arrived while the       -- widget was hidden were missed. Re-sync from the shared state before@@ -223,9 +224,7 @@       updateLabelFromState config label displayState currentSnapshot       usageThread <- forkUsageListener config label displayState snapshotVar usageChan       modeThread <- forkDisplayModeListener config label displayState snapshotVar-      void $ Gtk.onWidgetUnrealize label $ do-        killThread usageThread-        killThread modeThread+      return [usageThread, modeThread]      Gtk.widgetShowAll label     widget <- Gtk.toWidget label

@@ -18,6 +18,7 @@ import Control.Monad.IO.Class (liftIO) import Data.Default (Default (..)) import Data.IORef (newIORef, readIORef, writeIORef)+import Data.Maybe (fromMaybe) import qualified Data.Text as T import qualified GI.Gtk as Gtk import System.Taffybar.Context (TaffyIO)@@ -82,7 +83,7 @@           printf             "CPU clock average: %.2f GHz\nRange: %.2f-%.2f GHz\n%d frequency policies sampled"             average-            (maybe average id $ cpuFrequencyMinimumGHz info)-            (maybe average id $ cpuFrequencyMaximumGHz info)+            (fromMaybe average $ cpuFrequencyMinimumGHz info)+            (fromMaybe average $ cpuFrequencyMaximumGHz info)             (cpuFrequencySampleCount info)       )

@@ -1,4 +1,5 @@ {-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TupleSections #-}  -------------------------------------------------------------------------------- @@ -21,19 +22,30 @@ import Control.Monad (void) import Control.Monad.IO.Class (liftIO) import Data.IORef (atomicModifyIORef', newIORef)+import Data.Maybe (fromMaybe)+import qualified Data.Text as T import qualified GI.Gdk as Gdk import qualified GI.Gtk import System.Taffybar.Context (TaffyIO) import System.Taffybar.Information.CPU2   ( CPULoad (..),+    CPULoadSource,     acquireCPULoadFastRefresh,     cpuLoadSourceChannel,     forceCPULoadRefresh,     getCPULoadSource,   )+import System.Taffybar.Information.CPUPower+  ( CPUPowerInfo (..),+    getCPUPowerInfoChan,+    getCPUPowerInfoState,+  )+import System.Taffybar.Util (postGUIASync) import System.Taffybar.Widget.Generic.ChannelGraph+import System.Taffybar.Widget.Generic.ChannelWidget (channelWidgetNew) import System.Taffybar.Widget.Generic.Graph import System.Taffybar.Widget.Util (widgetSetClassGI)+import Text.Printf (printf)  -- | Creates a new CPU monitor. This is a channel-driven graph fed by CPU load -- samples for one core (or all cores when "cpu" is selected).@@ -66,36 +78,93 @@   source <- getCPULoadSource cpu interval hoverInterval   liftIO $ do     graphWidget <- channelGraphNew cfg (cpuLoadSourceChannel source) toSample-    eventBox <- GI.Gtk.eventBoxNew-    GI.Gtk.eventBoxSetVisibleWindow eventBox False-    GI.Gtk.eventBoxSetAboveChild eventBox True-    GI.Gtk.containerAdd eventBox graphWidget-    widget <- GI.Gtk.toWidget eventBox >>= (`widgetSetClassGI` "cpu-monitor")-    releaseRef <- newIORef Nothing+    addHoverRefresh source graphWidget -    let beginFastRefresh = do-          currentRelease <- atomicModifyIORef' releaseRef $ \current -> (current, current)-          case currentRelease of-            Just _ -> pure ()-            Nothing -> do-              release <- acquireCPULoadFastRefresh source-              previous <- atomicModifyIORef' releaseRef $ \current -> (Just release, current)-              maybe (pure ()) id previous+-- | Create a hover-responsive CPU graph with a live RAPL package-power label.+-- The power sampler is shared across all bars through the Taffybar context.+cpuMonitorNewWithHoverAndPower ::+  -- | Configuration data for the graph.+  GraphConfig ->+  -- | Normal CPU polling period, in seconds.+  Double ->+  -- | CPU polling period while hovered, in seconds.+  Double ->+  -- | Package-power polling period, in seconds.+  Double ->+  -- | Name of the core to watch (for example, @"cpu"@ or @"cpu0"@).+  String ->+  TaffyIO GI.Gtk.Widget+cpuMonitorNewWithHoverAndPower cfg interval hoverInterval powerInterval cpu = do+  source <- getCPULoadSource cpu interval hoverInterval+  powerChan <- getCPUPowerInfoChan powerInterval+  initialPower <- getCPUPowerInfoState powerInterval+  liftIO $ do+    graphWidget <- channelGraphNew (cfg {graphLabel = Nothing}) (cpuLoadSourceChannel source) toSample+    overlay <- GI.Gtk.overlayNew+    powerLabel <- GI.Gtk.labelNew Nothing+    void $ widgetSetClassGI powerLabel "graph-label"+    GI.Gtk.containerAdd overlay graphWidget+    GI.Gtk.overlayAddOverlay overlay powerLabel+    GI.Gtk.overlaySetOverlayPassThrough overlay powerLabel True -        endFastRefresh = do-          release <- atomicModifyIORef' releaseRef $ \current -> (Nothing, current)-          maybe (pure ()) id release+    let updatePowerLabel info = postGUIASync $ do+          GI.Gtk.labelSetMarkup powerLabel $ powerLabelMarkup cfg info+          GI.Gtk.widgetSetTooltipText overlay $ powerTooltip info -    GI.Gtk.widgetAddEvents-      widget-      [ Gdk.EventMaskEnterNotifyMask,-        Gdk.EventMaskLeaveNotifyMask-      ]-    void $ GI.Gtk.onWidgetEnterNotifyEvent widget $ \_ -> beginFastRefresh >> pure False-    void $ GI.Gtk.onWidgetLeaveNotifyEvent widget $ \_ -> endFastRefresh >> pure False-    void $ GI.Gtk.onWidgetRealize graphWidget $ forceCPULoadRefresh source-    void $ GI.Gtk.onWidgetUnrealize widget endFastRefresh-    pure widget+    void $ GI.Gtk.onWidgetRealize powerLabel $ updatePowerLabel initialPower+    powerWidget <- channelWidgetNew overlay powerChan updatePowerLabel+    GI.Gtk.toWidget powerWidget >>= addHoverRefresh source++addHoverRefresh ::+  CPULoadSource ->+  GI.Gtk.Widget ->+  IO GI.Gtk.Widget+addHoverRefresh source graphWidget = do+  eventBox <- GI.Gtk.eventBoxNew+  GI.Gtk.eventBoxSetVisibleWindow eventBox False+  GI.Gtk.eventBoxSetAboveChild eventBox True+  GI.Gtk.containerAdd eventBox graphWidget+  widget <- GI.Gtk.toWidget eventBox >>= (`widgetSetClassGI` "cpu-monitor")+  releaseRef <- newIORef Nothing++  let beginFastRefresh = do+        currentRelease <- atomicModifyIORef' releaseRef $ \current -> (current, current)+        case currentRelease of+          Just _ -> pure ()+          Nothing -> do+            release <- acquireCPULoadFastRefresh source+            previous <- atomicModifyIORef' releaseRef (Just release,)+            fromMaybe (pure ()) previous++      endFastRefresh = do+        release <- atomicModifyIORef' releaseRef (Nothing,)+        fromMaybe (pure ()) release++  GI.Gtk.widgetAddEvents+    widget+    [ Gdk.EventMaskEnterNotifyMask,+      Gdk.EventMaskLeaveNotifyMask+    ]+  void $ GI.Gtk.onWidgetEnterNotifyEvent widget $ \_ -> beginFastRefresh >> pure False+  void $ GI.Gtk.onWidgetLeaveNotifyEvent widget $ \_ -> endFastRefresh >> pure False+  void $ GI.Gtk.onWidgetRealize graphWidget $ forceCPULoadRefresh source+  void $ GI.Gtk.onWidgetUnrealize widget endFastRefresh+  pure widget++powerLabelMarkup :: GraphConfig -> CPUPowerInfo -> T.Text+powerLabelMarkup cfg info =+  T.intercalate "\n" $+    filter (not . T.null) [fromMaybe "" $ graphLabel cfg, powerText]+  where+    powerText = maybe "--W" (T.pack . printf "%.0fW") $ cpuPackagePowerWatts info++powerTooltip :: CPUPowerInfo -> Maybe T.Text+powerTooltip info =+  Just $+    maybe+      "CPU package power unavailable"+      (T.pack . printf "CPU package power: %.1f W")+      (cpuPackagePowerWatts info)  toSample :: CPULoad -> IO [Double] toSample CPULoad {cpuTotalLoad = totalLoad, cpuSystemLoad = systemLoad} =

@@ -11,7 +11,7 @@   ) where -import Control.Concurrent (forkIO, killThread)+import Control.Concurrent (forkIO) import Control.Concurrent.STM (atomically) import Control.Concurrent.STM.TChan (dupTChan, readTChan) import Control.Exception.Enclosed (catchAny)@@ -94,12 +94,12 @@         _ <- widgetSetClassGI label "text-clock-label"         void $ refreshClockLabel label -        _ <- onWidgetRealize label $ do+        manageWidgetThreads label $ do           ourWakeupChan <- atomically $ dupTChan wakeupChan           threadId <- forkIO $ forever $ do             void $ atomically $ readTChan ourWakeupChan             void $ refreshClockLabel label-          void $ onWidgetUnrealize label $ killThread threadId+          return [threadId]          ebox <- eventBoxNew         _ <- widgetSetClassGI ebox "text-clock"

@@ -34,8 +34,10 @@   ) where +import Control.Concurrent (forkIO) import Control.Monad (void) import Control.Monad.IO.Class+import Control.Monad.Trans.Reader (ask, runReaderT) import Data.Default (Default (..)) import qualified Data.Text as T import qualified GI.Gtk as Gtk@@ -83,24 +85,35 @@ -- | Create a disk usage label with the given configuration. diskUsageLabelNewWith :: DiskUsageWidgetConfig -> TaffyIO Gtk.Widget diskUsageLabelNewWith config = do+  (labelWidget, refreshNow) <- diskUsageLabelNewWithRefresh config+  liftIO $ wrapDiskUsageRefresh "disk-usage-label" labelWidget refreshNow++diskUsageLabelNewWithRefresh ::+  DiskUsageWidgetConfig ->+  TaffyIO (Gtk.Widget, IO ())+diskUsageLabelNewWithRefresh config = do   let path = diskUsagePath config       interval = diskUsagePollInterval config   chan <- getDiskUsageInfoChan interval path   initialInfo <- getDiskUsageInfoState interval path+  ctx <- ask    liftIO $ do     label <- Gtk.labelNew Nothing     _ <- widgetSetClassGI label "disk-usage-label" -    let updateLabel info = postGUIASync $ do+    let refreshNow = runReaderT (forceDiskUsageRefresh interval path) ctx+        updateLabel info = postGUIASync $ do           let (labelText, tooltipText) = formatDiskUsage config info           Gtk.labelSetText label labelText           Gtk.widgetSetTooltipText label tooltipText      void $ Gtk.onWidgetRealize label $ updateLabel initialInfo     Gtk.widgetShowAll label-    (Gtk.toWidget =<< channelWidgetNew label chan updateLabel)-      >>= (`widgetSetClassGI` "disk-usage-label")+    labelWidget <-+      (Gtk.toWidget =<< channelWidgetNew label chan updateLabel)+        >>= (`widgetSetClassGI` "disk-usage-label")+    pure (labelWidget, refreshNow)  -- | Create a disk usage icon widget with default configuration. diskUsageIconNew :: TaffyIO Gtk.Widget@@ -122,10 +135,28 @@ diskUsageNewWith :: DiskUsageWidgetConfig -> TaffyIO Gtk.Widget diskUsageNewWith config = do   iconWidget <- diskUsageIconNewWith config-  labelWidget <- diskUsageLabelNewWith config-  liftIO $-    buildIconLabelBox iconWidget labelWidget-      >>= (`widgetSetClassGI` "disk-usage")+  (labelWidget, refreshNow) <- diskUsageLabelNewWithRefresh config+  liftIO $ do+    widget <-+      buildIconLabelBox iconWidget labelWidget+        >>= (`widgetSetClassGI` "disk-usage")+    wrapDiskUsageRefresh "disk-usage" widget refreshNow++wrapDiskUsageRefresh ::+  T.Text ->+  Gtk.Widget ->+  IO () ->+  IO Gtk.Widget+wrapDiskUsageRefresh klass child refreshNow = do+  eventBox <- Gtk.eventBoxNew+  _ <- widgetSetClassGI eventBox klass+  Gtk.containerAdd eventBox child+  void $+    Gtk.onWidgetButtonPressEvent eventBox $ \_event -> do+      void $ forkIO refreshNow+      pure True+  Gtk.widgetShowAll eventBox+  Gtk.toWidget eventBox  -- -------------------------------------------------------------------------- -- Formatting

@@ -8,6 +8,7 @@ import Control.Monad.STM (atomically) import GI.Gtk import System.Taffybar.Widget.Generic.Graph+import System.Taffybar.Widget.Util (manageWidgetThreads)  -- | Given a broadcast 'TChan' and an action to consume that broadcast chan and -- turn it into graphable values, build a graph that will update as values are@@ -17,12 +18,12 @@   GraphConfig -> TChan a -> (a -> IO [Double]) -> m GI.Gtk.Widget channelGraphNew config chan sampleBuilder = do   (graphWidget, graphHandle) <- graphNew config-  _ <- onWidgetRealize graphWidget $ do+  liftIO $ manageWidgetThreads graphWidget $ do     ourChan <- atomically $ dupTChan chan     sampleThread <-       forkIO $         forever $           atomically (readTChan ourChan)             >>= (graphAddSample graphHandle <=< sampleBuilder)-    void $ onWidgetUnrealize graphWidget $ killThread sampleThread+    return [sampleThread]   return graphWidget

@@ -7,6 +7,7 @@ import Control.Monad.IO.Class import Control.Monad.STM (atomically) import GI.Gtk+import System.Taffybar.Widget.Util (manageWidgetThreads)  -- | Given a widget, a broadcast 'TChan' and a function that consumes the values -- yielded by the channel that is in 'IO', connect the function to the@@ -15,12 +16,12 @@   (MonadIO m, IsWidget w) =>   w -> TChan a -> (a -> IO ()) -> m w channelWidgetNew widget channel updateWidget = do-  void $ onWidgetRealize widget $ do+  liftIO $ manageWidgetThreads widget $ do     ourChan <- atomically $ dupTChan channel     processingThreadId <-       forkIO $         forever $           atomically (readTChan ourChan) >>= updateWidget-    void $ onWidgetUnrealize widget $ killThread processingThreadId+    return [processingThreadId]   widgetShowAll widget   return widget

@@ -8,7 +8,6 @@   ) where -import Control.Concurrent (killThread) import Control.Exception as E import Control.Monad (void) import Control.Monad.IO.Class (MonadIO, liftIO)@@ -18,6 +17,7 @@ import GI.Gtk import System.Taffybar.Context (TaffyIO) import System.Taffybar.Information.Wakeup (taffyForeverWithDelay)+import System.Taffybar.Widget.Util (manageWidgetThreads)  -- | Create a new widget that displays a static image --@@ -106,8 +106,8 @@ pollingIcon interval doUpdateName doInitImage doSetImage = do   context <- ask   image <- liftIO doInitImage-  liftIO $ do-    _ <- onWidgetRealize image $ do+  liftIO $+    manageWidgetThreads image $ do       sampleThread <-         runReaderT           ( taffyForeverWithDelay interval $@@ -120,8 +120,7 @@                   ignoreIOException           )           context-      void $ onWidgetUnrealize image $ killThread sampleThread-    return ()+      return [sampleThread]   liftIO $ putInBox image  putInBox :: (IsWidget child) => child -> IO Widget

@@ -15,7 +15,7 @@  import Control.Concurrent import Control.Exception.Enclosed (tryAny)-import Control.Monad (void)+import Control.Monad (forever) import Control.Monad.IO.Class (MonadIO, liftIO) import Control.Monad.Trans.Reader (ask, runReaderT) import Data.Foldable (traverse_)@@ -23,7 +23,7 @@ import System.Taffybar.Context (TaffyIO) import System.Taffybar.Information.Wakeup (taffyForeverWithDelay) import System.Taffybar.Widget.Generic.VerticalBar-import System.Taffybar.Widget.Util (backgroundLoop)+import System.Taffybar.Widget.Util (manageWidgetThreads)  -- | Construct a bar widget driven directly by a sample callback. verticalBarFromCallback ::@@ -31,9 +31,11 @@   BarConfig -> IO Double -> m GI.Gtk.Widget verticalBarFromCallback cfg action = liftIO $ do   (drawArea, h) <- verticalBarNew cfg-  _ <- GI.Gtk.onWidgetRealize drawArea $ backgroundLoop $ do-    esample <- tryAny action-    traverse (verticalBarSetPercent h) esample+  manageWidgetThreads drawArea $ do+    sampleThread <- forkIO $ forever $ do+      esample <- tryAny action+      traverse (verticalBarSetPercent h) esample+    return [sampleThread]   return drawArea  -- | Construct a polling bar with a fixed polling interval (seconds).@@ -43,8 +45,8 @@   context <- ask   (drawArea, h) <- verticalBarNew cfg -  liftIO $ do-    _ <- GI.Gtk.onWidgetRealize drawArea $ do+  liftIO $+    manageWidgetThreads drawArea $ do       sampleThread <-         runReaderT           ( taffyForeverWithDelay pollSeconds $@@ -53,7 +55,6 @@                 traverse_ (verticalBarSetPercent h) esample           )           context-      void $ GI.Gtk.onWidgetUnrealize drawArea $ killThread sampleThread-    return ()+      return [sampleThread]    return drawArea

@@ -14,16 +14,16 @@   ) where -import Control.Concurrent import qualified Control.Exception.Enclosed as E-import Control.Monad import Control.Monad.IO.Class (liftIO) import Control.Monad.Trans.Reader (ask, runReaderT) import qualified Data.Text as T import GI.Gtk import System.Taffybar.Context (TaffyIO) import System.Taffybar.Information.Wakeup (taffyForeverWithDelay)+import System.Taffybar.Util (postGUIASync) import System.Taffybar.Widget.Generic.Graph+import System.Taffybar.Widget.Util (manageWidgetThreads)  -- | Construct a polling graph whose callback also supplies tooltip text. pollingGraphNewWithTooltip ::@@ -32,8 +32,8 @@   context <- ask   (graphWidget, graphHandle) <- graphNew cfg -  liftIO $ do-    _ <- onWidgetRealize graphWidget $ do+  liftIO $+    manageWidgetThreads graphWidget $ do       sampleThread <-         runReaderT           ( taffyForeverWithDelay pollSeconds $@@ -43,11 +43,10 @@                   Left _ -> return ()                   Right (sample, tooltipStr) -> do                     graphAddSample graphHandle sample-                    widgetSetTooltipMarkup graphWidget tooltipStr+                    postGUIASync $ widgetSetTooltipMarkup graphWidget tooltipStr           )           context-      void $ onWidgetUnrealize graphWidget $ killThread sampleThread-    return ()+      return [sampleThread]    return graphWidget 

@@ -123,12 +123,12 @@         updateLabelHandlingErrors =           E.tryAny action >>= either (const $ return 1) updateLabel -    _ <- onWidgetRealize label $ do+    manageWidgetThreads label $ do       sampleThread <-         foreverWithVariableDelayWithConfig           (pollingLabelVariableDelayConfig config)           updateLabelHandlingErrors-      void $ onWidgetUnrealize label $ killThread sampleThread+      return [sampleThread]      vFillCenter label     vFillCenter grid

@@ -45,7 +45,7 @@ import qualified System.Taffybar.DBus.Client.MPRIS2 as MPRIS2DBus import System.Taffybar.Information.MPRIS2 import System.Taffybar.Util-import System.Taffybar.Widget.Generic.AutoSizeImage+import System.Taffybar.Widget.Generic.ScalingImage (scalingImage) import System.Taffybar.Widget.Util import System.Taffybar.WindowIcon import Text.Printf@@ -250,9 +250,12 @@   np@(Just NowPlaying {npBusName = busName}) = do     ctx <- ask     client <- asks sessionDBusClient+    (image, _) <-+      scalingImage+        (fmap Just . loadIconAtSize client busName)+        Gtk.OrientationHorizontal     lift $ do       mprisLog DEBUG "Building widget for %s" busName-      image <- autoSizeImageNew (loadIconAtSize client busName) Gtk.OrientationHorizontal       playerBox <- Gtk.gridNew       label <- Gtk.labelNew Nothing       setupPlayerLabel c label@@ -316,9 +319,12 @@   np@(Just nowPlaying@NowPlaying {npBusName = busName}) = do     ctx <- ask     client <- asks sessionDBusClient+    (image, _) <-+      scalingImage+        (fmap Just . loadIconAtSize client busName)+        Gtk.OrientationHorizontal     lift $ do       mprisLog DEBUG "Building widget for %s" busName-      image <- autoSizeImageNew (loadIconAtSize client busName) Gtk.OrientationHorizontal       playerBox <- Gtk.boxNew Gtk.OrientationHorizontal 0       clickArea <- Gtk.boxNew Gtk.OrientationHorizontal 0       controlsBox <- Gtk.boxNew Gtk.OrientationHorizontal 0@@ -476,15 +482,17 @@             busName <- parseBusName name             when (busName `M.member` playerWidgets) doUpdate -      _ <- Gtk.onWidgetRealize grid $ do-        updateHandler <--          DBus.registerForPropertiesChanged client propMatcher signalCallback-        nameHandler <--          DBus.registerForNameOwnerChanged client matchAny handleNameOwnerChanged-        doUpdate-        void $-          Gtk.onWidgetUnrealize grid $-            removeMatch client updateHandler >> removeMatch client nameHandler+      manageWidgetResource+        grid+        ( do+            updateHandler <-+              DBus.registerForPropertiesChanged client propMatcher signalCallback+            nameHandler <-+              DBus.registerForNameOwnerChanged client matchAny handleNameOwnerChanged+            doUpdate+            return (updateHandler, nameHandler)+        )+        (\(updateHandler, nameHandler) -> removeMatch client updateHandler >> removeMatch client nameHandler)        Gtk.widgetShow grid       setPlayingClass

@@ -25,7 +25,7 @@   ) where -import Control.Concurrent (ThreadId, forkIO, killThread)+import Control.Concurrent (ThreadId, forkIO) import Control.Concurrent.MVar (MVar, newMVar, readMVar, swapMVar) import Control.Concurrent.STM (atomically, newTVarIO, readTVarIO, swapTVar) import Control.Concurrent.STM.TChan (TChan, dupTChan, newBroadcastTChanIO, readTChan, writeTChan)@@ -44,6 +44,7 @@   ( UsageWindowLabelParts (..),     UsageWindowPosition (..),     buildIconLabelBox,+    manageWidgetThreads,     widgetSetClassGI,   ) import Text.Printf (printf)@@ -205,12 +206,10 @@     _ <- widgetSetClassGI label (openAIUsageLabelClass config)     updateLabelFromState config label displayState initialSnapshot -    void $ Gtk.onWidgetRealize label $ do+    manageWidgetThreads label $ do       usageThread <- forkUsageListener config label displayState snapshotVar usageChan       modeThread <- forkDisplayModeListener config label displayState snapshotVar-      void $ Gtk.onWidgetUnrealize label $ do-        killThread usageThread-        killThread modeThread+      return [usageThread, modeThread]      Gtk.widgetShowAll label     widget <- Gtk.toWidget label@@ -262,13 +261,13 @@         -- every usage snapshot.         Gtk.widgetDestroy oldMenu -  void $ Gtk.onWidgetRealize ebox $ do+  manageWidgetThreads ebox $ do     menuThread <-       forkCachedMenuUpdater         rebuildMenu         (openAIUsageLabelSnapshotVar parts)         (openAIUsageLabelUsageChan parts)-    void $ Gtk.onWidgetUnrealize ebox $ killThread menuThread+    return [menuThread]    void $     Gtk.onWidgetButtonPressEvent ebox $ \_event -> do

@@ -51,7 +51,7 @@  import Control.Concurrent (forkIO) import Control.Concurrent.STM.TChan-import Control.Monad (void, when)+import Control.Monad (when) import Control.Monad.IO.Class (liftIO) import Control.Monad.STM (atomically) import Data.Default (Default (..))@@ -71,7 +71,7 @@     getPrivacyInfoState,   ) import System.Taffybar.Util (postGUIASync)-import System.Taffybar.Widget.Util (widgetSetClassGI)+import System.Taffybar.Widget.Util (manageWidgetThreads, widgetSetClassGI)  -- | Configuration for the privacy widget. data PrivacyWidgetConfig = PrivacyWidgetConfig@@ -165,16 +165,14 @@     updateWidget initialInfo      -- Connect to channel updates-    void $ Gtk.onWidgetRealize revealer $ do+    manageWidgetThreads revealer $ do       ourChan <- atomically $ dupTChan chan-      void $ Gtk.onWidgetUnrealize revealer $ return ()-      -- Start update thread       let loop = do             info <- atomically $ readTChan ourChan             updateWidget info             loop-      _ <- forkIO loop-      return ()+      listenerThread <- forkIO loop+      return [listenerThread]      Gtk.widgetShowAll revealer     Gtk.toWidget revealer

@@ -18,7 +18,7 @@ -- Utility functions to facilitate building GTK interfaces. module System.Taffybar.Widget.Util where -import Control.Concurrent (forkIO)+import Control.Concurrent (ThreadId, forkIO, killThread) import qualified Control.Concurrent.MVar as MV import Control.Exception.Enclosed (catchAny) import Control.Monad@@ -248,6 +248,35 @@ -- | Run an action forever on a background thread. backgroundLoop :: IO a -> IO () backgroundLoop = void . forkIO . forever++-- | Acquire a resource whenever a widget is realized and release it when the+-- widget is unrealized or destroyed. At most one resource is retained.+manageWidgetResource ::+  (Gtk.IsWidget widget) =>+  widget ->+  IO resource ->+  (resource -> IO ()) ->+  IO ()+manageWidgetResource widget acquire release = do+  resourceVar <- MV.newMVar Nothing+  let releaseCurrent =+        MV.swapMVar resourceVar Nothing >>= mapM_ release+      acquireCurrent = do+        releaseCurrent+        resource <- acquire+        MV.swapMVar resourceVar (Just resource) >>= mapM_ release+  void $ Gtk.onWidgetRealize widget acquireCurrent+  void $ Gtk.onWidgetUnrealize widget releaseCurrent+  void $ Gtk.onWidgetDestroy widget releaseCurrent++-- | Keep worker threads scoped to a widget's realized lifetime.+manageWidgetThreads ::+  (Gtk.IsWidget widget) =>+  widget ->+  IO [ThreadId] ->+  IO ()+manageWidgetThreads widget startThreads =+  manageWidgetResource widget startThreads (mapM_ killThread)  -- | Register an action on widget realization and return the widget. drawOn :: (Gtk.IsWidget object) => object -> IO () -> IO object

@@ -9,10 +9,10 @@   ) where -import Control.Concurrent (forkIO, killThread, threadDelay)+import Control.Concurrent (forkIO, threadDelay) import Control.Concurrent.STM (atomically) import Control.Concurrent.STM.TChan (TChan, readTChan)-import Control.Monad (forever, void, when)+import Control.Monad (forever, when) import Control.Monad.IO.Class (liftIO) import Control.Monad.Trans.Reader (ask, runReaderT) import Data.IORef (IORef, atomicModifyIORef', newIORef, readIORef)@@ -30,7 +30,7 @@     getWakeupSchedulerEvents,   ) import System.Taffybar.Util (postGUIASync)-import System.Taffybar.Widget.Util (onClick, widgetSetClassGI)+import System.Taffybar.Widget.Util (manageWidgetThreads, onClick, widgetSetClassGI)  -- | Configuration for 'wakeupDebugWidgetNewWithConfig'. data WakeupDebugWidgetConfig = WakeupDebugWidgetConfig@@ -96,9 +96,9 @@                in (nextState, nextState)           refreshWidget stateRef label eventBox -    _ <- Gtk.onWidgetRealize eventBox $ do+    manageWidgetThreads eventBox $ do       listenerThread <- forkIO $ wakeupDebugLoop schedulerEvents refreshRegisteredIntervals stateRef label eventBox flashTokenRef config-      void $ Gtk.onWidgetUnrealize eventBox $ killThread listenerThread+      return [listenerThread]      Gtk.widgetShowAll eventBox     Gtk.toWidget eventBox

@@ -1,6 +1,6 @@ cabal-version: 3.4 name: taffybar-version: 7.2.7+version: 7.3.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.@@ -153,6 +153,7 @@                  , System.Taffybar.Information.Bluetooth                  , System.Taffybar.Information.CPU2                  , System.Taffybar.Information.CPUFrequency+                 , System.Taffybar.Information.CPUPower                  , System.Taffybar.Information.ChromeWindowInfo                  , System.Taffybar.Information.Crypto                  , System.Taffybar.Information.DiskIO@@ -402,6 +403,7 @@                , System.Taffybar.ContextSpec                , System.Taffybar.Information.ASUSSpec                , System.Taffybar.Information.CPUFrequencySpec+               , System.Taffybar.Information.CPUPowerSpec                , System.Taffybar.Information.CryptoSpec                , System.Taffybar.Information.LayoutSpec                , System.Taffybar.Information.NvidiaSpec@@ -427,6 +429,7 @@                , filepath                , text                , gi-gtk3+               , gtk-strut                , hspec                , hspec-core                , hspec-golden

@@ -283,6 +283,7 @@ toSimpleConfig GenSimpleConfig {..} =   SimpleTaffyConfig     { monitorsAction = toMonitorsAction monitors,+      barCssClasses = [],       barHeight = size,       barPadding = unGenSpace padding,       barPosition = position,

@@ -0,0 +1,22 @@+module System.Taffybar.Information.CPUPowerSpec (spec) where++import System.Taffybar.Information.CPUPower+import Test.Hspec++spec :: Spec+spec =+  describe "CPU package power calculation" $ do+    it "converts an energy delta over time to watts" $ do+      let previous = EnergySample 10_000_000 1_000_000_000+          current = EnergySample 55_000_000 2_000_000_000+      calculateCPUPowerWatts 100_000_000 previous current `shouldBe` Just 45++    it "accounts for a wrapping energy counter" $ do+      let previous = EnergySample 95_000_000 1_000_000_000+          current = EnergySample 5_000_000 2_000_000_000+      calculateCPUPowerWatts 100_000_000 previous current `shouldBe` Just 10++    it "rejects samples without elapsed time" $ do+      let previous = EnergySample 10_000_000 1_000_000_000+          current = EnergySample 20_000_000 1_000_000_000+      calculateCPUPowerWatts 100_000_000 previous current `shouldBe` Nothing

@@ -2,10 +2,18 @@  module System.Taffybar.SimpleConfigSpec (spec) where -import Data.Maybe (maybeToList)+import Control.Monad.IO.Class (liftIO)+import Control.Monad.Trans.Reader (runReaderT)+import Data.Default (def)+import Data.IORef+import Data.Maybe (fromMaybe, maybeToList)+import Data.Text qualified as T+import Graphics.UI.GIGtkStrut (strutYPadding)+import System.Taffybar.Context qualified as BC import System.Taffybar.ContextSpec (runTaffyDefault) import System.Taffybar.Information.X11DesktopInfo (DisplayName (..)) import System.Taffybar.SimpleConfig+import System.Taffybar.Test.DBusSpec (withTestDBus) import System.Taffybar.Test.XvfbSpec (RROutput (..), RROutputSettings (..), RRSetup (..), setDefaultDisplay_, withRandrSetup, withXdummy) import Test.Hspec import Test.Hspec.QuickCheck@@ -13,10 +21,71 @@ import Test.QuickCheck.Monadic  spec :: Spec-spec = aroundAll_ (withXdummy . flip setDefaultDisplay_) $ do-  -- Pending: Can't run properties without cleaning up buildContext-  xprop "useAllMonitors" prop_useAllMonitors-  xprop "usePrimaryMonitor" prop_usePrimaryMonitor+spec = do+  aroundAll_ withTestDBus $ describe "toTaffybarConfigPerMonitor" $ do+    it "builds distinct monitor geometry and CSS classes" $ do+      let base = defaultSimpleTaffyConfig {monitorsAction = pure [0, 1]}+          config =+            toTaffybarConfigPerMonitor base $ \monitorNumber ->+              pure $+                SimpleMonitorConfig+                  (T.pack $ show monitorNumber)+                  base+                    { barPadding = monitorNumber,+                      barCssClasses = [T.pack $ "monitor-" <> show monitorNumber]+                    }+      barConfigs <- runTaffyWayland $ BC.getBarConfigsParam config+      map BC.barCssClasses barConfigs `shouldBe` [["monitor-0"], ["monitor-1"]]+      map (strutYPadding . BC.strutConfig) barConfigs `shouldBe` [0, 1]++    it "reuses bars while monitor configuration keys are unchanged" $ do+      let base = defaultSimpleTaffyConfig {monitorsAction = pure [0, 1]}+          config =+            toTaffybarConfigPerMonitor base $ \monitorNumber ->+              pure $ SimpleMonitorConfig (T.pack $ show monitorNumber) base+      (first, second) <- runTaffyWayland $ do+        first <- BC.getBarConfigsParam config+        second <- BC.getBarConfigsParam config+        pure (first, second)+      map BC.barId second == map BC.barId first `shouldBe` True++    it "rebuilds only the monitor whose configuration key changed" $ do+      keysRef <- newIORef [(0, "zero"), (1, "one")]+      let base = defaultSimpleTaffyConfig {monitorsAction = pure [0, 1]}+          monitorConfig monitorNumber = do+            keys <- liftIO $ readIORef keysRef+            pure $ SimpleMonitorConfig (fromMaybe "" $ lookup monitorNumber keys) base+          config = toTaffybarConfigPerMonitor base monitorConfig+      (first, second) <- runTaffyWayland $ do+        first <- BC.getBarConfigsParam config+        liftIO $ writeIORef keysRef [(0, "changed"), (1, "one")]+        second <- BC.getBarConfigsParam config+        pure (first, second)+      zipWith (/=) (map BC.barId second) (map BC.barId first) `shouldBe` [True, False]++    it "purges removed monitors from the bar cache" $ do+      monitorsRef <- newIORef [0, 1]+      let base = defaultSimpleTaffyConfig {monitorsAction = liftIO $ readIORef monitorsRef}+          config =+            toTaffybarConfigPerMonitor base $ \monitorNumber ->+              pure $ SimpleMonitorConfig (T.pack $ show monitorNumber) base+      (first, third) <- runTaffyWayland $ do+        first <- BC.getBarConfigsParam config+        liftIO $ writeIORef monitorsRef [0]+        _ <- BC.getBarConfigsParam config+        liftIO $ writeIORef monitorsRef [0, 1]+        third <- BC.getBarConfigsParam config+        pure (first, third)+      zipWith (/=) (map BC.barId third) (map BC.barId first) `shouldBe` [False, True]++  aroundAll_ (withXdummy . flip setDefaultDisplay_) $ do+    -- Pending: Can't run properties without cleaning up buildContext+    xprop "useAllMonitors" prop_useAllMonitors+    xprop "usePrimaryMonitor" prop_usePrimaryMonitor++runTaffyWayland :: BC.TaffyIO a -> IO a+runTaffyWayland action =+  BC.buildContextWithBackend BC.BackendWayland def >>= runReaderT action  prop_useAllMonitors :: RRSetup -> Property prop_useAllMonitors rr = monadicIO $ do