packages feed

taffybar 4.1.1 → 4.1.2

raw patch · 78 files changed

+11252/−268 lines, 78 filesdep +JuicyPixelsdep +dbus-menudep +disk-free-spacedep ~X11dep ~dbus-hsloggerdep ~gi-gdk3new-component:exe:taffybar-appearance-snapnew-component:exe:taffybar-appearance-snap-hyprlandnew-component:exe:taffybar-test-wmbinary-added

Dependencies added: JuicyPixels, dbus-menu, disk-free-space, gi-gtk-layer-shell, monad-control, network, xmonad-contrib, yaml

Dependency ranges changed: X11, dbus-hslogger, gi-gdk3, gi-gdkpixbuf, gi-gtk3, gtk-strut, scotty, transformers

Files

CHANGELOG.md view
@@ -1,3 +1,17 @@+# Unreleased++# 4.1.2++## Improvements++ * Relax scotty upper bound to < 0.31.++## Documentation++ * Document that the PulseAudio Audio widget requires PulseAudio's DBus protocol+   to be enabled (load @module-dbus-protocol@), otherwise it may display+   @vol: n/a@.+ # 4.1.1  ## Improvements
README.md view
@@ -4,11 +4,16 @@  ## Summary  -Taffybar is a desktop-information bar, intended primarily for use with [XMonad][], though it can also-function alongside other EWMH compliant window managers. It is similar in spirit-to [xmobar][], but it differs in that it gives up some simplicity for a reasonable-helping of [GTK 3][] eye candy.+Taffybar is a desktop information bar, intended primarily for use with+[XMonad][], though it can also function alongside other EWMH compliant window+managers. It is similar in spirit to [xmobar][], but it differs in that it gives+up some simplicity for a reasonable helping of [GTK 3][] eye candy.++Taffybar also supports running under Wayland via `gtk-layer-shell`. Wayland+support is currently compositor-specific for some widgets, with Hyprland+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.  [![Screenshot](https://raw.githubusercontent.com/taffybar/taffybar/master/doc/screenshot.png)](https://github.com/taffybar/taffybar/blob/master/doc/screenshot.png)
+ app/AppearanceSnap.hs view
@@ -0,0 +1,476 @@+{-# LANGUAGE OverloadedStrings #-}++-- Helper executable for the appearance golden test.+--+-- This is intentionally a separate process from the Hspec runner because+-- 'startTaffybar' enters the GTK main loop (an FFI call) and is not reliably+-- interruptible by async exceptions. The Hspec test can always timeout/kill+-- this executable in CI.+module Main (main) where++import Control.Concurrent (MVar, forkIO, newEmptyMVar, threadDelay, takeMVar)+import Control.Concurrent.MVar (readMVar, tryPutMVar, tryReadMVar)+import Control.Exception (SomeException, bracket, try)+import Control.Monad (filterM, unless, void, when)+import Control.Monad.IO.Class (liftIO)+import Control.Monad.Trans.Reader (ask)+import Data.Bits ((.|.), shiftL)+import Data.Default (def)+import Data.Maybe (listToMaybe)+import Data.Unique (newUnique)+import qualified Data.Text as T+import System.Directory (createDirectoryIfMissing, doesFileExist, findExecutable, makeAbsolute)+import System.Environment (getArgs, setEnv, unsetEnv)+import System.Exit (ExitCode (..), exitWith)+import System.FilePath (takeDirectory, (</>))+import System.Info (arch, os)+import System.IO (hPutStrLn, stderr)+import Data.Word (Word32)++import UnliftIO.Temporary (withSystemTempDirectory)++import Foreign.C.Types (CLong)+import System.Posix.Process (exitImmediately)+import System.Posix.Signals (signalProcess, sigKILL, sigTERM)++import qualified Codec.Picture as JP+import qualified Data.ByteString as B+import qualified Data.ByteString.Lazy as BL++import qualified GI.Gdk as Gdk+import qualified GI.GdkPixbuf.Objects.Pixbuf as PB+import qualified GI.Gtk as Gtk++import Graphics.X11.Xlib+  ( Atom+  , Display+  , Window+  , closeDisplay+  , createSimpleWindow+  , defaultRootWindow+  , internAtom+  , mapWindow+  , openDisplay+  , storeName+  , sync+  )+import Graphics.X11.Xlib.Extras+  ( ClassHint (..)+  , changeProperty32+  , getWindowProperty32+  , propModeReplace+  , setClassHint+  )++import Graphics.UI.GIGtkStrut+  ( StrutConfig (..)+  , StrutPosition (TopPos)+  , StrutSize (ExactSize)+  , defaultStrutConfig+  )+import System.Posix.Files (createSymbolicLink, removeLink)+import System.Process.Typed (Process, getPid, proc, startProcess)++import System.Taffybar (startTaffybar)+import System.Taffybar.Context+  ( BarConfig (..)+  , Context (..)+  , TaffyIO+  , TaffybarConfig (..)+  , exitTaffybar+  )+import System.Taffybar.Util (postGUIASync)+import System.Taffybar.Widget.Workspaces+  ( WorkspacesConfig (..)+  , getWindowIconPixbufFromEWMH+  , sortWindowsByStackIndex+  , workspacesNew+  )++data Args = Args+  { outFile :: FilePath+  , cssFile :: FilePath+  }++main :: IO ()+main = do+  Args { outFile = outPath, cssFile = cssPath } <- parseArgs =<< getArgs++  -- Force X11 backend selection even if the surrounding session is Wayland.+  unsetEnv "WAYLAND_DISPLAY"+  unsetEnv "HYPRLAND_INSTANCE_SIGNATURE"+  setEnv "XDG_SESSION_TYPE" "x11"+  setEnv "GDK_BACKEND" "x11"+  setEnv "GDK_SCALE" "1"+  setEnv "GDK_DPI_SCALE" "1"+  setEnv "GTK_CSD" "0"+  setEnv "GTK_THEME" "Adwaita"+  setEnv "NO_AT_BRIDGE" "1"+  setEnv "GSETTINGS_BACKEND" "memory"++  ec <- withSystemTempDirectory "taffybar-appearance-snap" $ \tmp -> do+    let runtimeDir = tmp </> "xdg-run"+    createDirectoryIfMissing True runtimeDir+    setEnv "XDG_RUNTIME_DIR" runtimeDir++    wmExePath <-+      findComponentExecutable+        "taffybar-test-wm"+        [ "dist/build/taffybar-test-wm/taffybar-test-wm"+        ]++    -- XMonad expects the running binary to be named like xmonad-<arch>-<os>.+    -- If it isn't, it tries to re-exec (and can fail in CI).+    let expectedName = "xmonad-" ++ arch ++ "-" ++ os+        linkPath = tmp </> expectedName+    void (try (removeLink linkPath) :: IO (Either SomeException ()))+    createSymbolicLink wmExePath linkPath++    let wmCfg = proc linkPath []+    wmProc <- startProcess wmCfg+    waitForEwmh 10_000_000+    -- Best-effort cleanup. We do not wait for the WM process here because+    -- 'waitForProcess' can fail with ECHILD in some CI environments.+    --+    -- If this fails, the parent Xvfb teardown will still kill the X server,+    -- which causes the WM to exit.+    res <- runUnderWm wmProc outPath cssPath+    killProcessNoWait wmProc+    pure res++  exitWith ec++runUnderWm :: Process () () () -> FilePath -> FilePath -> IO ExitCode+runUnderWm wmProc outPath cssPath = do+  ctxVar <- (newEmptyMVar :: IO (MVar Context))+  resultVar <- (newEmptyMVar :: IO (MVar (Either String BL.ByteString)))+  doneVar <- (newEmptyMVar :: IO (MVar ExitCode))++  createDirectoryIfMissing True (takeDirectory outPath)++  -- Writes the result out and requests bar shutdown.+  void $ forkIO $ finalizeThread ctxVar resultVar doneVar outPath++  -- Hard watchdog for CI stability: always tries to end the GTK loop, and+  -- stops the WM as a last resort.+  void $ forkIO $ watchdogThread wmProc ctxVar resultVar doneVar 30_000_000++  barUnique <- newUnique+  let wsCfg =+        (def :: WorkspacesConfig)+          -- Avoid font-dependent output in the appearance golden: we only care+          -- that icons/layout render deterministically.+          { labelSetter = const (pure "")+          , maxIcons = Just 1+          , minIcons = 1+          , getWindowIconPixbuf = getWindowIconPixbufFromEWMH+          , iconSort = sortWindowsByStackIndex+          }+      barCfg =+        BarConfig+          { strutConfig =+              defaultStrutConfig+                { strutHeight = ExactSize 40+                , strutMonitor = Just 0+                , strutPosition = TopPos+                }+          , widgetSpacing = 8+          , startWidgets = [workspacesNew wsCfg]+          , centerWidgets = [testBoxWidget "test-center-box" 200 20]+          , endWidgets =+              [ testBoxWidget "test-pill" 52 20+              , testBoxWidget "test-pill" 52 20+              , testBoxWidget "test-right-box" 16 16+              ]+          , barId = barUnique+          }+      cfg =+        def+          { dbusClientParam = Nothing+          , cssPaths = [cssPath]+          , getBarConfigsParam = pure [barCfg]+          , startupHook = scheduleSnapshot ctxVar resultVar+          , errorMsg = Nothing+          }++  withTestWindows $ do+    -- Blocks in Gtk.main until we request shutdown.+    startTaffybar cfg++    -- Should have been set by finalizeThread or watchdogThread.+    takeMVar doneVar++testBoxWidget :: T.Text -> Int -> Int -> TaffyIO Gtk.Widget+testBoxWidget klass w h = liftIO $ do+  box <- Gtk.eventBoxNew+  widget <- Gtk.toWidget box+  Gtk.widgetSetSizeRequest widget (fromIntegral w) (fromIntegral h)+  sc <- Gtk.widgetGetStyleContext widget+  Gtk.styleContextAddClass sc klass+  -- Taffybar does not automatically show arbitrary user widgets; most built-in+  -- widgets call show/showAll themselves. For deterministic appearance tests,+  -- ensure these test widgets are visible.+  Gtk.widgetShowAll widget+  pure widget++withTestWindows :: IO a -> IO a+withTestWindows action =+  bracket setup closeDisplay (const action)+  where+    setup :: IO Display+    setup = do+      d <- openDisplay ""+      let root = defaultRootWindow d+      iconAtom <- internAtom d "_NET_WM_ICON" False+      cardinalAtom <- internAtom d "CARDINAL" False++      -- Create two managed windows with deterministic EWMH icons so the+      -- workspaces widget exercises its icon rendering path in CI.+      --+      -- Important: keep the X11 connection open until the snapshot is taken.+      -- X11 resources are owned by the client; closing the Display would+      -- destroy the windows.+      w1 <- createSimpleWindow d root 10 60 150 100 0 0 0+      w2 <- createSimpleWindow d root 170 60 150 100 0 0 0+      storeName d w1 "taffybar-test-1"+      storeName d w2 "taffybar-test-2"+      setClassHint d w1 (ClassHint "redwin" "RedWin")+      setClassHint d w2 (ClassHint "greenwin" "GreenWin")++      let setIcon win px =+            changeProperty32+              d+              win+              iconAtom+              cardinalAtom+              propModeReplace+              (ewmhIconDataSolid 16 16 px)++      setIcon w1 (argb 0xFF 0xE0 0x3A 0x3A) -- red+      setIcon w2 (argb 0xFF 0x3A 0xE0 0x6A) -- green++      mapWindow d w1+      mapWindow d w2+      sync d False++      -- Give the WM a moment to manage/map and publish EWMH properties.+      threadDelay 300_000+      pure d++argb :: Word32 -> Word32 -> Word32 -> Word32 -> Word32+argb a r g b = shiftL a 24 .|. shiftL r 16 .|. shiftL g 8 .|. b++ewmhIconDataSolid :: Int -> Int -> Word32 -> [CLong]+ewmhIconDataSolid w h px =+  let header = [fromIntegral w, fromIntegral h]+      pixels = replicate (w * h) (fromIntegral px)+   in header ++ pixels++scheduleSnapshot :: MVar Context -> MVar (Either String BL.ByteString) -> TaffyIO ()+scheduleSnapshot ctxVar resultVar = do+  ctx <- ask+  liftIO $ void (tryPutMVar ctxVar ctx)+  liftIO $ void $ forkIO (pollLoop ctx)+  where+    pollLoop ctx' = do+      done <- tryReadMVar resultVar+      case done of+        Just _ -> pure ()+        Nothing -> do+          postGUIASync (trySnapshotOnGuiThread ctx' resultVar)+          threadDelay 50_000+          pollLoop ctx'++finalizeThread+  :: MVar Context+  -> MVar (Either String BL.ByteString)+  -> MVar ExitCode+  -> FilePath+  -> IO ()+finalizeThread ctxVar resultVar doneVar outPath = do+  res <- takeMVar resultVar+  case res of+    Left msg -> do+      BL.writeFile outPath (BL.fromStrict B.empty)+      hPutStrLn stderr msg+      void $ tryPutMVar doneVar (ExitFailure 1)+    Right png -> do+      BL.writeFile outPath png+      void $ tryPutMVar doneVar ExitSuccess++  mCtx <- tryReadMVar ctxVar+  case mCtx of+    Nothing -> pure ()+    Just ctx -> void (try (exitTaffybar ctx) :: IO (Either SomeException ()))++watchdogThread+  :: Process () () ()+  -> MVar Context+  -> MVar (Either String BL.ByteString)+  -> MVar ExitCode+  -> Int+  -> IO ()+watchdogThread wmProc ctxVar resultVar doneVar usec = do+  threadDelay usec+  didSet <- tryPutMVar resultVar (Left "Timed out waiting for appearance snapshot")+  when didSet $ void $ tryPutMVar doneVar (ExitFailure 124)+  mCtx <- tryReadMVar ctxVar+  case mCtx of+    Nothing -> pure ()+    Just ctx -> void (try (exitTaffybar ctx) :: IO (Either SomeException ()))+  killProcessNoWait wmProc+  -- If the GTK loop doesn't exit promptly, force the process to end so+  -- the Hspec runner never hangs.+  threadDelay 2_000_000+  exitImmediately (ExitFailure 124)++killProcessNoWait :: Process () () () -> IO ()+killProcessNoWait p = do+  mpid <- getPid p+  case mpid of+    Nothing -> pure ()+    Just pid -> do+      -- Best-effort: TERM, then KILL shortly after.+      void (try (signalProcess sigTERM pid) :: IO (Either SomeException ()))+      threadDelay 250_000+      void (try (signalProcess sigKILL pid) :: IO (Either SomeException ()))++findComponentExecutable :: String -> [FilePath] -> IO FilePath+findComponentExecutable name localCandidates = do+  mexe <- findExecutable name+  case mexe of+    Just exe -> makeAbsolute exe+    Nothing -> do+      existing <- filterM doesFileExist localCandidates+      case existing of+        (p:_) -> makeAbsolute p+        [] -> die (name ++ " not found on PATH")++waitForEwmh :: Int -> IO ()+waitForEwmh maxUsec = do+  let stepUsec = 50_000+      maxSteps = maxUsec `div` stepUsec+  ed <- try (openDisplay "") :: IO (Either SomeException Display)+  d <- either (const (die "Failed to open X11 display (DISPLAY unset?)")) pure ed+  let root = defaultRootWindow d+  atom <- internAtom d "_NET_NUMBER_OF_DESKTOPS" False+  ok <- go d root atom 0 maxSteps+  closeDisplay d+  unless ok $ die "Timed out waiting for EWMH WM"+  where+    go :: Display -> Window -> Atom -> Int -> Int -> IO Bool+    go d root atom n maxSteps' = do+      r <- try (getWindowProperty32 d atom root) :: IO (Either SomeException (Maybe [CLong]))+      case r of+        Right (Just _) -> pure True+        _ ->+          if n > maxSteps'+            then pure False+            else threadDelay 50_000 >> go d root atom (n + 1) maxSteps'++trySnapshotOnGuiThread :: Context -> MVar (Either String BL.ByteString) -> IO ()+trySnapshotOnGuiThread ctx resultVar = do+  -- Read the windows list and snapshot the first bar window.+  ws <- readMVar (existingWindows ctx)+  case listToMaybe ws of+    Nothing -> pure ()+    Just (_, win) -> do+      mImg <- try (snapshotGtkWindowImageRGBA8 win) :: IO (Either SomeException (JP.Image JP.PixelRGBA8))+      case mImg of+        Left _ -> pure ()+        Right img ->+          -- Don't accept a snapshot until the workspace icons and basic bar+          -- styling are actually rendered, otherwise we can end up with a+          -- largely transparent screenshot that doesn't exercise much beyond+          -- the icon path.+          when (imageHasTestIcons img) $+            void (tryPutMVar resultVar (Right (JP.encodePng img)))++imageHasTestIcons :: JP.Image JP.PixelRGBA8 -> Bool+imageHasTestIcons img =+  let tol :: Int+      tol = 40+      opaqueThreshold :: Int+      opaqueThreshold = 5000+      near (JP.PixelRGBA8 r g b a) (tr, tg, tb) =+        a > 200 &&+        abs (fromIntegral r - tr) <= tol &&+        abs (fromIntegral g - tg) <= tol &&+        abs (fromIntegral b - tb) <= tol+      redTarget :: (Int, Int, Int)+      redTarget = (224, 58, 58)+      greenTarget :: (Int, Int, Int)+      greenTarget = (58, 224, 106)+      w = JP.imageWidth img+      h = JP.imageHeight img+      go y seenR seenG opaqueCount+        | y >= h = seenR && seenG && opaqueCount > opaqueThreshold+        | otherwise =+            let goX x sr sg oc+                  | x >= w = go (y + 1) sr sg oc+                  | otherwise =+                      let px = JP.pixelAt img x y+                          sr1 = sr || near px redTarget+                          sg1 = sg || near px greenTarget+                          oc1 =+                            oc+                              + (case px of JP.PixelRGBA8 _ _ _ a -> if a > 200 then 1 else 0)+                       in (sr1 && sg1 && oc1 > opaqueThreshold) || goX (x + 1) sr1 sg1 oc1+             in goX 0 seenR seenG opaqueCount+   in go 0 False False (0 :: Int)++snapshotGtkWindowImageRGBA8 :: Gtk.Window -> IO (JP.Image JP.PixelRGBA8)+snapshotGtkWindowImageRGBA8 win = do+  drainGtkEvents 200++  mw <- Gtk.widgetGetWindow win+  gdkWindow <- maybe (fail "No GdkWindow for Gtk.Window") pure mw++  w <- fromIntegral <$> Gtk.widgetGetAllocatedWidth win+  h <- fromIntegral <$> Gtk.widgetGetAllocatedHeight win+  when (w <= 0 || h <= 0) $ fail "Window has invalid size"++  mpb <- Gdk.pixbufGetFromWindow gdkWindow 0 0 w h+  pb <- maybe (fail "Failed to capture pixbuf from window") pure mpb++  pixbufToImageRGBA8 pb++pixbufToImageRGBA8 :: PB.Pixbuf -> IO (JP.Image JP.PixelRGBA8)+pixbufToImageRGBA8 pb = do+  w <- fromIntegral <$> PB.pixbufGetWidth pb+  h <- fromIntegral <$> PB.pixbufGetHeight pb+  rowstride <- fromIntegral <$> PB.pixbufGetRowstride pb+  nChannels <- fromIntegral <$> PB.pixbufGetNChannels pb+  hasAlpha <- PB.pixbufGetHasAlpha pb+  pixels <- PB.pixbufGetPixels pb++  let aIndex = if hasAlpha then 3 else (-1)+      pxAt x y =+        let base = y * rowstride + x * nChannels+            r = B.index pixels (base + 0)+            g = B.index pixels (base + 1)+            b = B.index pixels (base + 2)+            a = if aIndex >= 0 then B.index pixels (base + aIndex) else 255+         in JP.PixelRGBA8 r g b a++  pure (JP.generateImage pxAt w h)++drainGtkEvents :: Int -> IO ()+drainGtkEvents 0 = pure ()+drainGtkEvents n = do+  pendingEvents <- Gtk.eventsPending+  when pendingEvents $ do+    _ <- Gtk.mainIterationDo False+    drainGtkEvents (n - 1)++parseArgs :: [String] -> IO Args+parseArgs args =+  case args of+    ["--out", outPath, "--css", cssPath] -> pure Args { outFile = outPath, cssFile = cssPath }+    ["--css", cssPath, "--out", outPath] -> pure Args { outFile = outPath, cssFile = cssPath }+    _ -> die "usage: taffybar-appearance-snap --out OUT.png --css appearance-test.css"++die :: String -> IO a+die msg = do+  hPutStrLn stderr msg+  fail msg
+ app/AppearanceSnapHyprland.hs view
@@ -0,0 +1,327 @@+{-# LANGUAGE OverloadedStrings #-}++-- Helper executable for the Hyprland (Wayland) appearance golden test.+--+-- This is intentionally a separate process from the Hspec runner because+-- 'startTaffybar' enters the GTK main loop (an FFI call) and is not reliably+-- interruptible by async exceptions. The VM harness can always timeout/kill+-- this executable in CI.+module Main (main) where++import Control.Concurrent (MVar, forkIO, newEmptyMVar, threadDelay, takeMVar)+import Control.Concurrent.MVar (tryPutMVar, tryReadMVar)+import Control.Exception (SomeException, try)+import Control.Monad (void)+import Control.Monad.IO.Class (liftIO)+import Control.Monad.Trans.Reader (ask)+import Data.Default (def)+import Data.IORef (IORef, newIORef, readIORef, writeIORef)+import Data.Unique (newUnique)+import System.Directory+  ( createDirectoryIfMissing+  , findExecutable+  , makeAbsolute+  )+import System.Environment (getArgs, lookupEnv, setEnv, unsetEnv)+import System.Exit (ExitCode (..), exitWith)+import System.FilePath (takeDirectory, (</>))+import System.IO (hPutStrLn, stderr)+import System.Posix.Process (exitImmediately)++import qualified Codec.Picture as JP+import qualified Data.ByteString as B+import qualified Data.ByteString.Lazy as BL+import qualified Data.Text as T+import UnliftIO.Temporary (withSystemTempDirectory)++import System.Process.Typed+  ( proc+  , readProcess+  )++import qualified GI.Gtk as Gtk++import Graphics.UI.GIGtkStrut+  ( StrutConfig (..)+  , StrutPosition (TopPos)+  , StrutSize (ExactSize)+  , defaultStrutConfig+  )++import System.Taffybar (startTaffybar)+import System.Taffybar.Context+  ( BarConfig (..)+  , Context (..)+  , TaffyIO+  , TaffybarConfig (..)+  , exitTaffybar+  )++data Args = Args+  { outFile :: FilePath+  , cssFile :: FilePath+  }++main :: IO ()+main = do+  Args { outFile = outPath, cssFile = cssPath } <- parseArgs =<< getArgs++  -- Reduce variability (but do not clobber WAYLAND_DISPLAY / XDG_RUNTIME_DIR /+  -- HYPRLAND_INSTANCE_SIGNATURE; those are provided by the compositor session).+  unsetEnv "DISPLAY"+  setEnv "GDK_BACKEND" "wayland"+  setEnv "XDG_SESSION_TYPE" "wayland"+  setEnv "GDK_SCALE" "1"+  setEnv "GDK_DPI_SCALE" "1"+  setEnv "GTK_CSD" "0"+  setEnv "GTK_THEME" "Adwaita"+  setEnv "NO_AT_BRIDGE" "1"+  setEnv "GSETTINGS_BACKEND" "memory"++  _ <- requireEnv "XDG_RUNTIME_DIR"+  _ <- requireEnv "WAYLAND_DISPLAY"+  _ <- requireEnv "HYPRLAND_INSTANCE_SIGNATURE"+  _ <- requireExe "grim"++  ec <- withSystemTempDirectory "tb-hyprland" $ \tmp -> do+    let homeDir = tmp </> "home"+        xdgCfg = homeDir </> "xdg-config"+        xdgCache = homeDir </> "xdg-cache"+        xdgData = homeDir </> "xdg-data"++    createDirectoryIfMissing True homeDir+    createDirectoryIfMissing True xdgCfg+    createDirectoryIfMissing True xdgCache+    createDirectoryIfMissing True xdgData++    setEnv "HOME" homeDir+    setEnv "XDG_CONFIG_HOME" xdgCfg+    setEnv "XDG_CACHE_HOME" xdgCache+    setEnv "XDG_DATA_HOME" xdgData++    createDirectoryIfMissing True (takeDirectory outPath)++    runUnderHyprland outPath cssPath++  exitWith ec++runUnderHyprland :: FilePath -> FilePath -> IO ExitCode+runUnderHyprland outPath cssPath = do+  ctxVar :: MVar Context <- newEmptyMVar+  resultVar :: MVar (Either String BL.ByteString) <- newEmptyMVar+  doneVar :: MVar ExitCode <- newEmptyMVar+  lastShotRef :: IORef (Maybe BL.ByteString) <- newIORef Nothing++  -- Writes the result out and requests bar shutdown.+  void $ forkIO $ finalizeThread ctxVar resultVar doneVar outPath++  -- Hard watchdog for CI stability: always tries to end the GTK loop.+  void $ forkIO $ watchdogThread ctxVar resultVar doneVar lastShotRef 30_000_000++  barUnique <- newUnique++  let barCfg =+        BarConfig+          { strutConfig =+              defaultStrutConfig+                { strutHeight = ExactSize 40+                , strutMonitor = Just 0+                , strutPosition = TopPos+                }+          , widgetSpacing = 8+          , startWidgets = [testPillBoxWidget "test-pill" 56 20]+          , centerWidgets = [testBoxWidget "test-center-box" 200 20]+          , endWidgets =+              [ testPillBoxWidget "test-pill" 52 20+              , testPillBoxWidget "test-pill" 46 20+              , testBoxWidget "test-right-box" 16 16+              ]+          , barId = barUnique+          }++      cfg =+        def+          { dbusClientParam = Nothing+          , cssPaths = [cssPath]+          , getBarConfigsParam = pure [barCfg]+          , startupHook = scheduleSnapshot ctxVar resultVar lastShotRef+          , errorMsg = Nothing+          }++  -- Blocks in Gtk.main until we request shutdown.+  startTaffybar cfg++  -- Should have been set by finalizeThread or watchdogThread.+  takeMVar doneVar++testBoxWidget :: T.Text -> Int -> Int -> TaffyIO Gtk.Widget+testBoxWidget klass w h = liftIO $ do+  box <- Gtk.eventBoxNew+  widget <- Gtk.toWidget box+  Gtk.widgetSetSizeRequest widget (fromIntegral w) (fromIntegral h)+  sc <- Gtk.widgetGetStyleContext widget+  Gtk.styleContextAddClass sc klass+  Gtk.widgetShowAll widget+  pure widget++testPillBoxWidget :: T.Text -> Int -> Int -> TaffyIO Gtk.Widget+testPillBoxWidget klass w h = liftIO $ do+  box <- Gtk.eventBoxNew+  widget <- Gtk.toWidget box+  Gtk.widgetSetSizeRequest widget (fromIntegral w) (fromIntegral h)+  sc <- Gtk.widgetGetStyleContext widget+  Gtk.styleContextAddClass sc klass+  Gtk.widgetShowAll widget+  pure widget++scheduleSnapshot :: MVar Context -> MVar (Either String BL.ByteString) -> IORef (Maybe BL.ByteString) -> TaffyIO ()+scheduleSnapshot ctxVar resultVar lastShotRef = do+  ctx <- ask+  liftIO $ void (tryPutMVar ctxVar ctx)++  -- Delay slightly to give the compositor time to map the layer-surface and+  -- for widgets to render.+  liftIO $ void $ forkIO $ do+    threadDelay 2_000_000+    -- Require two consecutive identical frames to avoid capturing during+    -- initial GTK/compositor settling (animations, late mapping, etc).+    takeSnapshotWithRetries lastShotRef resultVar 60++takeSnapshotWithRetries :: IORef (Maybe BL.ByteString) -> MVar (Either String BL.ByteString) -> Int -> IO ()+takeSnapshotWithRetries _ resultVar 0 =+  void $ tryPutMVar resultVar (Left "Failed to capture Hyprland appearance snapshot")+takeSnapshotWithRetries lastShotRef resultVar n = do+  done <- tryReadMVar resultVar+  case done of+    Just _ -> pure ()+    Nothing -> do+      shot <- takeSnapshot+      case shot of+        Left _ -> do+          threadDelay 200_000+          takeSnapshotWithRetries lastShotRef resultVar (n - 1)+        Right encoded -> do+          prev <- readIORef lastShotRef+          writeIORef lastShotRef (Just encoded)+          case prev of+            Just prevEncoded | prevEncoded == encoded ->+              void $ tryPutMVar resultVar (Right encoded)+            _ -> do+              threadDelay 200_000+              takeSnapshotWithRetries lastShotRef resultVar (n - 1)++takeSnapshot :: IO (Either String BL.ByteString)+takeSnapshot =+  withSystemTempDirectory "tbshot" $ \tmp -> do+    let shotPath = tmp </> "shot.png"+    e <-+      try (readProcess (proc "grim" ["-s", "1", "-l", "1", "-g", "0,0 1024x40", shotPath]))+        :: IO (Either SomeException (ExitCode, BL.ByteString, BL.ByteString))+    case e of+      Left _ -> pure (Left ("grim failed" :: String))+      Right (ec, _stdout, _stderr) ->+        case ec of+          ExitFailure _ -> pure (Left ("grim failed" :: String))+          ExitSuccess -> do+            png <- BL.readFile shotPath+            case JP.decodePng (BL.toStrict png) of+              Left _ -> pure (Left "PNG decode failed")+              Right dyn ->+                let img = JP.convertRGBA8 dyn+                 in+                  if hasExpectedMarkers img+                    then pure (Right (JP.encodePng img))+                    else pure (Left "Expected marker colors not present (bar likely not rendered yet)")++hasExpectedMarkers :: JP.Image JP.PixelRGBA8 -> Bool+hasExpectedMarkers img =+  -- These solid colors come from test/data/appearance-test.css and are chosen+  -- specifically so we can detect when the bar has actually rendered.+  let centerBox = JP.PixelRGBA8 0x3a 0x3a 0x3a 0xff+      rightBox = JP.PixelRGBA8 0x3a 0x5a 0x7a 0xff+      centerCount = countColor img centerBox+      rightCount = countColor img rightBox+   in centerCount >= 200 && rightCount >= 50++countColor :: JP.Image JP.PixelRGBA8 -> JP.PixelRGBA8 -> Int+countColor img needle =+  let w = JP.imageWidth img+      h = JP.imageHeight img+   in+    length+      [ ()+      | y <- [0 .. h - 1]+      , x <- [0 .. w - 1]+      , JP.pixelAt img x y == needle+      ]++finalizeThread+  :: MVar Context+  -> MVar (Either String BL.ByteString)+  -> MVar ExitCode+  -> FilePath+  -> IO ()+finalizeThread ctxVar resultVar doneVar outPath = do+  res <- takeMVar resultVar+  case res of+    Left msg -> do+      BL.writeFile outPath (BL.fromStrict B.empty)+      hPutStrLn stderr msg+      void $ tryPutMVar doneVar (ExitFailure 1)+    Right png -> do+      BL.writeFile outPath png+      void $ tryPutMVar doneVar ExitSuccess++  mCtx <- tryReadMVar ctxVar+  case mCtx of+    Nothing -> pure ()+    Just ctx -> void (try (exitTaffybar ctx) :: IO (Either SomeException ()))++watchdogThread+  :: MVar Context+  -> MVar (Either String BL.ByteString)+  -> MVar ExitCode+  -> IORef (Maybe BL.ByteString)+  -> Int+  -> IO ()+watchdogThread ctxVar resultVar doneVar lastShotRef usec = do+  threadDelay usec+  void $ tryPutMVar doneVar (ExitFailure 124)+  lastShot <- readIORef lastShotRef+  let payload =+        case lastShot of+          Just png -> Right png+          Nothing -> Left "Timed out waiting for Hyprland appearance snapshot"+  void $ tryPutMVar resultVar payload+  mCtx <- tryReadMVar ctxVar+  case mCtx of+    Nothing -> pure ()+    Just ctx -> void (try (exitTaffybar ctx) :: IO (Either SomeException ()))+  -- If the GTK loop doesn't exit promptly, force the process to end so the+  -- harness never hangs.+  threadDelay 2_000_000+  exitImmediately (ExitFailure 124)++requireExe :: String -> IO FilePath+requireExe name = do+  mexe <- findExecutable name+  maybe (fail (name ++ " not found on PATH")) makeAbsolute mexe++requireEnv :: String -> IO String+requireEnv name = do+  v <- lookupEnv name+  case v of+    Nothing -> die ("Required environment variable missing: " ++ name)+    Just s -> pure s++parseArgs :: [String] -> IO Args+parseArgs args =+  case args of+    ["--out", outPath, "--css", cssPath] -> pure Args { outFile = outPath, cssFile = cssPath }+    ["--css", cssPath, "--out", outPath] -> pure Args { outFile = outPath, cssFile = cssPath }+    _ -> fail "usage: taffybar-appearance-snap-hyprland --out OUT.png --css appearance-test.css"++die :: String -> IO a+die msg = do+  hPutStrLn stderr msg+  fail msg
app/Main.hs view
@@ -50,8 +50,14 @@   -- XXX: The configuration record here does not get used, this just calls in to dyre.   then dyreTaffybar def   else do+    detectedBackend <- detectBackend+    let exampleConfig = case detectedBackend of+          BackendWayland -> exampleWaylandTaffybarConfig+          BackendX11 -> exampleTaffybarConfig     logM "System.Taffybar" WARNING            (  printf "No taffybar configuration file found at %s." taffyFilepath-           ++ " Starting with example configuration."+           ++ " Starting with example configuration for "+           ++ show detectedBackend+           ++ "."            )-    startTaffybar exampleTaffybarConfig+    startTaffybar exampleConfig
+ app/TestWM.hs view
@@ -0,0 +1,30 @@+module Main (main) where++import XMonad (def, manageHook, xmonad)+import XMonad.Hooks.EwmhDesktops (ewmh, ewmhFullscreen)+import XMonad.Hooks.ManageDocks (docks)+import XMonad.ManageHook+  ( (-->)+  , (<+>)+  , className+  , composeAll+  , doShift+  , (=?)+  )++-- Minimal EWMH-compliant WM used by CI appearance tests.+--+-- This is a normal executable so the tests can start a WM without invoking+-- xmonad's usual runtime recompilation of ~/.xmonad/xmonad.hs.+main :: IO ()+main =+  xmonad $+    ewmhFullscreen $+      ewmh $+        docks $+          def+            { manageHook =+                composeAll+                  [ className =? "GreenWin" --> doShift "2"+                  ] <+> manageHook def+            }
+ dbus-xml/org.PulseAudio.Core1.Device.xml view
@@ -0,0 +1,9 @@+<node>+  <interface name="org.PulseAudio.Core1.Device">+    <property type="s" name="Name" access="read"/>+    <property type="s" name="Description" access="read"/>+    <property type="b" name="Mute" access="readwrite"/>+    <property type="au" name="Volume" access="readwrite"/>+    <property type="u" name="MaxVolume" access="read"/>+  </interface>+</node>
+ dbus-xml/org.PulseAudio.Core1.xml view
@@ -0,0 +1,6 @@+<node>+  <interface name="org.PulseAudio.Core1">+    <property type="ao" name="Sinks" access="read"/>+    <property type="o" name="FallbackSink" access="read"/>+  </interface>+</node>
+ dbus-xml/org.PulseAudio.ServerLookup1.xml view
@@ -0,0 +1,5 @@+<node>+  <interface name="org.PulseAudio.ServerLookup1">+    <property type="s" name="Address" access="read"/>+  </interface>+</node>
+ dbus-xml/org.freedesktop.NetworkManager.AccessPoint.xml view
@@ -0,0 +1,8 @@+<!DOCTYPE node PUBLIC "-//freedesktop//DTD D-Bus Object Introspection 1.0//EN"+ "http://www.freedesktop.org/standards/dbus/1.0/introspect.dtd">+<node>+  <interface name="org.freedesktop.NetworkManager.AccessPoint">+    <property name="Ssid" type="ay" access="read"/>+    <property name="Strength" type="y" access="read"/>+  </interface>+</node>
+ dbus-xml/org.freedesktop.NetworkManager.Connection.Active.xml view
@@ -0,0 +1,9 @@+<!DOCTYPE node PUBLIC "-//freedesktop//DTD D-Bus Object Introspection 1.0//EN"+ "http://www.freedesktop.org/standards/dbus/1.0/introspect.dtd">+<node>+  <interface name="org.freedesktop.NetworkManager.Connection.Active">+    <property name="Type" type="s" access="read"/>+    <property name="Id" type="s" access="read"/>+    <property name="SpecificObject" type="o" access="read"/>+  </interface>+</node>
+ dbus-xml/org.freedesktop.NetworkManager.xml view
@@ -0,0 +1,8 @@+<!DOCTYPE node PUBLIC "-//freedesktop//DTD D-Bus Object Introspection 1.0//EN"+ "http://www.freedesktop.org/standards/dbus/1.0/introspect.dtd">+<node>+  <interface name="org.freedesktop.NetworkManager">+    <property name="WirelessEnabled" type="b" access="read"/>+    <property name="ActiveConnections" type="ao" access="read"/>+  </interface>+</node>
doc/index.md view
@@ -4,11 +4,16 @@  ## Summary  -Taffybar is a desktop-information bar, intended primarily for use with [XMonad][], though it can also-function alongside other EWMH compliant window managers. It is similar in spirit-to [xmobar][], but it differs in that it gives up some simplicity for a reasonable-helping of [GTK 3][] eye candy.+Taffybar is a desktop information bar, intended primarily for use with+[XMonad][], though it can also function alongside other EWMH compliant window+managers. It is similar in spirit to [xmobar][], but it differs in that it gives+up some simplicity for a reasonable helping of [GTK 3][] eye candy.++Taffybar also supports running under Wayland via `gtk-layer-shell`. Wayland+support is currently compositor-specific for some widgets, with Hyprland+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.  [![Screenshot](https://raw.githubusercontent.com/taffybar/taffybar/master/doc/screenshot.png)](https://github.com/taffybar/taffybar/blob/master/doc/screenshot.png)
src/System/Taffybar.hs view
@@ -135,6 +135,7 @@ import qualified Config.Dyre.Params as Dyre import           Control.Exception ( finally ) import           Data.Function ( on )+import           Data.Maybe (isJust) import           Control.Monad import qualified Data.GI.Gtk.Threading as GIThreading import           Data.List ( groupBy, sort, isPrefixOf )@@ -145,6 +146,7 @@ import qualified GI.GLib as G import           Graphics.X11.Xlib.Misc ( initThreads ) import           System.Directory+import           System.Environment (lookupEnv) import           System.Environment.XDG.BaseDir ( getUserConfigFile ) import           System.Exit ( exitFailure ) import           System.FilePath ( (</>), normalise, takeDirectory, takeFileName )@@ -210,7 +212,9 @@ -- just use the provided minimal theme to set the background and text -- colors. startCSS :: [FilePath] -> IO (IO (), Gtk.CssProvider)-startCSS = startCSS' 800+-- Use a higher priority than GTK's user stylesheet (800) so taffybar's CSS can+-- override theme/user rules for things like menu backgrounds.+startCSS = startCSS' 900  -- | Installs a GTK style provider at a certain priority and loads it -- with styles from a list of CSS files (if they exist).@@ -310,7 +314,8 @@   updateGlobalLogger "" removeHandler   setTaffyLogFormatter "System.Taffybar"   setTaffyLogFormatter "StatusNotifier"-  _ <- initThreads+  useX11 <- shouldInitX11+  when useX11 $ void initThreads   _ <- Gtk.init Nothing   GIThreading.setCurrentThreadAsGUIThread @@ -324,6 +329,12 @@       exitTaffybar context    logTaffy DEBUG "Exited normally"++shouldInitX11 :: IO Bool+shouldInitX11 = do+  sessionType <- lookupEnv "XDG_SESSION_TYPE"+  waylandDisplay <- lookupEnv "WAYLAND_DISPLAY"+  return $ not (sessionType == Just "wayland" || isJust waylandDisplay)  logTaffy :: Priority -> String -> IO () logTaffy = logM "System.Taffybar"
src/System/Taffybar/Context.hs view
@@ -42,6 +42,7 @@   , getState   , getStateDefault   , putState+  , setState    -- * Control   , refreshTaffyWindows@@ -57,6 +58,9 @@    -- * Threading   , taffyFork+  -- * Backend (re-exported from "System.Taffybar.Context.Backend")+  , Backend(..)+  , detectBackend   ) where  import           Control.Arrow ((&&&), (***))@@ -73,6 +77,7 @@ import           Data.Default (Default(..)) import           Data.GI.Base.ManagedPtr (unsafeCastTo) import           Data.Int+import           Data.IORef import           Data.List import qualified Data.Map as M import qualified Data.Text as T@@ -81,12 +86,20 @@ import           Data.Unique import qualified GI.Gdk import qualified GI.GdkX11 as GdkX11+import qualified GI.GtkLayerShell as GtkLayerShell import           GI.GdkX11.Objects.X11Window import qualified GI.Gtk as Gtk import           Graphics.UI.GIGtkStrut import           StatusNotifier.TransparentWindow import           System.Log.Logger (Priority(..), logM)-import           System.Taffybar.Information.SafeX11+import           System.Taffybar.Context.Backend (Backend(..), detectBackend)+import           System.Taffybar.Information.Hyprland+  ( HyprlandClient+  , HyprlandEventChan+  , defaultHyprlandClientConfig+  , newHyprlandClient+  )+import           System.Taffybar.Information.SafeX11 hiding (setState) import           System.Taffybar.Information.X11DesktopInfo import           System.Taffybar.Util import           System.Taffybar.Widget.Util@@ -186,7 +199,7 @@ data Context = Context   {   -- | The X11Context that will be used to service X11Property requests.-    x11ContextVar :: MV.MVar X11Context+    x11ContextVar :: Maybe (MV.MVar X11Context)   -- | The handlers which will be evaluated against incoming X11 events.   , listeners :: MV.MVar SubscriptionList   -- | A collection of miscellaneous pieces of state which are keyed by their@@ -204,6 +217,17 @@   -- | The action that will be evaluated to get the bar configs associated with   -- each active monitor taffybar should run on.   , getBarConfigs :: BarConfigGetter+  -- | A Hyprland client initialized at startup (used by Hyprland widgets).+  --+  -- Stored directly on 'Context' to avoid deadlocks from nested+  -- 'getStateDefault' usage during widget initialization.+  , hyprlandClient :: HyprlandClient+  -- | Lazily-initialized shared Hyprland event channel (socket reader thread).+  --+  -- Stored outside of 'contextState' for the same reason as 'hyprlandClient'.+  , hyprlandEventChanVar :: MV.MVar (Maybe HyprlandEventChan)+  -- | The backend taffybar is running on.+  , backend :: Backend   -- | Populated with the BarConfig that resulted in the creation of a given   -- widget, when its constructor is called. This lets widgets access thing like   -- who their neighbors are. Note that the value of 'contextBarConfig' is@@ -223,9 +247,14 @@   sDBusC <- DBus.connectSystem   _ <- DBus.requestName dbusC "org.taffybar.Bar"        [DBus.nameAllowReplacement, DBus.nameReplaceExisting]+  backendType <- detectBackend   listenersVar <- MV.newMVar []   state <- MV.newMVar M.empty-  x11Context <- getX11Context def >>= MV.newMVar+  hyprClient <- newHyprlandClient defaultHyprlandClientConfig+  hyprEventChanVar <- MV.newMVar Nothing+  x11Context <- case backendType of+    BackendX11 -> Just <$> (getX11Context def >>= MV.newMVar)+    BackendWayland -> return Nothing   windowsVar <- MV.newMVar []   let context = Context                 { x11ContextVar = x11Context@@ -234,7 +263,10 @@                 , sessionDBusClient = dbusC                 , systemDBusClient = sDBusC                 , getBarConfigs = barConfigGetter+                , hyprlandClient = hyprClient+                , hyprlandEventChanVar = hyprEventChanVar                 , existingWindows = windowsVar+                , backend = backendType                 , contextBarConfig = Nothing                 }   _ <- runMaybeT $ MaybeT GI.Gdk.displayGetDefault >>=@@ -283,6 +315,8 @@   box <- Gtk.boxNew Gtk.OrientationHorizontal $ fromIntegral $          widgetSpacing barConfig   _ <- widgetSetClassGI box "taffy-box"+  Gtk.widgetSetVexpand box False+  Gtk.setWidgetValign box Gtk.AlignFill   centerBox <- Gtk.boxNew Gtk.OrientationHorizontal $                fromIntegral $ widgetSpacing barConfig @@ -292,7 +326,7 @@   Gtk.setWidgetHalign centerBox Gtk.AlignCenter   Gtk.boxSetCenterWidget box (Just centerBox) -  setupStrutWindow (strutConfig barConfig) window+  setupBarWindow context (strutConfig barConfig) window   Gtk.containerAdd window box    _ <- widgetSetClassGI window "taffy-window"@@ -323,11 +357,12 @@   Gtk.widgetShow box   Gtk.widgetShow centerBox -  runX11Context context () $ void $ runMaybeT $ do-    gdkWindow <- MaybeT $ Gtk.widgetGetWindow window-    xid <- GdkX11.x11WindowGetXid =<< liftIO (unsafeCastTo X11Window gdkWindow)-    logC DEBUG $ printf "Lowering X11 window %s" $ show xid-    lift $ doLowerWindow (fromIntegral xid)+  when (backend context == BackendX11) $+    runX11Context context () $ void $ runMaybeT $ do+      gdkWindow <- MaybeT $ Gtk.widgetGetWindow window+      xid <- GdkX11.x11WindowGetXid =<< liftIO (unsafeCastTo X11Window gdkWindow)+      logC DEBUG $ printf "Lowering X11 window %s" $ show xid+      lift $ doLowerWindow (fromIntegral xid)    return window @@ -349,7 +384,7 @@               (remainingWindows, removedWindows) =                 partition ((`elem` barConfigs) . sel1) currentWindows               setPropertiesFromPair (barConf, window) =-                setupStrutWindow (strutConfig barConf) window+                setupBarWindow ctx (strutConfig barConf) window            newWindowPairs <- lift $ do             logIO DEBUG $ printf "removedWindows: %s" $@@ -413,8 +448,14 @@  -- | Run a function needing an X11 connection in 'TaffyIO'. runX11 :: X11Property a -> TaffyIO a-runX11 action =-  asksContextVar x11ContextVar >>= lift . runReaderT action+runX11 action = do+  maybeCtxVar <- asks x11ContextVar+  case maybeCtxVar of+    Nothing ->+      liftIO $ fail "X11 context unavailable (Wayland backend in use)"+    Just ctxVar -> do+      ctx <- liftIO $ MV.readMVar ctxVar+      liftIO $ runReaderT action ctx  -- | Use 'runX11' together with 'postX11RequestSyncProp' on the provided -- property. Return the provided default if 'Nothing' is returned@@ -456,19 +497,38 @@          (return . (contextStateMap,))          (currentValue >>= fromValue) +-- | Overwrite a state value by type in the 'contextState' field of 'Context'.+-- 'putState'/'getStateDefault' are intentionally "set-once" helpers; widgets+-- that maintain mutable caches should use this to update them.+setState :: forall t. Typeable t => t -> Taffy IO t+setState value = do+  contextVar <- asks contextState+  let theType = typeRep (Proxy :: Proxy t)+  lift $ MV.modifyMVar_ contextVar $ \contextStateMap ->+    return $ M.insert theType (Value value) contextStateMap+  return value+ -- | A version of 'forkIO' in 'TaffyIO'. taffyFork :: ReaderT r IO () -> ReaderT r IO () taffyFork = void . mapReaderT forkIO  startX11EventHandler :: Taffy IO ()-startX11EventHandler = taffyFork $ do-  c <- ask-  -- XXX: The event loop needs its own X11Context to separately handle-  -- communications from the X server. We deliberately avoid using the context-  -- from x11ContextVar here.-  lift $ withX11Context def $ eventLoop-         (\e -> runReaderT (handleX11Event e) c)+startX11EventHandler = do+  backendType <- asks backend+  when (backendType == BackendX11) $ taffyFork $ do+    c <- ask+    -- XXX: The event loop needs its own X11Context to separately handle+    -- communications from the X server. We deliberately avoid using the context+    -- from x11ContextVar here.+    lift $ withX11Context def $ eventLoop+           (\e -> runReaderT (handleX11Event e) c) +setupBarWindow :: Context -> StrutConfig -> Gtk.Window -> IO ()+setupBarWindow context config window =+  case backend context of+    BackendX11 -> setupStrutWindow config window+    BackendWayland -> setupLayerShellWindow config window+ -- | Remove the listener associated with the provided "Unique" from the -- collection of listeners. unsubscribe :: Unique -> Taffy IO ()@@ -506,3 +566,118 @@   asksContextVar listeners >>= mapM_ applyListener   where applyListener :: (Unique, Listener) -> Taffy IO ()         applyListener (_, listener) = taffyFork $ listener event++setupLayerShellWindow :: StrutConfig -> Gtk.Window -> IO ()+setupLayerShellWindow StrutConfig+                      { strutWidth = widthSize+                      , strutHeight = heightSize+                      , strutXPadding = xpadding+                      , strutYPadding = ypadding+                      , strutMonitor = monitorNumber+                      , strutPosition = position+                      , strutDisplayName = maybeDisplayName+                      } window = do+  supported <- GtkLayerShell.isSupported+  unless supported $+    logIO WARNING "Wayland backend selected, but gtk-layer-shell is not supported"+  when supported $ do+    maybeDisplay <- maybe GI.Gdk.displayGetDefault GI.Gdk.displayOpen maybeDisplayName+    case maybeDisplay of+      Nothing -> logIO WARNING "Failed to get GDK display for layer-shell"+      Just display -> do+        maybeMonitor <-+          maybe (GI.Gdk.displayGetPrimaryMonitor display)+                (GI.Gdk.displayGetMonitor display)+                monitorNumber+        case maybeMonitor of+          Nothing -> logIO WARNING "Failed to get GDK monitor for layer-shell"+          Just monitor -> do+            monitorGeometry <- GI.Gdk.monitorGetGeometry monitor+            monitorWidth <- GI.Gdk.getRectangleWidth monitorGeometry+            monitorHeight <- GI.Gdk.getRectangleHeight monitorGeometry+            let width =+                  case widthSize of+                    ExactSize w -> w+                    ScreenRatio p ->+                      floor $ p * fromIntegral (monitorWidth - (2 * xpadding))+                height =+                  case heightSize of+                    ExactSize h -> h+                    ScreenRatio p ->+                      floor $ p * fromIntegral (monitorHeight - (2 * ypadding))+                exclusive =+                  case position of+                    TopPos -> height + 2 * ypadding+                    BottomPos -> height + 2 * ypadding+                    LeftPos -> width + 2 * xpadding+                    RightPos -> width + 2 * xpadding++            Gtk.windowSetDefaultSize window (fromIntegral width) (fromIntegral height)+            let (reqWidth, reqHeight) =+                  case position of+                    TopPos -> (-1, height)+                    BottomPos -> (-1, height)+                    LeftPos -> (width, -1)+                    RightPos -> (width, -1)+            Gtk.widgetSetSizeRequest window+              (fromIntegral reqWidth)+              (fromIntegral reqHeight)++            alreadyLayer <- GtkLayerShell.isLayerWindow window+            unless alreadyLayer $ do+              GtkLayerShell.initForWindow window+              GtkLayerShell.setKeyboardMode window GtkLayerShell.KeyboardModeNone+              GtkLayerShell.setNamespace window (T.pack "taffybar")+            GtkLayerShell.setMonitor window monitor++            GtkLayerShell.setMargin window GtkLayerShell.EdgeLeft xpadding+            GtkLayerShell.setMargin window GtkLayerShell.EdgeRight xpadding+            GtkLayerShell.setMargin window GtkLayerShell.EdgeTop ypadding+            GtkLayerShell.setMargin window GtkLayerShell.EdgeBottom ypadding++            GtkLayerShell.setLayer window GtkLayerShell.LayerTop++            let setAnchor = GtkLayerShell.setAnchor window++            case position of+              TopPos -> do+                setAnchor GtkLayerShell.EdgeTop True+                setAnchor GtkLayerShell.EdgeBottom False+                setAnchor GtkLayerShell.EdgeLeft True+                setAnchor GtkLayerShell.EdgeRight True+              BottomPos -> do+                setAnchor GtkLayerShell.EdgeTop False+                setAnchor GtkLayerShell.EdgeBottom True+                setAnchor GtkLayerShell.EdgeLeft True+                setAnchor GtkLayerShell.EdgeRight True+              LeftPos -> do+                setAnchor GtkLayerShell.EdgeLeft True+                setAnchor GtkLayerShell.EdgeRight False+                setAnchor GtkLayerShell.EdgeTop True+                setAnchor GtkLayerShell.EdgeBottom True+              RightPos -> do+                setAnchor GtkLayerShell.EdgeLeft False+                setAnchor GtkLayerShell.EdgeRight True+                setAnchor GtkLayerShell.EdgeTop True+                setAnchor GtkLayerShell.EdgeBottom True++            GtkLayerShell.setExclusiveZone window exclusive++            -- Dynamically update exclusive zone when the bar's actual+            -- allocated size exceeds the configured size (issue #270).+            lastExclusiveRef <- newIORef exclusive+            void $ Gtk.onWidgetSizeAllocate window $ \alloc -> do+              allocH <- GI.Gdk.getRectangleHeight alloc+              allocW <- GI.Gdk.getRectangleWidth alloc+              let newExclusive =+                    case position of+                      TopPos    -> fromIntegral allocH + 2 * ypadding+                      BottomPos -> fromIntegral allocH + 2 * ypadding+                      LeftPos   -> fromIntegral allocW + 2 * xpadding+                      RightPos  -> fromIntegral allocW + 2 * xpadding+              prev <- readIORef lastExclusiveRef+              when (newExclusive /= prev) $ do+                logIO DEBUG $+                  printf "Updating exclusive zone from %d to %d" prev newExclusive+                writeIORef lastExclusiveRef newExclusive+                GtkLayerShell.setExclusiveZone window newExclusive
+ src/System/Taffybar/Context/Backend.hs view
@@ -0,0 +1,162 @@+-----------------------------------------------------------------------------+-- |+-- Module      : System.Taffybar.Context.Backend+-- Copyright   : (c) Ivan A. Malison+-- License     : BSD3-style (see LICENSE)+--+-- Maintainer  : Ivan A. Malison+-- Stability   : unstable+-- Portability : unportable+--+-- Display-server backend detection for taffybar.+--+-- The 'detectBackend' function probes the runtime environment to decide+-- whether to use an X11 or Wayland backend, compensating for stale or+-- missing environment variables that are common when the @systemd+-- --user@ manager persists across login sessions.+-----------------------------------------------------------------------------++module System.Taffybar.Context.Backend+  ( Backend(..)+  , detectBackend+  -- * Discovery helpers+  , discoverWaylandSocket+  , discoverHyprlandSignature+  ) where++import           Control.Exception.Enclosed (catchAny)+import           Control.Monad+import           Data.List (isPrefixOf, isSuffixOf)+import           System.Directory (doesPathExist, listDirectory)+import           System.Environment (lookupEnv, setEnv, unsetEnv)+import           System.FilePath ((</>))+import           System.Log.Logger (Priority(..), logM)+import           System.Posix.Files (getFileStatus, isSocket)++logIO :: Priority -> String -> IO ()+logIO = logM "System.Taffybar.Context.Backend"++data Backend+  = BackendX11+  | BackendWayland+  deriving (Eq, Show)++-- | Try to find a @wayland-*@ socket in the given runtime directory.+--+-- When the systemd user manager environment has a stale or empty+-- @WAYLAND_DISPLAY@, the actual socket may still exist.  This function+-- scans @XDG_RUNTIME_DIR@ for candidate sockets.+discoverWaylandSocket :: FilePath -> IO (Maybe String)+discoverWaylandSocket runtime = do+  entries <- listDirectory runtime+  let candidates =+        [ e | e <- entries+        , "wayland-" `isPrefixOf` e+        , not (".lock" `isSuffixOf` e)+        ]+  go candidates+  where+    go [] = pure Nothing+    go (c:cs) = do+      ok <- catchAny+        (isSocket <$> getFileStatus (runtime </> c))+        (const $ pure False)+      if ok then pure (Just c) else go cs++-- | Try to find a Hyprland instance signature in @XDG_RUNTIME_DIR/hypr/@.+--+-- Hyprland creates a directory named after its instance signature under+-- @$XDG_RUNTIME_DIR/hypr/@ containing @hyprland.lock@.+discoverHyprlandSignature :: FilePath -> IO (Maybe String)+discoverHyprlandSignature runtime = do+  let hyprDir = runtime </> "hypr"+  exists <- doesPathExist hyprDir+  if not exists+    then pure Nothing+    else do+      entries <- listDirectory hyprDir+      go hyprDir entries+  where+    go _ [] = pure Nothing+    go hyprDir (e:es) = do+      isSig <- doesPathExist (hyprDir </> e </> "hyprland.lock")+      if isSig then pure (Just e) else go hyprDir es++-- | Detect the display-server backend, compensating for stale or missing+-- environment variables.+--+-- The @systemd --user@ manager persists across login sessions, so its+-- environment can be stale in two ways:+--+-- * A leftover @WAYLAND_DISPLAY@ from a previous Wayland session points at a+--   socket that no longer exists (the original problem the socket check+--   addresses).+--+-- * @WAYLAND_DISPLAY@ and @HYPRLAND_INSTANCE_SIGNATURE@ are completely absent+--   or empty even though a Wayland compositor is running (e.g. after switching+--   from an X11 session).+--+-- This function discovers the real state by probing @XDG_RUNTIME_DIR@, fixes+-- up the process environment so downstream code sees consistent values, and+-- returns the appropriate 'Backend'.+detectBackend :: IO Backend+detectBackend = do+  mRuntime <- lookupEnv "XDG_RUNTIME_DIR"+  mDisplay <- lookupEnv "DISPLAY"+  mSessionType <- lookupEnv "XDG_SESSION_TYPE"++  -- Discover and fix up WAYLAND_DISPLAY if it is missing or empty.+  mWaylandDisplay <- do+    raw <- lookupEnv "WAYLAND_DISPLAY"+    case (mRuntime, raw) of+      (Just runtime, val) | maybe True null val -> do+        mSock <- discoverWaylandSocket runtime+        case mSock of+          Just sock -> do+            logIO INFO $ "Discovered wayland socket: " ++ sock+            setEnv "WAYLAND_DISPLAY" sock+            pure (Just sock)+          Nothing -> pure raw+      _ -> pure raw++  -- Discover and fix up HYPRLAND_INSTANCE_SIGNATURE if it is missing or empty.+  do+    raw <- lookupEnv "HYPRLAND_INSTANCE_SIGNATURE"+    case (mRuntime, raw) of+      (Just runtime, val) | maybe True null val -> do+        mSig <- discoverHyprlandSignature runtime+        case mSig of+          Just sig -> do+            logIO INFO $ "Discovered Hyprland signature: " ++ sig+            setEnv "HYPRLAND_INSTANCE_SIGNATURE" sig+          Nothing -> pure ()+      _ -> pure ()++  -- Validate the wayland socket.+  let mWaylandPath = do+        runtime <- mRuntime+        wl <- mWaylandDisplay+        guard (not (null runtime) && not (null wl))+        pure (runtime </> wl)++  waylandOk <- case mWaylandPath of+    Nothing -> pure False+    Just wlPath ->+      catchAny+        (isSocket <$> getFileStatus wlPath)+        (const $ pure False)++  -- Clean up the environment when falling back to X11.+  when (not waylandOk && maybe False (not . null) mDisplay) $ do+    unsetEnv "WAYLAND_DISPLAY"+    unsetEnv "HYPRLAND_INSTANCE_SIGNATURE"+    when (mSessionType == Just "wayland") $ setEnv "XDG_SESSION_TYPE" "x11"+    logIO DEBUG "Wayland socket not available; cleaned up environment for X11 backend"++  -- Fix XDG_SESSION_TYPE when selecting Wayland.+  when (waylandOk && mSessionType /= Just "wayland") $+    setEnv "XDG_SESSION_TYPE" "wayland"++  let selected = if waylandOk then BackendWayland else BackendX11+  logIO INFO $ "Detected backend: " ++ show selected+  pure selected
+ src/System/Taffybar/DBus/Client/NetworkManager.hs view
@@ -0,0 +1,16 @@+{-# LANGUAGE TemplateHaskell #-}+module System.Taffybar.DBus.Client.NetworkManager where++import DBus.Generation+import System.FilePath+import System.Taffybar.DBus.Client.Params+import System.Taffybar.DBus.Client.Util++generateClientFromFile+  defaultRecordGenerationParams+  { recordName = Just "NetworkManagerInfo"+  , recordPrefix = "nm"+  }+  nmGenerationParams { genObjectPath = Just nmObjectPath }+  False $+  "dbus-xml" </> "org.freedesktop.NetworkManager.xml"
+ src/System/Taffybar/DBus/Client/NetworkManagerAccessPoint.hs view
@@ -0,0 +1,15 @@+{-# LANGUAGE TemplateHaskell #-}+module System.Taffybar.DBus.Client.NetworkManagerAccessPoint where++import System.FilePath+import System.Taffybar.DBus.Client.Params+import System.Taffybar.DBus.Client.Util++generateClientFromFile+  defaultRecordGenerationParams+  { recordName = Just "AccessPointInfo"+  , recordPrefix = "nmap"+  }+  nmGenerationParams+  False $+  "dbus-xml" </> "org.freedesktop.NetworkManager.AccessPoint.xml"
+ src/System/Taffybar/DBus/Client/NetworkManagerActiveConnection.hs view
@@ -0,0 +1,15 @@+{-# LANGUAGE TemplateHaskell #-}+module System.Taffybar.DBus.Client.NetworkManagerActiveConnection where++import System.FilePath+import System.Taffybar.DBus.Client.Params+import System.Taffybar.DBus.Client.Util++generateClientFromFile+  defaultRecordGenerationParams+  { recordName = Just "ActiveConnectionInfo"+  , recordPrefix = "nmac"+  }+  nmGenerationParams+  False $+  "dbus-xml" </> "org.freedesktop.NetworkManager.Connection.Active.xml"
src/System/Taffybar/DBus/Client/Params.hs view
@@ -13,7 +13,40 @@   , genObjectPath = Just "/org/mpris/MediaPlayer2"   } +-- | The bus name for NetworkManager.+nmBusName :: BusName+nmBusName = "org.freedesktop.NetworkManager" +-- | The base object path for NetworkManager.+nmObjectPath :: ObjectPath+nmObjectPath = "/org/freedesktop/NetworkManager"++nmInterfaceName :: InterfaceName+nmInterfaceName = "org.freedesktop.NetworkManager"++nmActiveConnectionInterfaceName :: InterfaceName+nmActiveConnectionInterfaceName =+  "org.freedesktop.NetworkManager.Connection.Active"++nmAccessPointInterfaceName :: InterfaceName+nmAccessPointInterfaceName =+  "org.freedesktop.NetworkManager.AccessPoint"++nmActiveConnectionPathNamespace :: ObjectPath+nmActiveConnectionPathNamespace =+  "/org/freedesktop/NetworkManager/ActiveConnection"++nmAccessPointPathNamespace :: ObjectPath+nmAccessPointPathNamespace =+  "/org/freedesktop/NetworkManager/AccessPoint"++nmGenerationParams :: GenerationParams+nmGenerationParams = defaultGenerationParams+  { genTakeSignalErrorHandler = True+  , genBusName = Just nmBusName+  }++ -- | The base object path for the UPower interface uPowerBaseObjectPath :: ObjectPath uPowerBaseObjectPath = "/org/freedesktop/UPower"@@ -29,6 +62,45 @@ uPowerGenerationParams = defaultGenerationParams   { genTakeSignalErrorHandler = True   , genBusName = Just uPowerBusName+  }++-- | The bus name for PulseAudio's server lookup on the session bus.+paServerLookupBusName :: BusName+paServerLookupBusName = "org.PulseAudio1"++-- | The object path for PulseAudio's server lookup object.+paServerLookupObjectPath :: ObjectPath+paServerLookupObjectPath = "/org/pulseaudio/server_lookup1"++-- | The object path for PulseAudio's core object.+paCoreObjectPath :: ObjectPath+paCoreObjectPath = "/org/pulseaudio/core1"++paServerLookupInterfaceName :: InterfaceName+paServerLookupInterfaceName = "org.PulseAudio.ServerLookup1"++paCoreInterfaceName :: InterfaceName+paCoreInterfaceName = "org.PulseAudio.Core1"++paDeviceInterfaceName :: InterfaceName+paDeviceInterfaceName = "org.PulseAudio.Core1.Device"++paServerLookupGenerationParams :: GenerationParams+paServerLookupGenerationParams = defaultGenerationParams+  { genTakeSignalErrorHandler = True+  , genBusName = Just paServerLookupBusName+  , genObjectPath = Just paServerLookupObjectPath+  }++paCoreGenerationParams :: GenerationParams+paCoreGenerationParams = defaultGenerationParams+  { genTakeSignalErrorHandler = True+  , genObjectPath = Just paCoreObjectPath+  }++paDeviceGenerationParams :: GenerationParams+paDeviceGenerationParams = defaultGenerationParams+  { genTakeSignalErrorHandler = True   }  data BatteryType
+ src/System/Taffybar/DBus/Client/PulseAudioCore.hs view
@@ -0,0 +1,16 @@+{-# LANGUAGE TemplateHaskell #-}+module System.Taffybar.DBus.Client.PulseAudioCore where++import DBus.Generation ()+import System.FilePath+import System.Taffybar.DBus.Client.Params+import System.Taffybar.DBus.Client.Util++generateClientFromFile+  defaultRecordGenerationParams+  { recordName = Just "PulseAudioCoreInfo"+  , recordPrefix = "pac"+  }+  paCoreGenerationParams+  False $+  "dbus-xml" </> "org.PulseAudio.Core1.xml"
+ src/System/Taffybar/DBus/Client/PulseAudioDevice.hs view
@@ -0,0 +1,16 @@+{-# LANGUAGE TemplateHaskell #-}+module System.Taffybar.DBus.Client.PulseAudioDevice where++import DBus.Generation ()+import System.FilePath+import System.Taffybar.DBus.Client.Params+import System.Taffybar.DBus.Client.Util++generateClientFromFile+  defaultRecordGenerationParams+  { recordName = Just "PulseAudioDeviceInfo"+  , recordPrefix = "pad"+  }+  paDeviceGenerationParams+  False $+  "dbus-xml" </> "org.PulseAudio.Core1.Device.xml"
+ src/System/Taffybar/DBus/Client/PulseAudioServerLookup.hs view
@@ -0,0 +1,16 @@+{-# LANGUAGE TemplateHaskell #-}+module System.Taffybar.DBus.Client.PulseAudioServerLookup where++import DBus.Generation ()+import System.FilePath+import System.Taffybar.DBus.Client.Params+import System.Taffybar.DBus.Client.Util++generateClientFromFile+  defaultRecordGenerationParams+  { recordName = Just "PulseAudioServerLookupInfo"+  , recordPrefix = "pasl"+  }+  paServerLookupGenerationParams+  False $+  "dbus-xml" </> "org.PulseAudio.ServerLookup1.xml"
src/System/Taffybar/Example.hs view
@@ -1,3 +1,4 @@+{-# LANGUAGE DisambiguateRecordFields #-} {-# LANGUAGE OverloadedStrings #-} ----------------------------------------------------------------------------- -- |@@ -25,6 +26,7 @@ import System.Taffybar.SimpleConfig import System.Taffybar.Widget import System.Taffybar.Widget.Generic.PollingGraph+import qualified System.Taffybar.Widget.Workspaces as Workspaces  transparent, yellow1, yellow2, green1, green2, taffyBlue   :: (Double, Double, Double, Double)@@ -71,11 +73,12 @@  exampleTaffybarConfig :: TaffybarConfig exampleTaffybarConfig =-  let myWorkspacesConfig =+  let myWorkspacesConfig :: WorkspacesConfig+      myWorkspacesConfig =         def-        { minIcons = 1-        , widgetGap = 0-        , showWorkspaceFn = hideEmpty+        { Workspaces.minIcons = 1+        , Workspaces.widgetGap = 0+        , Workspaces.showWorkspaceFn = hideEmpty         }       workspaces = workspacesNew myWorkspacesConfig       cpu = pollingGraphNew cpuCfg 0.5 cpuCallback@@ -103,5 +106,20 @@         , barPadding = 10         , barHeight = ExactSize 50         , widgetSpacing = 0+        }+  in withLogServer $ withToggleServer $ toTaffybarConfig myConfig++exampleWaylandTaffybarConfig :: TaffybarConfig+exampleWaylandTaffybarConfig =+  let clock = textClockNewWith def+      cpu = pollingGraphNew cpuCfg 1 cpuCallback+      myConfig = def+        { startWidgets = []+        , endWidgets = [ clock, cpu ]+        , barPosition = Top+        , barHeight = ExactSize 28+        , barPadding = 0+        , widgetSpacing = 8+        , monitorsAction = usePrimaryMonitor         }   in withLogServer $ withToggleServer $ toTaffybarConfig myConfig
src/System/Taffybar/Hooks.hs view
@@ -15,6 +15,7 @@ module System.Taffybar.Hooks   ( module System.Taffybar.DBus   , module System.Taffybar.Hooks+  , module System.Taffybar.LogLevels   , ChromeTabImageData(..)   , getChromeTabImageDataChannel   , getChromeTabImageDataTable@@ -37,6 +38,7 @@ import           System.Taffybar.Information.Network import           System.Environment.XDG.DesktopEntry import           System.Taffybar.LogFormatter+import           System.Taffybar.LogLevels import           System.Taffybar.Util  -- | The type of the channel that provides network information in taffybar.@@ -69,6 +71,20 @@ -- UPower, and UPower usually works correctly. withBatteryRefresh :: TaffybarConfig -> TaffybarConfig withBatteryRefresh = appendHook refreshBatteriesOnPropChange++-- | Load log levels from @~\/.config\/taffybar\/log-levels.yaml@ during+-- startup. The file should contain a YAML mapping from logger names to log+-- level strings. If the file does not exist, this is a no-op.+--+-- Example @log-levels.yaml@:+--+-- > System.Taffybar.DBus.Toggle: DEBUG+-- > Graphics.UI.GIGtkStrut: INFO+--+-- To use a custom path instead, call 'loadLogLevelsFromFile' directly.+withLogLevels :: TaffybarConfig -> TaffybarConfig+withLogLevels = appendHook $+  lift $ defaultLogLevelsPath >>= loadLogLevelsFromFile  -- | Load the 'DesktopEntry' cache from 'Context' state. getDirectoryEntriesByClassName :: TaffyIO (MM.MultiMap String DesktopEntry)
+ src/System/Taffybar/Hyprland.hs view
@@ -0,0 +1,109 @@+-----------------------------------------------------------------------------+-- |+-- Module      : System.Taffybar.Hyprland+-- Copyright   : (c) Ivan A. Malison+-- License     : BSD3-style (see LICENSE)+--+-- Maintainer  : Ivan A. Malison+-- Stability   : unstable+-- Portability : unportable+--+-- Context-integrated helpers for the Hyprland client.+--+-- Hyprland resources are stored directly on 'Context' (not in 'contextState')+-- to avoid deadlocks from nested 'getStateDefault' usage during widget+-- initialization.+-----------------------------------------------------------------------------++module System.Taffybar.Hyprland+  ( -- * Shared Client+    getHyprlandClient+  , getHyprlandClientWith++    -- * Hyprland Monad In TaffyIO+  , HyprlandIO+  , runHyprland++    -- * Shared Event Channel+  , getHyprlandEventChan+  , getHyprlandEventChanWith++    -- * Convenience Runners+  , runHyprlandCommandRawT+  , runHyprlandCommandJsonT+  ) where++import qualified Control.Concurrent.MVar as MV+import           Control.Monad.IO.Class (liftIO)+import           Data.Aeson (FromJSON)+import qualified Data.ByteString as BS++import           Control.Monad.Trans.Reader (ReaderT, asks)++import           System.Taffybar.Context (Context(..), TaffyIO)+import           System.Taffybar.Information.Hyprland+  ( HyprlandClient+  , HyprlandClientConfig+  , HyprlandCommand+  , HyprlandError+  , HyprlandEventChan+  , HyprlandT+  , buildHyprlandEventChan+  , defaultHyprlandClientConfig+  , runHyprlandCommandJson+  , runHyprlandCommandRaw+  , runHyprlandT+  )++-- | Get a shared 'HyprlandClient' from the 'Context' state.+--+-- Note: this uses 'getStateDefault', so the first call wins and subsequent+-- calls return the existing client.+getHyprlandClient :: TaffyIO HyprlandClient+getHyprlandClient = getHyprlandClientWith defaultHyprlandClientConfig++-- | Like 'getHyprlandClient', but allows supplying the initial config.+--+-- The config is only used if the client has not already been created and+-- stored in the 'Context' state.+getHyprlandClientWith :: HyprlandClientConfig -> TaffyIO HyprlandClient+getHyprlandClientWith _cfg = asks hyprlandClient++-- | Hyprland actions in the 'TaffyIO' context.+--+-- Note: 'TaffyIO' is a type synonym, and type synonyms cannot be partially+-- applied. We therefore spell out the underlying 'ReaderT Context IO' here.+type HyprlandIO a = HyprlandT (ReaderT Context IO) a++runHyprland :: HyprlandIO a -> TaffyIO a+runHyprland action = getHyprlandClient >>= \client -> runHyprlandT client action++-- | Get a shared Hyprland event channel from the 'Context' state.+--+-- The channel is backed by a single event socket reader thread, and is safe to+-- use concurrently by multiple widgets via 'subscribeHyprlandEvents'.+getHyprlandEventChan :: TaffyIO HyprlandEventChan+getHyprlandEventChan = getHyprlandEventChanWith defaultHyprlandClientConfig++-- | Like 'getHyprlandEventChan', but allows supplying the initial client config.+--+-- The config is only used if the channel has not already been created and+-- stored in the 'Context' state.+getHyprlandEventChanWith :: HyprlandClientConfig -> TaffyIO HyprlandEventChan+getHyprlandEventChanWith cfg = do+  client <- getHyprlandClientWith cfg+  chanVar <- asks hyprlandEventChanVar+  liftIO $ MV.modifyMVar chanVar $ \existing ->+    case existing of+      Just c -> pure (existing, c)+      Nothing -> do+        c <- buildHyprlandEventChan client+        pure (Just c, c)++runHyprlandCommandRawT :: HyprlandCommand -> TaffyIO (Either HyprlandError BS.ByteString)+runHyprlandCommandRawT cmd =+  getHyprlandClient >>= \client -> liftIO $ runHyprlandCommandRaw client cmd++runHyprlandCommandJsonT :: FromJSON a => HyprlandCommand -> TaffyIO (Either HyprlandError a)+runHyprlandCommandJsonT cmd =+  getHyprlandClient >>= \client -> liftIO $ runHyprlandCommandJson client cmd
+ src/System/Taffybar/Information/Backlight.hs view
@@ -0,0 +1,241 @@+{-# LANGUAGE AllowAmbiguousTypes #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE KindSignatures #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeApplications #-}++-----------------------------------------------------------------------------+-- |+-- Module      : System.Taffybar.Information.Backlight+-- Copyright   : (c) Ivan A. Malison+-- License     : BSD3-style (see LICENSE)+--+-- Maintainer  : Ivan A. Malison+-- Stability   : unstable+-- Portability : unportable+--+-- Simple helpers to read backlight status from /sys/class/backlight.+--+-----------------------------------------------------------------------------++module System.Taffybar.Information.Backlight+  ( BacklightInfo(..)+  , getBacklightDevices+  , getBacklightInfo+  , getBacklightInfoChan+  , getBacklightInfoChanWithInterval+  , getBacklightInfoState+  ) where++import Control.Concurrent (forkIO, threadDelay)+import Control.Concurrent.MVar+import Control.Concurrent.STM.TChan+import Control.Exception (SomeException, bracket, catch, try)+import Control.Monad (forever)+import Control.Monad.IO.Class (liftIO)+import Control.Monad.STM (atomically)+import Data.List (sort, sortBy)+import Data.Maybe (fromMaybe, listToMaybe)+import Data.Ord (Down(..), comparing)+import Data.Proxy (Proxy(..))+import GHC.Conc (threadWaitRead)+import GHC.TypeLits (KnownSymbol, SomeSymbol(..), Symbol, someSymbolVal)+import System.Directory (doesDirectoryExist, listDirectory)+import System.FilePath ((</>))+import System.Log.Logger (Priority(..))+import System.Taffybar.Context (TaffyIO, getStateDefault)+import System.Taffybar.Information.Udev+  ( backlightMonitorFd+  , closeBacklightMonitor+  , drainBacklightMonitor+  , openBacklightMonitor+  )+import System.Taffybar.Util (logPrintF)+import System.Timeout (timeout)+import Text.Read (readMaybe)++backlightBasePath :: FilePath+backlightBasePath = "/sys/class/backlight"++defaultBacklightRefreshIntervalSeconds :: Double+defaultBacklightRefreshIntervalSeconds = 2++-- | Information about a backlight device.+data BacklightInfo = BacklightInfo+  { backlightDevice :: FilePath+  , backlightBrightness :: Int+  , backlightMaxBrightness :: Int+  , backlightPercent :: Int+  } deriving (Eq, Show)++-- | List all backlight device names under /sys/class/backlight.+getBacklightDevices :: IO [FilePath]+getBacklightDevices =+  catch (sort <$> listDirectory backlightBasePath) $ \(_ :: SomeException) ->+    return []++-- | Get backlight info for the provided device name, or (when no name is+-- provided) the "best" backlight device found under @/sys/class/backlight@.+--+-- The best device is the one with the highest @max_brightness@, which mirrors+-- Waybar's backlight selection logic.+getBacklightInfo :: Maybe FilePath -> IO (Maybe BacklightInfo)+getBacklightInfo deviceOverride = do+  device <- selectDevice deviceOverride+  case device of+    Nothing -> return Nothing+    Just dev -> readDevice dev++backlightLogPath :: String+backlightLogPath = "System.Taffybar.Information.Backlight"++backlightLogF :: Show t => Priority -> String -> t -> IO ()+backlightLogF = logPrintF backlightLogPath++newtype BacklightInfoChanVar (a :: Symbol)+  = BacklightInfoChanVar (TChan (Maybe BacklightInfo), MVar (Maybe BacklightInfo))++-- | Get a broadcast channel for backlight info for the provided device.+--+-- Like Waybar, this is event-driven when possible (udev netlink monitor) but+-- will still refresh at a regular interval as a fallback/sanity check.+getBacklightInfoChan :: Maybe FilePath -> TaffyIO (TChan (Maybe BacklightInfo))+getBacklightInfoChan deviceOverride =+  getBacklightInfoChanWithInterval deviceOverride defaultBacklightRefreshIntervalSeconds++-- | Like 'getBacklightInfoChan', but allows customizing the refresh interval+-- (in seconds).+--+-- Note: the first call for a given device key wins if multiple callers request+-- different intervals, because the underlying monitoring thread is cached in+-- 'Context' via 'getStateDefault'.+getBacklightInfoChanWithInterval :: Maybe FilePath -> Double -> TaffyIO (TChan (Maybe BacklightInfo))+getBacklightInfoChanWithInterval deviceOverride intervalSeconds =+  case someSymbolVal (fromMaybe "__default__" deviceOverride) of+    SomeSymbol (Proxy :: Proxy sym) ->+      getBacklightInfoChanFor @sym deviceOverride intervalSeconds++-- | Read the most recent backlight info state for the provided device.+--+-- See 'getBacklightInfoChan' for monitoring behavior.+getBacklightInfoState :: Maybe FilePath -> TaffyIO (Maybe BacklightInfo)+getBacklightInfoState deviceOverride =+  case someSymbolVal (fromMaybe "__default__" deviceOverride) of+    SomeSymbol (Proxy :: Proxy sym) -> getBacklightInfoStateFor @sym deviceOverride++getBacklightInfoChanFor+  :: forall (a :: Symbol)+   . KnownSymbol a+  => Maybe FilePath+  -> Double+  -> TaffyIO (TChan (Maybe BacklightInfo))+getBacklightInfoChanFor deviceOverride intervalSeconds = do+  BacklightInfoChanVar (chan, _) <-+    getBacklightInfoChanVarFor @a deviceOverride intervalSeconds+  pure chan++getBacklightInfoStateFor+  :: forall (a :: Symbol)+   . KnownSymbol a+  => Maybe FilePath+  -> TaffyIO (Maybe BacklightInfo)+getBacklightInfoStateFor deviceOverride = do+  BacklightInfoChanVar (_, var) <-+    getBacklightInfoChanVarFor @a deviceOverride defaultBacklightRefreshIntervalSeconds+  liftIO $ readMVar var++getBacklightInfoChanVarFor+  :: forall (a :: Symbol)+   . KnownSymbol a+  => Maybe FilePath+  -> Double+  -> TaffyIO (BacklightInfoChanVar a)+getBacklightInfoChanVarFor deviceOverride intervalSeconds =+  getStateDefault $ do+    liftIO $ do+      chan <- newBroadcastTChanIO+      var <- newMVar Nothing+      _ <- forkIO $ monitorBacklightInfo deviceOverride intervalSeconds chan var+      pure $ BacklightInfoChanVar (chan, var)++monitorBacklightInfo ::+  Maybe FilePath ->+  Double ->+  TChan (Maybe BacklightInfo) ->+  MVar (Maybe BacklightInfo) ->+  IO ()+monitorBacklightInfo deviceOverride intervalSeconds chan var = do+  let+    intervalMicros :: Int+    intervalMicros = max 1 (floor (intervalSeconds * 1000000))++    writeInfo info = do+      _ <- swapMVar var info+      atomically $ writeTChan chan info++    refresh = getBacklightInfo deviceOverride >>= writeInfo++    pollingFallback e = do+      -- Polling is a last resort, but we prefer it to a stuck widget.+      backlightLogF WARNING "Backlight udev monitor unavailable, falling back to polling: %s" e+      refresh+      forever $ do+        threadDelay intervalMicros+        refresh++  monitorResult <- try openBacklightMonitor+  case monitorResult of+    Left (e :: SomeException) -> pollingFallback e+    Right mon -> bracket (pure mon) closeBacklightMonitor $ \m -> do+      refresh+      forever $ do+        -- Wait for a udev event or time out for a periodic refresh (Waybar-style).+        mEvent <- timeout intervalMicros $ threadWaitRead (backlightMonitorFd m)+        -- Only read from the udev socket if we were woken due to readability.+        -- Otherwise udev_monitor_receive_device can block.+        case mEvent of+          Nothing -> pure ()+          Just () -> drainBacklightMonitor m+        refresh++selectDevice :: Maybe FilePath -> IO (Maybe FilePath)+selectDevice (Just device) = do+  let path = backlightBasePath </> device+  exists <- doesDirectoryExist path+  if exists then pure (Just device) else selectDevice Nothing+selectDevice Nothing = do+  devices <- getBacklightDevices+  candidates <- mapM (\d -> (d,) . fromMaybe 0 <$> readMaxBrightness d) devices+  pure $ fst <$> listToMaybe (sortBy (comparing (Down . snd)) candidates)++readDevice :: FilePath -> IO (Maybe BacklightInfo)+readDevice device = do+  let basePath = backlightBasePath </> device+  mActual <- readIntFile (basePath </> "actual_brightness")+  brightness <- case mActual of+    Just v -> pure (Just v)+    Nothing -> readIntFile (basePath </> "brightness")+  maxBrightness <- readIntFile (basePath </> "max_brightness")+  case (brightness, maxBrightness) of+    (Just current, Just maxVal) | maxVal > 0 -> do+      let percent = round $ (fromIntegral current * 100 :: Double) / fromIntegral maxVal+      return $ Just BacklightInfo+        { backlightDevice = device+        , backlightBrightness = current+        , backlightMaxBrightness = maxVal+        , backlightPercent = percent+        }+    _ -> return Nothing++readMaxBrightness :: FilePath -> IO (Maybe Int)+readMaxBrightness device =+  readIntFile (backlightBasePath </> device </> "max_brightness")++readIntFile :: FilePath -> IO (Maybe Int)+readIntFile path =+  catch (do+    contents <- readFile path+    case words contents of+      (val:_) -> return $ readMaybe val+      _ -> return Nothing+  ) $ \(_ :: SomeException) -> return Nothing
+ src/System/Taffybar/Information/Bluetooth.hs view
@@ -0,0 +1,334 @@+{-# LANGUAGE OverloadedStrings #-}+-----------------------------------------------------------------------------+-- |+-- Module      : System.Taffybar.Information.Bluetooth+-- Copyright   : (c) Ivan A. Malison+-- License     : BSD3-style (see LICENSE)+--+-- Maintainer  : Ivan A. Malison+-- Stability   : unstable+-- Portability : unportable+--+-- This module provides functions for querying Bluetooth information using the+-- BlueZ dbus interface (org.bluez), as well as a broadcast "TChan" system for+-- allowing multiple readers to receive 'BluetoothInfo' updates without+-- duplicating requests.+--+-- The module uses the DBus ObjectManager interface to dynamically discover+-- Bluetooth controllers and devices, and monitors property changes for+-- real-time updates.+-----------------------------------------------------------------------------+module System.Taffybar.Information.Bluetooth+  ( -- * Data Types+    BluetoothInfo(..)+  , BluetoothDevice(..)+  , BluetoothController(..)+  , BluetoothStatus(..)+    -- * Information Access+  , getBluetoothInfo+  , getBluetoothInfoChan+  , getBluetoothInfoState+    -- * Connection+  , connectBluez+  ) where++import Control.Concurrent (forkIO, threadDelay)+import Control.Concurrent.MVar+import Control.Concurrent.STM.TChan+import Control.Exception (SomeException, finally, try)+import Control.Monad (forever)+import Control.Monad.IO.Class (MonadIO, liftIO)+import Control.Monad.STM (atomically)+import DBus+import DBus.Client+import Data.List (sortOn)+import Data.Map (Map)+import qualified Data.Map as M+import Data.Maybe (fromMaybe, listToMaybe, mapMaybe)+import Data.Text (Text)+import qualified Data.Text as T+import Data.Word (Word8)+import System.Log.Logger (Priority(..))+import System.Taffybar.Context (TaffyIO, getStateDefault, systemDBusClient)+import System.Taffybar.Util (logPrintF)+import Control.Monad.Trans.Reader (asks)++-- | Information about a Bluetooth device.+data BluetoothDevice = BluetoothDevice+  { devicePath :: ObjectPath+  , deviceName :: String+  , deviceAlias :: String+  , deviceAddress :: String+  , deviceIcon :: Maybe String+  , deviceConnected :: Bool+  , devicePaired :: Bool+  , deviceTrusted :: Bool+  , deviceBlocked :: Bool+  , deviceBatteryPercentage :: Maybe Word8+  } deriving (Eq, Show)++-- | Information about a Bluetooth controller (adapter).+data BluetoothController = BluetoothController+  { controllerPath :: ObjectPath+  , controllerAlias :: String+  , controllerAddress :: String+  , controllerPowered :: Bool+  , controllerDiscoverable :: Bool+  , controllerDiscovering :: Bool+  , controllerPairable :: Bool+  } deriving (Eq, Show)++-- | Complete Bluetooth state information.+data BluetoothInfo = BluetoothInfo+  { bluetoothController :: Maybe BluetoothController+  , bluetoothConnectedDevices :: [BluetoothDevice]+  , bluetoothAllDevices :: [BluetoothDevice]+  , bluetoothStatus :: BluetoothStatus+  } deriving (Eq, Show)++-- | High-level Bluetooth status.+data BluetoothStatus+  = BluetoothNoController+  | BluetoothOff+  | BluetoothOn+  | BluetoothConnected+  deriving (Eq, Show)++bluetoothLogPath :: String+bluetoothLogPath = "System.Taffybar.Information.Bluetooth"++bluetoothLogF :: (MonadIO m, Show t) => Priority -> String -> t -> m ()+bluetoothLogF = logPrintF bluetoothLogPath++-- | BlueZ DBus constants+bluezBusName :: BusName+bluezBusName = "org.bluez"++bluezRootPath :: ObjectPath+bluezRootPath = "/"++objectManagerInterfaceName :: InterfaceName+objectManagerInterfaceName = "org.freedesktop.DBus.ObjectManager"++propertiesInterfaceName :: InterfaceName+propertiesInterfaceName = "org.freedesktop.DBus.Properties"++adapter1InterfaceName :: InterfaceName+adapter1InterfaceName = "org.bluez.Adapter1"++device1InterfaceName :: InterfaceName+device1InterfaceName = "org.bluez.Device1"++battery1InterfaceName :: InterfaceName+battery1InterfaceName = "org.bluez.Battery1"++-- | Newtype wrapper for the channel/mvar pair to enable getStateDefault.+newtype BluetoothInfoChanVar =+  BluetoothInfoChanVar (TChan BluetoothInfo, MVar BluetoothInfo)++-- | Get a broadcast channel for Bluetooth info updates.+--+-- The first call will start a monitoring thread that keeps the BlueZ DBus+-- connection open and refreshes on property changes. Subsequent calls return+-- the already created channel.+getBluetoothInfoChan :: TaffyIO (TChan BluetoothInfo)+getBluetoothInfoChan = do+  BluetoothInfoChanVar (chan, _) <- getBluetoothInfoChanVar+  pure chan++-- | Read the current Bluetooth info state.+getBluetoothInfoState :: TaffyIO BluetoothInfo+getBluetoothInfoState = do+  BluetoothInfoChanVar (_, var) <- getBluetoothInfoChanVar+  liftIO $ readMVar var++getBluetoothInfoChanVar :: TaffyIO BluetoothInfoChanVar+getBluetoothInfoChanVar =+  getStateDefault $ do+    client <- asks systemDBusClient+    liftIO $ do+      chan <- newBroadcastTChanIO+      var <- newMVar defaultBluetoothInfo+      _ <- forkIO $ monitorBluetoothInfo client chan var+      pure $ BluetoothInfoChanVar (chan, var)++defaultBluetoothInfo :: BluetoothInfo+defaultBluetoothInfo = BluetoothInfo+  { bluetoothController = Nothing+  , bluetoothConnectedDevices = []+  , bluetoothAllDevices = []+  , bluetoothStatus = BluetoothNoController+  }++-- | Monitor Bluetooth information changes.+monitorBluetoothInfo ::+  Client ->+  TChan BluetoothInfo ->+  MVar BluetoothInfo ->+  IO ()+monitorBluetoothInfo client chan var = do+  refreshLock <- newMVar ()+  let writeInfo info = do+        _ <- swapMVar var info+        atomically $ writeTChan chan info++      refreshUnlocked = do+        result <- try $ getBluetoothInfoFromClient client+        case result of+          Left (e :: SomeException) -> do+            bluetoothLogF WARNING "Bluetooth refresh failed: %s" e+            writeInfo defaultBluetoothInfo+          Right info -> writeInfo info++      refresh = withMVar refreshLock $ const refreshUnlocked++      -- Match rule for BlueZ property changes+      propertiesChangedMatcher :: MatchRule+      propertiesChangedMatcher = matchAny+        { matchSender = Just bluezBusName+        , matchInterface = Just propertiesInterfaceName+        , matchMember = Just "PropertiesChanged"+        }++      -- Match rule for ObjectManager signals+      interfacesAddedMatcher :: MatchRule+      interfacesAddedMatcher = matchAny+        { matchSender = Just bluezBusName+        , matchInterface = Just objectManagerInterfaceName+        , matchMember = Just "InterfacesAdded"+        }++      interfacesRemovedMatcher :: MatchRule+      interfacesRemovedMatcher = matchAny+        { matchSender = Just bluezBusName+        , matchInterface = Just objectManagerInterfaceName+        , matchMember = Just "InterfacesRemoved"+        }++      loop = do+        -- Initial refresh+        refresh++        let runWithClient = do+              -- Register signal handlers+              hProps <- addMatch client propertiesChangedMatcher (const refresh)+              hAdded <- addMatch client interfacesAddedMatcher (const refresh)+              hRemoved <- addMatch client interfacesRemovedMatcher (const refresh)++              let cleanup = do+                    removeMatch client hProps+                    removeMatch client hAdded+                    removeMatch client hRemoved++              -- Block forever until an exception occurs+              blockForever `finally` cleanup++        result <- try runWithClient+        case result of+          Left (e :: SomeException) ->+            bluetoothLogF WARNING "Bluetooth monitor error: %s" e+          Right _ -> pure ()++        -- Wait before retrying+        threadDelay 5000000+        loop++      blockForever = forever $ threadDelay 1000000000++  loop++-- | Get Bluetooth information from an existing DBus client.+getBluetoothInfoFromClient :: Client -> IO BluetoothInfo+getBluetoothInfoFromClient client = do+  managedObjects <- getManagedObjects client+  case managedObjects of+    Left err -> do+      bluetoothLogF WARNING "Failed to get BlueZ managed objects: %s" err+      return defaultBluetoothInfo+    Right objects -> do+      let controllers = parseControllers objects+          devices = parseDevices objects+          connectedDevices = filter deviceConnected devices+          controller = listToMaybe controllers+          status = case controller of+            Nothing -> BluetoothNoController+            Just c+              | not (controllerPowered c) -> BluetoothOff+              | not (null connectedDevices) -> BluetoothConnected+              | otherwise -> BluetoothOn+      return BluetoothInfo+        { bluetoothController = controller+        , bluetoothConnectedDevices = connectedDevices+        , bluetoothAllDevices = devices+        , bluetoothStatus = status+        }++-- | Get Bluetooth info using the system DBus client.+getBluetoothInfo :: Client -> IO BluetoothInfo+getBluetoothInfo = getBluetoothInfoFromClient++-- | Connect to BlueZ on the system bus.+connectBluez :: IO (Maybe Client)+connectBluez = do+  result <- try connectSystem+  case result of+    Left (_ :: SomeException) -> return Nothing+    Right client -> return (Just client)++-- | Get all managed objects from BlueZ ObjectManager.+getManagedObjects :: Client -> IO (Either MethodError (Map ObjectPath (Map Text (Map Text Variant))))+getManagedObjects client = do+  let callMsg = (methodCall bluezRootPath objectManagerInterfaceName "GetManagedObjects")+        { methodCallDestination = Just bluezBusName }+  reply <- call client callMsg+  return $ case reply of+    Left err -> Left err+    Right ret -> case listToMaybe (methodReturnBody ret) >>= fromVariant of+      Nothing -> Left $ methodError (methodReturnSerial ret) $+        errorName_ "org.taffybar.InvalidResponse"+      Just objects -> Right objects++-- | Parse controllers from managed objects.+parseControllers :: Map ObjectPath (Map Text (Map Text Variant)) -> [BluetoothController]+parseControllers objects =+  sortOn controllerPath $ mapMaybe parseController $ M.toList objects+  where+    parseController :: (ObjectPath, Map Text (Map Text Variant)) -> Maybe BluetoothController+    parseController (path, interfaces) = do+      props <- M.lookup (T.pack $ formatInterfaceName adapter1InterfaceName) interfaces+      let readProp :: IsVariant a => Text -> a -> a+          readProp key def = fromMaybe def $ M.lookup key props >>= fromVariant+      return BluetoothController+        { controllerPath = path+        , controllerAlias = readProp "Alias" ""+        , controllerAddress = readProp "Address" ""+        , controllerPowered = readProp "Powered" False+        , controllerDiscoverable = readProp "Discoverable" False+        , controllerDiscovering = readProp "Discovering" False+        , controllerPairable = readProp "Pairable" False+        }++-- | Parse devices from managed objects.+parseDevices :: Map ObjectPath (Map Text (Map Text Variant)) -> [BluetoothDevice]+parseDevices objects =+  sortOn devicePath $ mapMaybe parseDevice $ M.toList objects+  where+    parseDevice :: (ObjectPath, Map Text (Map Text Variant)) -> Maybe BluetoothDevice+    parseDevice (path, interfaces) = do+      props <- M.lookup (T.pack $ formatInterfaceName device1InterfaceName) interfaces+      let readProp :: IsVariant a => Text -> a -> a+          readProp key def = fromMaybe def $ M.lookup key props >>= fromVariant+          batteryProps = M.lookup (T.pack $ formatInterfaceName battery1InterfaceName) interfaces+          batteryPct = batteryProps >>= M.lookup "Percentage" >>= fromVariant+      return BluetoothDevice+        { devicePath = path+        , deviceName = readProp "Name" ""+        , deviceAlias = readProp "Alias" ""+        , deviceAddress = readProp "Address" ""+        , deviceIcon = M.lookup "Icon" props >>= fromVariant+        , deviceConnected = readProp "Connected" False+        , devicePaired = readProp "Paired" False+        , deviceTrusted = readProp "Trusted" False+        , deviceBlocked = readProp "Blocked" False+        , deviceBatteryPercentage = batteryPct+        }
+ src/System/Taffybar/Information/DiskUsage.hs view
@@ -0,0 +1,116 @@+-----------------------------------------------------------------------------+-- |+-- Module      : System.Taffybar.Information.DiskUsage+-- Copyright   : (c) Ivan A. Malison+-- License     : BSD3-style (see LICENSE)+--+-- Maintainer  : Ivan A. Malison+-- Stability   : unstable+-- Portability : unportable+--+-- Disk usage information using the @statvfs(2)@ system call (via the+-- @disk-free-space@ package).+--+-- The shared-channel API ('getDiskUsageInfoChan', 'getDiskUsageInfoState')+-- uses a single polling thread per process (via 'getStateDefault') so that+-- multiple bar instances do not each spawn their own poller.+--+-- Because the channel is keyed by the 'DiskUsageChanVar' newtype, only one+-- monitored path is supported through the shared API.  If you need to+-- monitor several mount points independently, call 'getDiskUsageInfo'+-- directly with 'pollingLabelNew'.+-----------------------------------------------------------------------------++module System.Taffybar.Information.DiskUsage+  ( DiskUsageInfo(..)+  , getDiskUsageInfo+  , getDiskUsageInfoChan+  , getDiskUsageInfoState+  ) where++import Control.Concurrent (forkIO, threadDelay)+import Control.Concurrent.MVar+import Control.Concurrent.STM.TChan+import Control.Exception.Enclosed (catchAny)+import Control.Monad (forever, void)+import Control.Monad.IO.Class (liftIO)+import Control.Monad.STM (atomically)+import System.DiskSpace (getDiskUsage, diskTotal, diskFree, diskAvail)+import System.Log.Logger (Priority(..))+import System.Taffybar.Context (TaffyIO, getStateDefault)+import System.Taffybar.Util (logPrintF)++-- | Disk usage statistics for a single filesystem.+data DiskUsageInfo = DiskUsageInfo+  { diskInfoTotal        :: !Integer+  -- ^ Total space in bytes.+  , diskInfoFree         :: !Integer+  -- ^ Free space in bytes (includes reserved blocks).+  , diskInfoAvailable    :: !Integer+  -- ^ Space available to unprivileged users, in bytes.+  , diskInfoUsed         :: !Integer+  -- ^ Used space in bytes (@total - free@).+  , diskInfoUsedPercent  :: !Double+  -- ^ Percentage of total space that is used.+  , diskInfoFreePercent  :: !Double+  -- ^ Percentage of total space available to unprivileged users.+  } deriving (Show, Eq)++-- | Query disk usage for the filesystem containing @path@ via @statvfs(2)@.+getDiskUsageInfo :: FilePath -> IO DiskUsageInfo+getDiskUsageInfo path = do+  du <- getDiskUsage path+  let total = diskTotal du+      free  = diskFree du+      avail = diskAvail du+      used  = total - free+      usedPct = if total > 0+                then fromIntegral used * 100.0 / fromIntegral total+                else 0+      freePct = if total > 0+                then fromIntegral avail * 100.0 / fromIntegral total+                else 0+  return DiskUsageInfo+    { diskInfoTotal       = total+    , diskInfoFree        = free+    , diskInfoAvailable   = avail+    , diskInfoUsed        = used+    , diskInfoUsedPercent = usedPct+    , diskInfoFreePercent = freePct+    }++-- --------------------------------------------------------------------------+-- Shared polling channel++newtype DiskUsageChanVar =+  DiskUsageChanVar (TChan DiskUsageInfo, MVar DiskUsageInfo)++-- | 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+  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+  liftIO $ readMVar var++setupDiskUsageChanVar :: Double -> FilePath -> TaffyIO DiskUsageChanVar+setupDiskUsageChanVar interval path = getStateDefault $ liftIO $ do+  chan <- newBroadcastTChanIO+  info <- getDiskUsageInfo path+  var  <- newMVar info+  void $ forkIO $ forever $ do+    threadDelay (floor $ interval * 1000000)+    catchAny+      (do newInfo <- getDiskUsageInfo path+          void $ swapMVar var newInfo+          atomically $ writeTChan chan newInfo)+      (logPrintF logName WARNING "DiskUsage poll failed: %s")+  pure $ DiskUsageChanVar (chan, var)++logName :: String+logName = "System.Taffybar.Information.DiskUsage"
+ src/System/Taffybar/Information/Hyprland.hs view
@@ -0,0 +1,478 @@+{-# LANGUAGE OverloadedStrings #-}++-----------------------------------------------------------------------------+-- |+-- Module      : System.Taffybar.Information.Hyprland+-- Copyright   : (c) Ivan A. Malison+-- License     : BSD3-style (see LICENSE)+--+-- Maintainer  : Ivan A. Malison+-- Stability   : unstable+-- Portability : unportable+--+-- A small Hyprland "client" that provides a structured interface for issuing+-- Hyprland commands (optionally over the Hyprland command socket) and for+-- connecting to the Hyprland event socket.+--+-- This module is intended to centralize the socket/path logic so widgets can+-- share it. It is not (yet) wired into widgets.+-----------------------------------------------------------------------------++module System.Taffybar.Information.Hyprland+  ( -- * Client+    HyprlandClient+  , HyprlandClientConfig(..)+  , defaultHyprlandClientConfig+  , newHyprlandClient+  , reloadHyprlandClient+  , HyprlandClientEnv(..)+  , getHyprlandClientEnv++    -- * Hyprland Monad+  , HyprlandT+  , runHyprlandT+  , askHyprlandClient+  , runHyprlandCommandRawM+  , runHyprlandCommandJsonM++    -- * Shared Event Channel+  , HyprlandEventChan(..)+  , subscribeHyprlandEvents+  , buildHyprlandEventChan++    -- * Commands+  , HyprlandCommand(..)+  , hyprCommand+  , hyprCommandJson+  , hyprlandCommandToSocketCommand+  , runHyprlandCommandRaw+  , runHyprlandCommandJson++    -- * Sockets+  , HyprlandSocket(..)+  , hyprlandSocketName+  , hyprlandSocketPaths+  , openHyprlandSocket+  , openHyprlandEventSocket+  , withHyprlandEventSocket++    -- * Errors+  , HyprlandError(..)+  ) where++import           Control.Concurrent (forkIO, threadDelay)+import           Control.Concurrent.STM.TChan+  ( TChan+  , dupTChan+  , newBroadcastTChanIO+  , writeTChan+  )+import           Control.Exception.Enclosed (catchAny)+import           Control.Monad (forM, forever, void)+import           Control.Monad.IO.Class (MonadIO(..))+import           Control.Monad.STM (atomically)+import           Control.Monad.Trans.Reader (ReaderT, ask, runReaderT)+import           Data.Aeson (FromJSON, eitherDecode')+import qualified Data.ByteString as BS+import qualified Data.ByteString.Char8 as BS8+import qualified Data.ByteString.Lazy as BL+import           Data.List (sortOn)+import           Data.Ord (Down(..))+import qualified Data.Text as T+import qualified Data.Text.Encoding as TE+import qualified Network.Socket as NS+import qualified Network.Socket.ByteString as NSB+import           System.Directory (doesDirectoryExist, listDirectory)+import           System.Environment (lookupEnv)+import           System.FilePath ((</>), takeDirectory, takeFileName)+import           System.IO+  ( BufferMode(LineBuffering)+  , Handle+  , IOMode(ReadWriteMode)+  , hClose+  , hGetLine+  , hSetBuffering+  )+import           System.Log.Logger (Priority(..), logM)+import           System.Posix.Files (getFileStatus, isSocket, modificationTime)+import           System.Posix.Types (EpochTime)+import           Text.Printf (printf)++import           System.Taffybar.Util (runCommand)++data HyprlandError+  = HyprlandEnvMissing String+  | HyprlandSocketUnavailable HyprlandSocket [FilePath]+  | HyprlandSocketException FilePath String+  | HyprlandHyprctlFailed String+  | HyprlandJsonDecodeFailed String+  | HyprlandCommandBuildFailed String+  deriving (Show, Eq)++data HyprlandClientConfig = HyprlandClientConfig+  { useSocket :: Bool+  -- ^ Try the Hyprland command/event sockets when possible.+  , fallbackToHyprctl :: Bool+  -- ^ If the socket path is unavailable, fall back to invoking @hyprctl@.+  , hyprctlPath :: FilePath+  } deriving (Show, Eq)++defaultHyprlandClientConfig :: HyprlandClientConfig+defaultHyprlandClientConfig =+  HyprlandClientConfig+    { useSocket = True+    , fallbackToHyprctl = True+    , hyprctlPath = "hyprctl"+    }++data HyprlandClientEnv = HyprlandClientEnv+  { instanceSignature :: String+  , runtimeDir :: Maybe FilePath+  } deriving (Show, Eq)++getHyprlandClientEnv :: IO (Either HyprlandError HyprlandClientEnv)+getHyprlandClientEnv = do+  mSig <- lookupEnv "HYPRLAND_INSTANCE_SIGNATURE"+  case mSig of+    Nothing ->+      return $ Left $ HyprlandEnvMissing "HYPRLAND_INSTANCE_SIGNATURE"+    Just sig -> do+      mRuntime <- lookupEnv "XDG_RUNTIME_DIR"+      return $ Right $ HyprlandClientEnv+        { instanceSignature = sig+        , runtimeDir = mRuntime+        }++data HyprlandClient = HyprlandClient+  { clientConfig :: HyprlandClientConfig+  , clientEnv :: Maybe HyprlandClientEnv+  } deriving (Show, Eq)++-- | Construct a 'HyprlandClient' by reading environment variables.+--+-- If 'HYPRLAND_INSTANCE_SIGNATURE' is not set, socket-based operations will be+-- unavailable, but command execution may still succeed via the @hyprctl@+-- fallback depending on 'HyprlandClientConfig'.+newHyprlandClient :: HyprlandClientConfig -> IO HyprlandClient+newHyprlandClient cfg = do+  envResult <- getHyprlandClientEnv+  let env = either (const Nothing) Just envResult+  pure $ HyprlandClient { clientConfig = cfg, clientEnv = env }++-- | Reload the environment-derived portions of a 'HyprlandClient'.+reloadHyprlandClient :: HyprlandClient -> IO HyprlandClient+reloadHyprlandClient client = newHyprlandClient (clientConfig client)++-- | A reader transformer that carries a 'HyprlandClient'.+type HyprlandT m a = ReaderT HyprlandClient m a++runHyprlandT :: HyprlandClient -> HyprlandT m a -> m a+runHyprlandT = flip runReaderT++askHyprlandClient :: Monad m => HyprlandT m HyprlandClient+askHyprlandClient = ask++runHyprlandCommandRawM :: (MonadIO m) => HyprlandCommand -> HyprlandT m (Either HyprlandError BS.ByteString)+runHyprlandCommandRawM cmd = do+  client <- ask+  liftIO $ runHyprlandCommandRaw client cmd++runHyprlandCommandJsonM :: (MonadIO m, FromJSON a) => HyprlandCommand -> HyprlandT m (Either HyprlandError a)+runHyprlandCommandJsonM cmd = do+  client <- ask+  liftIO $ runHyprlandCommandJson client cmd++data HyprlandSocket+  = HyprlandCommandSocket+  | HyprlandEventSocket+  deriving (Show, Eq)++hyprlandSocketName :: HyprlandSocket -> FilePath+hyprlandSocketName HyprlandCommandSocket = ".socket.sock"+hyprlandSocketName HyprlandEventSocket = ".socket2.sock"++hyprlandSocketPaths :: HyprlandClient -> HyprlandSocket -> [FilePath]+hyprlandSocketPaths HyprlandClient { clientEnv = Nothing } _ = []+hyprlandSocketPaths+  HyprlandClient+    { clientEnv =+        Just HyprlandClientEnv+          { instanceSignature = sig+          , runtimeDir = mRuntimeDir+          }+    }+  sock =+  let name = hyprlandSocketName sock+      runtimePaths =+        case mRuntimeDir of+          Nothing -> []+          Just rd -> [rd ++ "/hypr/" ++ sig ++ "/" ++ name]+      tmpPath = "/tmp/hypr/" ++ sig ++ "/" ++ name+  in runtimePaths ++ [tmpPath]++openHyprlandSocket :: HyprlandClient -> HyprlandSocket -> IO (Either HyprlandError NS.Socket)+openHyprlandSocket client sock = do+  -- Prefer the instance signature from the process environment first. If that+  -- fails (e.g. Hyprland restarted and the signature changed), fall back to+  -- discovering currently-running instance sockets from the filesystem.+  let envPaths = hyprlandSocketPaths client sock+  envResult <- connectFirst envPaths+  case envResult of+    Just s -> pure (Right s)+    Nothing -> do+      discoveredPaths <- discoverHyprlandSocketPaths client sock+      discResult <- connectFirst discoveredPaths+      case discResult of+        Just s -> pure (Right s)+        Nothing ->+          if null envPaths && null discoveredPaths+            then pure $ Left $ HyprlandEnvMissing "HYPRLAND_INSTANCE_SIGNATURE"+            else pure $ Left $ HyprlandSocketUnavailable sock (envPaths ++ discoveredPaths)+  where+    connectFirst :: [FilePath] -> IO (Maybe NS.Socket)+    connectFirst [] = pure Nothing+    connectFirst (path:rest) = do+      result <- connectToSocket path+      case result of+        Left _ -> connectFirst rest+        Right s -> pure (Just s)++discoverHyprlandSocketPaths :: HyprlandClient -> HyprlandSocket -> IO [FilePath]+discoverHyprlandSocketPaths _client sock = do+  mRuntime <- lookupEnv "XDG_RUNTIME_DIR"+  let bases =+        maybe [] (\rd -> [rd </> "hypr"]) mRuntime +++        ["/tmp/hypr"]+  let name = hyprlandSocketName sock+  pathsWithTimes <- fmap concat $ forM bases $ \base -> do+    baseExists <- doesDirectoryExist base+    if not baseExists+      then pure []+      else do+        -- Best-effort: Hyprland instances come and go and we don't want to+        -- bring down widgets if this scan races a restart.+        sigEntries <- listDirectory base `catchAny` \_ -> pure []+        let candidates = map (\sig -> base </> sig </> name) sigEntries+        fmap concat $ forM candidates $ \p -> do+          mTime <- socketPathMTime p+          pure $ maybe [] (\t -> [(t, p)]) mTime++  -- Prefer the newest sockets first to minimize binding to a stale instance.+  pure $ map snd $ sortOn (Down . fst) pathsWithTimes++socketPathMTime :: FilePath -> IO (Maybe EpochTime)+socketPathMTime path =+  (do+      st <- getFileStatus path+      if isSocket st+        then pure $ Just $ modificationTime st+        else pure Nothing+    ) `catchAny` \_ -> pure Nothing++connectToSocket :: FilePath -> IO (Either HyprlandError NS.Socket)+connectToSocket path = do+  sock <- NS.socket NS.AF_UNIX NS.Stream NS.defaultProtocol+  (do+      NS.connect sock (NS.SockAddrUnix path)+      return $ Right sock+    ) `catchAny` \e -> do+      void $ NS.close sock `catchAny` \_ -> pure ()+      return $ Left $ HyprlandSocketException path (show e)++openHyprlandEventSocket :: HyprlandClient -> IO (Either HyprlandError Handle)+openHyprlandEventSocket client = do+  sockResult <- openHyprlandSocket client HyprlandEventSocket+  case sockResult of+    Left err -> return (Left err)+    Right sock -> do+      handle <- NS.socketToHandle sock ReadWriteMode+      hSetBuffering handle LineBuffering+      return (Right handle)++withHyprlandEventSocket :: HyprlandClient -> (Handle -> IO a) -> IO (Either HyprlandError a)+withHyprlandEventSocket client action = do+  handleResult <- openHyprlandEventSocket client+  case handleResult of+    Left err -> return (Left err)+    Right handle ->+      (do+          result <- action handle+          hClose handle+          return (Right result)+        ) `catchAny` \e -> do+          hClose handle+          return (Left $ HyprlandSocketException (show HyprlandEventSocket) (show e))++-- | A shared broadcast channel for Hyprland events read from the event socket.+--+-- Readers should call 'subscribeHyprlandEvents' to get their own cursor.+newtype HyprlandEventChan =+  HyprlandEventChan (TChan T.Text)++subscribeHyprlandEvents :: HyprlandEventChan -> IO (TChan T.Text)+subscribeHyprlandEvents (HyprlandEventChan chan) =+  atomically $ dupTChan chan++buildHyprlandEventChan :: HyprlandClient -> IO HyprlandEventChan+buildHyprlandEventChan client = do+  chan <- newBroadcastTChanIO+  _ <- forkIO $ eventThread chan+  pure $ HyprlandEventChan chan+  where+    logH :: Priority -> String -> IO ()+    logH = logM "System.Taffybar.Information.Hyprland"++    retryDelayMicros :: Int+    retryDelayMicros = 1 * 1000000++    eventThread chan = forever $ do+      handleResult <- openHyprlandEventSocket client+      case handleResult of+        Left err -> do+          logH WARNING $ printf "Hyprland event socket unavailable: %s" (show err)+          threadDelay retryDelayMicros+        Right handle -> do+          -- Emit a synthetic event on (re)connect so widgets can refresh their+          -- state after Hyprland restarts without resorting to polling.+          atomically $ writeTChan chan "taffybar-hyprland-connected>>"+          let loop =+                hGetLine handle >>= (atomically . writeTChan chan . T.pack) >> loop+          loop `catchAny` \e ->+            logH WARNING $ printf "Hyprland event socket failed: %s" (show e)+          void $ hClose handle `catchAny` \_ -> pure ()+          threadDelay retryDelayMicros++data HyprlandCommand = HyprlandCommand+  { commandArgs :: [String]+  , commandJson :: Bool+  } deriving (Show, Eq)++hyprCommand :: [String] -> HyprlandCommand+hyprCommand args = HyprlandCommand { commandArgs = args, commandJson = False }++hyprCommandJson :: [String] -> HyprlandCommand+hyprCommandJson args = HyprlandCommand { commandArgs = args, commandJson = True }++hyprlandCommandToSocketCommand :: HyprlandCommand -> Either HyprlandError BS.ByteString+hyprlandCommandToSocketCommand HyprlandCommand { commandArgs = args, commandJson = isJson }+  | null args = Left $ HyprlandCommandBuildFailed "No Hyprland command provided"+  | isJson = Right $ BS8.pack $ "j/" ++ unwords args+  | otherwise = Right $ BS8.pack $ unwords args++-- | Run a Hyprland command, preferring the command socket if enabled.+--+-- If socket execution fails and 'fallbackToHyprctl' is enabled, @hyprctl@ will+-- be invoked as a fallback.+runHyprlandCommandRaw :: HyprlandClient -> HyprlandCommand -> IO (Either HyprlandError BS.ByteString)+runHyprlandCommandRaw+  client@HyprlandClient+    { clientConfig =+        HyprlandClientConfig+          { useSocket = useSock+          , fallbackToHyprctl = fallback+          , hyprctlPath = hyprctl+          }+    }+  cmd = do+  socketResult <-+    if useSock+      then runHyprlandCommandSocket client cmd+      else pure $ Left $ HyprlandSocketUnavailable HyprlandCommandSocket []+  case socketResult of+    Right out -> pure (Right out)+    Left sockErr ->+      if fallback+        then do+          hyprctlResult <- runHyprlandCommandHyprctl client hyprctl cmd+          pure $ case hyprctlResult of+            Right out -> Right out+            Left hyprctlErr -> Left $ HyprlandHyprctlFailed $+              printf "%s (socket error: %s)" hyprctlErr (show sockErr)+        else pure (Left sockErr)++runHyprlandCommandSocket :: HyprlandClient -> HyprlandCommand -> IO (Either HyprlandError BS.ByteString)+runHyprlandCommandSocket client cmd = do+  sockResult <- openHyprlandSocket client HyprlandCommandSocket+  case sockResult of+    Left err -> pure (Left err)+    Right sock ->+      (do+          cmdBytes <- case hyprlandCommandToSocketCommand cmd of+            Left e -> NS.close sock >> pure (Left e)+            Right b -> pure (Right b)+          case cmdBytes of+            Left e -> pure (Left e)+            Right b -> do+              NSB.sendAll sock b+              NS.shutdown sock NS.ShutdownSend+              resp <- recvAll sock+              NS.close sock+              pure (Right resp)+        ) `catchAny` \e -> do+          NS.close sock+          pure $ Left $ HyprlandSocketException (show HyprlandCommandSocket) (show e)++runHyprlandCommandHyprctl :: HyprlandClient -> FilePath -> HyprlandCommand -> IO (Either String BS.ByteString)+runHyprlandCommandHyprctl client hyprctl HyprlandCommand { commandArgs = args, commandJson = isJson } = do+  mSig <- pickHyprlandInstanceSignature client+  let flags =+        ["-j" | isJson] +++        maybe [] (\sig -> ["-i", sig]) mSig+  result <- runCommand hyprctl (flags ++ args)+  pure $ case result of+    Left err -> Left err+    Right out -> Right $ TE.encodeUtf8 $ T.pack out++pickHyprlandInstanceSignature :: HyprlandClient -> IO (Maybe String)+pickHyprlandInstanceSignature client =+  case clientEnv client of+    Just HyprlandClientEnv { instanceSignature = sig } -> do+      -- Prefer the signature from the environment if we can actually connect+      -- to the command socket. (After a Hyprland restart the old socket path+      -- might still exist but be stale.)+      envAlive <- anyM canConnectSocket $+        hyprlandSocketPaths client HyprlandCommandSocket+      if envAlive+        then pure (Just sig)+        else discover+    Nothing -> discover+  where+    canConnectSocket path = do+      result <- connectToSocket path+      case result of+        Left _ -> pure False+        Right sock -> do+          void $ NS.close sock `catchAny` \_ -> pure ()+          pure True++    discover = do+      -- Use the newest discovered command socket.+      paths <- discoverHyprlandSocketPaths client HyprlandCommandSocket+      pure $ case paths of+        p:_ -> Just $ takeFileName $ takeDirectory p+        [] -> Nothing++anyM :: Monad m => (a -> m Bool) -> [a] -> m Bool+anyM _ [] = pure False+anyM p (x:xs) = do+  b <- p x+  if b then pure True else anyM p xs++recvAll :: NS.Socket -> IO BS.ByteString+recvAll sock = go []+  where+    go acc = do+      chunk <- NSB.recv sock 4096+      if BS.null chunk+        then return (BS.concat (reverse acc))+        else go (chunk:acc)++runHyprlandCommandJson :: FromJSON a => HyprlandClient -> HyprlandCommand -> IO (Either HyprlandError a)+runHyprlandCommandJson client cmd = do+  raw <- runHyprlandCommandRaw client cmd+  pure $ case raw of+    Left err -> Left err+    Right out ->+      case eitherDecode' (BL.fromStrict out) of+        Left decodeErr -> Left $ HyprlandJsonDecodeFailed decodeErr+        Right a -> Right a
+ src/System/Taffybar/Information/Inhibitor.hs view
@@ -0,0 +1,226 @@+{-# LANGUAGE OverloadedStrings #-}+-----------------------------------------------------------------------------+-- |+-- Module      : System.Taffybar.Information.Inhibitor+-- Copyright   : (c) Ivan A. Malison+-- License     : BSD3-style (see LICENSE)+--+-- Maintainer  : Ivan A. Malison+-- Stability   : unstable+-- Portability : unportable+--+-- This module provides functions for managing idle/sleep inhibitors using the+-- systemd-logind DBus interface. The inhibitor is acquired by calling the+-- Inhibit method on org.freedesktop.login1.Manager, which returns a file+-- descriptor. The lock is held as long as the fd is open.+-----------------------------------------------------------------------------+module System.Taffybar.Information.Inhibitor+  ( -- * Types+    InhibitType(..)+  , InhibitorState(..)+  , InhibitorContext(..)+    -- * Inhibitor Management+  , getInhibitorContext+  , getInhibitorState+  , toggleInhibitor+  , getInhibitorChan+    -- * Utilities+  , inhibitTypeToString+  , inhibitTypesFromStrings+  ) where++import           Control.Concurrent+import           Control.Concurrent.STM.TChan+import           Control.Monad.IO.Class+import           Control.Monad.STM (atomically)+import           Control.Monad.Trans.Reader+import           DBus+import           DBus.Client+import           Data.List (intercalate)+import qualified Data.Text as T+import           System.Log.Logger+import           System.Posix.IO (closeFd)+import           System.Posix.Types (Fd)+import           System.Taffybar.Context++-- | Types of inhibitors supported by systemd-logind+data InhibitType+  = InhibitIdle+  | InhibitShutdown+  | InhibitSleep+  | InhibitHandlePowerKey+  | InhibitHandleSuspendKey+  | InhibitHandleHibernateKey+  | InhibitHandleLidSwitch+  deriving (Eq, Show, Ord, Enum, Bounded)++-- | Current state of the inhibitor+data InhibitorState = InhibitorState+  { inhibitorActive :: Bool+  , inhibitorTypes :: [InhibitType]+  } deriving (Eq, Show)++-- | Context for managing an inhibitor, stored in taffybar's state+data InhibitorContext = InhibitorContext+  { inhibitorChan :: TChan InhibitorState+  , inhibitorStateVar :: MVar InhibitorState+  , inhibitorFdVar :: MVar (Maybe Fd)+  , inhibitorConfig :: [InhibitType]+  }++inhibitorLogPath :: String+inhibitorLogPath = "System.Taffybar.Information.Inhibitor"++inhibitorLog :: MonadIO m => Priority -> String -> m ()+inhibitorLog priority = liftIO . logM inhibitorLogPath priority++-- | Convert an InhibitType to its string representation for DBus+inhibitTypeToString :: InhibitType -> String+inhibitTypeToString InhibitIdle = "idle"+inhibitTypeToString InhibitShutdown = "shutdown"+inhibitTypeToString InhibitSleep = "sleep"+inhibitTypeToString InhibitHandlePowerKey = "handle-power-key"+inhibitTypeToString InhibitHandleSuspendKey = "handle-suspend-key"+inhibitTypeToString InhibitHandleHibernateKey = "handle-hibernate-key"+inhibitTypeToString InhibitHandleLidSwitch = "handle-lid-switch"++-- | Parse a string to an InhibitType+inhibitTypeFromString :: String -> Maybe InhibitType+inhibitTypeFromString "idle" = Just InhibitIdle+inhibitTypeFromString "shutdown" = Just InhibitShutdown+inhibitTypeFromString "sleep" = Just InhibitSleep+inhibitTypeFromString "handle-power-key" = Just InhibitHandlePowerKey+inhibitTypeFromString "handle-suspend-key" = Just InhibitHandleSuspendKey+inhibitTypeFromString "handle-hibernate-key" = Just InhibitHandleHibernateKey+inhibitTypeFromString "handle-lid-switch" = Just InhibitHandleLidSwitch+inhibitTypeFromString _ = Nothing++-- | Parse a list of strings to InhibitTypes, ignoring invalid ones+inhibitTypesFromStrings :: [String] -> [InhibitType]+inhibitTypesFromStrings = foldr go []+  where+    go s acc = case inhibitTypeFromString s of+      Just t -> t : acc+      Nothing -> acc++-- | Convert a list of InhibitTypes to the colon-separated format for DBus+inhibitTypesToDBusString :: [InhibitType] -> String+inhibitTypesToDBusString = intercalate ":" . map inhibitTypeToString++-- | The DBus destination for systemd-logind+login1BusName :: BusName+login1BusName = "org.freedesktop.login1"++-- | The DBus object path for the login1 manager+login1ObjectPath :: ObjectPath+login1ObjectPath = "/org/freedesktop/login1"++-- | The DBus interface for the login1 manager+login1Interface :: InterfaceName+login1Interface = "org.freedesktop.login1.Manager"++-- | Acquire an inhibitor lock via DBus+-- The Inhibit method takes (what, who, why, mode) and returns a file descriptor+acquireInhibitor :: Client -> [InhibitType] -> IO (Either MethodError Fd)+acquireInhibitor client types = do+  let what = inhibitTypesToDBusString types+      who = "taffybar"+      why = "User requested inhibition"+      mode = "block" :: String+  inhibitorLog DEBUG $ "Acquiring inhibitor for: " ++ what+  reply <- call client (methodCall login1ObjectPath login1Interface "Inhibit")+    { methodCallDestination = Just login1BusName+    , methodCallBody = [ toVariant (T.pack what)+                       , toVariant (T.pack who)+                       , toVariant (T.pack why)+                       , toVariant (T.pack mode)+                       ]+    }+  case reply of+    Left err -> do+      inhibitorLog WARNING $ "Failed to acquire inhibitor: " ++ show err+      return $ Left err+    Right ret -> do+      case methodReturnBody ret of+        [v] -> case fromVariant v :: Maybe Fd of+          Just fd -> do+            inhibitorLog DEBUG $ "Acquired inhibitor fd: " ++ show fd+            return $ Right fd+          Nothing -> do+            inhibitorLog WARNING "Invalid fd type in response"+            return $ Left $ methodError (methodReturnSerial ret) $+              errorName_ "org.taffybar.InvalidResponse"+        _ -> do+          inhibitorLog WARNING "Unexpected response format"+          return $ Left $ methodError (methodReturnSerial ret) $+            errorName_ "org.taffybar.InvalidResponse"++-- | Release an inhibitor by closing its file descriptor+releaseInhibitor :: Fd -> IO ()+releaseInhibitor fd = do+  inhibitorLog DEBUG $ "Releasing inhibitor fd: " ++ show fd+  closeFd fd++-- | Get or create the InhibitorContext for the given inhibit types+getInhibitorContext :: [InhibitType] -> TaffyIO InhibitorContext+getInhibitorContext types = getStateDefault $ do+  inhibitorLog DEBUG "Initializing InhibitorContext"+  chan <- liftIO newBroadcastTChanIO+  stateVar <- liftIO $ newMVar InhibitorState+    { inhibitorActive = False+    , inhibitorTypes = types+    }+  fdVar <- liftIO $ newMVar Nothing+  return InhibitorContext+    { inhibitorChan = chan+    , inhibitorStateVar = stateVar+    , inhibitorFdVar = fdVar+    , inhibitorConfig = types+    }++-- | Get the current inhibitor state+getInhibitorState :: [InhibitType] -> TaffyIO InhibitorState+getInhibitorState types = do+  ctx <- getInhibitorContext types+  liftIO $ readMVar (inhibitorStateVar ctx)++-- | Get the broadcast channel for inhibitor state changes+getInhibitorChan :: [InhibitType] -> TaffyIO (TChan InhibitorState)+getInhibitorChan types = do+  ctx <- getInhibitorContext types+  return $ inhibitorChan ctx++-- | Toggle the inhibitor on or off+toggleInhibitor :: [InhibitType] -> TaffyIO ()+toggleInhibitor types = do+  ctx <- getInhibitorContext types+  client <- asks systemDBusClient+  liftIO $ modifyMVar_ (inhibitorFdVar ctx) $ \maybeFd -> do+    case maybeFd of+      Just fd -> do+        -- Currently active, release it+        releaseInhibitor fd+        let newState = InhibitorState+              { inhibitorActive = False+              , inhibitorTypes = types+              }+        _ <- swapMVar (inhibitorStateVar ctx) newState+        atomically $ writeTChan (inhibitorChan ctx) newState+        inhibitorLog DEBUG "Inhibitor deactivated"+        return Nothing+      Nothing -> do+        -- Currently inactive, acquire it+        result <- acquireInhibitor client types+        case result of+          Right fd -> do+            let newState = InhibitorState+                  { inhibitorActive = True+                  , inhibitorTypes = types+                  }+            _ <- swapMVar (inhibitorStateVar ctx) newState+            atomically $ writeTChan (inhibitorChan ctx) newState+            inhibitorLog DEBUG "Inhibitor activated"+            return (Just fd)+          Left _ -> do+            inhibitorLog WARNING "Failed to acquire inhibitor"+            return Nothing
+ src/System/Taffybar/Information/KeyboardState.hs view
@@ -0,0 +1,99 @@+{-# LANGUAGE OverloadedStrings #-}++--------------------------------------------------------------------------------+-- |+-- Module      : System.Taffybar.Information.KeyboardState+-- Copyright   : (c) Ivan Malison+-- License     : BSD3-style (see LICENSE)+--+-- Maintainer  : Ivan Malison <IvanMalison@gmail.com>+-- Stability   : unstable+-- Portability : unportable+--+-- Provides information about keyboard lock states (Caps Lock, Num Lock,+-- Scroll Lock) by reading LED brightness values from sysfs.+--+--------------------------------------------------------------------------------++module System.Taffybar.Information.KeyboardState+  ( KeyboardState(..)+  , getKeyboardState+  , defaultKeyboardState+  , findLedPath+  , defaultLedBasePath+  ) where++import Control.Exception (catch, SomeException)+import Data.List (find)+import System.Directory (listDirectory, doesFileExist)+import System.FilePath ((</>))++-- | Represents the state of keyboard lock keys.+data KeyboardState = KeyboardState+  { capsLock :: Bool+  , numLock :: Bool+  , scrollLock :: Bool+  } deriving (Eq, Show)++-- | Default keyboard state with all locks off.+defaultKeyboardState :: KeyboardState+defaultKeyboardState = KeyboardState False False False++-- | Default base path for LED sysfs entries.+defaultLedBasePath :: FilePath+defaultLedBasePath = "/sys/class/leds"++-- | Find the LED path for a given lock type by scanning sysfs.+-- Returns the full path to the brightness file, or Nothing if not found.+findLedPath :: FilePath -> String -> IO (Maybe FilePath)+findLedPath basePath lockType = do+  entries <- listDirectory basePath `catch` \(_ :: SomeException) -> return []+  let matchingEntry = find (matchesLockType lockType) entries+  case matchingEntry of+    Nothing -> return Nothing+    Just entry -> do+      let brightnessPath = basePath </> entry </> "brightness"+      exists <- doesFileExist brightnessPath+      return $ if exists then Just brightnessPath else Nothing++-- | Check if an LED entry name matches a lock type.+-- Matches patterns like "input15::capslock" for lock type "capslock".+matchesLockType :: String -> String -> Bool+matchesLockType lockType entry =+  ("::" ++ lockType) `isSuffixOf` entry || (":" ++ lockType) `isSuffixOf` entry+  where+    isSuffixOf :: String -> String -> Bool+    isSuffixOf suffix str = drop (length str - length suffix) str == suffix++-- | Read the brightness value from a sysfs LED file.+-- Returns True if the LED is on (brightness > 0), False otherwise.+readLedState :: FilePath -> IO Bool+readLedState path = do+  content <- readFile path `catch` \(_ :: SomeException) -> return "0"+  let value = reads (filter (/= '\n') content) :: [(Int, String)]+  case value of+    [(n, _)] -> return (n > 0)+    _ -> return False++-- | Get the current keyboard state by reading LED brightness from sysfs.+-- Uses the default LED base path ("/sys/class/leds").+-- Returns 'defaultKeyboardState' if LED files cannot be found.+getKeyboardState :: IO KeyboardState+getKeyboardState = getKeyboardStateFromPath defaultLedBasePath++-- | Get the keyboard state from a custom sysfs path.+getKeyboardStateFromPath :: FilePath -> IO KeyboardState+getKeyboardStateFromPath basePath = do+  capsPath <- findLedPath basePath "capslock"+  numPath <- findLedPath basePath "numlock"+  scrollPath <- findLedPath basePath "scrolllock"++  capsState <- maybe (return False) readLedState capsPath+  numState <- maybe (return False) readLedState numPath+  scrollState <- maybe (return False) readLedState scrollPath++  return KeyboardState+    { capsLock = capsState+    , numLock = numState+    , scrollLock = scrollState+    }
+ src/System/Taffybar/Information/NetworkManager.hs view
@@ -0,0 +1,443 @@+{-# LANGUAGE OverloadedStrings #-}+-----------------------------------------------------------------------------+-- |+-- Module      : System.Taffybar.Information.NetworkManager+-- Copyright   : (c) Ivan A. Malison+-- License     : BSD3-style (see LICENSE)+--+-- Maintainer  : Ivan A. Malison+-- Stability   : unstable+-- Portability : unportable+--+-- This module provides information about the active WiFi connection using+-- NetworkManager's DBus API.+-----------------------------------------------------------------------------+module System.Taffybar.Information.NetworkManager+  ( WifiInfo(..)+  , WifiState(..)+  , NetworkInfo(..)+  , NetworkState(..)+  , NetworkType(..)+  , getWifiInfo+  , getWifiInfoFromClient+  , getWifiInfoChan+  , getWifiInfoState+  , getNetworkInfo+  , getNetworkInfoFromClient+  , getNetworkInfoChan+  , getNetworkInfoState+  ) where++import           Control.Concurrent.MVar+import           Control.Concurrent.STM.TChan+import           Control.Monad.IO.Class+import           Control.Monad.STM (atomically)+import           Control.Monad.Trans.Class+import           Control.Monad.Trans.Except+import           Control.Monad.Trans.Reader+import           DBus+import           DBus.Client+import           DBus.Internal.Types (Serial(..))+import qualified DBus.TH as DBus+import qualified Data.ByteString as BS+import           Data.List (minimumBy)+import           Data.Map (Map)+import qualified Data.Map as M+import           Data.Maybe (fromMaybe, listToMaybe)+import           Data.Text (Text)+import qualified Data.Text as T+import qualified Data.Text.Encoding as TE+import qualified Data.Text.Encoding.Error as TEE+import           Data.Word (Word8)+import           System.Log.Logger+import           System.Taffybar.Context+import           System.Taffybar.DBus.Client.Params+import           System.Taffybar.Util (logPrintF, maybeToEither)++data WifiState+  = WifiDisabled+  | WifiDisconnected+  | WifiConnected+  | WifiUnknown+  deriving (Eq, Show)++data WifiInfo = WifiInfo+  { wifiState :: WifiState+  , wifiSsid :: Maybe Text+  , wifiStrength :: Maybe Int+  , wifiConnectionId :: Maybe Text+  } deriving (Eq, Show)++data NetworkState+  = NetworkConnected+  | NetworkDisconnected+  | NetworkUnknown+  deriving (Eq, Show)++data NetworkType+  = NetworkWifi+  | NetworkWired+  | NetworkVpn+  | NetworkOther Text+  deriving (Eq, Show)++data NetworkInfo = NetworkInfo+  { networkState :: NetworkState+  , networkType :: Maybe NetworkType+  , networkSsid :: Maybe Text+  , networkStrength :: Maybe Int+  , networkConnectionId :: Maybe Text+  , networkWirelessEnabled :: Maybe Bool+  } deriving (Eq, Show)++wifiLogPath :: String+wifiLogPath = "System.Taffybar.Information.NetworkManager"++wifiLogF :: (MonadIO m, Show t) => Priority -> String -> t -> m ()+wifiLogF = logPrintF wifiLogPath++nullObjectPath :: ObjectPath+nullObjectPath = objectPath_ "/"++wifiUnknownInfo :: WifiInfo+wifiUnknownInfo =+  WifiInfo+    { wifiState = WifiUnknown+    , wifiSsid = Nothing+    , wifiStrength = Nothing+    , wifiConnectionId = Nothing+    }++wifiDisabledInfo :: WifiInfo+wifiDisabledInfo =+  WifiInfo+    { wifiState = WifiDisabled+    , wifiSsid = Nothing+    , wifiStrength = Nothing+    , wifiConnectionId = Nothing+    }++wifiDisconnectedInfo :: WifiInfo+wifiDisconnectedInfo =+  WifiInfo+    { wifiState = WifiDisconnected+    , wifiSsid = Nothing+    , wifiStrength = Nothing+    , wifiConnectionId = Nothing+    }++newtype WifiInfoChanVar = WifiInfoChanVar (TChan WifiInfo, MVar WifiInfo)++getWifiInfoState :: TaffyIO WifiInfo+getWifiInfoState = do+  WifiInfoChanVar (_, theVar) <- getWifiInfoChanVar+  lift $ readMVar theVar++getWifiInfoChan :: TaffyIO (TChan WifiInfo)+getWifiInfoChan = do+  WifiInfoChanVar (chan, _) <- getWifiInfoChanVar+  return chan++getWifiInfoChanVar :: TaffyIO WifiInfoChanVar+getWifiInfoChanVar =+  getStateDefault $ WifiInfoChanVar <$> monitorWifiInfo++monitorWifiInfo :: TaffyIO (TChan WifiInfo, MVar WifiInfo)+monitorWifiInfo = do+  _client <- asks systemDBusClient+  infoVar <- lift $ newMVar wifiUnknownInfo+  chan <- liftIO newBroadcastTChanIO+  taffyFork $ do+    ctx <- ask+    let updateInfo = updateWifiInfo chan infoVar+        signalCallback _ _ _ _ = runReaderT updateInfo ctx+    _ <- registerForNetworkManagerPropertiesChanged signalCallback+    _ <- registerForActiveConnectionPropertiesChanged signalCallback+    _ <- registerForAccessPointPropertiesChanged signalCallback+    updateInfo+  return (chan, infoVar)++registerForNetworkManagerPropertiesChanged+  :: (Signal -> String -> Map String Variant -> [String] -> IO ())+  -> ReaderT Context IO SignalHandler+registerForNetworkManagerPropertiesChanged signalHandler = do+  client <- asks systemDBusClient+  lift $ DBus.registerForPropertiesChanged+    client+    matchAny { matchInterface = Just nmInterfaceName+             , matchPath = Just nmObjectPath+             }+    signalHandler++registerForActiveConnectionPropertiesChanged+  :: (Signal -> String -> Map String Variant -> [String] -> IO ())+  -> ReaderT Context IO SignalHandler+registerForActiveConnectionPropertiesChanged signalHandler = do+  client <- asks systemDBusClient+  lift $ DBus.registerForPropertiesChanged+    client+    matchAny { matchInterface = Just nmActiveConnectionInterfaceName+             , matchPathNamespace = Just nmActiveConnectionPathNamespace+             }+    signalHandler++registerForAccessPointPropertiesChanged+  :: (Signal -> String -> Map String Variant -> [String] -> IO ())+  -> ReaderT Context IO SignalHandler+registerForAccessPointPropertiesChanged signalHandler = do+  client <- asks systemDBusClient+  lift $ DBus.registerForPropertiesChanged+    client+    matchAny { matchInterface = Just nmAccessPointInterfaceName+             , matchPathNamespace = Just nmAccessPointPathNamespace+             }+    signalHandler++updateWifiInfo+  :: TChan WifiInfo+  -> MVar WifiInfo+  -> TaffyIO ()+updateWifiInfo chan var = do+  info <- getWifiInfo+  lift $ do+    _ <- swapMVar var info+    atomically $ writeTChan chan info++-- XXX: Remove this once it is exposed in haskell-dbus+dummyMethodError :: MethodError+dummyMethodError = methodError (Serial 1) $ errorName_ "org.ClientTypeMismatch"++readDictMaybe :: IsVariant a => Map Text Variant -> Text -> Maybe a+readDictMaybe dict key = M.lookup key dict >>= fromVariant++getProperties+  :: Client+  -> ObjectPath+  -> InterfaceName+  -> IO (Either MethodError (Map Text Variant))+getProperties client path iface = runExceptT $ do+  reply <- ExceptT $ getAllProperties client $+    (methodCall path iface "FakeMethod")+      { methodCallDestination = Just nmBusName }+  ExceptT $ return $ maybeToEither dummyMethodError $+    listToMaybe (methodReturnBody reply) >>= fromVariant++getWifiInfo :: TaffyIO WifiInfo+getWifiInfo = asks systemDBusClient >>= liftIO . getWifiInfoFromClient++getWifiInfoFromClient :: Client -> IO WifiInfo+getWifiInfoFromClient client = do+  nmPropsResult <- getProperties client nmObjectPath nmInterfaceName+  case nmPropsResult of+    Left err -> do+      wifiLogF WARNING "Failed to read NetworkManager properties: %s" err+      return wifiUnknownInfo+    Right nmProps -> do+      let wirelessEnabled = readDictMaybe nmProps "WirelessEnabled" :: Maybe Bool+          activeConnections =+            readDictMaybe nmProps "ActiveConnections" :: Maybe [ObjectPath]+      case wirelessEnabled of+        Just False -> return wifiDisabledInfo+        Just True -> case activeConnections of+          Just paths -> fromMaybe wifiDisconnectedInfo <$>+                        findActiveWifi client paths+          Nothing -> do+            logM wifiLogPath WARNING "NetworkManager missing ActiveConnections"+            return wifiUnknownInfo+        Nothing -> do+          logM wifiLogPath WARNING "NetworkManager missing WirelessEnabled"+          return wifiUnknownInfo++findActiveWifi :: Client -> [ObjectPath] -> IO (Maybe WifiInfo)+findActiveWifi _ [] = return Nothing+findActiveWifi client (path:rest) = do+  connPropsResult <- getProperties client path nmActiveConnectionInterfaceName+  case connPropsResult of+    Left err -> do+      wifiLogF DEBUG "Failed to read active connection %s" err+      findActiveWifi client rest+    Right connProps -> do+      let connType = readDictMaybe connProps "Type" :: Maybe Text+      if connType /= Just "802-11-wireless"+        then findActiveWifi client rest+        else do+          let connId = readDictMaybe connProps "Id" :: Maybe Text+              specificObject =+                readDictMaybe connProps "SpecificObject" :: Maybe ObjectPath+          (ssid, strength) <- getAccessPointInfo client specificObject+          return $ Just WifiInfo+            { wifiState = WifiConnected+            , wifiSsid = ssid+            , wifiStrength = strength+            , wifiConnectionId = connId+            }++getAccessPointInfo+  :: Client+  -> Maybe ObjectPath+  -> IO (Maybe Text, Maybe Int)+getAccessPointInfo _ Nothing = return (Nothing, Nothing)+getAccessPointInfo _ (Just path) | path == nullObjectPath =+  return (Nothing, Nothing)+getAccessPointInfo client (Just path) = do+  apPropsResult <- getProperties client path nmAccessPointInterfaceName+  case apPropsResult of+    Left err -> do+      wifiLogF DEBUG "Failed to read access point properties %s" err+      return (Nothing, Nothing)+    Right apProps -> do+      let ssidBytes = readDictMaybe apProps "Ssid" :: Maybe [Word8]+          strength = readDictMaybe apProps "Strength" :: Maybe Word8+      return+        ( ssidBytes >>= decodeSsid+        , fromIntegral <$> strength+        )++decodeSsid :: [Word8] -> Maybe Text+decodeSsid bytes+  | null bytes = Nothing+  | otherwise = Just $ TE.decodeUtf8With TEE.lenientDecode (BS.pack bytes)++-- Network info (WiFi + wired + VPN + disconnected)++newtype NetworkInfoChanVar = NetworkInfoChanVar (TChan NetworkInfo, MVar NetworkInfo)++networkUnknownInfo :: NetworkInfo+networkUnknownInfo =+  NetworkInfo+    { networkState = NetworkUnknown+    , networkType = Nothing+    , networkSsid = Nothing+    , networkStrength = Nothing+    , networkConnectionId = Nothing+    , networkWirelessEnabled = Nothing+    }++getNetworkInfoState :: TaffyIO NetworkInfo+getNetworkInfoState = do+  NetworkInfoChanVar (_, theVar) <- getNetworkInfoChanVar+  lift $ readMVar theVar++getNetworkInfoChan :: TaffyIO (TChan NetworkInfo)+getNetworkInfoChan = do+  NetworkInfoChanVar (chan, _) <- getNetworkInfoChanVar+  return chan++getNetworkInfoChanVar :: TaffyIO NetworkInfoChanVar+getNetworkInfoChanVar =+  getStateDefault $ NetworkInfoChanVar <$> monitorNetworkInfo++monitorNetworkInfo :: TaffyIO (TChan NetworkInfo, MVar NetworkInfo)+monitorNetworkInfo = do+  infoVar <- lift $ newMVar networkUnknownInfo+  chan <- liftIO newBroadcastTChanIO+  taffyFork $ do+    ctx <- ask+    let updateInfo = updateNetworkInfo chan infoVar+        signalCallback _ _ _ _ = runReaderT updateInfo ctx+    _ <- registerForNetworkManagerPropertiesChanged signalCallback+    _ <- registerForActiveConnectionPropertiesChanged signalCallback+    _ <- registerForAccessPointPropertiesChanged signalCallback+    updateInfo+  return (chan, infoVar)++updateNetworkInfo+  :: TChan NetworkInfo+  -> MVar NetworkInfo+  -> TaffyIO ()+updateNetworkInfo chan var = do+  info <- getNetworkInfo+  lift $ do+    _ <- swapMVar var info+    atomically $ writeTChan chan info++getNetworkInfo :: TaffyIO NetworkInfo+getNetworkInfo = asks systemDBusClient >>= liftIO . getNetworkInfoFromClient++data ActiveConnectionInfo = ActiveConnectionInfo+  { activeConnectionPath :: ObjectPath+  , activeConnectionType :: Text+  , activeConnectionId :: Maybe Text+  , activeConnectionSpecificObject :: Maybe ObjectPath+  } deriving (Eq, Show)++getNetworkInfoFromClient :: Client -> IO NetworkInfo+getNetworkInfoFromClient client = do+  nmPropsResult <- getProperties client nmObjectPath nmInterfaceName+  case nmPropsResult of+    Left err -> do+      wifiLogF WARNING "Failed to read NetworkManager properties: %s" err+      return networkUnknownInfo+    Right nmProps -> do+      let wirelessEnabled = readDictMaybe nmProps "WirelessEnabled" :: Maybe Bool+          activeConnections =+            readDictMaybe nmProps "ActiveConnections" :: Maybe [ObjectPath]++      activeInfos <- maybe (return []) (mapM (getActiveConnectionInfo client)) activeConnections+      let best = pickBestActiveConnection activeInfos++      case best of+        Nothing ->+          return networkUnknownInfo+            { networkState = NetworkDisconnected+            , networkWirelessEnabled = wirelessEnabled+            }+        Just ac -> do+          (ssid, strength) <-+            if activeConnectionType ac == "802-11-wireless"+              then getAccessPointInfo client (activeConnectionSpecificObject ac)+              else return (Nothing, Nothing)+          return networkUnknownInfo+            { networkState = NetworkConnected+            , networkType = Just $ toNetworkType (activeConnectionType ac)+            , networkSsid = ssid+            , networkStrength = strength+            , networkConnectionId = activeConnectionId ac+            , networkWirelessEnabled = wirelessEnabled+            }++getActiveConnectionInfo :: Client -> ObjectPath -> IO ActiveConnectionInfo+getActiveConnectionInfo client path = do+  connPropsResult <- getProperties client path nmActiveConnectionInterfaceName+  case connPropsResult of+    Left err -> do+      wifiLogF DEBUG "Failed to read active connection %s" err+      return ActiveConnectionInfo+        { activeConnectionPath = path+        , activeConnectionType = ""+        , activeConnectionId = Nothing+        , activeConnectionSpecificObject = Nothing+        }+    Right connProps -> do+      let connType = fromMaybe "" (readDictMaybe connProps "Type" :: Maybe Text)+          connId = readDictMaybe connProps "Id" :: Maybe Text+          specificObject =+            readDictMaybe connProps "SpecificObject" :: Maybe ObjectPath+      return ActiveConnectionInfo+        { activeConnectionPath = path+        , activeConnectionType = connType+        , activeConnectionId = connId+        , activeConnectionSpecificObject = specificObject+        }++pickBestActiveConnection :: [ActiveConnectionInfo] -> Maybe ActiveConnectionInfo+pickBestActiveConnection [] = Nothing+pickBestActiveConnection infos =+  let+    rank t+      | t == "802-3-ethernet" = 0 :: Int+      | t == "802-11-wireless" = 1+      | t == "vpn" = 2+      | T.null t = 99+      | otherwise = 50+  in Just $+     minimumBy+       (\a b -> compare (rank (activeConnectionType a)) (rank (activeConnectionType b)))+       infos++toNetworkType :: Text -> NetworkType+toNetworkType t+  | t == "802-11-wireless" = NetworkWifi+  | t == "802-3-ethernet" = NetworkWired+  | t == "vpn" = NetworkVpn+  | otherwise = NetworkOther t
+ src/System/Taffybar/Information/PowerProfiles.hs view
@@ -0,0 +1,226 @@+{-# LANGUAGE OverloadedStrings #-}+-----------------------------------------------------------------------------+-- |+-- Module      : System.Taffybar.Information.PowerProfiles+-- Copyright   : (c) Ivan A. Malison+-- License     : BSD3-style (see LICENSE)+--+-- Maintainer  : Ivan A. Malison+-- Stability   : unstable+-- Portability : unportable+--+-- This module provides information about the current power profile using+-- the power-profiles-daemon DBus API (net.hadess.PowerProfiles).+-----------------------------------------------------------------------------+module System.Taffybar.Information.PowerProfiles+  ( PowerProfile(..)+  , PowerProfileInfo(..)+  , getPowerProfileInfo+  , getPowerProfileInfoFromClient+  , getPowerProfileInfoChan+  , getPowerProfileInfoState+  , cycleProfile+  , setProfile+  , powerProfileToString+  , stringToPowerProfile+  ) where++import           Control.Concurrent.MVar+import           Control.Concurrent.STM.TChan+import           Control.Monad.IO.Class+import           Control.Monad.STM (atomically)+import           Control.Monad.Trans.Class+import           Control.Monad.Trans.Except+import           Control.Monad.Trans.Reader+import           DBus+import           DBus.Client+import           DBus.Internal.Types (Serial(..))+import qualified DBus.TH as DBus+import           Data.Map (Map)+import qualified Data.Map as M+import           Data.Maybe (fromMaybe, listToMaybe, mapMaybe)+import           Data.Text (Text)+import           System.Log.Logger+import           System.Taffybar.Context+import           System.Taffybar.Util (logPrintF, maybeToEither)++-- | Power profile modes supported by power-profiles-daemon.+data PowerProfile+  = PowerSaver+  | Balanced+  | Performance+  deriving (Eq, Show, Ord, Enum, Bounded)++-- | Information about the current power profile state.+data PowerProfileInfo = PowerProfileInfo+  { currentProfile :: PowerProfile+  , availableProfiles :: [PowerProfile]+  , performanceDegraded :: Maybe Text+  } deriving (Eq, Show)++-- | The DBus bus name for power-profiles-daemon.+powerProfilesBusName :: BusName+powerProfilesBusName = "net.hadess.PowerProfiles"++-- | The DBus object path for power-profiles-daemon.+powerProfilesObjectPath :: ObjectPath+powerProfilesObjectPath = "/net/hadess/PowerProfiles"++-- | The DBus interface name for power-profiles-daemon.+powerProfilesInterfaceName :: InterfaceName+powerProfilesInterfaceName = "net.hadess.PowerProfiles"++powerProfilesLogPath :: String+powerProfilesLogPath = "System.Taffybar.Information.PowerProfiles"++powerProfilesLogF :: (MonadIO m, Show t) => Priority -> String -> t -> m ()+powerProfilesLogF = logPrintF powerProfilesLogPath++-- | Convert a PowerProfile to its DBus string representation.+powerProfileToString :: PowerProfile -> Text+powerProfileToString PowerSaver = "power-saver"+powerProfileToString Balanced = "balanced"+powerProfileToString Performance = "performance"++-- | Parse a DBus string to a PowerProfile.+stringToPowerProfile :: Text -> Maybe PowerProfile+stringToPowerProfile "power-saver" = Just PowerSaver+stringToPowerProfile "balanced" = Just Balanced+stringToPowerProfile "performance" = Just Performance+stringToPowerProfile _ = Nothing++-- | Default info when power-profiles-daemon is unavailable.+unknownProfileInfo :: PowerProfileInfo+unknownProfileInfo = PowerProfileInfo+  { currentProfile = Balanced+  , availableProfiles = []+  , performanceDegraded = Nothing+  }++-- XXX: Remove this once it is exposed in haskell-dbus+dummyMethodError :: MethodError+dummyMethodError = methodError (Serial 1) $ errorName_ "org.ClientTypeMismatch"++readDictMaybe :: IsVariant a => Map Text Variant -> Text -> Maybe a+readDictMaybe dict key = M.lookup key dict >>= fromVariant++getProperties+  :: Client+  -> IO (Either MethodError (Map Text Variant))+getProperties client = runExceptT $ do+  reply <- ExceptT $ getAllProperties client $+    (methodCall powerProfilesObjectPath powerProfilesInterfaceName "FakeMethod")+      { methodCallDestination = Just powerProfilesBusName }+  ExceptT $ return $ maybeToEither dummyMethodError $+    listToMaybe (methodReturnBody reply) >>= fromVariant++-- | Get current power profile info using the system DBus client from Context.+getPowerProfileInfo :: TaffyIO PowerProfileInfo+getPowerProfileInfo = asks systemDBusClient >>= liftIO . getPowerProfileInfoFromClient++-- | Get current power profile info from a DBus client.+getPowerProfileInfoFromClient :: Client -> IO PowerProfileInfo+getPowerProfileInfoFromClient client = do+  propsResult <- getProperties client+  case propsResult of+    Left err -> do+      powerProfilesLogF WARNING "Failed to read power profiles properties: %s" err+      return unknownProfileInfo+    Right props -> do+      let activeProfileStr = readDictMaybe props "ActiveProfile" :: Maybe Text+          profilesArray = readDictMaybe props "Profiles" :: Maybe [Map Text Variant]+          degraded = readDictMaybe props "PerformanceDegraded" :: Maybe Text++          -- Parse available profiles from the array of dicts+          parseProfile :: Map Text Variant -> Maybe PowerProfile+          parseProfile m = do+            name <- readDictMaybe m "Profile"+            stringToPowerProfile name++          availableProfs = maybe [] (mapMaybe parseProfile) profilesArray+          currentProf = fromMaybe Balanced (activeProfileStr >>= stringToPowerProfile)++      return PowerProfileInfo+        { currentProfile = currentProf+        , availableProfiles = availableProfs+        , performanceDegraded = if degraded == Just "" then Nothing else degraded+        }++-- | Set the active power profile.+setProfile :: Client -> PowerProfile -> IO (Either MethodError ())+setProfile client profile = do+  let profileStr = powerProfileToString profile+  result <- setProperty client+    (methodCall powerProfilesObjectPath powerProfilesInterfaceName "ActiveProfile")+      { methodCallDestination = Just powerProfilesBusName }+    (toVariant profileStr)+  return $ case result of+    Left err -> Left err+    Right _ -> Right ()++-- | Cycle to the next power profile.+-- Order: power-saver -> balanced -> performance -> power-saver+cycleProfile :: Client -> PowerProfileInfo -> IO (Either MethodError ())+cycleProfile client info =+  let current = currentProfile info+      -- Find next profile in cycle+      nextProfile = case current of+        PowerSaver -> Balanced+        Balanced -> Performance+        Performance -> PowerSaver+  in setProfile client nextProfile++-- State management for monitoring++newtype PowerProfileInfoChanVar =+  PowerProfileInfoChanVar (TChan PowerProfileInfo, MVar PowerProfileInfo)++-- | Get the current power profile info state.+getPowerProfileInfoState :: TaffyIO PowerProfileInfo+getPowerProfileInfoState = do+  PowerProfileInfoChanVar (_, theVar) <- getPowerProfileInfoChanVar+  lift $ readMVar theVar++-- | Get a broadcast channel for power profile info updates.+getPowerProfileInfoChan :: TaffyIO (TChan PowerProfileInfo)+getPowerProfileInfoChan = do+  PowerProfileInfoChanVar (chan, _) <- getPowerProfileInfoChanVar+  return chan++getPowerProfileInfoChanVar :: TaffyIO PowerProfileInfoChanVar+getPowerProfileInfoChanVar =+  getStateDefault $ PowerProfileInfoChanVar <$> monitorPowerProfileInfo++monitorPowerProfileInfo :: TaffyIO (TChan PowerProfileInfo, MVar PowerProfileInfo)+monitorPowerProfileInfo = do+  infoVar <- lift $ newMVar unknownProfileInfo+  chan <- liftIO newBroadcastTChanIO+  taffyFork $ do+    ctx <- ask+    let updateInfo = updatePowerProfileInfo chan infoVar+        signalCallback _ _ _ _ = runReaderT updateInfo ctx+    _ <- registerForPowerProfilesPropertiesChanged signalCallback+    updateInfo+  return (chan, infoVar)++registerForPowerProfilesPropertiesChanged+  :: (Signal -> String -> Map String Variant -> [String] -> IO ())+  -> ReaderT Context IO SignalHandler+registerForPowerProfilesPropertiesChanged signalHandler = do+  client <- asks systemDBusClient+  lift $ DBus.registerForPropertiesChanged+    client+    matchAny { matchInterface = Just powerProfilesInterfaceName+             , matchPath = Just powerProfilesObjectPath+             }+    signalHandler++updatePowerProfileInfo+  :: TChan PowerProfileInfo+  -> MVar PowerProfileInfo+  -> TaffyIO ()+updatePowerProfileInfo chan var = do+  info <- getPowerProfileInfo+  lift $ do+    _ <- swapMVar var info+    atomically $ writeTChan chan info
+ src/System/Taffybar/Information/Privacy.hs view
@@ -0,0 +1,298 @@+{-# LANGUAGE AllowAmbiguousTypes #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE ScopedTypeVariables #-}++-----------------------------------------------------------------------------+-- |+-- Module      : System.Taffybar.Information.Privacy+-- Copyright   : (c) Ivan A. Malison+-- License     : BSD3-style (see LICENSE)+--+-- Maintainer  : Ivan A. Malison+-- Stability   : unstable+-- Portability : unportable+--+-- PipeWire-based privacy monitoring for microphone, camera, and screen sharing.+--+-- This module uses @pw-dump@ to detect active audio/video streams.+--+-----------------------------------------------------------------------------++module System.Taffybar.Information.Privacy+  ( -- * Data types+    PrivacyInfo(..)+  , PrivacyNode(..)+  , NodeType(..)+    -- * Query functions+  , getPrivacyInfo+    -- * Channel-based monitoring+  , getPrivacyInfoChan+  , getPrivacyInfoState+    -- * Configuration+  , PrivacyConfig(..)+  , defaultPrivacyConfig+  ) where++import Control.Concurrent (forkIO, threadDelay)+import Control.Concurrent.MVar+import Control.Concurrent.STM.TChan+import Control.Exception (SomeException, catch)+import Control.Monad (forever)+import Control.Monad.IO.Class (liftIO)+import Control.Monad.STM (atomically)+import Data.Aeson+  ( FromJSON(..)+  , (.:)+  , (.:?)+  , withObject+  )+import qualified Data.Aeson as Aeson+import qualified Data.ByteString.Lazy as BL+import Data.Default (Default(..))+import qualified Data.Text.Encoding as TE+import Data.List (nubBy)+import Data.Maybe (fromMaybe, mapMaybe)+import Data.Text (Text)+import qualified Data.Text as T+import GHC.Generics (Generic)+import System.Log.Logger (Priority(..))+import System.Taffybar.Context (TaffyIO, getStateDefault)+import System.Taffybar.Util (logPrintF, runCommand)++-- | Type of privacy-relevant node.+data NodeType+  = AudioInput   -- ^ Microphone / audio capture+  | AudioOutput  -- ^ Audio playback (less privacy-sensitive, but useful)+  | VideoInput   -- ^ Camera / screen capture+  deriving (Eq, Show, Generic, Ord)++-- | Information about an active privacy-relevant node.+data PrivacyNode = PrivacyNode+  { nodeType :: NodeType+  , appName :: Text+  , appIcon :: Maybe Text+  , nodeName :: Text+  , isMonitor :: Bool+  } deriving (Eq, Show, Generic)++-- | Aggregated privacy information.+newtype PrivacyInfo = PrivacyInfo+  { activeNodes :: [PrivacyNode]+  } deriving (Eq, Show, Generic)++-- | Configuration for the privacy monitor.+data PrivacyConfig = PrivacyConfig+  { privacyPollingInterval :: Double  -- ^ Polling interval in seconds+  , privacyPwDumpPath :: FilePath     -- ^ Path to pw-dump command+  , privacyIgnoreMonitors :: Bool     -- ^ Whether to ignore monitor streams+  , privacyIgnoreAudioOutput :: Bool  -- ^ Whether to ignore audio output streams+  } deriving (Eq, Show, Generic)++-- | Default privacy configuration.+defaultPrivacyConfig :: PrivacyConfig+defaultPrivacyConfig = PrivacyConfig+  { privacyPollingInterval = 2.0+  , privacyPwDumpPath = "pw-dump"+  , privacyIgnoreMonitors = True+  , privacyIgnoreAudioOutput = True+  }++instance Default PrivacyConfig where+  def = defaultPrivacyConfig++privacyLogPath :: String+privacyLogPath = "System.Taffybar.Information.Privacy"++privacyLogF :: Show t => Priority -> String -> t -> IO ()+privacyLogF = logPrintF privacyLogPath++-- | Internal representation of a PipeWire object from pw-dump.+data PwObject = PwObject+  { pwId :: Int+  , pwType :: Text+  , pwInfo :: Maybe PwInfo+  } deriving (Eq, Show, Generic)++data PwInfo = PwInfo+  { pwState :: Maybe Text+  , pwProps :: Maybe PwProps+  } deriving (Eq, Show, Generic)++data PwProps = PwProps+  { propMediaClass :: Maybe Text+  , propMediaName :: Maybe Text+  , propNodeName :: Maybe Text+  , propAppName :: Maybe Text+  , propAppIconName :: Maybe Text+  , propPortalAppId :: Maybe Text+  , propStreamMonitor :: Maybe Text+  } deriving (Eq, Show, Generic)++instance FromJSON PwObject where+  parseJSON = withObject "PwObject" $ \v -> PwObject+    <$> v .: "id"+    <*> v .: "type"+    <*> v .:? "info"++instance FromJSON PwInfo where+  parseJSON = withObject "PwInfo" $ \v -> PwInfo+    <$> v .:? "state"+    <*> v .:? "props"++instance FromJSON PwProps where+  parseJSON = withObject "PwProps" $ \v -> PwProps+    <$> v .:? "media.class"+    <*> v .:? "media.name"+    <*> v .:? "node.name"+    <*> v .:? "application.name"+    <*> v .:? "application.icon-name"+    <*> v .:? "pipewire.access.portal.app_id"+    <*> v .:? "stream.monitor"++-- | Get current privacy information by running pw-dump.+getPrivacyInfo :: PrivacyConfig -> IO PrivacyInfo+getPrivacyInfo config = do+  result <- runCommand (privacyPwDumpPath config) []+  case result of+    Left err -> do+      privacyLogF WARNING "pw-dump failed: %s" err+      return $ PrivacyInfo []+    Right output -> do+      let parsed = Aeson.decode (BL.fromStrict $ TE.encodeUtf8 $ T.pack output) :: Maybe [PwObject]+      case parsed of+        Nothing -> do+          privacyLogF WARNING "Failed to parse pw-dump output" ("" :: String)+          return $ PrivacyInfo []+        Just objects -> do+          let nodes = mapMaybe (toPrivacyNode config) objects+              filtered = filterNodes config nodes+              -- Remove duplicates based on app name and node type+              unique = nubBy (\a b -> appName a == appName b && nodeType a == nodeType b) filtered+          return $ PrivacyInfo unique++-- | Convert a PipeWire object to a PrivacyNode if relevant.+toPrivacyNode :: PrivacyConfig -> PwObject -> Maybe PrivacyNode+toPrivacyNode _config obj = do+  -- Only process Node type objects+  if pwType obj /= "PipeWire:Interface:Node"+    then Nothing+    else do+      info <- pwInfo obj+      props <- pwProps info+      mediaClass <- propMediaClass props++      -- Check if the node is running+      let state = pwState info+          isRunning = state == Just "running"++      if not isRunning+        then Nothing+        else do+          -- Determine node type from media.class+          nType <- classToNodeType mediaClass++          -- Get application name (try multiple sources)+          let name = fromMaybe "Unknown" $+                propAppName props+                  <|> propPortalAppId props+                  <|> propNodeName props+                  <|> propMediaName props++              -- Get icon name+              icon = propAppIconName props+                       <|> propPortalAppId props+                       <|> propAppName props++              -- Check if it's a monitor stream+              monitor = propStreamMonitor props == Just "true"++              nName = fromMaybe "" $ propNodeName props++          Just PrivacyNode+            { nodeType = nType+            , appName = name+            , appIcon = icon+            , nodeName = nName+            , isMonitor = monitor+            }+  where+    (<|>) :: Maybe a -> Maybe a -> Maybe a+    (<|>) ma mb = case ma of+      Nothing -> mb+      just -> just++-- | Map media.class to NodeType.+classToNodeType :: Text -> Maybe NodeType+classToNodeType cls+  | "Stream/Input/Audio" `T.isInfixOf` cls = Just AudioInput+  | "Audio/Source" `T.isInfixOf` cls = Just AudioInput+  | "Stream/Output/Audio" `T.isInfixOf` cls = Just AudioOutput+  | "Audio/Sink" `T.isInfixOf` cls = Just AudioOutput+  | "Video/Source" `T.isInfixOf` cls = Just VideoInput+  | "Stream/Input/Video" `T.isInfixOf` cls = Just VideoInput+  | otherwise = Nothing++-- | Filter nodes based on configuration.+filterNodes :: PrivacyConfig -> [PrivacyNode] -> [PrivacyNode]+filterNodes config = filter keep+  where+    keep node+      | privacyIgnoreMonitors config && isMonitor node = False+      | privacyIgnoreAudioOutput config && nodeType node == AudioOutput = False+      | otherwise = True++-- | State for the privacy info channel.+newtype PrivacyInfoChanVar = PrivacyInfoChanVar+  (TChan PrivacyInfo, MVar PrivacyInfo)++-- | Get a broadcast channel for privacy info updates.+--+-- The first call starts a monitoring thread that polls PipeWire at the+-- configured interval. Subsequent calls return the already created channel.+getPrivacyInfoChan :: PrivacyConfig -> TaffyIO (TChan PrivacyInfo)+getPrivacyInfoChan config = do+  PrivacyInfoChanVar (chan, _) <- getPrivacyInfoChanVar config+  pure chan++-- | Read the current privacy info state.+getPrivacyInfoState :: PrivacyConfig -> TaffyIO PrivacyInfo+getPrivacyInfoState config = do+  PrivacyInfoChanVar (_, var) <- getPrivacyInfoChanVar config+  liftIO $ readMVar var++getPrivacyInfoChanVar :: PrivacyConfig -> TaffyIO PrivacyInfoChanVar+getPrivacyInfoChanVar config =+  getStateDefault $ do+    liftIO $ do+      chan <- newBroadcastTChanIO+      var <- newMVar (PrivacyInfo [])+      _ <- forkIO $ monitorPrivacyInfo config chan var+      pure $ PrivacyInfoChanVar (chan, var)++monitorPrivacyInfo ::+  PrivacyConfig ->+  TChan PrivacyInfo ->+  MVar PrivacyInfo ->+  IO ()+monitorPrivacyInfo config chan var = do+  let+    intervalMicros :: Int+    intervalMicros = max 100000 (floor (privacyPollingInterval config * 1000000))++    writeInfo info = do+      _ <- swapMVar var info+      atomically $ writeTChan chan info++    refresh = do+      info <- catch (getPrivacyInfo config) $ \(e :: SomeException) -> do+        privacyLogF WARNING "Privacy info refresh failed: %s" e+        return $ PrivacyInfo []+      writeInfo info++  -- Initial refresh+  refresh+  -- Polling loop+  forever $ do+    threadDelay intervalMicros+    refresh
+ src/System/Taffybar/Information/PulseAudio.hs view
@@ -0,0 +1,601 @@+{-# LANGUAGE AllowAmbiguousTypes #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE KindSignatures #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeApplications #-}++-----------------------------------------------------------------------------++-----------------------------------------------------------------------------++-- |+-- Module      : System.Taffybar.Information.PulseAudio+-- Copyright   : (c) Ivan A. Malison+-- License     : BSD3-style (see LICENSE)+--+-- Maintainer  : Ivan A. Malison+-- Stability   : unstable+-- Portability : unportable+--+-- Basic PulseAudio information using PulseAudio's DBus interface.+--+-- Note: PulseAudio's DBus socket is not always enabled by default.+-- If callers see 'Nothing' from 'connectPulseAudio' (or 'getPulseAudioInfo'+-- returns 'Nothing'), ensure the PulseAudio server has loaded+-- @module-dbus-protocol@+-- so @/run/user/$UID/pulse/dbus-socket@ exists.+module System.Taffybar.Information.PulseAudio+  ( PulseAudioInfo (..),+    getPulseAudioInfo,+    getPulseAudioInfoFromClient,+    getPulseAudioInfoChan,+    getPulseAudioInfoState,+    getPulseAudioInfoChanAndVar,+    getPulseAudioInfoChanFor,+    getPulseAudioInfoStateFor,+    connectPulseAudio,+    togglePulseAudioMute,+    adjustPulseAudioVolume,+  )+where++import Control.Applicative ((<|>))+import Control.Concurrent (forkIO, threadDelay)+import Control.Concurrent.MVar+import Control.Concurrent.STM.TChan+import Control.Exception (SomeException, finally, throwIO, try)+import Control.Monad (forever, guard, join, void, when)+import Control.Monad.IO.Class (MonadIO, liftIO)+import Control.Monad.STM (atomically)+import Control.Monad.Trans.Except+import DBus+import DBus.Client+import DBus.Internal.Types (Serial (..))+import Data.IORef (newIORef, readIORef, writeIORef)+import Data.List (isInfixOf)+import Data.Map (Map)+import qualified Data.Map as M+import Data.Maybe (fromMaybe, isNothing, listToMaybe)+import Data.Proxy (Proxy (..))+import Data.Text (Text)+import Data.Word (Word32)+import GHC.TypeLits (KnownSymbol, SomeSymbol (..), Symbol, someSymbolVal, symbolVal)+import System.Directory (doesPathExist)+import System.Environment (lookupEnv)+import System.FilePath ((</>))+import System.Log.Logger (Priority (..))+import System.Taffybar.Context (TaffyIO, getStateDefault)+import System.Taffybar.DBus.Client.Params+  ( paCoreInterfaceName,+    paCoreObjectPath,+    paDeviceInterfaceName,+    paServerLookupBusName,+    paServerLookupInterfaceName,+    paServerLookupObjectPath,+  )+import System.Taffybar.Util (logPrintF, maybeToEither)++-- | PulseAudio information for the default (or provided) sink.+data PulseAudioInfo = PulseAudioInfo+  { pulseAudioVolumePercent :: Maybe Int,+    pulseAudioMuted :: Maybe Bool,+    pulseAudioSinkName :: String+  }+  deriving (Eq, Show)++audioLogPath :: String+audioLogPath = "System.Taffybar.Information.PulseAudio"++audioLogF :: (MonadIO m, Show t) => Priority -> String -> t -> m ()+audioLogF = logPrintF audioLogPath++newtype PulseAudioInfoChanVar (a :: Symbol)+  = PulseAudioInfoChanVar (TChan (Maybe PulseAudioInfo), MVar (Maybe PulseAudioInfo))++-- | Get a broadcast channel for PulseAudio info for the provided sink spec.+--+-- The first call for a given sink spec will start a monitoring thread that+-- keeps a PulseAudio DBus connection open and refreshes on property changes.+-- Subsequent calls return the already created channel.+getPulseAudioInfoChan :: String -> TaffyIO (TChan (Maybe PulseAudioInfo))+getPulseAudioInfoChan sinkSpec =+  case someSymbolVal sinkSpec of+    SomeSymbol (Proxy :: Proxy sym) -> getPulseAudioInfoChanFor @sym++-- | Read the current PulseAudio info state for the provided sink spec.+--+-- See 'getPulseAudioInfoChan' for monitoring behavior.+getPulseAudioInfoState :: String -> TaffyIO (Maybe PulseAudioInfo)+getPulseAudioInfoState sinkSpec =+  case someSymbolVal sinkSpec of+    SomeSymbol (Proxy :: Proxy sym) -> getPulseAudioInfoStateFor @sym++-- | Get both the broadcast channel and the state MVar for PulseAudio info.+--+-- This is useful when a widget needs to read the current state at realize time+-- (from the MVar) and also subscribe to future updates (via the channel).+getPulseAudioInfoChanAndVar :: String -> TaffyIO (TChan (Maybe PulseAudioInfo), MVar (Maybe PulseAudioInfo))+getPulseAudioInfoChanAndVar sinkSpec =+  case someSymbolVal sinkSpec of+    SomeSymbol (Proxy :: Proxy sym) -> do+      PulseAudioInfoChanVar (chan, var) <- getPulseAudioInfoChanVarFor @sym+      pure (chan, var)++-- | Get a broadcast channel for PulseAudio info for a sink spec given as a+-- type-level string.+--+-- This is the closest analogue to 'System.Taffybar.Information.Crypto', where+-- the type parameter provides a stable key for 'getStateDefault' so multiple+-- parameterized versions can coexist in 'Context'.+getPulseAudioInfoChanFor :: forall a. KnownSymbol a => TaffyIO (TChan (Maybe PulseAudioInfo))+getPulseAudioInfoChanFor = do+  PulseAudioInfoChanVar (chan, _) <- getPulseAudioInfoChanVarFor @a+  pure chan++-- | Read the current PulseAudio info state for a sink spec given as a+-- type-level string.+getPulseAudioInfoStateFor :: forall a. KnownSymbol a => TaffyIO (Maybe PulseAudioInfo)+getPulseAudioInfoStateFor = do+  PulseAudioInfoChanVar (_, var) <- getPulseAudioInfoChanVarFor @a+  liftIO $ readMVar var++getPulseAudioInfoChanVarFor :: forall a. KnownSymbol a => TaffyIO (PulseAudioInfoChanVar a)+getPulseAudioInfoChanVarFor =+  getStateDefault $ do+    let sinkSpec = symbolVal (Proxy @a)+    liftIO $ do+      chan <- newBroadcastTChanIO+      var <- newMVar Nothing+      _ <- forkIO $ monitorPulseAudioInfo sinkSpec chan var+      pure $ PulseAudioInfoChanVar (chan, var)++monitorPulseAudioInfo ::+  String ->+  TChan (Maybe PulseAudioInfo) ->+  MVar (Maybe PulseAudioInfo) ->+  IO ()+monitorPulseAudioInfo sinkSpec chan var = do+  refreshLock <- newMVar ()+  let writeInfo info = do+        _ <- swapMVar var info+        atomically $ writeTChan chan info++      refreshWithClientUnlocked client = do+        result <- try $ getPulseAudioInfoFromClient client sinkSpec+        case result of+          Left (e :: SomeException) -> do+            audioLogF WARNING "Audio refresh failed: %s" e+            writeInfo Nothing+            pure $ Left e+          Right info -> writeInfo info >> pure (Right info)++      -- PulseAudio's DBus interface is usually exposed via a peer-to-peer+      -- connection (unix:path=$XDG_RUNTIME_DIR/pulse/dbus-socket). In that mode+      -- there is no bus daemon, so org.freedesktop.DBus.AddMatch/RemoveMatch do+      -- not exist.+      --+      -- Instead, PulseAudio provides org.PulseAudio.Core1.ListenForSignal which+      -- must be called to enable emission of signals like:+      --   org.PulseAudio.Core1.Device.VolumeUpdated+      --   org.PulseAudio.Core1.Device.MuteUpdated+      --+      -- We still use haskell-dbus 'addMatch' to register local handlers. When+      -- AddMatch fails (peer-to-peer), we ignore the exception; the handler is+      -- registered locally before the failing bus call.++      isMissingAddMatch :: ClientError -> Bool+      isMissingAddMatch e =+        let msg = clientErrorMessage e+         in "AddMatch" `isInfixOf` msg+              && ("doesn't exist" `isInfixOf` msg || "UnknownMethod" `isInfixOf` msg)++      addMatchP2P :: Client -> MatchRule -> (Signal -> IO ()) -> IO (Maybe SignalHandler)+      addMatchP2P client rule callback = do+        result <- try (addMatch client rule callback)+        case result of+          Right handler -> pure (Just handler)+          Left (e :: ClientError)+            | isMissingAddMatch e -> pure Nothing+            | otherwise -> throwIO e++      listenForSignal :: Client -> String -> [ObjectPath] -> IO ()+      listenForSignal client signalName objects = do+        let callMsg =+              (methodCall paCorePath paCoreInterfaceName "ListenForSignal")+                { methodCallDestination = Nothing+                , methodCallBody = [toVariant signalName, toVariant objects]+                }+        reply <- call client callMsg+        case reply of+          Left err -> audioLogF WARNING "PulseAudio ListenForSignal failed: %s" err+          Right _ -> pure ()++      paCoreInterfaceNameStr :: String+      paCoreInterfaceNameStr = "org.PulseAudio.Core1"++      paDeviceInterfaceNameStr :: String+      paDeviceInterfaceNameStr = "org.PulseAudio.Core1.Device"++      volumeUpdatedSignal :: String+      volumeUpdatedSignal = paDeviceInterfaceNameStr ++ ".VolumeUpdated"++      muteUpdatedSignal :: String+      muteUpdatedSignal = paDeviceInterfaceNameStr ++ ".MuteUpdated"++      coreSignalName :: String -> String+      coreSignalName memberName = paCoreInterfaceNameStr ++ "." ++ memberName++      coreFallbackUpdatedMember :: MemberName+      coreFallbackUpdatedMember = "FallbackSinkUpdated"++      coreFallbackUnsetMember :: MemberName+      coreFallbackUnsetMember = "FallbackSinkUnset"++      coreNewSinkMember :: MemberName+      coreNewSinkMember = "NewSink"++      coreSinkRemovedMember :: MemberName+      coreSinkRemovedMember = "SinkRemoved"++      deviceSignalMatcher :: MemberName -> MatchRule+      deviceSignalMatcher memberName =+        matchAny+          { matchPathNamespace = Just paCoreObjectPath+          , matchInterface = Just paDeviceInterfaceName+          , matchMember = Just memberName+          }++      coreSignalMatcher :: MemberName -> MatchRule+      coreSignalMatcher memberName =+        matchAny+          { matchPath = Just paCoreObjectPath+          , matchInterface = Just paCoreInterfaceName+          , matchMember = Just memberName+          }++      loop = do+        mClient <- connectPulseAudio+        case mClient of+          Nothing -> do+            writeInfo Nothing+            -- No polling; just retry connection periodically.+            threadDelay 5000000+            loop+          Just client -> do+            let runWithClient = do+                  subscribedSinksRef <- newIORef ([] :: [ObjectPath])++                  let getSinksUnlocked = do+                        corePropsResult <- getProperties client Nothing paCorePath paCoreInterfaceName+                        case corePropsResult of+                          Left err -> do+                            audioLogF WARNING "Failed to read PulseAudio Core1 properties: %s" err+                            pure []+                          Right coreProps ->+                            pure $ fromMaybe [] (readDictMaybe coreProps "Sinks")++                      updateDeviceSignalSubscriptionsUnlocked = do+                        sinks <- getSinksUnlocked+                        prev <- readIORef subscribedSinksRef+                        when (sinks /= prev && not (null sinks)) $ do+                          writeIORef subscribedSinksRef sinks+                          listenForSignal client volumeUpdatedSignal sinks+                          listenForSignal client muteUpdatedSignal sinks++                      resubscribeAndRefresh = withMVar refreshLock $ \_ -> do+                        updateDeviceSignalSubscriptionsUnlocked+                        void $ refreshWithClientUnlocked client++                  -- Ask PulseAudio to emit the signals we care about.+                  listenForSignal client (coreSignalName "FallbackSinkUpdated") [paCorePath]+                  listenForSignal client (coreSignalName "FallbackSinkUnset") [paCorePath]+                  listenForSignal client (coreSignalName "NewSink") [paCorePath]+                  listenForSignal client (coreSignalName "SinkRemoved") [paCorePath]++                  -- Emit device signals for the current set of sinks.+                  resubscribeAndRefresh++                  -- Install signal handlers. In peer-to-peer mode this will+                  -- throw a ClientError due to missing AddMatch, but the handler+                  -- remains registered locally and still works.+                  hVol <- addMatchP2P client (deviceSignalMatcher "VolumeUpdated") $ const resubscribeAndRefresh+                  hMute <- addMatchP2P client (deviceSignalMatcher "MuteUpdated") $ const resubscribeAndRefresh+                  hFallbackUpdated <- addMatchP2P client (coreSignalMatcher coreFallbackUpdatedMember) $ const resubscribeAndRefresh+                  hFallbackUnset <- addMatchP2P client (coreSignalMatcher coreFallbackUnsetMember) $ const resubscribeAndRefresh+                  hNewSink <- addMatchP2P client (coreSignalMatcher coreNewSinkMember) $ const resubscribeAndRefresh+                  hSinkRemoved <- addMatchP2P client (coreSignalMatcher coreSinkRemovedMember) $ const resubscribeAndRefresh++                  let cleanup = do+                        let removeIfJust = maybe (pure ()) (removeMatch client)+                        removeIfJust hVol+                        removeIfJust hMute+                        removeIfJust hFallbackUpdated+                        removeIfJust hFallbackUnset+                        removeIfJust hNewSink+                        removeIfJust hSinkRemoved++                  blockForever `finally` cleanup+            result <- try runWithClient+            case result of+              Left (e :: SomeException) ->+                audioLogF WARNING "Audio monitor error: %s" e+              Right _ -> pure ()+            disconnect client+            loop++      -- Avoid BlockedIndefinitelyOnMVar exceptions from the "empty mvar trick".+      blockForever =+        forever $ threadDelay 1000000000 -- ~1000s; interruptible by async exceptions.++  loop++-- | Query volume and mute state for the provided sink name.+-- Returns Nothing when neither value is available.+getPulseAudioInfo :: String -> IO (Maybe PulseAudioInfo)+getPulseAudioInfo sinkSpec = do+  result <- withPulseAudio (`getPulseAudioInfoFromClient` sinkSpec)+  return $ join result++getPulseAudioInfoFromClient :: Client -> String -> IO (Maybe PulseAudioInfo)+getPulseAudioInfoFromClient client sinkSpec = do+  sinkPath <- resolveSinkPath client sinkSpec+  maybe (return Nothing) (getDeviceInfo client) sinkPath++-- | Toggle mute for the provided sink. Returns True on success.+togglePulseAudioMute :: String -> IO Bool+togglePulseAudioMute sinkSpec = do+  result <- withPulseAudio $ \client -> do+    sinkPath <- resolveSinkPath client sinkSpec+    case sinkPath of+      Nothing -> return False+      Just path -> do+        propsResult <- getProperties client Nothing path paDeviceInterfaceName+        case propsResult of+          Left err -> do+            audioLogF WARNING "Failed to read device properties: %s" err+            return False+          Right props -> case readDictMaybe props "Mute" of+            Nothing -> return False+            Just muted -> setDeviceMute client path (not muted)+  return $ fromMaybe False result++-- | Adjust volume by the provided percentage delta. Returns True on success.+adjustPulseAudioVolume :: String -> Int -> IO Bool+adjustPulseAudioVolume sinkSpec deltaPercent = do+  result <- withPulseAudio $ \client -> do+    sinkPath <- resolveSinkPath client sinkSpec+    case sinkPath of+      Nothing -> return False+      Just path -> do+        propsResult <- getProperties client Nothing path paDeviceInterfaceName+        case propsResult of+          Left err -> do+            audioLogF WARNING "Failed to read device properties: %s" err+            return False+          Right props -> do+            let maxVol = fromMaybe defaultMaxVolume (readDictMaybe props "MaxVolume")+            case readDictMaybe props "Volume" of+              Nothing -> return False+              Just volumes -> setDeviceVolume client path maxVol volumes deltaPercent+  return $ fromMaybe False result++-- --------------------------------------------------------------------------+-- DBus helpers++paServerLookupPath :: ObjectPath+paServerLookupPath = paServerLookupObjectPath++paCorePath :: ObjectPath+paCorePath = paCoreObjectPath++nullObjectPath :: ObjectPath+nullObjectPath = objectPath_ "/"++connectPulseAudio :: IO (Maybe Client)+connectPulseAudio = do+  addressString <- getPulseAudioAddress+  case addressString >>= parsePulseAddress of+    Nothing -> return Nothing+    Just addr -> do+      result <- try (connect addr)+      case result of+        Left (_ :: SomeException) -> return Nothing+        Right client -> return (Just client)++withPulseAudio :: (Client -> IO a) -> IO (Maybe a)+withPulseAudio action = do+  mClient <- connectPulseAudio+  case mClient of+    Nothing -> return Nothing+    Just client -> do+      result <- try $ action client+      disconnect client+      case result of+        Left (_ :: SomeException) -> return Nothing+        Right value -> return $ Just value++parsePulseAddress :: String -> Maybe Address+parsePulseAddress addrStr = listToMaybe =<< parseAddresses addrStr++getPulseAudioAddress :: IO (Maybe String)+getPulseAudioAddress = do+  envAddress <- lookupEnv "PULSE_DBUS_SERVER"+  case envAddress of+    Just addr | not (null addr) -> return (Just addr)+    _ -> do+      result <- try connectSession+      case result of+        Left (_ :: SomeException) -> runtimeDirFallback+        Right client -> do+          pulseAddr <- getServerLookupAddress client+          disconnect client+          case pulseAddr of+            Just _ -> return pulseAddr+            Nothing -> runtimeDirFallback++-- Many setups (notably pipewire-pulse) have the peer-to-peer PulseAudio DBus+-- socket available at $XDG_RUNTIME_DIR/pulse/dbus-socket but do not expose a+-- ServerLookup1 entry on the session bus. Fall back to the well-known socket.+runtimeDirFallback :: IO (Maybe String)+runtimeDirFallback = do+  mRuntimeDir <- lookupEnv "XDG_RUNTIME_DIR"+  case mRuntimeDir of+    Nothing -> return Nothing+    Just runtimeDir -> do+      let sockPath = runtimeDir </> "pulse" </> "dbus-socket"+      exists <- doesPathExist sockPath+      return $+        if exists+          then Just ("unix:path=" ++ sockPath)+          else Nothing++getServerLookupAddress :: Client -> IO (Maybe String)+getServerLookupAddress client = do+  propsResult <-+    getProperties+      client+      (Just paServerLookupBusName)+      paServerLookupPath+      paServerLookupInterfaceName+  case propsResult of+    Left err -> do+      audioLogF WARNING "Failed to read PulseAudio ServerLookup1 properties: %s" err+      return Nothing+    Right props -> case readDictMaybe props "Address" of+      Just addr | not (null addr) -> return (Just addr)+      _ -> return Nothing++resolveSinkPath :: Client -> String -> IO (Maybe ObjectPath)+resolveSinkPath client sinkSpec = do+  corePropsResult <- getProperties client Nothing paCorePath paCoreInterfaceName+  case corePropsResult of+    Left err -> do+      audioLogF WARNING "Failed to read PulseAudio Core1 properties: %s" err+      return Nothing+    Right coreProps+      | sinkSpec == "@DEFAULT_SINK@" || null sinkSpec ->+          return $ selectDefaultSink coreProps+      | isObjectPath sinkSpec ->+          return $ Just $ objectPath_ sinkSpec+      | otherwise -> findSinkByName client coreProps sinkSpec++selectDefaultSink :: Map Text Variant -> Maybe ObjectPath+selectDefaultSink props =+  let fallback = readDictMaybe props "FallbackSink" :: Maybe ObjectPath+      sinks = readDictMaybe props "Sinks" :: Maybe [ObjectPath]+   in case fallback of+        Just path | path /= nullObjectPath -> Just path+        _ -> listToMaybe =<< sinks++findSinkByName :: Client -> Map Text Variant -> String -> IO (Maybe ObjectPath)+findSinkByName client props target =+  case readDictMaybe props "Sinks" :: Maybe [ObjectPath] of+    Nothing -> return Nothing+    Just sinks -> findM (sinkMatchesName client target) sinks++sinkMatchesName :: Client -> String -> ObjectPath -> IO Bool+sinkMatchesName client target path = do+  propsResult <- getProperties client Nothing path paDeviceInterfaceName+  case propsResult of+    Left _ -> return False+    Right props ->+      let name = readDictMaybe props "Name" :: Maybe String+          description = readDictMaybe props "Description" :: Maybe String+       in return $ Just target == name || Just target == description++getDeviceInfo :: Client -> ObjectPath -> IO (Maybe PulseAudioInfo)+getDeviceInfo client path = do+  propsResult <- getProperties client Nothing path paDeviceInterfaceName+  case propsResult of+    Left err -> do+      audioLogF WARNING "Failed to read device properties: %s" err+      return Nothing+    Right props -> return $ Just $ buildPulseAudioInfo props++buildPulseAudioInfo :: Map Text Variant -> PulseAudioInfo+buildPulseAudioInfo props =+  let volumePercent = calcVolumePercent props+      muted = readDictMaybe props "Mute"+      name = fromMaybe "" (readDictMaybe props "Description" <|> readDictMaybe props "Name")+   in PulseAudioInfo+        { pulseAudioVolumePercent = volumePercent,+          pulseAudioMuted = muted,+          pulseAudioSinkName = name+        }++calcVolumePercent :: Map Text Variant -> Maybe Int+calcVolumePercent props = do+  volumes <- readDictMaybe props "Volume" :: Maybe [Word32]+  guard (not (null volumes))+  let maxVolume = fromMaybe defaultMaxVolume (readDictMaybe props "MaxVolume")+  guard (maxVolume > 0)+  let total = sum volumes+      avg = fromIntegral total / fromIntegral (length volumes) :: Double+      percent = round $ avg * 100 / fromIntegral maxVolume+  return percent++defaultMaxVolume :: Word32+defaultMaxVolume = 65536++setDeviceMute :: Client -> ObjectPath -> Bool -> IO Bool+setDeviceMute client path muteState = do+  let muteCall =+        (methodCall path paDeviceInterfaceName "Mute")+          { methodCallDestination = Nothing+          }+  err <- setPropertyValue client muteCall muteState+  pure $ isNothing err++setDeviceVolume :: Client -> ObjectPath -> Word32 -> [Word32] -> Int -> IO Bool+setDeviceVolume client path maxVol volumes deltaPercent = do+  let maxI = fromIntegral maxVol :: Int+      delta = round (fromIntegral maxI * fromIntegral deltaPercent / 100.0 :: Double)+      newVolumes = map (fromIntegral . clamp 0 maxI . (+ delta) . fromIntegral) volumes :: [Word32]+      volCall =+        (methodCall path paDeviceInterfaceName "Volume")+          { methodCallDestination = Nothing+          }+  err <- setPropertyValue client volCall newVolumes+  pure $ isNothing err++clamp :: Int -> Int -> Int -> Int+clamp low high value = max low (min high value)++isObjectPath :: String -> Bool+isObjectPath ('/' : _) = True+isObjectPath _ = False++findM :: (Monad m) => (a -> m Bool) -> [a] -> m (Maybe a)+findM _ [] = return Nothing+findM predicate (x : xs) = do+  matches <- predicate x+  if matches+    then return (Just x)+    else findM predicate xs++readDictMaybe :: (IsVariant a) => Map Text Variant -> Text -> Maybe a+readDictMaybe dict key = M.lookup key dict >>= fromVariant++getProperties ::+  Client ->+  Maybe BusName ->+  ObjectPath ->+  InterfaceName ->+  IO (Either MethodError (Map Text Variant))+getProperties client destination path iface = runExceptT $ do+  reply <-+    ExceptT $+      getAllProperties client $+        (methodCall path iface "FakeMethod")+          { methodCallDestination = destination+          }+  ExceptT $+    return $+      maybeToEither dummyMethodError $+        listToMaybe (methodReturnBody reply) >>= fromVariant++-- XXX: Remove this once it is exposed in haskell-dbus+-- Same workaround pattern used elsewhere in Taffybar.+dummyMethodError :: MethodError+dummyMethodError = methodError (Serial 1) $ errorName_ "org.ClientTypeMismatch"
+ src/System/Taffybar/Information/Systemd.hs view
@@ -0,0 +1,246 @@+{-# LANGUAGE OverloadedStrings #-}+-----------------------------------------------------------------------------+-- |+-- Module      : System.Taffybar.Information.Systemd+-- Copyright   : (c) Ivan A. Malison+-- License     : BSD3-style (see LICENSE)+--+-- Maintainer  : Ivan A. Malison+-- Stability   : unstable+-- Portability : unportable+--+-- This module provides information about systemd failed units using the+-- org.freedesktop.systemd1 DBus interface. It monitors both the system bus+-- (for system units) and the session bus (for user units).+-----------------------------------------------------------------------------+module System.Taffybar.Information.Systemd+  ( SystemdState(..)+  , SystemdInfo(..)+  , getSystemdInfo+  , getSystemdInfoFromClients+  , getSystemdInfoChan+  , getSystemdInfoState+  , systemdUnknownInfo+  ) 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           Control.Monad.Trans.Reader+import           DBus+import           DBus.Client+import qualified DBus.TH as DBus+import           Data.Maybe (fromMaybe)+import           Data.Text (Text)+import qualified Data.Text as T+import           Data.Word (Word32)+import           System.Log.Logger+import           System.Taffybar.Context++-- | The state of a systemd instance (system or user).+data SystemdState+  = SystemdRunning        -- ^ All units are running properly+  | SystemdDegraded       -- ^ Some units have failed+  | SystemdStarting       -- ^ System is starting up+  | SystemdStopping       -- ^ System is shutting down+  | SystemdMaintenance    -- ^ System is in maintenance mode+  | SystemdInitializing   -- ^ System is initializing+  | SystemdOther Text     -- ^ Unknown state+  | SystemdUnavailable    -- ^ systemd is not available on this bus+  deriving (Eq, Show)++-- | Information about systemd failed units.+data SystemdInfo = SystemdInfo+  { systemState :: SystemdState        -- ^ State of system systemd+  , userState :: SystemdState          -- ^ State of user systemd+  , systemFailedCount :: Int           -- ^ Number of failed system units+  , userFailedCount :: Int             -- ^ Number of failed user units+  , totalFailedCount :: Int            -- ^ Total failed units (system + user)+  } deriving (Eq, Show)++-- | Default info when systemd is unknown/unavailable.+systemdUnknownInfo :: SystemdInfo+systemdUnknownInfo = SystemdInfo+  { systemState = SystemdUnavailable+  , userState = SystemdUnavailable+  , systemFailedCount = 0+  , userFailedCount = 0+  , totalFailedCount = 0+  }++systemdLogPath :: String+systemdLogPath = "System.Taffybar.Information.Systemd"++-- | DBus constants for systemd.+systemdBusName :: BusName+systemdBusName = "org.freedesktop.systemd1"++systemdObjectPath :: ObjectPath+systemdObjectPath = "/org/freedesktop/systemd1"++systemdManagerInterface :: InterfaceName+systemdManagerInterface = "org.freedesktop.systemd1.Manager"++-- | Parse a SystemdState from a DBus string.+parseSystemdState :: Text -> SystemdState+parseSystemdState txt =+  case T.toLower txt of+    "running"      -> SystemdRunning+    "degraded"     -> SystemdDegraded+    "starting"     -> SystemdStarting+    "stopping"     -> SystemdStopping+    "maintenance"  -> SystemdMaintenance+    "initializing" -> SystemdInitializing+    _              -> SystemdOther txt++-- | Newtype wrapper for the channel/var pair stored in Context.+newtype SystemdInfoChanVar = SystemdInfoChanVar (TChan SystemdInfo, MVar SystemdInfo)++-- | Get the current systemd info state.+getSystemdInfoState :: TaffyIO SystemdInfo+getSystemdInfoState = do+  SystemdInfoChanVar (_, theVar) <- getSystemdInfoChanVar+  lift $ readMVar theVar++-- | Get the broadcast channel for systemd info updates.+getSystemdInfoChan :: TaffyIO (TChan SystemdInfo)+getSystemdInfoChan = do+  SystemdInfoChanVar (chan, _) <- getSystemdInfoChanVar+  return chan++-- | Get or create the channel/var pair for systemd monitoring.+getSystemdInfoChanVar :: TaffyIO SystemdInfoChanVar+getSystemdInfoChanVar =+  getStateDefault $ SystemdInfoChanVar <$> monitorSystemdInfo++-- | The debounce delay in microseconds (1 second, like Waybar).+debounceDelayMicros :: Int+debounceDelayMicros = 1_000_000++-- | Start monitoring systemd on both system and session buses.+monitorSystemdInfo :: TaffyIO (TChan SystemdInfo, MVar SystemdInfo)+monitorSystemdInfo = do+  infoVar <- lift $ newMVar systemdUnknownInfo+  chan <- liftIO newBroadcastTChanIO+  debounceVar <- liftIO $ newMVar False++  taffyFork $ do+    ctx <- ask+    systemClient <- asks systemDBusClient+    sessionClient <- asks sessionDBusClient++    let doUpdate = updateSystemdInfo chan infoVar systemClient sessionClient+        debouncedUpdate = do+          pending <- liftIO $ swapMVar debounceVar True+          unless pending $ do+            liftIO $ threadDelay debounceDelayMicros+            liftIO $ void $ swapMVar debounceVar False+            doUpdate++        signalCallback _ _ _ _ = runReaderT debouncedUpdate ctx++    -- Register for PropertiesChanged on system bus+    _ <- lift $ DBus.registerForPropertiesChanged+      systemClient+      matchAny { matchInterface = Just systemdManagerInterface+               , matchPath = Just systemdObjectPath+               }+      signalCallback++    -- Register for PropertiesChanged on session bus+    _ <- lift $ DBus.registerForPropertiesChanged+      sessionClient+      matchAny { matchInterface = Just systemdManagerInterface+               , matchPath = Just systemdObjectPath+               }+      signalCallback++    -- Initial update+    doUpdate++  return (chan, infoVar)++-- | Update the systemd info by querying both buses.+updateSystemdInfo+  :: TChan SystemdInfo+  -> MVar SystemdInfo+  -> Client+  -> Client+  -> TaffyIO ()+updateSystemdInfo chan var systemClient sessionClient = do+  info <- liftIO $ getSystemdInfoFromClients systemClient sessionClient+  liftIO $ do+    _ <- swapMVar var info+    atomically $ writeTChan chan info++-- | Get systemd info using the clients from Context.+getSystemdInfo :: TaffyIO SystemdInfo+getSystemdInfo = do+  systemClient <- asks systemDBusClient+  sessionClient <- asks sessionDBusClient+  liftIO $ getSystemdInfoFromClients systemClient sessionClient++-- | Get systemd info from the provided DBus clients.+getSystemdInfoFromClients :: Client -> Client -> IO SystemdInfo+getSystemdInfoFromClients systemClient sessionClient = do+  (sysState, sysFailed) <- getSystemdStateAndFailed systemClient "system"+  (usrState, usrFailed) <- getSystemdStateAndFailed sessionClient "user"+  return SystemdInfo+    { systemState = sysState+    , userState = usrState+    , systemFailedCount = sysFailed+    , userFailedCount = usrFailed+    , totalFailedCount = sysFailed + usrFailed+    }++-- | Query a single systemd instance for its state and failed count.+getSystemdStateAndFailed :: Client -> String -> IO (SystemdState, Int)+getSystemdStateAndFailed client busType = do+  stateResult <- getSystemdProperty client "SystemState"+  case stateResult of+    Left err -> do+      logM systemdLogPath DEBUG $+        "Failed to get " ++ busType ++ " systemd state: " ++ show err+      return (SystemdUnavailable, 0)+    Right stateVariant -> do+      let state = maybe (SystemdOther "unknown")+                        parseSystemdState+                        (fromVariant stateVariant :: Maybe Text)+      -- Only query failed count if degraded+      if state == SystemdDegraded+        then do+          failedResult <- getSystemdProperty client "NFailedUnits"+          case failedResult of+            Left err -> do+              logM systemdLogPath WARNING $+                "Failed to get " ++ busType ++ " failed units count: " ++ show err+              return (state, 0)+            Right failedVariant -> do+              let failed = fromMaybe 0 (fromVariant failedVariant :: Maybe Word32)+              return (state, fromIntegral failed)+        else return (state, 0)++-- | Get a property from the systemd1.Manager interface.+getSystemdProperty :: Client -> MemberName -> IO (Either MethodError Variant)+getSystemdProperty client propName = do+  reply <- call client $ (methodCall systemdObjectPath+                           "org.freedesktop.DBus.Properties"+                           "Get")+    { methodCallDestination = Just systemdBusName+    , methodCallBody = [toVariant systemdManagerInterface, toVariant propName]+    }+  case reply of+    Left err -> return $ Left err+    Right ret ->+      case methodReturnBody ret of+        [v] -> case fromVariant v of+          Just inner -> return $ Right inner+          Nothing -> return $ Left $ methodError+            (methodReturnSerial ret)+            (errorName_ "org.taffybar.Systemd.TypeMismatch")+        _ -> return $ Left $ methodError+          (methodReturnSerial ret)+          (errorName_ "org.taffybar.Systemd.InvalidResponse")
+ src/System/Taffybar/Information/Temperature.hs view
@@ -0,0 +1,181 @@+--------------------------------------------------------------------------------+-- |+-- Module      : System.Taffybar.Information.Temperature+-- Copyright   : (c) Ivan Malison+-- License     : BSD3-style (see LICENSE)+--+-- Maintainer  : Ivan Malison <IvanMalison@gmail.com>+-- Stability   : unstable+-- Portability : unportable+--+-- This module provides functions to read system temperature information from+-- Linux thermal zones and hwmon devices.+--+--------------------------------------------------------------------------------++module System.Taffybar.Information.Temperature+  ( TemperatureInfo(..)+  , ThermalSensor(..)+  , TemperatureUnit(..)+  , discoverSensors+  , readSensorTemperature+  , readAllTemperatures+  , readTemperaturesFrom+  , convertTemperature+  ) where++import Control.Exception (try, SomeException)+import Control.Monad (forM)+import Data.List (sortOn)+import Data.Maybe (catMaybes, fromMaybe)+import System.Directory (doesDirectoryExist, doesFileExist, listDirectory)+import System.FilePath ((</>))+import Text.Read (readMaybe)++-- | Temperature unit for display+data TemperatureUnit = Celsius | Fahrenheit | Kelvin+  deriving (Show, Eq)++-- | Information about a thermal sensor+data ThermalSensor = ThermalSensor+  { sensorName :: String      -- ^ Human-readable sensor name+  , sensorPath :: FilePath    -- ^ Path to the temperature file+  , sensorZone :: String      -- ^ Zone or hwmon identifier+  } deriving (Show, Eq)++-- | Temperature reading from a sensor+data TemperatureInfo = TemperatureInfo+  { tempCelsius :: Double     -- ^ Temperature in Celsius+  , tempSensor :: ThermalSensor  -- ^ The sensor this reading is from+  } deriving (Show, Eq)++-- | Convert temperature from Celsius to another unit+convertTemperature :: TemperatureUnit -> Double -> Double+convertTemperature Celsius t = t+convertTemperature Fahrenheit t = t * 1.8 + 32+convertTemperature Kelvin t = t + 273.15++-- | Discover all available thermal sensors on the system+-- Tries thermal_zone first, then hwmon devices+discoverSensors :: IO [ThermalSensor]+discoverSensors = do+  thermalSensors <- discoverThermalZones+  hwmonSensors <- discoverHwmon+  return $ thermalSensors ++ hwmonSensors++-- | Discover thermal zones from /sys/class/thermal/+discoverThermalZones :: IO [ThermalSensor]+discoverThermalZones = do+  let thermalDir = "/sys/class/thermal"+  exists <- doesDirectoryExist thermalDir+  if not exists+    then return []+    else do+      entries <- listDirectory thermalDir+      let zones = filter (isPrefixOf "thermal_zone") entries+      sensors <- forM zones $ \zone -> do+        let tempPath = thermalDir </> zone </> "temp"+            typePath = thermalDir </> zone </> "type"+        tempExists <- doesFileExist tempPath+        if tempExists+          then do+            sensorType <- readFileSafe typePath+            return $ Just ThermalSensor+              { sensorName = fromMaybe zone sensorType+              , sensorPath = tempPath+              , sensorZone = zone+              }+          else return Nothing+      return $ catMaybes sensors+  where+    isPrefixOf prefix str = take (length prefix) str == prefix++-- | Discover hwmon temperature sensors from /sys/class/hwmon/+discoverHwmon :: IO [ThermalSensor]+discoverHwmon = do+  let hwmonDir = "/sys/class/hwmon"+  exists <- doesDirectoryExist hwmonDir+  if not exists+    then return []+    else do+      entries <- listDirectory hwmonDir+      let hwmons = filter (isPrefixOf "hwmon") entries+      sensorLists <- forM hwmons $ \hwmon -> do+        let hwmonPath = hwmonDir </> hwmon+            namePath = hwmonPath </> "name"+        hwmonName <- readFileSafe namePath+        -- Find all temp*_input files+        allFiles <- listDirectory hwmonPath+        let tempInputs = filter isTempInput allFiles+        forM tempInputs $ \tempFile -> do+          let tempPath = hwmonPath </> tempFile+              sensorId = extractSensorId tempFile+              labelPath = hwmonPath </> ("temp" ++ sensorId ++ "_label")+          labelName <- readFileSafe labelPath+          let name = case (labelName, hwmonName) of+                (Just l, _) -> l+                (_, Just n) -> n ++ "_temp" ++ sensorId+                _ -> hwmon ++ "_temp" ++ sensorId+          return ThermalSensor+            { sensorName = name+            , sensorPath = tempPath+            , sensorZone = hwmon+            }+      return $ concat sensorLists+  where+    isPrefixOf prefix str = take (length prefix) str == prefix+    isTempInput file = take 4 file == "temp" && isSuffixOf "_input" file+    isSuffixOf suffix str =+      let suffixLen = length suffix+          strLen = length str+      in strLen >= suffixLen && drop (strLen - suffixLen) str == suffix+    -- Extract sensor number from "temp1_input" -> "1"+    extractSensorId file =+      let withoutPrefix = drop 4 file  -- remove "temp"+          withoutSuffix = take (length withoutPrefix - 6) withoutPrefix  -- remove "_input"+      in withoutSuffix++-- | Read temperature from a file, returns Nothing if file cannot be read+readFileSafe :: FilePath -> IO (Maybe String)+readFileSafe path = do+  exists <- doesFileExist path+  if not exists+    then return Nothing+    else do+      result <- try $ readFile path :: IO (Either SomeException String)+      case result of+        Left _ -> return Nothing+        Right content -> return $ Just $ strip content+  where+    strip = dropWhile (== ' ') . reverse . dropWhile (== '\n') . reverse . dropWhile (== ' ')++-- | Read temperature from a single sensor+-- Returns Nothing if the sensor cannot be read+readSensorTemperature :: ThermalSensor -> IO (Maybe TemperatureInfo)+readSensorTemperature sensor = do+  result <- try $ readFile (sensorPath sensor) :: IO (Either SomeException String)+  case result of+    Left _ -> return Nothing+    Right content ->+      case readMaybe (strip content) :: Maybe Integer of+        Nothing -> return Nothing+        Just milliDegrees -> return $ Just TemperatureInfo+          { tempCelsius = fromIntegral milliDegrees / 1000.0+          , tempSensor = sensor+          }+  where+    strip = dropWhile (== ' ') . reverse . dropWhile (== '\n') . reverse . dropWhile (== ' ')++-- | Read temperatures from all discovered sensors+-- Returns list sorted by temperature (highest first)+readAllTemperatures :: IO [TemperatureInfo]+readAllTemperatures = do+  sensors <- discoverSensors+  temps <- forM sensors readSensorTemperature+  return $ sortOn (negate . tempCelsius) $ catMaybes temps++-- | Read temperatures from specific sensors (by path)+readTemperaturesFrom :: [ThermalSensor] -> IO [TemperatureInfo]+readTemperaturesFrom sensors = do+  temps <- forM sensors readSensorTemperature+  return $ catMaybes temps
+ src/System/Taffybar/Information/Udev.hs view
@@ -0,0 +1,108 @@+{-# LANGUAGE ForeignFunctionInterface #-}++-- | Minimal libudev bindings used for event-driven backlight monitoring.+--+-- We only bind what we need for Waybar-style monitoring:+-- 1. Subscribe to udev netlink events for the "backlight" subsystem.+-- 2. Expose the monitor fd so callers can block (with a timeout) using+--    'GHC.Conc.threadWaitRead'.+-- 3. Drain pending udev events via 'udev_monitor_receive_device'.+module System.Taffybar.Information.Udev+  ( UdevBacklightMonitor+  , openBacklightMonitor+  , closeBacklightMonitor+  , backlightMonitorFd+  , drainBacklightMonitor+  ) where++import Control.Monad (void, when)+import Control.Exception (bracketOnError, throwIO)+import Foreign hiding (void)+import Foreign.C+import System.Posix.Types (Fd(..))++data Udev+data UdevMonitor+data UdevDevice++foreign import ccall unsafe "udev_new"+  c_udev_new :: IO (Ptr Udev)++foreign import ccall unsafe "udev_unref"+  c_udev_unref :: Ptr Udev -> IO (Ptr Udev)++foreign import ccall unsafe "udev_monitor_new_from_netlink"+  c_udev_monitor_new_from_netlink :: Ptr Udev -> CString -> IO (Ptr UdevMonitor)++foreign import ccall unsafe "udev_monitor_unref"+  c_udev_monitor_unref :: Ptr UdevMonitor -> IO (Ptr UdevMonitor)++foreign import ccall unsafe "udev_monitor_filter_add_match_subsystem_devtype"+  c_udev_monitor_filter_add_match_subsystem_devtype+    :: Ptr UdevMonitor+    -> CString+    -> CString -- nullable+    -> IO CInt++foreign import ccall unsafe "udev_monitor_enable_receiving"+  c_udev_monitor_enable_receiving :: Ptr UdevMonitor -> IO CInt++foreign import ccall unsafe "udev_monitor_get_fd"+  c_udev_monitor_get_fd :: Ptr UdevMonitor -> IO CInt++foreign import ccall unsafe "udev_monitor_receive_device"+  c_udev_monitor_receive_device :: Ptr UdevMonitor -> IO (Ptr UdevDevice)++foreign import ccall unsafe "udev_device_unref"+  c_udev_device_unref :: Ptr UdevDevice -> IO (Ptr UdevDevice)++data UdevBacklightMonitor = UdevBacklightMonitor+  { monitorUdev :: Ptr Udev+  , monitorHandle :: Ptr UdevMonitor+  , monitorFd :: Fd+  }++openBacklightMonitor :: IO UdevBacklightMonitor+openBacklightMonitor = do+  udev <- c_udev_new+  whenNull udev "udev_new failed"+  bracketOnError (pure udev) (void . c_udev_unref) $ \udev' ->+    withCString "udev" $ \netlinkName -> do+      mon <- c_udev_monitor_new_from_netlink udev' netlinkName+      whenNull mon "udev_monitor_new_from_netlink failed"+      bracketOnError (pure mon) (void . c_udev_monitor_unref) $ \mon' -> do+        withCString "backlight" $ \subsystem -> do+          rc <- c_udev_monitor_filter_add_match_subsystem_devtype mon' subsystem nullPtr+          whenNeg rc "udev_monitor_filter_add_match_subsystem_devtype failed"+        rc2 <- c_udev_monitor_enable_receiving mon'+        whenNeg rc2 "udev_monitor_enable_receiving failed"+        fdC <- c_udev_monitor_get_fd mon'+        whenNeg fdC "udev_monitor_get_fd failed"+        pure $ UdevBacklightMonitor+          { monitorUdev = udev'+          , monitorHandle = mon'+          , monitorFd = Fd fdC+          }+  where+    whenNull p msg = when (p == nullPtr) $ throwIO (userError msg)+    whenNeg rc msg = when (rc < 0) $ throwIO (userError msg)++closeBacklightMonitor :: UdevBacklightMonitor -> IO ()+closeBacklightMonitor mon = do+  void $ c_udev_monitor_unref (monitorHandle mon)+  void $ c_udev_unref (monitorUdev mon)++backlightMonitorFd :: UdevBacklightMonitor -> Fd+backlightMonitorFd = monitorFd++-- | Drain pending udev events from the monitor.+--+-- Call this after the monitor fd becomes readable.+drainBacklightMonitor :: UdevBacklightMonitor -> IO ()+drainBacklightMonitor mon = do+  -- Only consume a single event per wake; if multiple are queued, the fd will+  -- stay readable and we'll be woken again.+  dev <- c_udev_monitor_receive_device (monitorHandle mon)+  if dev == nullPtr+    then pure ()+    else void $ c_udev_device_unref dev
+ src/System/Taffybar/Information/WirePlumber.hs view
@@ -0,0 +1,224 @@+{-# LANGUAGE AllowAmbiguousTypes #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE KindSignatures #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeApplications #-}++-----------------------------------------------------------------------------++-----------------------------------------------------------------------------++-- |+-- Module      : System.Taffybar.Information.WirePlumber+-- Copyright   : (c) Ivan A. Malison+-- License     : BSD3-style (see LICENSE)+--+-- Maintainer  : Ivan A. Malison+-- Stability   : unstable+-- Portability : unportable+--+-- WirePlumber/PipeWire audio information using the @wpctl@ command-line tool.+--+-- This module provides access to audio volume and mute state for the default+-- audio sink or source via WirePlumber's command-line interface.+module System.Taffybar.Information.WirePlumber+  ( WirePlumberInfo (..),+    NodeType (..),+    getWirePlumberInfo,+    getWirePlumberInfoChan,+    getWirePlumberInfoState,+    getWirePlumberInfoChanFor,+    getWirePlumberInfoStateFor,+    toggleWirePlumberMute,+    adjustWirePlumberVolume,+    setWirePlumberVolume,+  )+where++import Control.Concurrent (forkIO, threadDelay)+import Control.Concurrent.MVar+import Control.Concurrent.STM.TChan+import Control.Exception (SomeException, try)+import Control.Monad (forever)+import Control.Monad.IO.Class (MonadIO, liftIO)+import Control.Monad.STM (atomically)+import Data.List (isInfixOf)+import Data.Proxy (Proxy (..))+import Data.Text (Text)+import qualified Data.Text as T+import GHC.TypeLits (KnownSymbol, SomeSymbol (..), Symbol, someSymbolVal, symbolVal)+import System.Log.Logger (Priority (..))+import System.Taffybar.Context (TaffyIO, getStateDefault)+import System.Taffybar.Util (logPrintF, runCommand)+import Text.Read (readMaybe)++-- | Type of audio node.+data NodeType+  = -- | Output device (speakers, headphones)+    Sink+  | -- | Input device (microphone)+    Source+  deriving (Eq, Show)++-- | WirePlumber audio information for a node.+data WirePlumberInfo = WirePlumberInfo+  { -- | Volume level from 0.0 to 1.0 (can exceed 1.0 for amplification)+    wirePlumberVolume :: Double,+    -- | Whether the node is muted+    wirePlumberMuted :: Bool,+    -- | Name of the node (e.g., "@DEFAULT_AUDIO_SINK@")+    wirePlumberNodeName :: Text+  }+  deriving (Eq, Show)++wpLogPath :: String+wpLogPath = "System.Taffybar.Information.WirePlumber"++wpLogF :: (MonadIO m, Show t) => Priority -> String -> t -> m ()+wpLogF = logPrintF wpLogPath++newtype WirePlumberInfoChanVar (a :: Symbol)+  = WirePlumberInfoChanVar (TChan (Maybe WirePlumberInfo), MVar (Maybe WirePlumberInfo))++-- | Get a broadcast channel for WirePlumber info for the provided node spec.+--+-- The first call for a given node spec will start a monitoring thread that+-- polls @wpctl@ periodically and broadcasts updates.+-- Subsequent calls return the already created channel.+getWirePlumberInfoChan :: String -> TaffyIO (TChan (Maybe WirePlumberInfo))+getWirePlumberInfoChan nodeSpec =+  case someSymbolVal nodeSpec of+    SomeSymbol (Proxy :: Proxy sym) -> getWirePlumberInfoChanFor @sym++-- | Read the current WirePlumber info state for the provided node spec.+--+-- See 'getWirePlumberInfoChan' for monitoring behavior.+getWirePlumberInfoState :: String -> TaffyIO (Maybe WirePlumberInfo)+getWirePlumberInfoState nodeSpec =+  case someSymbolVal nodeSpec of+    SomeSymbol (Proxy :: Proxy sym) -> getWirePlumberInfoStateFor @sym++-- | Get a broadcast channel for WirePlumber info for a node spec given as a+-- type-level string.+getWirePlumberInfoChanFor :: forall a. KnownSymbol a => TaffyIO (TChan (Maybe WirePlumberInfo))+getWirePlumberInfoChanFor = do+  WirePlumberInfoChanVar (chan, _) <- getWirePlumberInfoChanVarFor @a+  pure chan++-- | Read the current WirePlumber info state for a node spec given as a+-- type-level string.+getWirePlumberInfoStateFor :: forall a. KnownSymbol a => TaffyIO (Maybe WirePlumberInfo)+getWirePlumberInfoStateFor = do+  WirePlumberInfoChanVar (_, var) <- getWirePlumberInfoChanVarFor @a+  liftIO $ readMVar var++getWirePlumberInfoChanVarFor :: forall a. KnownSymbol a => TaffyIO (WirePlumberInfoChanVar a)+getWirePlumberInfoChanVarFor =+  getStateDefault $ do+    let nodeSpec = symbolVal (Proxy @a)+    liftIO $ do+      chan <- newBroadcastTChanIO+      var <- newMVar Nothing+      _ <- forkIO $ monitorWirePlumberInfo nodeSpec chan var+      pure $ WirePlumberInfoChanVar (chan, var)++-- | Polling interval in microseconds (1 second).+pollIntervalMicros :: Int+pollIntervalMicros = 1_000_000++monitorWirePlumberInfo ::+  String ->+  TChan (Maybe WirePlumberInfo) ->+  MVar (Maybe WirePlumberInfo) ->+  IO ()+monitorWirePlumberInfo nodeSpec chan var = forever $ do+  result <- try $ getWirePlumberInfo nodeSpec+  let info = case result of+        Left (_ :: SomeException) -> Nothing+        Right i -> i+  _ <- swapMVar var info+  atomically $ writeTChan chan info+  threadDelay pollIntervalMicros++-- | Query volume and mute state for the provided node spec.+--+-- The node spec can be:+-- * "@DEFAULT_AUDIO_SINK@" or "" for the default output+-- * "@DEFAULT_AUDIO_SOURCE@" for the default input+-- * A numeric node ID+--+-- Returns 'Nothing' if wpctl is not available or fails.+getWirePlumberInfo :: String -> IO (Maybe WirePlumberInfo)+getWirePlumberInfo nodeSpec = do+  let node = if null nodeSpec then "@DEFAULT_AUDIO_SINK@" else nodeSpec+  result <- runCommand "wpctl" ["get-volume", node]+  case result of+    Left err -> do+      wpLogF WARNING "wpctl get-volume failed: %s" err+      return Nothing+    Right output -> return $ parseWpctlOutput node output++-- | Parse the output of @wpctl get-volume@.+--+-- Expected formats:+-- * "Volume: 0.50"+-- * "Volume: 0.50 [MUTED]"+parseWpctlOutput :: String -> String -> Maybe WirePlumberInfo+parseWpctlOutput nodeSpec output = do+  let trimmed = dropWhile (== ' ') output+  -- Check if it starts with "Volume:"+  volumeStr <-+    if "Volume:" `isInfixOf` trimmed+      then Just $ drop 7 $ dropWhile (/= ':') trimmed+      else Nothing+  -- Parse the volume value and mute state+  let isMuted = "[MUTED]" `isInfixOf` volumeStr+      cleanVolStr = takeWhile (\c -> c /= '[' && c /= '\n') $ dropWhile (== ' ') volumeStr+  volume <- readMaybe cleanVolStr+  return+    WirePlumberInfo+      { wirePlumberVolume = volume,+        wirePlumberMuted = isMuted,+        wirePlumberNodeName = T.pack nodeSpec+      }++-- | Toggle mute for the provided node spec. Returns True on success.+toggleWirePlumberMute :: String -> IO Bool+toggleWirePlumberMute nodeSpec = do+  let node = if null nodeSpec then "@DEFAULT_AUDIO_SINK@" else nodeSpec+  result <- runCommand "wpctl" ["set-mute", node, "toggle"]+  case result of+    Left err -> do+      wpLogF WARNING "wpctl set-mute toggle failed: %s" err+      return False+    Right _ -> return True++-- | Adjust volume by the provided percentage delta. Returns True on success.+--+-- Positive values increase volume, negative values decrease it.+-- The delta is clamped to prevent going below 0%.+adjustWirePlumberVolume :: String -> Int -> IO Bool+adjustWirePlumberVolume nodeSpec deltaPercent = do+  let node = if null nodeSpec then "@DEFAULT_AUDIO_SINK@" else nodeSpec+      sign = if deltaPercent >= 0 then "+" else "-"+      absVal = abs deltaPercent+      arg = show absVal ++ "%" ++ sign+  result <- runCommand "wpctl" ["set-volume", node, arg, "--limit", "1.5"]+  case result of+    Left err -> do+      wpLogF WARNING "wpctl set-volume failed: %s" err+      return False+    Right _ -> return True++-- | Set volume to an absolute percentage value. Returns True on success.+setWirePlumberVolume :: String -> Int -> IO Bool+setWirePlumberVolume nodeSpec percent = do+  let node = if null nodeSpec then "@DEFAULT_AUDIO_SINK@" else nodeSpec+      arg = show (max 0 percent) ++ "%"+  result <- runCommand "wpctl" ["set-volume", node, arg, "--limit", "1.5"]+  case result of+    Left err -> do+      wpLogF WARNING "wpctl set-volume failed: %s" err+      return False+    Right _ -> return True
+ src/System/Taffybar/LogLevels.hs view
@@ -0,0 +1,99 @@+{-# LANGUAGE OverloadedStrings #-}+-----------------------------------------------------------------------------+-- |+-- Module      : System.Taffybar.LogLevels+-- Copyright   : (c) Ivan A. Malison+-- License     : BSD3-style (see LICENSE)+--+-- Maintainer  : Ivan A. Malison+-- Stability   : unstable+-- Portability : unportable+--+-- This module provides runtime-configurable log levels for taffybar. It reads+-- a YAML file mapping logger names to log levels, allowing users to enable+-- debug logging for specific modules without recompiling.+--+-- The default file location is @~\/.config\/taffybar\/log-levels.yaml@. The+-- format is a simple YAML mapping:+--+-- > # Enable debug logging for the toggle module+-- > System.Taffybar.DBus.Toggle: DEBUG+-- > Graphics.UI.GIGtkStrut: DEBUG+--+-- Valid log levels are: @DEBUG@, @INFO@, @NOTICE@, @WARNING@, @ERROR@,+-- @CRITICAL@, @ALERT@, @EMERGENCY@.+-----------------------------------------------------------------------------++module System.Taffybar.LogLevels+  ( loadLogLevelsFromFile+  , defaultLogLevelsPath+  ) where++import           Control.Monad (forM_, when)+import           Data.Aeson (Value(..))+import qualified Data.Aeson.Key as Key+import qualified Data.Aeson.KeyMap as KM+import qualified Data.Text as T+import qualified Data.Yaml as Yaml+import           System.Directory (doesFileExist)+import           System.Environment.XDG.BaseDir (getUserConfigFile)+import           System.Log.Logger++-- | The default path for the log levels configuration file:+-- @~\/.config\/taffybar\/log-levels.yaml@.+defaultLogLevelsPath :: IO FilePath+defaultLogLevelsPath = getUserConfigFile "taffybar" "log-levels.yaml"++-- | Load log levels from a YAML file. The file should contain a mapping from+-- logger names to log level strings. If the file does not exist, this is a+-- no-op.+--+-- Example YAML:+--+-- > System.Taffybar.DBus.Toggle: DEBUG+-- > System.Taffybar.Context: INFO+loadLogLevelsFromFile :: FilePath -> IO ()+loadLogLevelsFromFile path = do+  exists <- doesFileExist path+  when exists $ do+    result <- Yaml.decodeFileEither path+    case result of+      Left err ->+        logM loggerName WARNING $+          "Failed to parse " ++ path ++ ": " ++ show err+      Right (Object obj) ->+        forM_ (KM.toList obj) $ \(key, val) ->+          case val of+            String levelStr ->+              case readPriority (T.unpack levelStr) of+                Just level -> do+                  enableLogger (Key.toString key) level+                  logM loggerName INFO $+                    "Set log level: " ++ Key.toString key ++ " -> " ++ T.unpack levelStr+                Nothing ->+                  logM loggerName WARNING $+                    "Unknown log level: " ++ T.unpack levelStr+            _ ->+              logM loggerName WARNING $+                "Expected string value for key: " ++ Key.toString key+      Right _ ->+        logM loggerName WARNING $ "Expected YAML mapping in " ++ path+  where+    loggerName = "System.Taffybar.LogLevels"++enableLogger :: String -> Priority -> IO ()+enableLogger name level = do+  logger <- getLogger name+  saveGlobalLogger $ setLevel level logger++readPriority :: String -> Maybe Priority+readPriority s = case s of+  "DEBUG"     -> Just DEBUG+  "INFO"      -> Just INFO+  "NOTICE"    -> Just NOTICE+  "WARNING"   -> Just WARNING+  "ERROR"     -> Just ERROR+  "CRITICAL"  -> Just CRITICAL+  "ALERT"     -> Just ALERT+  "EMERGENCY" -> Just EMERGENCY+  _           -> Nothing
src/System/Taffybar/SimpleConfig.hs view
@@ -34,7 +34,6 @@ import qualified GI.Gtk as Gtk import           GI.Gdk import           Graphics.UI.GIGtkStrut-import           System.Taffybar.Information.X11DesktopInfo import           System.Taffybar import qualified System.Taffybar.Context as BC (BarConfig(..), TaffybarConfig(..)) import           System.Taffybar.Context hiding (TaffybarConfig(..), BarConfig(..))@@ -186,5 +185,15 @@ -- | Supply this value for 'monitorsAction' to display the taffybar window only -- on the primary monitor. usePrimaryMonitor :: TaffyIO [Int]-usePrimaryMonitor =-  singleton . fromMaybe 0 <$> lift (withX11Context def getPrimaryOutputNumber)+usePrimaryMonitor = lift $ do+  maybeDisplay <- displayGetDefault+  case maybeDisplay of+    Nothing -> return [0]+    Just display -> do+      maybePrimary <- displayGetPrimaryMonitor display+      monitorCount <- displayGetNMonitors display+      monitors <- catMaybes <$> mapM (displayGetMonitor display) [0..(monitorCount-1)]+      let primaryIndex = case maybePrimary of+            Nothing -> 0+            Just primary -> fromMaybe 0 (elemIndex primary monitors)+      return [primaryIndex]
src/System/Taffybar/Widget.hs view
@@ -1,10 +1,23 @@ {-# LANGUAGE CPP #-}+{-# LANGUAGE DuplicateRecordFields #-}  module System.Taffybar.Widget   ( module System.Taffybar.Widget.Util+  -- * "System.Taffybar.Widget.PulseAudio"+  , module System.Taffybar.Widget.PulseAudio++  -- * "System.Taffybar.Widget.Backlight"+  , module System.Taffybar.Widget.Backlight+   -- * "System.Taffybar.Widget.Battery"   , module System.Taffybar.Widget.Battery +  -- * "System.Taffybar.Widget.BatteryDonut"+  , module System.Taffybar.Widget.BatteryDonut++  -- * "System.Taffybar.Widget.BatteryTextIcon"+  , module System.Taffybar.Widget.BatteryTextIcon+   -- * "System.Taffybar.Widget.CPUMonitor"   , module System.Taffybar.Widget.CPUMonitor @@ -19,12 +32,18 @@   -- * "System.Taffybar.Widget.DiskIOMonitor"   , module System.Taffybar.Widget.DiskIOMonitor +  -- * "System.Taffybar.Widget.DiskUsage"+  , module System.Taffybar.Widget.DiskUsage+   -- * "System.Taffybar.Widget.FSMonitor"   , module System.Taffybar.Widget.FSMonitor    -- * "System.Taffybar.Widget.FreedesktopNotifications"   , module System.Taffybar.Widget.FreedesktopNotifications +  -- * "System.Taffybar.Widget.Inhibitor"+  , module System.Taffybar.Widget.Inhibitor+   -- * "System.Taffybar.Widget.Layout"   , module System.Taffybar.Widget.Layout @@ -34,6 +53,12 @@   -- * "System.Taffybar.Widget.NetworkGraph"   , module System.Taffybar.Widget.NetworkGraph +  -- * "System.Taffybar.Widget.NetworkManager"+  , module System.Taffybar.Widget.NetworkManager++  -- * "System.Taffybar.Widget.PowerProfiles"+  , module System.Taffybar.Widget.PowerProfiles+   -- * "System.Taffybar.Widget.SNITray"   , module System.Taffybar.Widget.SNITray @@ -58,6 +83,32 @@   -- * "System.Taffybar.Widget.Windows"   , module System.Taffybar.Widget.Windows +  -- * "System.Taffybar.Widget.HyprlandWorkspaces"+  , HyprlandWorkspacesConfig(..)+  , defaultHyprlandWorkspacesConfig+  , hyprlandWorkspacesNew+  , HyprlandWorkspace(..)+  , HyprlandWindow(..)+  , HyprlandWindowIconPixbufGetter+  , HyprlandWorkspaceWidgetController(..)+  , HyprlandWWC(..)+  , HyprlandControllerConstructor+  , HyprlandParentControllerConstructor+  , hyprlandBuildLabelController+  , hyprlandBuildIconController+  , hyprlandBuildContentsController+  , hyprlandBuildLabelOverlayController+  , hyprlandBuildCustomOverlayController+  , hyprlandBuildButtonController+  , defaultHyprlandWidgetBuilder+  , defaultHyprlandGetWindowIconPixbuf+  , getHyprlandWorkspaces+  , hyprlandSwitchToWorkspace+  , getActiveWindowAddress+  , runHyprctlJson+  , HyprlandClient(..)+  , windowFromClient+   -- * "System.Taffybar.Widget.Workspaces"   , module System.Taffybar.Widget.Workspaces @@ -66,17 +117,23 @@   ) where  import System.Taffybar.Widget.Battery+import System.Taffybar.Widget.BatteryDonut+import System.Taffybar.Widget.BatteryTextIcon import System.Taffybar.Widget.CPUMonitor import System.Taffybar.Widget.CommandRunner #ifdef WIDGET_CRYPTO import System.Taffybar.Widget.Crypto #endif import System.Taffybar.Widget.DiskIOMonitor+import System.Taffybar.Widget.DiskUsage import System.Taffybar.Widget.FSMonitor import System.Taffybar.Widget.FreedesktopNotifications+import System.Taffybar.Widget.Inhibitor import System.Taffybar.Widget.Layout import System.Taffybar.Widget.MPRIS2 import System.Taffybar.Widget.NetworkGraph+import System.Taffybar.Widget.NetworkManager+import System.Taffybar.Widget.PowerProfiles import System.Taffybar.Widget.SNITray import System.Taffybar.Widget.SimpleClock import System.Taffybar.Widget.SimpleCommandButton@@ -84,7 +141,35 @@ import System.Taffybar.Widget.Text.MemoryMonitor import System.Taffybar.Widget.Text.NetworkMonitor import System.Taffybar.Widget.Util+import System.Taffybar.Widget.PulseAudio+import System.Taffybar.Widget.Backlight import System.Taffybar.Widget.Weather import System.Taffybar.Widget.Windows+import System.Taffybar.Widget.HyprlandWorkspaces+  ( HyprlandWorkspacesConfig(..)+  , defaultHyprlandWorkspacesConfig+  , hyprlandWorkspacesNew+  , HyprlandWorkspace(..)+  , HyprlandWindow(..)+  , HyprlandWindowIconPixbufGetter+  , HyprlandWorkspaceWidgetController(..)+  , HyprlandWWC(..)+  , HyprlandControllerConstructor+  , HyprlandParentControllerConstructor+  , hyprlandBuildLabelController+  , hyprlandBuildIconController+  , hyprlandBuildContentsController+  , hyprlandBuildLabelOverlayController+  , hyprlandBuildCustomOverlayController+  , hyprlandBuildButtonController+  , defaultHyprlandWidgetBuilder+  , defaultHyprlandGetWindowIconPixbuf+  , getHyprlandWorkspaces+  , hyprlandSwitchToWorkspace+  , getActiveWindowAddress+  , runHyprctlJson+  , HyprlandClient(..)+  , windowFromClient+  ) import System.Taffybar.Widget.Workspaces import System.Taffybar.Widget.XDGMenu.MenuWidget
+ src/System/Taffybar/Widget/Backlight.hs view
@@ -0,0 +1,249 @@+{-# LANGUAGE OverloadedStrings #-}+----------------------------------------------------------------------------- +-- |+-- Module      : System.Taffybar.Widget.Backlight+-- Copyright   : (c) Ivan A. Malison+-- License     : BSD3-style (see LICENSE)+--+-- Maintainer  : Ivan A. Malison+-- Stability   : unstable+-- Portability : unportable+--+-- Simple backlight widget using /sys/class/backlight and optional+-- brightnessctl adjustments.+--+-----------------------------------------------------------------------------++module System.Taffybar.Widget.Backlight+  ( BacklightWidgetConfig(..)+  , defaultBacklightWidgetConfig+  , backlightIconNew+  , backlightIconNewWith+  , backlightLabelNew+  , backlightLabelNewWith+  , backlightLabelNewChan+  , backlightLabelNewChanWith+  , backlightNew+  , backlightNewWith+  , backlightNewChan+  , backlightNewChanWith+  ) where++import Control.Exception (SomeException, catch)+import Control.Monad (void)+import Control.Monad.IO.Class+import Data.Default (Default(..))+import qualified Data.Text as T+import qualified GI.Gdk.Structs.EventScroll as GdkEvent+import qualified GI.Gdk.Enums as Gdk+import qualified GI.Gtk as Gtk+import qualified GI.GLib as G+import System.Taffybar.Context (TaffyIO)+import qualified System.Taffybar.Information.Backlight as BL+import System.Taffybar.Util (postGUIASync, runCommand)+import System.Taffybar.Widget.Generic.ChannelWidget+import System.Taffybar.Widget.Generic.PollingLabel+import System.Taffybar.Widget.Util (buildIconLabelBox)+import Text.StringTemplate++-- | Configuration for the backlight widget.+data BacklightWidgetConfig = BacklightWidgetConfig+  { backlightPollingInterval :: Double+  , backlightDevice :: Maybe FilePath+  , backlightFormat :: String+  , backlightUnknownFormat :: String+  , backlightTooltipFormat :: Maybe String+  , backlightScrollStepPercent :: Maybe Int+  , backlightBrightnessctlPath :: FilePath+  , backlightIcon :: T.Text+  -- ^ Nerd font icon character (default U+F0EB, \xF0EB).+  }++-- | Default backlight widget configuration.+defaultBacklightWidgetConfig :: BacklightWidgetConfig+defaultBacklightWidgetConfig =+  BacklightWidgetConfig+    { backlightPollingInterval = 2+    , backlightDevice = Nothing+    , backlightFormat = "bl: $percent$%"+    , backlightUnknownFormat = "bl: n/a"+    , backlightTooltipFormat =+        Just "Device: $device$\nBrightness: $brightness$/$max$ ($percent$%)"+    , backlightScrollStepPercent = Just 5+    , backlightBrightnessctlPath = "brightnessctl"+    , backlightIcon = T.pack "\xF0EB"+    }++instance Default BacklightWidgetConfig where+  def = defaultBacklightWidgetConfig++-- | Create a backlight icon widget with default configuration.+backlightIconNew :: MonadIO m => m Gtk.Widget+backlightIconNew = backlightIconNewWith defaultBacklightWidgetConfig++-- | Create a backlight icon widget with the provided configuration.+backlightIconNewWith :: MonadIO m => BacklightWidgetConfig -> m Gtk.Widget+backlightIconNewWith config = liftIO $ do+  label <- Gtk.labelNew (Just (backlightIcon config))+  Gtk.widgetShowAll label+  Gtk.toWidget label++-- | Create a combined icon+label backlight widget with default configuration.+backlightNew :: MonadIO m => m Gtk.Widget+backlightNew = backlightNewWith defaultBacklightWidgetConfig++-- | Create a combined icon+label backlight widget.+backlightNewWith :: MonadIO m => BacklightWidgetConfig -> m Gtk.Widget+backlightNewWith config = liftIO $ do+  iconWidget <- backlightIconNewWith config+  labelWidget <- backlightLabelNewWith config+  buildIconLabelBox iconWidget labelWidget++-- | Create a combined icon+label backlight widget (channel-driven).+backlightNewChan :: TaffyIO Gtk.Widget+backlightNewChan = backlightNewChanWith defaultBacklightWidgetConfig++-- | Create a combined icon+label backlight widget (channel-driven).+backlightNewChanWith :: BacklightWidgetConfig -> TaffyIO Gtk.Widget+backlightNewChanWith config = do+  iconWidget <- liftIO $ backlightIconNewWith config+  labelWidget <- backlightLabelNewChanWith config+  liftIO $ buildIconLabelBox iconWidget labelWidget++-- | Create a backlight widget with default configuration.+backlightLabelNew :: MonadIO m => m Gtk.Widget+backlightLabelNew = backlightLabelNewWith defaultBacklightWidgetConfig++-- | Create a backlight widget with the provided configuration.+backlightLabelNewWith :: MonadIO m => BacklightWidgetConfig -> m Gtk.Widget+backlightLabelNewWith config = liftIO $ do+  widget <- pollingLabelNewWithTooltip+    (backlightPollingInterval config)+    (formatBacklightWidget config)++  case backlightScrollStepPercent config of+    Nothing -> return ()+    Just step | step <= 0 -> return ()+    Just step -> do+      _ <- Gtk.onWidgetScrollEvent widget $ \scrollEvent -> do+        dir <- GdkEvent.getEventScrollDirection scrollEvent+        case dir of+          Gdk.ScrollDirectionUp -> adjustBacklight config step >> return True+          Gdk.ScrollDirectionDown -> adjustBacklight config (-step) >> return True+          Gdk.ScrollDirectionLeft -> adjustBacklight config step >> return True+          Gdk.ScrollDirectionRight -> adjustBacklight config (-step) >> return True+          _ -> return False+      return ()++  Gtk.widgetShowAll widget+  return widget++-- | Create a backlight widget driven by a 'TChan' (no polling in the widget).+--+-- Monitoring is handled in 'System.Taffybar.Information.Backlight' (udev when+-- possible, with interval refresh as a fallback).+backlightLabelNewChan :: TaffyIO Gtk.Widget+backlightLabelNewChan = backlightLabelNewChanWith defaultBacklightWidgetConfig++-- | Create a backlight widget driven by a 'TChan' (no polling in the widget).+backlightLabelNewChanWith :: BacklightWidgetConfig -> TaffyIO Gtk.Widget+backlightLabelNewChanWith config = do+  chan <- BL.getBacklightInfoChanWithInterval+    (backlightDevice config)+    (backlightPollingInterval config)+  initialInfo <- BL.getBacklightInfoState (backlightDevice config)++  liftIO $ do+    label <- Gtk.labelNew Nothing++    let+      updateLabel info = do+        (labelText, tooltipText) <- formatBacklightWidgetFromInfo config info+        postGUIASync $ do+          Gtk.labelSetMarkup label labelText+          Gtk.widgetSetTooltipMarkup label tooltipText++      refreshNow = BL.getBacklightInfo (backlightDevice config) >>= updateLabel++    void $ Gtk.onWidgetRealize label $ updateLabel initialInfo++    case backlightScrollStepPercent config of+      Nothing -> return ()+      Just step | step <= 0 -> return ()+      Just step -> do+        _ <- Gtk.onWidgetScrollEvent label $ \scrollEvent -> do+          dir <- GdkEvent.getEventScrollDirection scrollEvent+          let doAdjust delta = do+                adjustBacklight config delta+                refreshNow+                return True+          case dir of+            Gdk.ScrollDirectionUp -> doAdjust step+            Gdk.ScrollDirectionDown -> doAdjust (-step)+            Gdk.ScrollDirectionLeft -> doAdjust step+            Gdk.ScrollDirectionRight -> doAdjust (-step)+            _ -> return False+        return ()++    Gtk.widgetShowAll label+    Gtk.toWidget =<< channelWidgetNew label chan updateLabel++formatBacklightWidget+  :: BacklightWidgetConfig+  -> IO (T.Text, Maybe T.Text)+formatBacklightWidget config = do+  info <- BL.getBacklightInfo (backlightDevice config)+  formatBacklightWidgetFromInfo config info++formatBacklightWidgetFromInfo+  :: BacklightWidgetConfig+  -> Maybe BL.BacklightInfo+  -> IO (T.Text, Maybe T.Text)+formatBacklightWidgetFromInfo config info =+  case info of+    Nothing -> return (T.pack $ backlightUnknownFormat config, Nothing)+    Just bl -> do+      attrs <- buildAttrs bl+      let labelText = renderTemplate (backlightFormat config) attrs+          tooltipText = fmap (`renderTemplate` attrs) (backlightTooltipFormat config)+      return (T.pack labelText, T.pack <$> tooltipText)++buildAttrs :: BL.BacklightInfo -> IO [(String, String)]+buildAttrs info = do+  let+    brightnessText = show $ BL.backlightBrightness info+    maxText = show $ BL.backlightMaxBrightness info+    percentText = show $ BL.backlightPercent info+    deviceText = BL.backlightDevice info+  brightness <- escapeText $ T.pack brightnessText+  maxBrightness <- escapeText $ T.pack maxText+  percent <- escapeText $ T.pack percentText+  device <- escapeText $ T.pack deviceText+  return+    [ ("brightness", brightness)+    , ("max", maxBrightness)+    , ("percent", percent)+    , ("device", device)+    ]++renderTemplate :: String -> [(String, String)] -> String+renderTemplate template attrs = render $ setManyAttrib attrs (newSTMP template)++escapeText :: T.Text -> IO String+escapeText input = T.unpack <$> G.markupEscapeText input (-1)++adjustBacklight :: BacklightWidgetConfig -> Int -> IO ()+adjustBacklight config delta =+  void $ safeRunCommand (backlightBrightnessctlPath config) (brightnessctlArgs delta)+  where+    brightnessctlArgs change =+      let+        step = abs change+        direction = if change >= 0 then "+" else "-"+        deviceArgs = maybe [] (\dev -> ["-d", dev]) (backlightDevice config)+      in deviceArgs ++ ["set", show step ++ "%" ++ direction]++safeRunCommand :: FilePath -> [String] -> IO (Either String String)+safeRunCommand cmd args =+  catch (runCommand cmd args) $ \(e :: SomeException) ->+    return $ Left $ show e
src/System/Taffybar/Widget/Battery.hs view
@@ -18,6 +18,9 @@ ----------------------------------------------------------------------------- module System.Taffybar.Widget.Battery   ( batteryIconNew+  , BatteryClassesConfig(..)+  , defaultBatteryClassesConfig+  , setBatteryStateClasses   , textBatteryNew   , textBatteryNewWithLabelAction   ) where@@ -26,15 +29,16 @@ import           Control.Monad.IO.Class import           Control.Monad.Trans.Reader import           Data.Default (Default(..))+import           Data.GI.Base.Overloading (IsDescendantOf) import           Data.Int (Int64)+import           Data.IORef (newIORef, readIORef, writeIORef) import qualified Data.Text as T import           GI.Gtk as Gtk-import           StatusNotifier.Tray (scalePixbufToSize) import           System.Taffybar.Context import           System.Taffybar.Information.Battery import           System.Taffybar.Util-import           System.Taffybar.Widget.Generic.AutoSizeImage import           System.Taffybar.Widget.Generic.ChannelWidget+import           System.Taffybar.Widget.Generic.ScalingImage (scalingImage) import           System.Taffybar.Widget.Util hiding (themeLoadFlags) import           Text.Printf import           Text.StringTemplate@@ -112,15 +116,16 @@   def = defaultBatteryClassesConfig  setBatteryStateClasses ::-  MonadIO m => BatteryClassesConfig -> Gtk.Label -> BatteryInfo -> m ()-setBatteryStateClasses config label info = do+  (IsDescendantOf Widget a, GObject a, MonadIO m) =>+  BatteryClassesConfig -> a -> BatteryInfo -> m ()+setBatteryStateClasses config widget info = do   case batteryState info of-    BatteryStateCharging -> addClassIfMissing "charging" label >>-                            removeClassIfPresent "discharging" label-    BatteryStateDischarging -> addClassIfMissing "discharging" label >>-                               removeClassIfPresent "charging" label-    _ -> removeClassIfPresent "charging" label >>-         removeClassIfPresent "discharging" label+    BatteryStateCharging -> addClassIfMissing "charging" widget >>+                            removeClassIfPresent "discharging" widget+    BatteryStateDischarging -> addClassIfMissing "discharging" widget >>+                               removeClassIfPresent "charging" widget+    _ -> removeClassIfPresent "charging" widget >>+         removeClassIfPresent "discharging" widget    classIf "high" $ percentage >= batteryHighThreshold config   classIf "low" $ percentage <= batteryLowThreshold config@@ -128,8 +133,8 @@   where percentage = batteryPercentage info         classIf klass condition =           if condition-          then addClassIfMissing klass label-          else removeClassIfPresent klass label+          then addClassIfMissing klass widget+          else removeClassIfPresent klass widget  -- | Like `textBatteryNew` but provides a more general way to update the label -- widget. The argument provided is an action that is used to update the text@@ -154,18 +159,15 @@ batteryIconNew = do   chan <- getDisplayBatteryChan   ctx <- ask+  defaultTheme <- liftIO iconThemeGetDefault+  imageWidgetRef <- liftIO $ newIORef (error "imageWidget not initialised")+  let setIconForSize size = do+        iw <- readIORef imageWidgetRef+        styleCtx <- widgetGetStyleContext iw+        name <- T.pack . batteryIconName <$> runReaderT getDisplayBatteryInfo ctx+        iconThemeLookupIcon defaultTheme name size themeLoadFlags >>=+          traverse (\info -> fst <$> iconInfoLoadSymbolicForContext info styleCtx)+  (imageWidget, updateImage) <- scalingImage setIconForSize OrientationHorizontal   liftIO $ do-    image <- imageNew-    styleCtx <- widgetGetStyleContext =<< toWidget image-    defaultTheme <- iconThemeGetDefault-    let getCurrentBatteryIconNameString =-          T.pack . batteryIconName <$> runReaderT getDisplayBatteryInfo ctx-        extractPixbuf info =-          fst <$> iconInfoLoadSymbolicForContext info styleCtx-        setIconForSize size = do-          name <- getCurrentBatteryIconNameString-          iconThemeLookupIcon defaultTheme name size themeLoadFlags >>=-            traverse extractPixbuf >>=-              traverse (scalePixbufToSize size OrientationHorizontal)-    updateImage <- autoSizeImage image setIconForSize OrientationHorizontal-    toWidget =<< channelWidgetNew image chan (const $ postGUIASync updateImage)+    writeIORef imageWidgetRef imageWidget+    toWidget =<< channelWidgetNew imageWidget chan (const $ postGUIASync updateImage)
+ src/System/Taffybar/Widget/BatteryDonut.hs view
@@ -0,0 +1,201 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RecordWildCards   #-}+-----------------------------------------------------------------------------+-- |+-- Module      : System.Taffybar.Widget.BatteryDonut+-- Copyright   : (c) Ivan A. Malison+-- License     : BSD3-style (see LICENSE)+--+-- Maintainer  : Ivan A. Malison+-- Stability   : unstable+-- Portability : unportable+--+-- A battery widget that draws a donut\/arc using Cairo to visualize battery+-- charge level. The arc color changes based on configurable charge thresholds.+-----------------------------------------------------------------------------+module System.Taffybar.Widget.BatteryDonut+  ( batteryDonutNew+  , batteryDonutNewWith+  , batteryDonutLabelNew+  , batteryDonutLabelNewWith+  , BatteryDonutConfig(..)+  , defaultBatteryDonutConfig+  ) where++import           Control.Monad+import           Control.Monad.IO.Class+import           Control.Monad.Trans.Reader+import           Data.Default (Default(..))+import           Data.Int (Int32)+import           Data.IORef+import qualified GI.Cairo.Render as C+import           GI.Cairo.Render.Connector (renderWithContext)+import           GI.Gtk as Gtk+import           System.Taffybar.Context+import           System.Taffybar.Information.Battery+import           System.Taffybar.Util+import           System.Taffybar.Widget.Generic.ChannelWidget+import           System.Taffybar.Widget.Battery (textBatteryNew)+import           System.Taffybar.Widget.Util (widgetSetClassGI,+                                               addClassIfMissing, removeClassIfPresent,+                                               buildIconLabelBox)+import qualified System.Taffybar.Widget.Util as WU++-- | Configuration for the donut/arc battery widget.+data BatteryDonutConfig = BatteryDonutConfig+  { donutHighColor :: (Double, Double, Double)+    -- ^ Color when charge is high (default: green)+  , donutMediumColor :: (Double, Double, Double)+    -- ^ Color when charge is medium (default: yellow)+  , donutLowColor :: (Double, Double, Double)+    -- ^ Color when charge is low (default: orange)+  , donutCriticalColor :: (Double, Double, Double)+    -- ^ Color when charge is critical (default: red)+  , donutBackgroundColor :: (Double, Double, Double)+    -- ^ Background ring color (default: dim gray)+  , donutHighThreshold :: Double+    -- ^ Percentage above which color is "high" (default: 60)+  , donutMediumThreshold :: Double+    -- ^ Percentage above which color is "medium" (default: 30)+  , donutCriticalThreshold :: Double+    -- ^ Percentage below which color is "critical" (default: 10)+  , donutSize :: Int32+    -- ^ Requested widget size in pixels (default: 24)+  , donutChargingColor :: Maybe (Double, Double, Double)+    -- ^ Optional override color when charging (default: Nothing)+  , donutLabelFormat :: String+    -- ^ Format string for the text label in the combined donut+label variant.+    -- Uses the same template syntax as 'textBatteryNew': @$percentage$@,+    -- @$time$@, and @$status$@ are replaced with the corresponding values.+    -- (default: @"$percentage$%"@)+  }++-- | Default donut battery configuration.+defaultBatteryDonutConfig :: BatteryDonutConfig+defaultBatteryDonutConfig = BatteryDonutConfig+  { donutHighColor = (0.3, 0.85, 0.3)+  , donutMediumColor = (0.95, 0.85, 0.2)+  , donutLowColor = (0.95, 0.5, 0.1)+  , donutCriticalColor = (0.9, 0.2, 0.2)+  , donutBackgroundColor = (0.3, 0.3, 0.3)+  , donutHighThreshold = 60+  , donutMediumThreshold = 30+  , donutCriticalThreshold = 10+  , donutSize = 24+  , donutChargingColor = Nothing+  , donutLabelFormat = "$percentage$%"+  }++instance Default BatteryDonutConfig where+  def = defaultBatteryDonutConfig++-- | Select the arc color based on battery percentage and charging state.+donutColorForLevel :: BatteryDonutConfig -> Double -> BatteryState -> (Double, Double, Double)+donutColorForLevel BatteryDonutConfig{..} pct state =+  case (state, donutChargingColor) of+    (BatteryStateCharging, Just color) -> color+    _ | pct >= donutHighThreshold     -> donutHighColor+      | pct >= donutMediumThreshold   -> donutMediumColor+      | pct >= donutCriticalThreshold -> donutLowColor+      | otherwise                     -> donutCriticalColor++-- | Render the donut arc for the battery.+renderDonut :: BatteryDonutConfig -> Double -> BatteryState -> Int -> Int -> C.Render ()+renderDonut cfg pct state w h = do+  let size = fromIntegral (min w h) :: Double+      cx = fromIntegral w / 2+      cy = fromIntegral h / 2+      lineW = size * 0.22+      radius = (size - lineW) / 2+      startAngle = -(pi / 2)+      fullAngle = 2 * pi+      fraction = pct / 100+      endAngle = startAngle + fullAngle * fraction+      (bgR, bgG, bgB) = donutBackgroundColor cfg+      (fgR, fgG, fgB) = donutColorForLevel cfg pct state++  -- Draw background ring+  C.setLineCap C.LineCapRound+  C.setLineWidth lineW+  C.setSourceRGB bgR bgG bgB+  C.arc cx cy radius 0 fullAngle+  C.stroke++  -- Draw foreground arc (only if there is something to draw)+  when (fraction > 0.001) $ do+    C.setSourceRGB fgR fgG fgB+    C.arc cx cy radius startAngle endAngle+    C.stroke++-- | Set CSS classes on the donut widget based on battery state.+setDonutBatteryClasses ::+  (Gtk.IsWidget w, MonadIO m) => BatteryDonutConfig -> w -> BatteryInfo -> m ()+setDonutBatteryClasses cfg widget info = do+  case batteryState info of+    BatteryStateCharging -> addClassIfMissing "charging" widget >>+                            removeClassIfPresent "discharging" widget+    BatteryStateDischarging -> addClassIfMissing "discharging" widget >>+                               removeClassIfPresent "charging" widget+    _ -> removeClassIfPresent "charging" widget >>+         removeClassIfPresent "discharging" widget++  classIf "high" $ percentage >= donutHighThreshold cfg+  classIf "medium" $ percentage >= donutMediumThreshold cfg &&+                     percentage < donutHighThreshold cfg+  classIf "low" $ percentage < donutMediumThreshold cfg &&+                  percentage >= donutCriticalThreshold cfg+  classIf "critical" $ percentage < donutCriticalThreshold cfg+  where percentage = batteryPercentage info+        classIf klass condition =+          if condition+          then addClassIfMissing klass widget+          else removeClassIfPresent klass widget++-- | Create a donut/arc battery widget with the default configuration.+batteryDonutNew :: TaffyIO Widget+batteryDonutNew = batteryDonutNewWith def++-- | Create a donut/arc battery widget with a custom configuration.+batteryDonutNewWith :: BatteryDonutConfig -> TaffyIO Widget+batteryDonutNewWith cfg = do+  chan <- getDisplayBatteryChan+  ctx <- ask+  liftIO $ do+    drawArea <- drawingAreaNew+    widgetSetSizeRequest drawArea (donutSize cfg) (donutSize cfg)++    pctRef <- newIORef 0.0+    stateRef <- newIORef BatteryStateUnknown++    _ <- widgetSetClassGI drawArea "battery-donut"++    _ <- onWidgetDraw drawArea $ \cairoCtx -> do+      (w, h) <- WU.widgetGetAllocatedSize drawArea+      pct <- readIORef pctRef+      bState <- readIORef stateRef+      renderWithContext (renderDonut cfg pct bState w h) cairoCtx+      return True++    let updateWidget info = postGUIASync $ do+          writeIORef pctRef (batteryPercentage info)+          writeIORef stateRef (batteryState info)+          setDonutBatteryClasses cfg drawArea info+          widgetQueueDraw drawArea++    void $ onWidgetRealize drawArea $+      runReaderT getDisplayBatteryInfo ctx >>= updateWidget++    toWidget =<< channelWidgetNew drawArea chan updateWidget++-- | Create a combined donut icon + text label battery widget with the default+-- configuration.+batteryDonutLabelNew :: TaffyIO Widget+batteryDonutLabelNew = batteryDonutLabelNewWith def++-- | Create a combined donut icon + text label battery widget with a custom+-- configuration.+batteryDonutLabelNewWith :: BatteryDonutConfig -> TaffyIO Widget+batteryDonutLabelNewWith config = do+  iconWidget <- batteryDonutNewWith config+  labelWidget <- textBatteryNew (donutLabelFormat config)+  liftIO $ buildIconLabelBox iconWidget labelWidget
+ src/System/Taffybar/Widget/BatteryTextIcon.hs view
@@ -0,0 +1,124 @@+{-# LANGUAGE OverloadedStrings #-}+-----------------------------------------------------------------------------+-- |+-- Module      : System.Taffybar.Widget.BatteryTextIcon+-- Copyright   : (c) Ivan A. Malison+-- License     : BSD3-style (see LICENSE)+--+-- Maintainer  : Ivan A. Malison+-- Stability   : unstable+-- Portability : unportable+--+-- A battery icon widget that uses text glyphs (e.g. Nerd Font icons) to+-- display battery state. The glyph changes based on charge level and whether+-- the battery is charging or discharging. CSS classes are applied for+-- additional styling.+-----------------------------------------------------------------------------+module System.Taffybar.Widget.BatteryTextIcon+  ( batteryTextIconNew+  , batteryTextIconNewWith+  , BatteryTextIconConfig(..)+  , defaultBatteryTextIconConfig+  ) where++import           Control.Monad+import           Control.Monad.IO.Class+import           Control.Monad.Trans.Reader+import           Data.Default (Default(..))+import qualified Data.Text as T+import           GI.Gtk as Gtk+import           System.Taffybar.Context+import           System.Taffybar.Information.Battery+import           System.Taffybar.Util+import           System.Taffybar.Widget.Battery+import           System.Taffybar.Widget.Generic.ChannelWidget+import           System.Taffybar.Widget.Util hiding (themeLoadFlags)++-- | Configuration for the nerd font battery text icon widget.+data BatteryTextIconConfig = BatteryTextIconConfig+  { -- | Glyphs to use when discharging, ordered from empty (0%) to full (100%).+    -- Must have at least one element.+    batteryTextIconDischarging :: [T.Text]+    -- | Glyphs to use when charging, ordered from empty (0%) to full (100%).+    -- Must have at least one element.+  , batteryTextIconCharging :: [T.Text]+    -- | Glyph to use when fully charged / on AC with no discharge.+  , batteryTextIconFull :: T.Text+  }++-- | Default config using Nerd Font battery icons (Material Design Icons).+defaultBatteryTextIconConfig :: BatteryTextIconConfig+defaultBatteryTextIconConfig = BatteryTextIconConfig+  { batteryTextIconDischarging =+      [ "\xf008e" -- 󰂎 nf-md-battery_outline (0%)+      , "\xf007a" -- 󰁺 nf-md-battery_10+      , "\xf007b" -- 󰁻 nf-md-battery_20+      , "\xf007c" -- 󰁼 nf-md-battery_30+      , "\xf007d" -- 󰁽 nf-md-battery_40+      , "\xf007e" -- 󰁾 nf-md-battery_50+      , "\xf007f" -- 󰁿 nf-md-battery_60+      , "\xf0080" -- 󰂀 nf-md-battery_70+      , "\xf0081" -- 󰂁 nf-md-battery_80+      , "\xf0082" -- 󰂂 nf-md-battery_90+      , "\xf0079" -- 󰁹 nf-md-battery (100%)+      ]+  , batteryTextIconCharging =+      [ "\xf089f" -- 󰢟 nf-md-battery_charging_outline (0%)+      , "\xf089c" -- 󰢜 nf-md-battery_charging_10+      , "\xf0086" -- 󰂆 nf-md-battery_charging_20+      , "\xf0087" -- 󰂇 nf-md-battery_charging_30+      , "\xf0088" -- 󰂈 nf-md-battery_charging_40+      , "\xf089d" -- 󰢝 nf-md-battery_charging_50+      , "\xf0089" -- 󰂉 nf-md-battery_charging_60+      , "\xf089e" -- 󰢞 nf-md-battery_charging_70+      , "\xf008a" -- 󰂊 nf-md-battery_charging_80+      , "\xf008b" -- 󰂋 nf-md-battery_charging_90+      , "\xf0085" -- 󰂅 nf-md-battery_charging_100+      ]+  , batteryTextIconFull = "\xf0085" -- 󰂅 nf-md-battery_charging_100+  }++instance Default BatteryTextIconConfig where+  def = defaultBatteryTextIconConfig++-- | Select the appropriate glyph from a list based on battery percentage.+selectGlyph :: [T.Text] -> Double -> T.Text+selectGlyph [] _ = "?"+selectGlyph glyphs pct =+  let n = length glyphs+      idx = min (n - 1) $ floor (pct / 100.0 * fromIntegral n)+  in glyphs !! max 0 idx++-- | A battery icon widget that uses text glyphs (e.g. Nerd Font icons) to+-- display battery state. The glyph changes based on charge level and+-- charging\/discharging state. CSS classes @charging@, @discharging@, @high@,+-- @low@, and @critical@ are applied for styling.+--+-- Uses default Nerd Font Material Design battery icons. For custom glyphs, use+-- 'batteryTextIconNewWith'.+batteryTextIconNew :: TaffyIO Widget+batteryTextIconNew = batteryTextIconNewWith def++-- | Like 'batteryTextIconNew' but with a custom 'BatteryTextIconConfig'.+batteryTextIconNewWith :: BatteryTextIconConfig -> TaffyIO Widget+batteryTextIconNewWith config = do+  chan <- getDisplayBatteryChan+  ctx <- ask+  liftIO $ do+    label <- labelNew Nothing+    _ <- widgetSetClassGI label "battery-text-icon"+    let updateWidget info = postGUIASync $ do+          let pct = batteryPercentage info+              glyph = case batteryState info of+                BatteryStateCharging ->+                  selectGlyph (batteryTextIconCharging config) pct+                BatteryStateDischarging ->+                  selectGlyph (batteryTextIconDischarging config) pct+                _ | pct >= 99 -> batteryTextIconFull config+                  | otherwise ->+                    selectGlyph (batteryTextIconDischarging config) pct+          labelSetLabel label glyph+          setBatteryStateClasses def label info+    void $ onWidgetRealize label $+         runReaderT getDisplayBatteryInfo ctx >>= updateWidget+    toWidget =<< channelWidgetNew label chan updateWidget
+ src/System/Taffybar/Widget/Bluetooth.hs view
@@ -0,0 +1,232 @@+{-# LANGUAGE OverloadedStrings #-}+-----------------------------------------------------------------------------+-- |+-- Module      : System.Taffybar.Widget.Bluetooth+-- Copyright   : (c) Ivan A. Malison+-- License     : BSD3-style (see LICENSE)+--+-- Maintainer  : Ivan A. Malison+-- Stability   : unstable+-- Portability : unportable+--+-- This module provides a Bluetooth status widget that displays the current+-- Bluetooth state, connected devices, and optionally battery percentages.+--+-- The widget uses the 'TChan'-based system from+-- "System.Taffybar.Information.Bluetooth" for receiving updates.+-----------------------------------------------------------------------------+module System.Taffybar.Widget.Bluetooth+  ( BluetoothWidgetConfig(..)+  , defaultBluetoothWidgetConfig+  , bluetoothIconNew+  , bluetoothIconNewWith+  , bluetoothLabelNew+  , bluetoothLabelNewWith+  , bluetoothNew+  , bluetoothNewWith+  ) where++import Control.Monad (void)+import Control.Monad.IO.Class+import Data.Default (Default(..))+import Data.List (intercalate)+import qualified Data.Text as T+import qualified GI.GLib as G+import qualified GI.Gtk as Gtk+import System.Taffybar.Context (TaffyIO)+import System.Taffybar.Information.Bluetooth+import System.Taffybar.Util (postGUIASync)+import System.Taffybar.Widget.Generic.ChannelWidget+import System.Taffybar.Widget.Util (buildIconLabelBox)+import Text.StringTemplate++-- | Configuration for the Bluetooth widget.+data BluetoothWidgetConfig = BluetoothWidgetConfig+  { -- | Format string when Bluetooth is connected.+    -- Available variables: $status$, $device_alias$, $device_battery$,+    -- $num_connections$, $controller_alias$+    bluetoothFormatConnected :: String+    -- | Format string when Bluetooth is on but not connected.+  , bluetoothFormatOn :: String+    -- | Format string when Bluetooth is off (powered down).+  , bluetoothFormatOff :: String+    -- | Format string when no Bluetooth controller is found.+  , bluetoothFormatNoController :: String+    -- | Optional tooltip format.+    -- Additional variable: $device_list$+  , bluetoothTooltipFormat :: Maybe String+    -- | Format for each device in the tooltip device list.+    -- Variables: $device_alias$, $device_battery$+  , bluetoothDeviceListFormat :: String+    -- | Icon to display when Bluetooth is connected.+  , bluetoothConnectedIcon :: T.Text+    -- | Icon to display when Bluetooth is on but not connected.+  , bluetoothOnIcon :: T.Text+    -- | Icon to display when Bluetooth is off (powered down).+  , bluetoothOffIcon :: T.Text+    -- | Icon to display when no Bluetooth controller is found.+  , bluetoothNoControllerIcon :: T.Text+  }++defaultBluetoothWidgetConfig :: BluetoothWidgetConfig+defaultBluetoothWidgetConfig = BluetoothWidgetConfig+  { bluetoothFormatConnected = "$device_alias$"+  , bluetoothFormatOn = ""+  , bluetoothFormatOff = ""+  , bluetoothFormatNoController = ""+  , bluetoothTooltipFormat = Just "Bluetooth: $status$\nController: $controller_alias$\n$device_list$"+  , bluetoothDeviceListFormat = "$device_alias$ ($device_battery$%)"+  , bluetoothConnectedIcon = T.pack "\xF293"+  , bluetoothOnIcon = T.pack "\xF293"+  , bluetoothOffIcon = T.pack "\xF294"+  , bluetoothNoControllerIcon = T.pack "\xF294"+  }++instance Default BluetoothWidgetConfig where+  def = defaultBluetoothWidgetConfig++-- | Create a Bluetooth icon widget with default configuration.+bluetoothIconNew :: TaffyIO Gtk.Widget+bluetoothIconNew = bluetoothIconNewWith defaultBluetoothWidgetConfig++-- | Create a Bluetooth icon widget with custom configuration.+-- The icon updates dynamically based on the current Bluetooth status.+bluetoothIconNewWith :: BluetoothWidgetConfig -> TaffyIO Gtk.Widget+bluetoothIconNewWith config = do+  chan <- getBluetoothInfoChan+  initialInfo <- getBluetoothInfoState+  liftIO $ do+    label <- Gtk.labelNew Nothing+    let updateIcon info = postGUIASync $ do+          let iconText = case bluetoothStatus info of+                BluetoothConnected -> bluetoothConnectedIcon config+                BluetoothOn -> bluetoothOnIcon config+                BluetoothOff -> bluetoothOffIcon config+                BluetoothNoController -> bluetoothNoControllerIcon config+          Gtk.labelSetText label iconText+          updateStyleClasses label info+    void $ Gtk.onWidgetRealize label $ updateIcon initialInfo+    Gtk.widgetShowAll label+    Gtk.toWidget =<< channelWidgetNew label chan updateIcon++-- | Create a Bluetooth label widget with default configuration.+bluetoothLabelNew :: TaffyIO Gtk.Widget+bluetoothLabelNew = bluetoothLabelNewWith defaultBluetoothWidgetConfig++-- | Create a Bluetooth label widget with custom configuration.+-- The label shows text information (device alias, status, etc.) but no icon.+bluetoothLabelNewWith :: BluetoothWidgetConfig -> TaffyIO Gtk.Widget+bluetoothLabelNewWith config = do+  chan <- getBluetoothInfoChan+  initialInfo <- getBluetoothInfoState++  liftIO $ do+    label <- Gtk.labelNew Nothing++    let updateLabel info = do+          (labelText, tooltipText) <- formatBluetoothWidget config info+          postGUIASync $ do+            Gtk.labelSetMarkup label labelText+            Gtk.widgetSetTooltipMarkup label tooltipText+            -- Add CSS classes based on status+            updateStyleClasses label info++    void $ Gtk.onWidgetRealize label $ updateLabel initialInfo++    Gtk.widgetShowAll label+    Gtk.toWidget =<< channelWidgetNew label chan updateLabel++-- | Create a combined icon+label Bluetooth widget with default configuration.+bluetoothNew :: TaffyIO Gtk.Widget+bluetoothNew = bluetoothNewWith defaultBluetoothWidgetConfig++-- | Create a combined icon+label Bluetooth widget with custom configuration.+bluetoothNewWith :: BluetoothWidgetConfig -> TaffyIO Gtk.Widget+bluetoothNewWith config = do+  iconWidget <- bluetoothIconNewWith config+  labelWidget <- bluetoothLabelNewWith config+  liftIO $ buildIconLabelBox iconWidget labelWidget++-- | Update CSS classes on the widget based on Bluetooth status.+updateStyleClasses :: Gtk.Label -> BluetoothInfo -> IO ()+updateStyleClasses label info = do+  styleCtx <- Gtk.widgetGetStyleContext label++  -- Remove all bluetooth status classes first+  Gtk.styleContextRemoveClass styleCtx "bluetooth-connected"+  Gtk.styleContextRemoveClass styleCtx "bluetooth-on"+  Gtk.styleContextRemoveClass styleCtx "bluetooth-off"+  Gtk.styleContextRemoveClass styleCtx "bluetooth-no-controller"++  -- Add the appropriate class+  case bluetoothStatus info of+    BluetoothConnected -> Gtk.styleContextAddClass styleCtx "bluetooth-connected"+    BluetoothOn -> Gtk.styleContextAddClass styleCtx "bluetooth-on"+    BluetoothOff -> Gtk.styleContextAddClass styleCtx "bluetooth-off"+    BluetoothNoController -> Gtk.styleContextAddClass styleCtx "bluetooth-no-controller"++-- | Format the Bluetooth widget based on current state.+formatBluetoothWidget ::+  BluetoothWidgetConfig ->+  BluetoothInfo ->+  IO (T.Text, Maybe T.Text)+formatBluetoothWidget config info = do+  attrs <- buildAttrs info+  let format = case bluetoothStatus info of+        BluetoothConnected -> bluetoothFormatConnected config+        BluetoothOn -> bluetoothFormatOn config+        BluetoothOff -> bluetoothFormatOff config+        BluetoothNoController -> bluetoothFormatNoController config+      labelText = renderTemplate format attrs+      tooltipText = fmap (`renderTemplate` attrs) (bluetoothTooltipFormat config)+  return (T.pack labelText, T.pack <$> tooltipText)++-- | Build template attributes from Bluetooth info.+buildAttrs :: BluetoothInfo -> IO [(String, String)]+buildAttrs info = do+  let statusText = case bluetoothStatus info of+        BluetoothConnected -> "connected"+        BluetoothOn -> "on"+        BluetoothOff -> "off"+        BluetoothNoController -> "no-controller"++      -- Get the first connected device for primary display+      primaryDevice = case bluetoothConnectedDevices info of+        [] -> Nothing+        (d:_) -> Just d++      deviceAliasText = maybe "" deviceAlias primaryDevice+      deviceBatteryText = maybe "?" (maybe "?" show . deviceBatteryPercentage) primaryDevice+      numConnections = length $ bluetoothConnectedDevices info+      controllerAliasText = maybe "none" controllerAlias (bluetoothController info)++      -- Build device list for tooltip+      deviceListText = intercalate "\n" $+        map formatDeviceEntry (bluetoothConnectedDevices info)++      formatDeviceEntry dev =+        let battery = maybe "?" show (deviceBatteryPercentage dev)+        in deviceAlias dev ++ " (" ++ battery ++ "%)"++  status <- escapeText $ T.pack statusText+  deviceAliasEsc <- escapeText $ T.pack deviceAliasText+  deviceBatteryEsc <- escapeText $ T.pack deviceBatteryText+  controllerAliasEsc <- escapeText $ T.pack controllerAliasText+  deviceListEsc <- escapeText $ T.pack deviceListText++  return+    [ ("status", status)+    , ("device_alias", deviceAliasEsc)+    , ("device_battery", deviceBatteryEsc)+    , ("num_connections", show numConnections)+    , ("controller_alias", controllerAliasEsc)+    , ("device_list", deviceListEsc)+    ]++-- | Render a template with the given attributes.+renderTemplate :: String -> [(String, String)] -> String+renderTemplate template attrs = render $ setManyAttrib attrs (newSTMP template)++-- | Escape text for Pango markup.+escapeText :: T.Text -> IO String+escapeText input = T.unpack <$> G.markupEscapeText input (-1)
src/System/Taffybar/Widget/Crypto.hs view
@@ -39,8 +39,8 @@ import           System.Taffybar.Context import           System.Taffybar.Information.Crypto hiding (symbol) import           System.Taffybar.Util-import           System.Taffybar.Widget.Generic.AutoSizeImage import           System.Taffybar.Widget.Generic.ChannelWidget+import           System.Taffybar.Widget.Generic.ScalingImage (scalingImage) import           System.Taffybar.WindowIcon import           Text.Printf @@ -61,10 +61,10 @@   hbox <- Gtk.boxNew Gtk.OrientationHorizontal 0    ctx <- ask-  let refresh =-        const $ flip runReaderT ctx $-        fromMaybe <$> pixBufFromColor 10 0 <*> getCryptoPixbuf symbol-  image <- autoSizeImageNew refresh Gtk.OrientationHorizontal+  let refresh size =+        Just <$> runReaderT+        (fromMaybe <$> pixBufFromColor size 0 <*> getCryptoPixbuf symbol) ctx+  (image, _) <- scalingImage refresh Gtk.OrientationHorizontal    Gtk.containerAdd hbox image   Gtk.containerAdd hbox label
+ src/System/Taffybar/Widget/DiskUsage.hs view
@@ -0,0 +1,152 @@+{-# LANGUAGE OverloadedStrings #-}+-----------------------------------------------------------------------------+-- |+-- Module      : System.Taffybar.Widget.DiskUsage+-- Copyright   : (c) Ivan A. Malison+-- License     : BSD3-style (see LICENSE)+--+-- Maintainer  : Ivan A. Malison+-- Stability   : unstable+-- Portability : unportable+--+-- A label widget that displays disk usage information, backed by a shared+-- polling thread from "System.Taffybar.Information.DiskUsage".+--+-- Template variables: @$total$@, @$used$@, @$free$@, @$available$@,+-- @$usedPercent$@, @$freePercent$@, @$path$@.+--+-- Size values are auto-formatted with appropriate units (GiB, TiB, etc.).+-----------------------------------------------------------------------------++module System.Taffybar.Widget.DiskUsage+  ( DiskUsageWidgetConfig(..)+  , defaultDiskUsageWidgetConfig+  , diskUsageIconNew+  , diskUsageIconNewWith+  , diskUsageLabelNew+  , diskUsageLabelNewWith+  , diskUsageNew+  , diskUsageNewWith+  ) where++import Control.Monad (void)+import Control.Monad.IO.Class+import Data.Default (Default(..))+import qualified Data.Text as T+import qualified GI.Gtk as Gtk+import System.Taffybar.Context (TaffyIO)+import System.Taffybar.Information.DiskUsage+import System.Taffybar.Util (postGUIASync)+import System.Taffybar.Widget.Generic.ChannelWidget+import System.Taffybar.Widget.Util (buildIconLabelBox)+import Text.Printf (printf)+import Text.StringTemplate++data DiskUsageWidgetConfig = DiskUsageWidgetConfig+  { diskUsagePath         :: FilePath+  -- ^ Filesystem path to monitor (default @\/@).+  , diskUsagePollInterval :: Double+  -- ^ Polling interval in seconds (default 60).+  , diskUsageFormat       :: String+  -- ^ Label format string (default @\"$free$\"@).+  , diskUsageTooltipFormat :: Maybe String+  -- ^ Optional tooltip format string.+  , diskUsageIcon :: T.Text+  -- ^ Nerd font icon character (default U+F0A0, ).+  }++defaultDiskUsageWidgetConfig :: DiskUsageWidgetConfig+defaultDiskUsageWidgetConfig = DiskUsageWidgetConfig+  { diskUsagePath         = "/"+  , diskUsagePollInterval = 60+  , diskUsageFormat       = "$free$"+  , diskUsageTooltipFormat =+      Just "$path$: $used$ / $total$ ($usedPercent$% used)"+  , diskUsageIcon = T.pack "\xF0A0" --+  }++instance Default DiskUsageWidgetConfig where+  def = defaultDiskUsageWidgetConfig++-- | Create a disk usage label with default settings (monitors @/@, 60s poll).+diskUsageLabelNew :: TaffyIO Gtk.Widget+diskUsageLabelNew = diskUsageLabelNewWith defaultDiskUsageWidgetConfig++-- | Create a disk usage label with the given configuration.+diskUsageLabelNewWith :: DiskUsageWidgetConfig -> TaffyIO Gtk.Widget+diskUsageLabelNewWith config = do+  let path     = diskUsagePath config+      interval = diskUsagePollInterval config+  chan        <- getDiskUsageInfoChan interval path+  initialInfo <- getDiskUsageInfoState interval path++  liftIO $ do+    label <- Gtk.labelNew Nothing++    let 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++-- | Create a disk usage icon widget with default configuration.+diskUsageIconNew :: TaffyIO Gtk.Widget+diskUsageIconNew = diskUsageIconNewWith defaultDiskUsageWidgetConfig++-- | Create a disk usage icon widget with the provided configuration.+diskUsageIconNewWith :: DiskUsageWidgetConfig -> TaffyIO Gtk.Widget+diskUsageIconNewWith config = liftIO $ do+  label <- Gtk.labelNew (Just (diskUsageIcon config))+  Gtk.widgetShowAll label+  Gtk.toWidget label++-- | Create a combined icon+label disk usage widget with default configuration.+diskUsageNew :: TaffyIO Gtk.Widget+diskUsageNew = diskUsageNewWith defaultDiskUsageWidgetConfig++-- | Create a combined icon+label disk usage widget.+diskUsageNewWith :: DiskUsageWidgetConfig -> TaffyIO Gtk.Widget+diskUsageNewWith config = do+  iconWidget <- diskUsageIconNewWith config+  labelWidget <- diskUsageLabelNewWith config+  liftIO $ buildIconLabelBox iconWidget labelWidget++-- --------------------------------------------------------------------------+-- Formatting++formatDiskUsage :: DiskUsageWidgetConfig -> DiskUsageInfo -> (T.Text, Maybe T.Text)+formatDiskUsage config info =+  let attrs = diskUsageAttrs (diskUsagePath config) info+      labelText   = renderTpl (diskUsageFormat config) attrs+      tooltipText = renderTpl <$> diskUsageTooltipFormat config <*> pure attrs+  in (labelText, tooltipText)++renderTpl :: String -> [(String, String)] -> T.Text+renderTpl template attrs =+  T.pack $ render $ setManyAttrib attrs (newSTMP template)++diskUsageAttrs :: FilePath -> DiskUsageInfo -> [(String, String)]+diskUsageAttrs path info =+  [ ("total",       formatBytes (diskInfoTotal info))+  , ("used",        formatBytes (diskInfoUsed info))+  , ("free",        formatBytes (diskInfoFree info))+  , ("available",   formatBytes (diskInfoAvailable info))+  , ("usedPercent", printf "%.0f" (diskInfoUsedPercent info))+  , ("freePercent", printf "%.0f" (diskInfoFreePercent info))+  , ("path",        path)+  ]++-- | Format a byte count with auto-scaled units.+formatBytes :: Integer -> String+formatBytes bytes+  | gb >= 1024 = printf "%.1f TiB" (gb / 1024 :: Double)+  | gb >= 1    = printf "%.1f GiB" gb+  | mb >= 1    = printf "%.0f MiB" mb+  | otherwise  = printf "%.0f KiB" kb+  where+    kb = fromIntegral bytes / 1024        :: Double+    mb = kb / 1024+    gb = mb / 1024
+ src/System/Taffybar/Widget/Generic/AutoFillImage.hs view
@@ -0,0 +1,217 @@+{-# LANGUAGE OverloadedStrings #-}+-- | A draw-based alternative to "System.Taffybar.Widget.Generic.AutoSizeImage"+-- that scales a pixbuf to fit its allocated area while preserving aspect ratio,+-- avoiding the resize feedback loops inherent in 'Gtk.Image'.+module System.Taffybar.Widget.Generic.AutoFillImage+  ( autoFillImage+  , autoFillImageNew+  , AutoFillCache(..)+  , fitPixbufToBox+  ) where++import qualified Control.Concurrent.MVar as MV+import           Control.Monad+import           Control.Monad.IO.Class+import           Data.Int+import qualified GI.Cairo.Render as C+import           GI.Cairo.Render.Connector+import qualified GI.Gdk as Gdk+import qualified GI.GdkPixbuf.Enums as GdkPixbuf+import           GI.GdkPixbuf.Objects.Pixbuf as Gdk+import qualified GI.Gtk as Gtk+import           System.Taffybar.Widget.Generic.AutoSizeImage+import           System.Taffybar.Widget.Util++data AutoFillCache = AutoFillCache+  { afRequestSize :: Int32+  , afScaleFactor :: Int32+  , afInsets :: BorderInfo+  , afContentWidth :: Int32+  , afContentHeight :: Int32+  , afSourcePixbuf :: Maybe Gdk.Pixbuf+  , afScaledPixbuf :: Maybe Gdk.Pixbuf+  , afOffsetX :: Double+  , afOffsetY :: Double+  }++fitPixbufToBox+  :: Int32 -- ^ scale factor+  -> BorderInfo+  -> Int32 -- ^ allocated width (logical px)+  -> Int32 -- ^ allocated height (logical px)+  -> Gdk.Pixbuf+  -> IO (Int32, Int32, Double, Double, Maybe Gdk.Pixbuf)+fitPixbufToBox scaleFactor insets allocW allocH pixbuf = do+  pbW' <- Gdk.getPixbufWidth pixbuf+  pbH' <- Gdk.getPixbufHeight pixbuf++  let contentW = max 1 $ allocW - fromIntegral (borderWidth insets)+      contentH = max 1 $ allocH - fromIntegral (borderHeight insets)++      targetWDev = max 1 $ contentW * scaleFactor+      targetHDev = max 1 $ contentH * scaleFactor++      pbW = fromIntegral pbW' :: Double+      pbH = fromIntegral pbH' :: Double+      targetW = fromIntegral targetWDev :: Double+      targetH = fromIntegral targetHDev :: Double++      scale =+        if pbW <= 0 || pbH <= 0+        then 1+        else min (targetW / pbW) (targetH / pbH)++      drawWDev = max 1 $ floor (pbW * scale)+      drawHDev = max 1 $ floor (pbH * scale)++      drawWLogical = fromIntegral drawWDev / fromIntegral scaleFactor+      drawHLogical = fromIntegral drawHDev / fromIntegral scaleFactor++      leftInset = fromIntegral (borderLeft insets) :: Double+      topInset = fromIntegral (borderTop insets) :: Double+      offsetX = leftInset + (fromIntegral contentW - drawWLogical) / 2+      offsetY = topInset + (fromIntegral contentH - drawHLogical) / 2++  scaledM <- Gdk.pixbufScaleSimple pixbuf drawWDev drawHDev GdkPixbuf.InterpTypeBilinear+  -- GDK can return NULL; treat that as "draw nothing".+  pure (contentW, contentH, offsetX, offsetY, scaledM)++-- | A draw-based alternative to 'autoSizeImage' that avoids resize loops and+-- naturally responds to CSS changes. The widget will always draw the current+-- pixbuf scaled to fit its allocated area (minus padding+border).+--+-- This uses a 'Gtk.DrawingArea' instead of 'Gtk.Image' because GTK3 does not+-- support "scale-to-allocation" semantics for 'Gtk.Image'.+autoFillImage+  :: MonadIO m+  => Gtk.DrawingArea+  -> (Int32 -> IO (Maybe Gdk.Pixbuf))+  -> Gtk.Orientation+  -> m (IO ())+autoFillImage drawArea getPixbuf orientation = liftIO $ do+  case orientation of+    Gtk.OrientationHorizontal -> Gtk.widgetSetVexpand drawArea True+    _ -> Gtk.widgetSetHexpand drawArea True++  -- Keep existing styling working.+  void $ widgetSetClassGI drawArea "auto-size-image"+  void $ widgetSetClassGI drawArea "auto-fill-image"++  -- Ensure the widget has a non-zero natural size even before the first+  -- allocation.+  Gtk.widgetSetSizeRequest drawArea 16 16++  -- Cache is only accessed from the GTK main loop via signal handlers.+  cacheVar <- MV.newMVar AutoFillCache+    { afRequestSize = 0+    , afScaleFactor = 1+    , afInsets = borderInfoZero+    , afContentWidth = 1+    , afContentHeight = 1+    , afSourcePixbuf = Nothing+    , afScaledPixbuf = Nothing+    , afOffsetX = 0+    , afOffsetY = 0+    }++  let+    recompute force = do+      allocation <- Gtk.widgetGetAllocation drawArea+      allocW <- Gdk.getRectangleWidth allocation+      allocH <- Gdk.getRectangleHeight allocation++      -- CSS can change dynamically (taffybar supports live CSS reload), so we+      -- recompute insets every time we recompute sizing.+      insets <- getInsetInfo drawArea+      scaleFactor <- Gtk.widgetGetScaleFactor drawArea++      let contentW = max 1 $ allocW - fromIntegral (borderWidth insets)+          contentH = max 1 $ allocH - fromIntegral (borderHeight insets)+          requestSize =+            case orientation of+              Gtk.OrientationHorizontal -> contentH+              _ -> contentW++      -- Update the widget's natural size so it won't collapse to 0 when packed+      -- without expand.+      Gtk.widgetSetSizeRequest drawArea+        (fromIntegral requestSize + fromIntegral (borderWidth insets))+        (fromIntegral requestSize + fromIntegral (borderHeight insets))++      old <- MV.readMVar cacheVar+      srcFresh <-+        if force || requestSize /= afRequestSize old+        then getPixbuf requestSize+        else pure Nothing++      -- If the getter fails transiently, keep drawing the last known pixbuf.+      let src =+            case srcFresh of+              Just pb -> Just pb+              Nothing -> afSourcePixbuf old++      let needsRefit =+            force+            || requestSize /= afRequestSize old+            || scaleFactor /= afScaleFactor old+            || insets /= afInsets old+            || contentW /= afContentWidth old+            || contentH /= afContentHeight old++      when needsRefit $ do+        newCache <-+          case src of+            Nothing -> pure old+              { afRequestSize = requestSize+              , afScaleFactor = scaleFactor+              , afInsets = insets+              , afContentWidth = contentW+              , afContentHeight = contentH+              , afSourcePixbuf = Nothing+              , afScaledPixbuf = Nothing+              , afOffsetX = 0+              , afOffsetY = 0+              }+            Just pb -> do+              (cw, ch, ox, oy, scaledM) <-+                fitPixbufToBox (max 1 scaleFactor) insets allocW allocH pb+              pure old+                { afRequestSize = requestSize+                , afScaleFactor = max 1 scaleFactor+                , afInsets = insets+                , afContentWidth = cw+                , afContentHeight = ch+                , afSourcePixbuf = Just pb+                , afScaledPixbuf = scaledM+                , afOffsetX = ox+                , afOffsetY = oy+                }++        void $ MV.swapMVar cacheVar newCache+        Gtk.widgetQueueDraw drawArea++  -- Redraw when GTK allocates or when style changes.+  void $ Gtk.onWidgetSizeAllocate drawArea $ \_ -> recompute False+  void $ Gtk.onWidgetStyleUpdated drawArea $ recompute True++  void $ Gtk.onWidgetDraw drawArea $ \ctx -> do+    st <- MV.readMVar cacheVar+    case afScaledPixbuf st of+      Nothing -> pure True+      Just pb -> do+        Gdk.cairoSetSourcePixbuf ctx pb (afOffsetX st) (afOffsetY st)+        renderWithContext C.paint ctx+        pure True++  pure $ recompute True++-- | Convenience constructor for 'autoFillImage'.+autoFillImageNew+  :: MonadIO m+  => (Int32 -> IO (Maybe Gdk.Pixbuf))+  -> Gtk.Orientation+  -> m Gtk.DrawingArea+autoFillImageNew getPixBuf orientation = do+  drawArea <- Gtk.drawingAreaNew+  void $ autoFillImage drawArea getPixBuf orientation+  pure drawArea
src/System/Taffybar/Widget/Generic/AutoSizeImage.hs view
@@ -1,9 +1,22 @@ {-# LANGUAGE OverloadedStrings #-}-module System.Taffybar.Widget.Generic.AutoSizeImage where+module System.Taffybar.Widget.Generic.AutoSizeImage+  ( autoSizeImage+  , autoSizeImageNew+  , imageMenuItemNew+  , ImageScaleStrategy(..)+  , BorderInfo(..)+  , borderInfoZero+  , borderWidth+  , borderHeight+  , getBorderInfo+  , getInsetInfo+  , getContentAllocation+  ) where  import qualified Control.Concurrent.MVar as MV import           Control.Monad import           Control.Monad.IO.Class+import           Data.Default (Default(..)) import           Data.Int import           Data.Maybe import qualified Data.Text as T@@ -16,6 +29,15 @@ import           System.Taffybar.Widget.Util import           Text.Printf +-- | Strategy for how auto-scaling image widgets render their pixbufs.+data ImageScaleStrategy+  = ImageResize  -- ^ Use 'Gtk.Image' with 'imageSetFromPixbuf' + 'queueResize' (original behavior).+  | ImageDraw    -- ^ Use 'Gtk.DrawingArea' with Cairo rendering (avoids resize feedback loops).+  deriving (Eq, Show)++instance Default ImageScaleStrategy where+  def = ImageDraw+ imageLog :: Priority -> String -> IO () imageLog = logM "System.Taffybar.Widget.Generic.AutoSizeImage" @@ -26,6 +48,14 @@   , Gtk.styleContextGetBorder   ] +-- Insets that are inside a widget's allocation and should be respected when+-- drawing inside it.+insetFunctions :: [Gtk.StyleContext -> [Gtk.StateFlags] -> IO Gtk.Border]+insetFunctions =+  [ Gtk.styleContextGetPadding+  , Gtk.styleContextGetBorder+  ]+ data BorderInfo = BorderInfo   { borderTop :: Int16   , borderBottom :: Int16@@ -67,6 +97,19 @@         addBorderInfo lastSum <$> getBorderInfoFor fn    foldM combineBorderInfo borderInfoZero borderFunctions++-- | Get the size of the padding+border drawn inside a widget's allocation.+getInsetInfo :: (MonadIO m, Gtk.IsWidget a) => a -> m BorderInfo+getInsetInfo widget = liftIO $ do+  stateFlags <- Gtk.widgetGetStateFlags widget+  styleContext <- Gtk.widgetGetStyleContext widget++  let getBorderInfoFor borderFn =+        borderFn styleContext stateFlags >>= toBorderInfo+      combineBorderInfo lastSum fn =+        addBorderInfo lastSum <$> getBorderInfoFor fn++  foldM combineBorderInfo borderInfoZero insetFunctions  -- | Get the actual allocation for a "Gtk.Widget", accounting for the size of -- its CSS assined margin, border and padding values.
+ src/System/Taffybar/Widget/Generic/ScalingImage.hs view
@@ -0,0 +1,74 @@+-- | Unified interface for auto-scaling image widgets.+--+-- This module dispatches between the two image scaling implementations+-- ('autoSizeImage' and 'autoFillImage') based on an 'ImageScaleStrategy'.+-- All call sites should use 'scalingImage' (TaffyIO) or 'scalingImageNew'+-- (plain IO with an explicit strategy) instead of calling the underlying+-- implementations directly.+module System.Taffybar.Widget.Generic.ScalingImage+  ( scalingImageNew+  , scalingImage+  , getScalingImageStrategy+  , setScalingImageStrategy+  ) where++import           Control.Monad+import           Control.Monad.IO.Class+import           Data.Int+import           Data.Typeable+import qualified GI.GdkPixbuf.Objects.Pixbuf as Gdk+import qualified GI.Gtk as Gtk+import           StatusNotifier.Tray (scalePixbufToSize)+import           System.Taffybar.Context+import           System.Taffybar.Widget.Generic.AutoFillImage (autoFillImage)+import           System.Taffybar.Widget.Generic.AutoSizeImage+  ( ImageScaleStrategy(..)+  , autoSizeImage+  )++newtype ScalingImageStrategySetting =+  ScalingImageStrategySetting ImageScaleStrategy+  deriving Typeable++-- | Create a scaling image widget using the given strategy.+--+-- Returns a @(widget, refreshAction)@ pair. The widget is a generic+-- 'Gtk.Widget' regardless of which strategy is used.+scalingImageNew+  :: ImageScaleStrategy+  -> (Int32 -> IO (Maybe Gdk.Pixbuf))+  -> Gtk.Orientation+  -> IO (Gtk.Widget, IO ())+scalingImageNew ImageResize getPixbuf orientation = do+  image <- Gtk.imageNew+  let scaledGetter size =+        getPixbuf size >>= traverse (scalePixbufToSize size orientation)+  refresh <- autoSizeImage image scaledGetter orientation+  widget <- Gtk.toWidget image+  return (widget, refresh)+scalingImageNew ImageDraw getPixbuf orientation = do+  drawArea <- Gtk.drawingAreaNew+  refresh <- autoFillImage drawArea getPixbuf orientation+  widget <- Gtk.toWidget drawArea+  return (widget, refresh)++-- | TaffyIO variant that reads the strategy from context state.+scalingImage+  :: (Int32 -> IO (Maybe Gdk.Pixbuf))+  -> Gtk.Orientation+  -> TaffyIO (Gtk.Widget, IO ())+scalingImage getPixbuf orientation = do+  strategy <- getScalingImageStrategy+  liftIO $ scalingImageNew strategy getPixbuf orientation++-- | Read the current global image scale strategy (defaults to 'ImageDraw').+getScalingImageStrategy :: TaffyIO ImageScaleStrategy+getScalingImageStrategy = do+  ScalingImageStrategySetting s <-+    getStateDefault $ return $ ScalingImageStrategySetting ImageDraw+  return s++-- | Set the global image scale strategy in context state.+setScalingImageStrategy :: ImageScaleStrategy -> TaffyIO ()+setScalingImageStrategy strategy =+  void $ setState $ ScalingImageStrategySetting strategy
+ src/System/Taffybar/Widget/HyprlandLayout.hs view
@@ -0,0 +1,144 @@+{-# LANGUAGE OverloadedStrings #-}++-----------------------------------------------------------------------------+-- |+-- Module      : System.Taffybar.Widget.HyprlandLayout+-- Copyright   : (c) Ivan A. Malison+-- License     : BSD3-style (see LICENSE)+--+-- Maintainer  : Ivan A. Malison <IvanMalison@gmail.com>+-- Stability   : unstable+-- Portability : unportable+--+-- Simple text widget that shows the Hyprland layout used in the currently+-- active workspace.+-----------------------------------------------------------------------------++module System.Taffybar.Widget.HyprlandLayout+  ( HyprlandLayoutConfig(..)+  , defaultHyprlandLayoutConfig+  , hyprlandLayoutNew+  ) where++import           Control.Applicative ((<|>))+import           Control.Concurrent (killThread)+import           Control.Monad (void)+import           Control.Monad.Trans.Class+import           Control.Monad.Trans.Reader+import           Data.Aeson (FromJSON(..), withObject, (.:?))+import           Data.Default (Default(..))+import           Data.Maybe (fromMaybe)+import           Data.Text (Text)+import qualified Data.Text as T+import           GI.Gdk+import qualified GI.Gtk as Gtk+import           System.Log.Logger (Priority(..))+import           System.Taffybar.Context+import           System.Taffybar.Hyprland+  ( runHyprlandCommandJsonT+  , runHyprlandCommandRawT+  )+import qualified System.Taffybar.Information.Hyprland as Hypr+import           System.Taffybar.Util+import           System.Taffybar.Widget.Util++data HyprlandLayoutConfig = HyprlandLayoutConfig+  { formatLayout :: T.Text -> TaffyIO T.Text+  , updateIntervalSeconds :: Double+  , onLeftClick :: Maybe [String]+  , onRightClick :: Maybe [String]+  }++instance Default HyprlandLayoutConfig where+  def = defaultHyprlandLayoutConfig++defaultHyprlandLayoutConfig :: HyprlandLayoutConfig+defaultHyprlandLayoutConfig =+  HyprlandLayoutConfig+  { formatLayout = return+  , updateIntervalSeconds = 1+  , onLeftClick = Nothing+  , onRightClick = Nothing+  }++-- | Create a new Hyprland Layout widget.+hyprlandLayoutNew :: HyprlandLayoutConfig -> TaffyIO Gtk.Widget+hyprlandLayoutNew config = do+  ctx <- ask+  label <- lift $ Gtk.labelNew (Nothing :: Maybe T.Text)+  _ <- widgetSetClassGI label "layout-label"++  let refresh = do+        layoutText <- getHyprlandLayoutText+        markup <- formatLayout config layoutText+        lift $ postGUIASync $ Gtk.labelSetMarkup label markup++  void refresh+  threadId <- lift $ foreverWithDelay (updateIntervalSeconds config) $+    void $ runReaderT refresh ctx++  ebox <- lift Gtk.eventBoxNew+  lift $ Gtk.containerAdd ebox label+  _ <- lift $ Gtk.onWidgetButtonPressEvent ebox $ dispatchButtonEvent ctx config+  _ <- lift $ Gtk.onWidgetUnrealize ebox $ killThread threadId+  lift $ Gtk.widgetShowAll ebox+  Gtk.toWidget ebox++-- | Call the configured dispatch action depending on click.+dispatchButtonEvent :: Context -> HyprlandLayoutConfig -> EventButton -> IO Bool+dispatchButtonEvent context config btn = do+  pressType <- getEventButtonType btn+  buttonNumber <- getEventButtonButton btn+  case pressType of+    EventTypeButtonPress ->+      case buttonNumber of+        1 -> runReaderT (dispatchMaybe $ onLeftClick config) context >> return True+        3 -> runReaderT (dispatchMaybe $ onRightClick config) context >> return True+        _ -> return False+    _ -> return False++-- | Dispatch a Hyprland command if provided.+dispatchMaybe :: Maybe [String] -> TaffyIO ()+dispatchMaybe maybeArgs =+  case maybeArgs of+    Nothing -> return ()+    Just args -> do+      result <- runHyprlandCommandRawT (Hypr.hyprCommand ("dispatch" : args))+      case result of+        Left err ->+          logPrintF "System.Taffybar.Widget.HyprlandLayout" WARNING+            "Failed to dispatch Hyprland command: %s" (show err)+        Right _ -> return ()++-- Hyprland JSON helpers++newtype HyprlandActiveWorkspace = HyprlandActiveWorkspace+  { hawLayout :: Maybe Text+  } deriving (Show, Eq)++instance FromJSON HyprlandActiveWorkspace where+  parseJSON = withObject "HyprlandActiveWorkspace" $ \v -> do+    layout <- v .:? "layout" <|> v .:? "layoutName" <|> v .:? "layoutname"+    return $ HyprlandActiveWorkspace layout++getHyprlandLayoutText :: TaffyIO T.Text+getHyprlandLayoutText = do+  result <- runHyprctlJson ["-j", "activeworkspace"]+  case result of+    Left err ->+      logPrintF "System.Taffybar.Widget.HyprlandLayout" WARNING+        "hyprctl activeworkspace failed: %s" err >>+      return ""+    Right (HyprlandActiveWorkspace layout) ->+      return $ fromMaybe "" layout++runHyprctlJson :: FromJSON a => [String] -> TaffyIO (Either String a)+runHyprctlJson args = do+  let args' =+        case args of+          ("-j":rest) -> rest+          _ -> args+  result <- runHyprlandCommandJsonT (Hypr.hyprCommandJson args')+  pure $ case result of+    Left err -> Left (show err)+    Right out -> Right out
+ src/System/Taffybar/Widget/HyprlandWindows.hs view
@@ -0,0 +1,175 @@+{-# LANGUAGE OverloadedStrings #-}++-----------------------------------------------------------------------------+-- |+-- Module      : System.Taffybar.Widget.HyprlandWindows+-- Copyright   : (c) Ivan A. Malison+-- License     : BSD3-style (see LICENSE)+--+-- Maintainer  : Ivan A. Malison+-- Stability   : unstable+-- Portability : unportable+--+-- Menu widget that shows the title of the currently focused Hyprland window+-- and that, when clicked, displays a menu from which the user may select a+-- window to which to switch focus.+-----------------------------------------------------------------------------++module System.Taffybar.Widget.HyprlandWindows where++import           Control.Concurrent (killThread)+import           Control.Monad (forM_, void)+import           Control.Monad.Trans.Class+import           Control.Monad.Trans.Reader+import           Control.Monad.Trans.Maybe+import           Data.Default (Default(..))+import           Data.List (find)+import qualified Data.Text as T+import qualified GI.Gtk as Gtk+import           System.Log.Logger (Priority(..))+import           System.Taffybar.Context+import           System.Taffybar.Hyprland (runHyprlandCommandRawT)+import qualified System.Taffybar.Information.Hyprland as Hypr+import           System.Taffybar.Util+import           System.Taffybar.Widget.Generic.DynamicMenu+import           System.Taffybar.Widget.Generic.ScalingImage (scalingImage)+import           System.Taffybar.Widget.Util+import           System.Taffybar.Widget.HyprlandWorkspaces+  ( HyprlandWindow(..)+  , HyprlandWindowIconPixbufGetter+  , HyprlandClient+  , defaultHyprlandGetWindowIconPixbuf+  , getActiveWindowAddress+  , runHyprctlJson+  , windowFromClient+  )++-- | Window menu widget configuration for Hyprland.+data HyprlandWindowsConfig = HyprlandWindowsConfig+  { getMenuLabel :: HyprlandWindow -> TaffyIO T.Text+  -- ^ A monadic function used to build labels for windows in the menu.+  , getActiveLabel :: Maybe HyprlandWindow -> TaffyIO T.Text+  -- ^ Action to build the label text for the active window.+  , getActiveWindowIconPixbuf :: Maybe HyprlandWindowIconPixbufGetter+  -- ^ Optional function to retrieve a pixbuf to show next to the window label.+  , updateIntervalSeconds :: Double+  }++truncatedGetMenuLabel :: Int -> HyprlandWindow -> TaffyIO T.Text+truncatedGetMenuLabel maxLength window =+  return $ truncateText maxLength (T.pack $ windowTitle window)++defaultGetMenuLabel :: HyprlandWindow -> TaffyIO T.Text+defaultGetMenuLabel = truncatedGetMenuLabel 35++defaultGetActiveLabel :: Maybe HyprlandWindow -> TaffyIO T.Text+defaultGetActiveLabel = maybe (return "") defaultGetMenuLabel++defaultHyprlandWindowsConfig :: HyprlandWindowsConfig+defaultHyprlandWindowsConfig =+  HyprlandWindowsConfig+  { getMenuLabel = defaultGetMenuLabel+  , getActiveLabel = defaultGetActiveLabel+  , getActiveWindowIconPixbuf = Just defaultHyprlandGetWindowIconPixbuf+  , updateIntervalSeconds = 1+  }++instance Default HyprlandWindowsConfig where+  def = defaultHyprlandWindowsConfig++-- | Create a new Hyprland Windows widget.+hyprlandWindowsNew :: HyprlandWindowsConfig -> TaffyIO Gtk.Widget+hyprlandWindowsNew config = do+  hbox <- lift $ Gtk.boxNew Gtk.OrientationHorizontal 0++  refreshIcon <- case getActiveWindowIconPixbuf config of+    Just getIcon -> do+      (rf, icon) <- buildWindowsIcon getIcon+      Gtk.boxPackStart hbox icon True True 0+      pure rf+    Nothing -> pure (pure ())++  (setLabelTitle, label) <- buildWindowsLabel+  Gtk.boxPackStart hbox label True True 0+  let refreshLabel = do+        activeWindow <- getActiveHyprlandWindow+        labelText <- getActiveLabel config activeWindow+        lift $ setLabelTitle labelText++  let refresh = refreshLabel >> lift refreshIcon+  ctx <- ask+  void refresh+  threadId <- lift $ foreverWithDelay (updateIntervalSeconds config) $+    void $ runReaderT refresh ctx++  _ <- lift $ Gtk.onWidgetUnrealize hbox $ killThread threadId++  Gtk.widgetShowAll hbox+  boxWidget <- Gtk.toWidget hbox++  runTaffy <- asks (flip runReaderT)+  menu <- dynamicMenuNew+    DynamicMenuConfig { dmClickWidget = boxWidget+                      , dmPopulateMenu = runTaffy . fillMenu config+                      }++  widgetSetClassGI menu "windows"++buildWindowsLabel :: TaffyIO (T.Text -> IO (), Gtk.Widget)+buildWindowsLabel = do+  label <- lift $ Gtk.labelNew Nothing+  let setLabelTitle title = postGUIASync $ Gtk.labelSetMarkup label title+  (setLabelTitle,) <$> Gtk.toWidget label++buildWindowsIcon :: HyprlandWindowIconPixbufGetter -> TaffyIO (IO (), Gtk.Widget)+buildWindowsIcon windowIconPixbufGetter = do+  runTaffy <- asks (flip runReaderT)+  let getActiveWindowPixbuf size = runTaffy . runMaybeT $ do+        wd <- MaybeT getActiveHyprlandWindow+        MaybeT $ windowIconPixbufGetter size wd++  (imageWidget, updateImage) <- scalingImage getActiveWindowPixbuf Gtk.OrientationHorizontal+  return (postGUIASync updateImage, imageWidget)++getActiveHyprlandWindow :: TaffyIO (Maybe HyprlandWindow)+getActiveHyprlandWindow = find windowActive <$> getHyprlandWindows++getHyprlandWindows :: TaffyIO [HyprlandWindow]+getHyprlandWindows = do+  activeAddr <- getActiveWindowAddress+  clientsResult <- runHyprctlJson ["-j", "clients"]+  case clientsResult of+    Left err ->+      logPrintF "System.Taffybar.Widget.HyprlandWindows" WARNING+        "hyprctl clients failed: %s" err >>+      return []+    Right clients ->+      return $ map (windowFromClient activeAddr) (clients :: [HyprlandClient])++fillMenu :: Gtk.IsMenuShell a => HyprlandWindowsConfig -> a -> ReaderT Context IO ()+fillMenu config menu = ask >>= \context -> do+  windowIds <- getHyprlandWindows+  forM_ windowIds $ \windowData ->+    lift $ do+      labelText <- runReaderT (getMenuLabel config windowData) context+      let focusCallback = runReaderT (focusHyprlandWindow windowData) context >>+                          return True+      item <- Gtk.menuItemNewWithLabel labelText+      _ <- Gtk.onWidgetButtonPressEvent item $ const focusCallback+      Gtk.menuShellAppend menu item+      Gtk.widgetShow item++focusHyprlandWindow :: HyprlandWindow -> TaffyIO ()+focusHyprlandWindow windowData = do+  result <-+    runHyprlandCommandRawT $+      Hypr.hyprCommand+        [ "dispatch"+        , "focuswindow"+        , "address:" <> T.unpack (windowAddress windowData)+        ]+  case result of+    Left err ->+      logPrintF "System.Taffybar.Widget.HyprlandWindows" WARNING+        "Failed to focus window: %s" (show err)+    Right _ -> return ()
+ src/System/Taffybar/Widget/HyprlandWorkspaces.hs view
@@ -0,0 +1,880 @@+{-# LANGUAGE ExistentialQuantification #-}+{-# LANGUAGE OverloadedStrings #-}++-----------------------------------------------------------------------------+-- |+-- Module      : System.Taffybar.Widget.HyprlandWorkspaces+-- Copyright   : (c) Ivan A. Malison+-- License     : BSD3-style (see LICENSE)+--+-- Maintainer  : Ivan A. Malison+-- Stability   : unstable+-- Portability : unportable+--+-- Hyprland workspaces widget backed by hyprctl.+-----------------------------------------------------------------------------++module System.Taffybar.Widget.HyprlandWorkspaces where++import           Control.Applicative ((<|>))+import           Control.Concurrent (forkIO, killThread)+import           Control.Concurrent.STM.TChan (TChan, readTChan)+import           Control.Monad (foldM, forM_, when)+import           Control.Monad.IO.Class (MonadIO(liftIO))+import           Control.Monad.STM (atomically)+import           Control.Monad.Trans.Reader (ReaderT, ask, runReaderT)+import           Data.Aeson (FromJSON(..), withObject, (.:), (.:?), (.!=))+import           Data.Char (toLower)+import qualified Data.ByteString as BS+import           Data.Default (Default(..))+import qualified Data.Foldable as F+import           Data.Int (Int32)+import           Data.List (intercalate, sortOn, stripPrefix)+import           Data.Maybe (fromMaybe, listToMaybe, mapMaybe)+import qualified Data.Map.Strict as M+import qualified Data.MultiMap as MM+import           Data.IORef (IORef, newIORef, readIORef, writeIORef)+import           Data.Text (Text)+import qualified Data.Text as T+import           System.Log.Logger (Priority(..), logM)+import           Text.Printf (printf)++import qualified GI.GdkPixbuf.Objects.Pixbuf as Gdk+import qualified GI.Gtk as Gtk++import           System.Environment.XDG.DesktopEntry+  ( DesktopEntry+  , deFilename+  , getDirectoryEntriesDefault+  )+import           System.Taffybar.Context+import           System.Taffybar.Hyprland+  ( getHyprlandEventChan+  , runHyprlandCommandJsonT+  , runHyprlandCommandRawT+  )+import qualified System.Taffybar.Information.Hyprland as Hypr+import           System.Taffybar.Util+import           System.Taffybar.Widget.Util+  ( WindowIconWidget(..)+  , computeIconStripLayout+  , getImageForDesktopEntry+  , handlePixbufGetterException+  , scaledPixbufGetter+  , syncWidgetPool+  , updateWindowIconWidgetState+  , widgetSetClassGI+  , windowStatusClassFromFlags+  )+import           System.Taffybar.Widget.Generic.ScalingImage (getScalingImageStrategy)+import           System.Taffybar.Widget.Workspaces.Shared+  ( WorkspaceState(..)+  , setWorkspaceWidgetStatusClass+  , buildWorkspaceIconLabelOverlay+  , mkWorkspaceIconWidget+  )+import           System.Taffybar.WindowIcon (getWindowIconFromClasses, pixBufFromColor)++stripSuffix :: Eq a => [a] -> [a] -> Maybe [a]+stripSuffix suffix value =+  reverse <$> stripPrefix (reverse suffix) (reverse value)++isSpecialHyprWorkspace :: HyprlandWorkspace -> Bool+isSpecialHyprWorkspace ws =+  let name = T.toLower $ T.pack $ workspaceName ws+  in T.isPrefixOf "special" name || workspaceIdx ws < 0++data HyprlandWindow = HyprlandWindow+  { windowAddress :: Text+  , windowTitle :: String+  , windowClass :: Maybe String+  , windowInitialClass :: Maybe String+  -- | The top-left position (x, y) of the window, as reported by+  -- @hyprctl clients -j@. This is used for optional icon ordering.+  , windowAt :: Maybe (Int, Int)+  , windowUrgent :: Bool+  , windowActive :: Bool+  , windowMinimized :: Bool+  } deriving (Show, Eq)++data HyprlandWorkspace = HyprlandWorkspace+  { workspaceIdx :: Int+  , workspaceName :: String+  , workspaceState :: WorkspaceState+  , windows :: [HyprlandWindow]+  } deriving (Show, Eq)++newtype HyprlandWorkspaceCache = HyprlandWorkspaceCache [HyprlandWorkspace]++newtype HyprlandWorkspaceWidgetCache+  = HyprlandWorkspaceWidgetCache (M.Map Int HyprlandWorkspaceEntry)++newtype HyprlandWorkspaceOrderCache+  = HyprlandWorkspaceOrderCache [Int]++data HyprlandWorkspaceEntry = HyprlandWorkspaceEntry+  { hweWrapper :: Gtk.Widget+  , hweController :: HyprlandWWC+  , hweLast :: HyprlandWorkspace+  }++type HyprlandIconWidget = WindowIconWidget HyprlandWindow++-- | Controller typeclass for Hyprland workspace widgets, mirroring+-- the X11 'WorkspaceWidgetController' pattern.+class HyprlandWorkspaceWidgetController wc where+  hwcGetWidget :: wc -> IO Gtk.Widget+  hwcUpdateWidget :: wc -> HyprlandWorkspace -> TaffyIO wc++-- | Existential wrapper for Hyprland workspace controllers.+data HyprlandWWC = forall a. HyprlandWorkspaceWidgetController a => HyprlandWWC a++instance HyprlandWorkspaceWidgetController HyprlandWWC where+  hwcGetWidget (HyprlandWWC wc) = hwcGetWidget wc+  hwcUpdateWidget (HyprlandWWC wc) ws = HyprlandWWC <$> hwcUpdateWidget wc ws++type HyprlandControllerConstructor = HyprlandWorkspace -> TaffyIO HyprlandWWC+type HyprlandParentControllerConstructor =+  HyprlandControllerConstructor -> HyprlandControllerConstructor++type HyprlandWindowIconPixbufGetter =+  Int32 -> HyprlandWindow -> TaffyIO (Maybe Gdk.Pixbuf)++data HyprlandWorkspacesConfig =+  HyprlandWorkspacesConfig+  { getWorkspaces :: TaffyIO [HyprlandWorkspace]+  , switchToWorkspace :: HyprlandWorkspace -> TaffyIO ()+  , updateIntervalSeconds :: Double+  , widgetBuilder :: HyprlandControllerConstructor+  , widgetGap :: Int+  , maxIcons :: Maybe Int+  , minIcons :: Int+  , iconSize :: Int32+  , getWindowIconPixbuf :: HyprlandWindowIconPixbufGetter+  , labelSetter :: HyprlandWorkspace -> TaffyIO String+  , showWorkspaceFn :: HyprlandWorkspace -> Bool+  , iconSort :: [HyprlandWindow] -> TaffyIO [HyprlandWindow]+  , urgentWorkspaceState :: Bool+  }++defaultHyprlandWorkspacesConfig :: HyprlandWorkspacesConfig+defaultHyprlandWorkspacesConfig = cfg+  where+    cfg = HyprlandWorkspacesConfig+      { getWorkspaces = getHyprlandWorkspaces+      , switchToWorkspace = hyprlandSwitchToWorkspace+      , updateIntervalSeconds = 1+      , widgetBuilder = defaultHyprlandWidgetBuilder cfg+      , widgetGap = 0+      , maxIcons = Nothing+      , minIcons = 0+      , iconSize = 16+      , getWindowIconPixbuf = defaultHyprlandGetWindowIconPixbuf+      , labelSetter = return . workspaceName+      , showWorkspaceFn = \ws ->+          workspaceState ws /= Empty && not (isSpecialHyprWorkspace ws)+      -- Match the X11 Workspaces widget default: order icons by window position.+      , iconSort = pure . sortHyprlandWindowsByPosition+      , urgentWorkspaceState = False+      }++instance Default HyprlandWorkspacesConfig where+  def = defaultHyprlandWorkspacesConfig++hyprlandWorkspacesNew :: HyprlandWorkspacesConfig -> TaffyIO Gtk.Widget+hyprlandWorkspacesNew cfg = do+  cont <- liftIO $ Gtk.boxNew Gtk.OrientationHorizontal $+          fromIntegral (widgetGap cfg)+  _ <- widgetSetClassGI cont "workspaces"+  ctx <- ask+  let refresh = runReaderT (refreshWorkspaces cfg cont) ctx+  liftIO refresh+  -- Ensure this top-level container is visible when packed into the bar.+  -- Otherwise the start widget area can appear blank under Wayland/Hyprland.+  liftIO $ Gtk.widgetShowAll cont+  eventChan <- getHyprlandEventChan+  events <- liftIO $ Hypr.subscribeHyprlandEvents eventChan+  tid <- liftIO $ forkIO $ hyprlandUpdateLoop refresh events+  _ <- liftIO $ Gtk.onWidgetUnrealize cont $ killThread tid+  Gtk.toWidget cont++hyprlandUpdateLoop :: IO () -> TChan T.Text -> IO ()+hyprlandUpdateLoop refresh events = do+  line <- atomically $ readTChan events+  when (isRelevantHyprEvent (T.unpack line)) refresh+  hyprlandUpdateLoop refresh events++isRelevantHyprEvent :: String -> Bool+isRelevantHyprEvent line =+  let eventName = takeWhile (/= '>') line+  in eventName `elem`+     [ "workspace"+     , "workspacev2"+     , "focusedmon"+     , "activewindow"+     , "activewindowv2"+     , "openwindow"+     , "closewindow"+     , "movewindow"+     , "movewindowv2"+     , "moveworkspace"+     , "renameworkspace"+     , "createworkspace"+     , "destroyworkspace"+     , "monitoradded"+     , "monitorremoved"+     -- Synthetic "event" emitted by our event reader thread whenever it+     -- (re)connects to Hyprland. This lets us refresh after a compositor+     -- restart without polling.+     , "taffybar-hyprland-connected"+     ]++refreshWorkspaces :: HyprlandWorkspacesConfig -> Gtk.Box -> ReaderT Context IO ()+refreshWorkspaces cfg cont = do+  ws <- getWorkspaces cfg+  HyprlandWorkspaceCache prev <- getStateDefault $ return (HyprlandWorkspaceCache [])+  -- Detect whether the cached widgets have been orphaned (e.g. the bar window+  -- was destroyed and recreated after a compositor reload).  When the old GTK+  -- objects are gone we must re-render even if the workspace data is unchanged.+  HyprlandWorkspaceWidgetCache wc <-+    getStateDefault $ return (HyprlandWorkspaceWidgetCache M.empty)+  widgetsStale <- case M.elems wc of+    [] -> return False+    (first:_) -> liftIO $ not <$> Gtk.widgetGetRealized (hweWrapper first)+  let ignoreEmptyResult = null ws && not (null prev)+  when ignoreEmptyResult $+    liftIO $ wLog WARNING $+      printf+        "Hyprland workspaces refresh returned empty list; retaining previous state (prevTotal=%d)."+        (length prev)+  let needsRender = (ws /= prev || widgetsStale) && not ignoreEmptyResult+  when needsRender $ do+    liftIO $ wLog DEBUG $+      printf "Hyprland workspaces refresh: total=%d shown=%d (minIcons=%d maxIcons=%s) widgetsStale=%s %s"+        (length ws)+        (length (filter (showWorkspaceFn cfg) ws))+        (minIcons cfg)+        (show (maxIcons cfg))+        (show widgetsStale)+        (summarizeWorkspaces ws)+    _ <- setState (HyprlandWorkspaceCache ws)+    ctx <- ask+    liftIO $ postGUIASync $ runReaderT (renderWorkspaces cfg cont ws) ctx++renderWorkspaces ::+  HyprlandWorkspacesConfig -> Gtk.Box -> [HyprlandWorkspace] -> ReaderT Context IO ()+renderWorkspaces cfg cont workspaces = do+  let workspaces' = map (applyUrgentState cfg) workspaces+  HyprlandWorkspaceWidgetCache widgetCache <-+    getStateDefault $ return (HyprlandWorkspaceWidgetCache M.empty)+  HyprlandWorkspaceOrderCache prevOrder <-+    getStateDefault $ return (HyprlandWorkspaceOrderCache [])+  -- If any cached widget has been unrealized (e.g. because the bar window was+  -- recreated after a compositor reload), the old GTK objects are dead and must+  -- be discarded so that fresh widgets are built for the new container.+  stale <- case M.elems widgetCache of+    [] -> return False+    (first:_) -> liftIO $ not <$> Gtk.widgetGetRealized (hweWrapper first)+  let oldCache = if stale then M.empty else widgetCache+      oldOrder = if stale then [] else prevOrder+  when stale $+    liftIO $ wLog DEBUG "renderWorkspaces: discarding stale widget cache (widgets unrealized)"+  let buildOrUpdate newCache ws = do+        let idx = workspaceIdx ws+        entry <- case M.lookup idx oldCache of+          Just prevEntry+            | hweLast prevEntry == ws -> return prevEntry+            | otherwise -> do+                newCtrl <- hwcUpdateWidget (hweController prevEntry) ws+                return prevEntry { hweController = newCtrl, hweLast = ws }+          Nothing -> do+            ctrl <- widgetBuilder cfg ws+            ctrlWidget <- liftIO $ hwcGetWidget ctrl+            wrapperBox <- liftIO $ Gtk.boxNew Gtk.OrientationHorizontal 0+            liftIO $ Gtk.containerAdd wrapperBox ctrlWidget+            wrapper <- Gtk.toWidget wrapperBox+            return HyprlandWorkspaceEntry+              { hweWrapper = wrapper+              , hweController = ctrl+              , hweLast = ws+              }+        return (M.insert idx entry newCache, entry)++  (newCache, orderedEntriesRev) <-+    foldM+      (\(cacheAcc, entriesAcc) ws -> do+          (cacheAcc', entry) <- buildOrUpdate cacheAcc ws+          return (cacheAcc', (ws, entry) : entriesAcc)+      )+      (M.empty, [])+      workspaces'+  let orderedEntries = reverse orderedEntriesRev++  let primaryShowFn = showWorkspaceFn cfg+      primaryShownCount = length $ filter (primaryShowFn . fst) orderedEntries+      fallbackShowFn ws = workspaceState ws /= Empty+      fallbackShownCount = length $ filter (fallbackShowFn . fst) orderedEntries+      (finalShowFn, finalShownCount, fallbackUsed) =+        if primaryShownCount == 0 && fallbackShownCount > 0+          then (fallbackShowFn, fallbackShownCount, True)+          else (primaryShowFn, primaryShownCount, False)++  when (fallbackUsed && not (null orderedEntries)) $+    liftIO $ wLog WARNING $+      printf+        "Hyprland workspaces: showWorkspaceFn hid all %d workspaces; falling back to showing non-empty workspaces (including special:*). %s"+        (length orderedEntries)+        (summarizeWorkspaces (map fst orderedEntries))+  when (finalShownCount == 0 && not (null orderedEntries)) $+    liftIO $ wLog WARNING $+      printf+        "Hyprland workspaces widget is blank: no workspaces passed the show filter (total=%d). %s"+        (length orderedEntries)+        (summarizeWorkspaces (map fst orderedEntries))++  -- Remove wrappers for workspaces that disappeared.+  let removed = M.difference oldCache newCache+  forM_ (M.elems removed) $ \entry ->+    liftIO $ Gtk.containerRemove cont (hweWrapper entry)++  -- Add wrappers for newly created workspaces.+  let added = M.difference newCache oldCache+  forM_ (M.elems added) $ \entry -> do+    liftIO $ Gtk.containerAdd cont (hweWrapper entry)+    liftIO $ Gtk.widgetShowAll (hweWrapper entry)++  let desiredOrder = map (workspaceIdx . fst) orderedEntries+      needsReorder =+        desiredOrder /= oldOrder || not (M.null added) || not (M.null removed)+  when needsReorder $ do+    -- Reorder wrappers to match the order returned by hyprctl.+    forM_ (zip [0 :: Int ..] orderedEntries) $ \(pos, (_ws, entry)) ->+      liftIO $ Gtk.boxReorderChild cont (hweWrapper entry) (fromIntegral pos)++  -- Show/hide the controller widget without removing the wrapper from the box.+  forM_ orderedEntries $ \(ws, entry) -> do+    ctrlWidget <- liftIO $ hwcGetWidget (hweController entry)+    if finalShowFn ws+      then liftIO $ Gtk.widgetShow ctrlWidget+      else liftIO $ Gtk.widgetHide ctrlWidget++  _ <- setState (HyprlandWorkspaceWidgetCache newCache)+  _ <- setState (HyprlandWorkspaceOrderCache desiredOrder)+  return ()++summarizeWorkspaces :: [HyprlandWorkspace] -> String+summarizeWorkspaces wss =+  let summarizeOne ws =+        printf "%d:%s:%s(wins=%d)"+          (workspaceIdx ws)+          (workspaceName ws)+          (show (workspaceState ws))+          (length (windows ws))+      maxShown = 12+      body = intercalate ", " $ map summarizeOne (take maxShown wss)+      suffix = if length wss > maxShown then ", ..." else ""+   in "workspaces=[" ++ body ++ suffix ++ "]"++applyUrgentState :: HyprlandWorkspacesConfig -> HyprlandWorkspace -> HyprlandWorkspace+applyUrgentState cfg ws+  | urgentWorkspaceState cfg+    && workspaceState ws == Hidden+    && any windowUrgent (windows ws) =+      ws { workspaceState = Urgent }+  | otherwise = ws++-- Controller types++data HyprlandLabelController = HyprlandLabelController+  { hlcLabel :: Gtk.Label+  , hlcLabelSetter :: HyprlandWorkspace -> TaffyIO String+  }++instance HyprlandWorkspaceWidgetController HyprlandLabelController where+  hwcGetWidget = Gtk.toWidget . hlcLabel+  hwcUpdateWidget lc ws = do+    labelText <- hlcLabelSetter lc ws+    liftIO $ do+      Gtk.labelSetMarkup (hlcLabel lc) (T.pack labelText)+      setWorkspaceWidgetStatusClass (workspaceState ws) (hlcLabel lc)+    return lc++hyprlandBuildLabelController :: HyprlandWorkspacesConfig -> HyprlandControllerConstructor+hyprlandBuildLabelController cfg ws = do+  lbl <- liftIO $ Gtk.labelNew Nothing+  _ <- widgetSetClassGI lbl "workspace-label"+  labelText <- labelSetter cfg ws+  liftIO $ Gtk.labelSetMarkup lbl (T.pack labelText)+  liftIO $ setWorkspaceWidgetStatusClass (workspaceState ws) lbl+  return $ HyprlandWWC $ HyprlandLabelController+    { hlcLabel = lbl+    , hlcLabelSetter = labelSetter cfg+    }++data HyprlandIconController = HyprlandIconController+  { hicIconsContainer :: Gtk.Box+  , hicIconImages :: [HyprlandIconWidget]+  , hicWorkspace :: HyprlandWorkspace+  , hicConfig :: HyprlandWorkspacesConfig+  }++instance HyprlandWorkspaceWidgetController HyprlandIconController where+  hwcGetWidget = Gtk.toWidget . hicIconsContainer+  hwcUpdateWidget ic ws = do+    newImages <-+      if windows ws /= windows (hicWorkspace ic)+        then updateIcons (hicConfig ic) ws (hicIconsContainer ic) (hicIconImages ic)+        else return (hicIconImages ic)+    return ic { hicIconImages = newImages, hicWorkspace = ws }++hyprlandBuildIconController :: HyprlandWorkspacesConfig -> HyprlandControllerConstructor+hyprlandBuildIconController cfg ws = do+  iconsBox <- liftIO $ Gtk.boxNew Gtk.OrientationHorizontal 0+  icons <- updateIcons cfg ws iconsBox []+  return $ HyprlandWWC $ HyprlandIconController+    { hicIconsContainer = iconsBox+    , hicIconImages = icons+    , hicWorkspace = ws+    , hicConfig = cfg+    }++data HyprlandContentsController = HyprlandContentsController+  { hccContainerWidget :: Gtk.Widget+  , hccControllers :: [HyprlandWWC]+  }++instance HyprlandWorkspaceWidgetController HyprlandContentsController where+  hwcGetWidget = return . hccContainerWidget+  hwcUpdateWidget cc ws = do+    liftIO $ setWorkspaceWidgetStatusClass (workspaceState ws) (hccContainerWidget cc)+    newControllers <- mapM (`hwcUpdateWidget` ws) (hccControllers cc)+    return cc { hccControllers = newControllers }++hyprlandBuildContentsController ::+  [HyprlandControllerConstructor] -> HyprlandControllerConstructor+hyprlandBuildContentsController constructors ws = do+  controllers <- mapM ($ ws) constructors+  widgets <- liftIO $ mapM hwcGetWidget controllers+  widget <- liftIO $ do+    cons <- Gtk.boxNew Gtk.OrientationHorizontal 0+    mapM_ (Gtk.containerAdd cons) widgets+    _ <- widgetSetClassGI cons "contents"+    Gtk.toWidget cons+  liftIO $ setWorkspaceWidgetStatusClass (workspaceState ws) widget+  return $ HyprlandWWC $ HyprlandContentsController+    { hccContainerWidget = widget+    , hccControllers = controllers+    }++hyprlandBuildLabelOverlayController ::+  HyprlandWorkspacesConfig -> HyprlandControllerConstructor+hyprlandBuildLabelOverlayController cfg ws = do+  iconCtrl <- hyprlandBuildIconController cfg ws+  labelCtrl <- hyprlandBuildLabelController cfg ws+  iconWidget <- liftIO $ hwcGetWidget iconCtrl+  labelWidget <- liftIO $ hwcGetWidget labelCtrl+  widget <- buildWorkspaceIconLabelOverlay iconWidget labelWidget+  liftIO $ setWorkspaceWidgetStatusClass (workspaceState ws) widget+  return $ HyprlandWWC $ HyprlandContentsController+    { hccContainerWidget = widget+    , hccControllers = [iconCtrl, labelCtrl]+    }++-- | Like 'hyprlandBuildLabelOverlayController' but accepts a custom function+-- to combine the icon and label widgets into a single container widget.+hyprlandBuildCustomOverlayController ::+  (Gtk.Widget -> Gtk.Widget -> TaffyIO Gtk.Widget)+  -> HyprlandWorkspacesConfig -> HyprlandControllerConstructor+hyprlandBuildCustomOverlayController combiner cfg ws = do+  iconCtrl <- hyprlandBuildIconController cfg ws+  labelCtrl <- hyprlandBuildLabelController cfg ws+  iconWidget <- liftIO $ hwcGetWidget iconCtrl+  labelWidget <- liftIO $ hwcGetWidget labelCtrl+  widget <- combiner iconWidget labelWidget+  liftIO $ setWorkspaceWidgetStatusClass (workspaceState ws) widget+  return $ HyprlandWWC $ HyprlandContentsController+    { hccContainerWidget = widget+    , hccControllers = [iconCtrl, labelCtrl]+    }++hyprlandDefaultBuildContentsController ::+  HyprlandWorkspacesConfig -> HyprlandControllerConstructor+hyprlandDefaultBuildContentsController = hyprlandBuildLabelOverlayController++data HyprlandButtonController = HyprlandButtonController+  { hbcButton :: Gtk.EventBox+  , hbcWorkspaceRef :: IORef HyprlandWorkspace+  , hbcContentsController :: HyprlandWWC+  }++instance HyprlandWorkspaceWidgetController HyprlandButtonController where+  hwcGetWidget = Gtk.toWidget . hbcButton+  hwcUpdateWidget wbc ws = do+    liftIO $ writeIORef (hbcWorkspaceRef wbc) ws+    newContents <- hwcUpdateWidget (hbcContentsController wbc) ws+    return wbc { hbcContentsController = newContents }++hyprlandBuildButtonController ::+  HyprlandWorkspacesConfig -> HyprlandParentControllerConstructor+hyprlandBuildButtonController cfg contentsBuilder ws = do+  cc <- contentsBuilder ws+  ctx <- ask+  contentsWidget <- liftIO $ hwcGetWidget cc+  wsRef <- liftIO $ newIORef ws+  ebox <- liftIO $ do+    eb <- Gtk.eventBoxNew+    Gtk.eventBoxSetVisibleWindow eb False+    Gtk.containerAdd eb contentsWidget+    _ <- Gtk.onWidgetButtonPressEvent eb $ const $ do+           wsCurrent <- readIORef wsRef+           runReaderT (switchToWorkspace cfg wsCurrent) ctx+           return True+    return eb+  return $ HyprlandWWC $ HyprlandButtonController+    { hbcButton = ebox+    , hbcWorkspaceRef = wsRef+    , hbcContentsController = cc+    }++defaultHyprlandWidgetBuilder :: HyprlandWorkspacesConfig -> HyprlandControllerConstructor+defaultHyprlandWidgetBuilder cfg =+  hyprlandBuildButtonController cfg (hyprlandDefaultBuildContentsController cfg)++updateIcons ::+  HyprlandWorkspacesConfig+  -> HyprlandWorkspace+  -> Gtk.Box+  -> [HyprlandIconWidget]+  -> ReaderT Context IO [HyprlandIconWidget]+updateIcons cfg ws iconsBox iconWidgets = do+  sortedWindows <- iconSort cfg $ windows ws+  let (effectiveMinIcons, _targetLen, paddedWindows) =+        computeIconStripLayout (minIcons cfg) (maxIcons cfg) sortedWindows+      buildOne i = buildIconWidget (i < effectiveMinIcons) cfg+  syncWidgetPool iconsBox iconWidgets paddedWindows buildOne iconContainer updateIconWidget++buildIconWidget :: Bool -> HyprlandWorkspacesConfig -> ReaderT Context IO HyprlandIconWidget+buildIconWidget transparentOnNone cfg = do+  ctx <- ask+  strategy <- getScalingImageStrategy+  liftIO $+    mkWorkspaceIconWidget+      strategy+      (Just $ iconSize cfg)+      transparentOnNone+      (\size w -> runReaderT (getWindowIconPixbuf cfg size w) ctx)+      (`pixBufFromColor` 0)++updateIconWidget :: HyprlandIconWidget -> Maybe HyprlandWindow -> ReaderT Context IO ()+updateIconWidget iconWidget windowData =+  updateWindowIconWidgetState+    iconWidget+    windowData+    (T.pack . windowTitle)+    getWindowStatusString+++getWindowStatusString :: HyprlandWindow -> T.Text+getWindowStatusString windowData =+  windowStatusClassFromFlags+    (windowMinimized windowData)+    (windowActive windowData)+    (windowUrgent windowData)++-- | Sort windows by their top-left corner position.+--+-- This mirrors the X11 Workspaces widget default ('sortWindowsByPosition'),+-- but uses Hyprland's @at@ coordinate from @hyprctl clients -j@.+sortHyprlandWindowsByPosition :: [HyprlandWindow] -> [HyprlandWindow]+sortHyprlandWindowsByPosition =+  sortOn $ \w ->+    ( windowMinimized w+    , fromMaybe (999999999, 999999999) (windowAt w)+    )++wLog :: MonadIO m => Priority -> String -> m ()+wLog l s = liftIO $ logM "System.Taffybar.Widget.HyprlandWorkspaces" l s++-- Window icon lookup++scaledWindowIconPixbufGetter ::+  HyprlandWindowIconPixbufGetter -> HyprlandWindowIconPixbufGetter+scaledWindowIconPixbufGetter = scaledPixbufGetter++handleIconGetterException ::+  HyprlandWindowIconPixbufGetter -> HyprlandWindowIconPixbufGetter+handleIconGetterException = handlePixbufGetterException wLog++defaultHyprlandGetWindowIconPixbuf :: HyprlandWindowIconPixbufGetter+defaultHyprlandGetWindowIconPixbuf =+  scaledWindowIconPixbufGetter $+  getWindowIconPixbufFromDesktopEntry <|||> getWindowIconPixbufFromClass++getWindowIconPixbufFromClass :: HyprlandWindowIconPixbufGetter+getWindowIconPixbufFromClass size windowData =+  maybeTCombine+    (maybe (return Nothing) (liftIO . getWindowIconFromClasses size) (windowClass windowData))+    (maybe (return Nothing) (liftIO . getWindowIconFromClasses size) (windowInitialClass windowData))++getWindowIconPixbufFromDesktopEntry :: HyprlandWindowIconPixbufGetter+getWindowIconPixbufFromDesktopEntry =+  handleIconGetterException $ \size windowData ->+    maybeTCombine+      (maybe (return Nothing) (getWindowIconFromDesktopEntryByAppId size) (windowClass windowData))+      (maybe (return Nothing) (getWindowIconFromDesktopEntryByAppId size) (windowInitialClass windowData))++getDirectoryEntriesByAppId :: TaffyIO (MM.MultiMap String DesktopEntry)+getDirectoryEntriesByAppId = getStateDefault readDirectoryEntriesByAppId++readDirectoryEntriesByAppId :: TaffyIO (MM.MultiMap String DesktopEntry)+readDirectoryEntriesByAppId =+  liftIO $ indexDesktopEntriesByAppId <$> getDirectoryEntriesDefault++indexDesktopEntriesByAppId :: [DesktopEntry] -> MM.MultiMap String DesktopEntry+indexDesktopEntriesByAppId =+  F.foldl' (\m de -> MM.insert (normalizeAppId $ deFilename de) de m) MM.empty++normalizeAppId :: String -> String+normalizeAppId name =+  let stripped = fromMaybe name (stripSuffix ".desktop" name)+  in map toLower stripped++getWindowIconFromDesktopEntryByAppId ::+  Int32 -> String -> TaffyIO (Maybe Gdk.Pixbuf)+getWindowIconFromDesktopEntryByAppId size appId = do+  entries <- MM.lookup (normalizeAppId appId) <$> getDirectoryEntriesByAppId+  case entries of+    [] -> return Nothing+    (entry:_) -> do+      liftIO $ logM "System.Taffybar.Widget.HyprlandWorkspaces" DEBUG $+        printf "Using desktop entry for icon %s (appId=%s)"+               (deFilename entry) appId+      liftIO $ getImageForDesktopEntry size entry++-- Hyprland backend++data HyprlandWorkspaceRef = HyprlandWorkspaceRef+  { hwrId :: Int+  , hwrName :: Text+  } deriving (Show, Eq)++instance FromJSON HyprlandWorkspaceRef where+  parseJSON = withObject "HyprlandWorkspaceRef" $ \v ->+    HyprlandWorkspaceRef+      <$> v .: "id"+      <*> v .: "name"++data HyprlandWorkspaceInfo = HyprlandWorkspaceInfo+  { hwiId :: Int+  , hwiName :: Text+  , hwiWindows :: Int+  } deriving (Show, Eq)++instance FromJSON HyprlandWorkspaceInfo where+  parseJSON = withObject "HyprlandWorkspaceInfo" $ \v ->+    HyprlandWorkspaceInfo+      <$> v .: "id"+      <*> v .: "name"+      <*> v .:? "windows" .!= 0++data HyprlandMonitorInfo = HyprlandMonitorInfo+  { hmFocused :: Bool+  , hmActiveWorkspace :: Maybe HyprlandWorkspaceRef+  } deriving (Show, Eq)++instance FromJSON HyprlandMonitorInfo where+  parseJSON = withObject "HyprlandMonitorInfo" $ \v ->+    HyprlandMonitorInfo+      <$> v .:? "focused" .!= False+      <*> v .:? "activeWorkspace"++data HyprlandClient = HyprlandClient+  { hcAddress :: Text+  , hcTitle :: Text+  , hcInitialTitle :: Maybe Text+  , hcClass :: Maybe Text+  , hcInitialClass :: Maybe Text+  , hcAt :: Maybe (Int, Int)+  , hcWorkspace :: HyprlandWorkspaceRef+  , hcFocused :: Bool+  , hcHidden :: Bool+  , hcMapped :: Bool+  , hcUrgent :: Bool+  } deriving (Show, Eq)++instance FromJSON HyprlandClient where+  parseJSON = withObject "HyprlandClient" $ \v ->+    HyprlandClient+      <$> v .: "address"+      <*> v .:? "title" .!= ""+      <*> v .:? "initialTitle"+      <*> v .:? "class"+      <*> v .:? "initialClass"+      <*> (vec2FromList <$> v .:? "at")+      <*> v .: "workspace"+      <*> v .:? "focused" .!= False+      <*> v .:? "hidden" .!= False+      <*> v .:? "mapped" .!= True+      <*> v .:? "urgent" .!= False+    where+      vec2FromList :: Maybe [Int] -> Maybe (Int, Int)+      vec2FromList (Just [x, y]) = Just (x, y)+      vec2FromList _ = Nothing++newtype HyprlandActiveWindow = HyprlandActiveWindow+  { hawAddress :: Text+  } deriving (Show, Eq)++instance FromJSON HyprlandActiveWindow where+  parseJSON = withObject "HyprlandActiveWindow" $ \v ->+    HyprlandActiveWindow <$> v .: "address"++runHyprctlJson :: FromJSON a => [String] -> TaffyIO (Either String a)+runHyprctlJson args = do+  let args' =+        case args of+          ("-j":rest) -> rest+          _ -> args+  result <- runHyprlandCommandJsonT (Hypr.hyprCommandJson args')+  pure $ case result of+    Left err -> Left (show err)+    Right out -> Right out++runHyprlandCommandRaw :: [String] -> TaffyIO (Either String BS.ByteString)+runHyprlandCommandRaw args = do+  let cmd =+        case args of+          ("-j":rest) -> Hypr.hyprCommandJson rest+          _ -> Hypr.hyprCommand args+  result <- runHyprlandCommandRawT cmd+  pure $ case result of+    Left err -> Left (show err)+    Right out -> Right out++hyprlandSwitchToWorkspace :: HyprlandWorkspace -> TaffyIO ()+hyprlandSwitchToWorkspace ws = do+  result <- runHyprlandCommandRaw ["dispatch", "workspace", workspaceName ws]+  case result of+    Left err -> wLog WARNING $ printf "Failed to switch workspace: %s" err+    Right _ -> return ()++getHyprlandWorkspaces :: TaffyIO [HyprlandWorkspace]+getHyprlandWorkspaces = do+  workspacesResult <- runHyprctlJson ["-j", "workspaces"]+  clientsResult <- runHyprctlJson ["-j", "clients"]+  monitorsResult <- runHyprctlJson ["-j", "monitors"]+  activeWorkspaceResult <- runHyprctlJson ["-j", "activeworkspace"]+  activeWindowAddress <- getActiveWindowAddress++  workspaces <- case workspacesResult of+    Left err -> wLog WARNING (printf "hyprctl workspaces failed: %s" err) >> return []+    Right ws -> return ws++  let workspacesCount = length workspaces+      workspacesWindowsSum = sum (map hwiWindows workspaces)+  (clientsOk, clients) <- case clientsResult of+    Left err -> do+      wLog WARNING $+        printf+          "hyprctl clients failed: %s (workspaces=%d windowsSum=%d)"+          err+          workspacesCount+          workspacesWindowsSum+      return (False, [])+    Right cs -> return (True, cs)++  monitors <- case monitorsResult of+    Left err -> wLog WARNING (printf "hyprctl monitors failed: %s" err) >> return []+    Right ms -> return ms++  activeWorkspace <- case activeWorkspaceResult of+    Left err -> wLog WARNING (printf "hyprctl activeworkspace failed: %s" err) >> return Nothing+    Right ws -> return $ Just ws++  buildWorkspacesFromHyprland+    workspaces+    clientsOk+    clients+    monitors+    activeWorkspace+    activeWindowAddress++getActiveWindowAddress :: TaffyIO (Maybe Text)+getActiveWindowAddress = do+  result <- runHyprctlJson ["-j", "activewindow"]+  case result of+    Left _ -> return Nothing+    Right activeWindow -> return $ Just $ hawAddress activeWindow++buildWorkspacesFromHyprland ::+  [HyprlandWorkspaceInfo]+  -> Bool+  -> [HyprlandClient]+  -> [HyprlandMonitorInfo]+  -> Maybe HyprlandWorkspaceRef+  -> Maybe Text+  -> TaffyIO [HyprlandWorkspace]+buildWorkspacesFromHyprland workspaces clientsOk clients monitors activeWorkspace activeWindowAddress = do+  let windowsByWorkspace = collectWorkspaceWindows activeWindowAddress clients+      sortedWorkspaces = sortOn hwiId workspaces+      visibleWorkspaceIds =+        map hwrId $ mapMaybe hmActiveWorkspace monitors+      focusedWorkspaceId =+        listToMaybe [ hwrId ws+                    | m <- monitors+                    , hmFocused m+                    , Just ws <- [hmActiveWorkspace m]+                    ]+      activeWorkspaceId =+        focusedWorkspaceId <|> fmap hwrId activeWorkspace++  return $ map (buildWorkspace windowsByWorkspace visibleWorkspaceIds activeWorkspaceId) sortedWorkspaces+  where+    buildWorkspace windowsMap visibleIds activeId wsInfo =+      let wsId = hwiId wsInfo+          wsName = hwiName wsInfo+          wins = M.findWithDefault [] wsId windowsMap+          hasWindows = not (null wins) || hwiWindows wsInfo > 0+          state+            | Just wsId == activeId = Active+            | wsId `elem` visibleIds = Visible+            -- If we couldn't fetch clients, don't aggressively hide workspaces.+            -- This prevents "invisible" workspaces on transient Hyprland restarts.+            | not hasWindows && clientsOk = Empty+            | otherwise = Hidden+      in HyprlandWorkspace+           { workspaceIdx = wsId+           , workspaceName = T.unpack wsName+           , workspaceState = state+           , windows = wins+           }++collectWorkspaceWindows :: Maybe Text -> [HyprlandClient] -> M.Map Int [HyprlandWindow]+collectWorkspaceWindows activeWindowAddress =+  F.foldl' (addWindow activeWindowAddress) M.empty+  where+    addWindow activeAddr windowsMap client =+      let wsId = hwrId (hcWorkspace client)+          windowData = windowFromClient activeAddr client+      in M.insertWith (++) wsId [windowData] windowsMap++windowFromClient :: Maybe Text -> HyprlandClient -> HyprlandWindow+windowFromClient activeAddr client =+  let titleText =+        if T.null (hcTitle client)+          then fromMaybe "" (hcInitialTitle client)+          else hcTitle client+      active =+        hcFocused client || Just (hcAddress client) == activeAddr+      minimized =+        hcHidden client || not (hcMapped client)+  in HyprlandWindow+       { windowAddress = hcAddress client+       , windowTitle = T.unpack titleText+       , windowClass = T.unpack <$> hcClass client+       , windowInitialClass = T.unpack <$> hcInitialClass client+       , windowAt = hcAt client+       , windowUrgent = hcUrgent client+       , windowActive = active+       , windowMinimized = minimized+       }
+ src/System/Taffybar/Widget/Inhibitor.hs view
@@ -0,0 +1,189 @@+{-# LANGUAGE OverloadedStrings #-}+-----------------------------------------------------------------------------+-- |+-- Module      : System.Taffybar.Widget.Inhibitor+-- Copyright   : (c) Ivan A. Malison+-- License     : BSD3-style (see LICENSE)+--+-- Maintainer  : Ivan A. Malison+-- Stability   : unstable+-- Portability : unportable+--+-- This module provides a widget for controlling idle/sleep inhibitors.+-- The widget displays the current inhibitor state and allows toggling+-- the inhibitor on/off with a click.+--+-- Example usage:+--+-- > import System.Taffybar.Widget.Inhibitor+-- >+-- > main = do+-- >   -- Simple inhibitor widget that inhibits idle+-- >   let inhibitor = inhibitorNew+-- >+-- >   -- Or with custom configuration+-- >   let customInhibitor = inhibitorNewWithConfig defaultInhibitorConfig+-- >         { inhibitWhat = [InhibitIdle, InhibitSleep]+-- >         , inhibitorActiveText = "AWAKE"+-- >         , inhibitorInactiveText = "zzz"+-- >         }+-----------------------------------------------------------------------------+module System.Taffybar.Widget.Inhibitor+  ( -- * Widget constructors+    inhibitorNew+  , inhibitorNewWithConfig+  , inhibitorIconNew+  , inhibitorIconNewWithConfig+  , inhibitorLabelNew+  , inhibitorLabelNewWithConfig+    -- * Configuration+  , InhibitorConfig(..)+  , defaultInhibitorConfig+    -- * Re-exports+  , InhibitType(..)+  ) where++import           Control.Monad+import           Control.Monad.IO.Class+import           Control.Monad.Trans.Reader+import qualified Data.Text as T+import qualified GI.Gdk as Gdk+import           GI.Gtk as Gtk+import           System.Taffybar.Context+import           System.Taffybar.Information.Inhibitor+import           System.Taffybar.Util+import           System.Taffybar.Widget.Generic.ChannelWidget+import           System.Taffybar.Widget.Util++-- | Configuration for the inhibitor widget+data InhibitorConfig = InhibitorConfig+  { -- | What types of inhibitors to manage (default: [InhibitIdle])+    inhibitWhat :: [InhibitType]+    -- | Text to display when inhibitor is active+  , inhibitorActiveText :: T.Text+    -- | Text to display when inhibitor is inactive+  , inhibitorInactiveText :: T.Text+    -- | Icon to display when inhibitor is active (default: U+F0F4, nf-fa-coffee)+  , inhibitorActiveIcon :: T.Text+    -- | Icon to display when inhibitor is inactive (default: U+F236, nf-fa-bed)+  , inhibitorInactiveIcon :: T.Text+    -- | CSS class prefix (results in "prefix-active" and "prefix-inactive")+  , inhibitorCssPrefix :: T.Text+  } deriving (Eq, Show)++-- | Default configuration: inhibits idle, shows simple icon-style text+defaultInhibitorConfig :: InhibitorConfig+defaultInhibitorConfig = InhibitorConfig+  { inhibitWhat = [InhibitIdle]+  , inhibitorActiveText = "INHIBIT"+  , inhibitorInactiveText = "inhibit"+  , inhibitorActiveIcon = T.pack "\xF0F4"+  , inhibitorInactiveIcon = T.pack "\xF236"+  , inhibitorCssPrefix = "inhibitor"+  }++-- | Create a combined icon+label inhibitor widget with default configuration+inhibitorNew :: TaffyIO Widget+inhibitorNew = inhibitorNewWithConfig defaultInhibitorConfig++-- | Create a combined icon+label inhibitor widget with custom configuration.+-- The icon changes dynamically based on inhibitor state.+-- Click to toggle the inhibitor on/off.+inhibitorNewWithConfig :: InhibitorConfig -> TaffyIO Widget+inhibitorNewWithConfig config = do+  let types = inhibitWhat config+  iconWidget <- inhibitorIconNewWithConfig config+  labelWidget <- inhibitorLabelNewWithConfig config+  ctx <- ask+  liftIO $ do+    box <- buildIconLabelBox iconWidget labelWidget+    ebox <- eventBoxNew+    containerAdd ebox box++    _ <- widgetSetClassGI ebox "inhibitor"++    _ <- onWidgetButtonPressEvent ebox $ \event -> do+      button <- Gdk.getEventButtonButton event+      when (button == 1) $+        runReaderT (toggleInhibitor types) ctx+      return True++    widgetShowAll ebox+    toWidget ebox++-- | Create an icon-only inhibitor widget with default configuration+inhibitorIconNew :: TaffyIO Widget+inhibitorIconNew = inhibitorIconNewWithConfig defaultInhibitorConfig++-- | Create an icon-only inhibitor widget with custom configuration.+-- The icon changes dynamically based on inhibitor state.+inhibitorIconNewWithConfig :: InhibitorConfig -> TaffyIO Widget+inhibitorIconNewWithConfig config = do+  let types = inhibitWhat config+  chan <- getInhibitorChan types+  ctx <- ask+  liftIO $ do+    label <- labelNew Nothing+    let updateIcon state = postGUIASync $+          labelSetText label $+            if inhibitorActive state+            then inhibitorActiveIcon config+            else inhibitorInactiveIcon config+    void $ onWidgetRealize label $ do+      initialState <- runReaderT (getInhibitorState types) ctx+      updateIcon initialState+    widgetShowAll label+    toWidget =<< channelWidgetNew label chan updateIcon++-- | Create a label-only inhibitor widget with default configuration.+-- Click to toggle the inhibitor on/off.+inhibitorLabelNew :: TaffyIO Widget+inhibitorLabelNew = inhibitorLabelNewWithConfig defaultInhibitorConfig++-- | Create a label-only inhibitor widget with custom configuration.+-- Displays text and CSS classes based on inhibitor state.+-- Click to toggle the inhibitor on/off.+inhibitorLabelNewWithConfig :: InhibitorConfig -> TaffyIO Widget+inhibitorLabelNewWithConfig config = do+  let types = inhibitWhat config+  chan <- getInhibitorChan types+  ctx <- ask+  liftIO $ do+    label <- labelNew Nothing+    ebox <- eventBoxNew++    -- Set initial CSS class+    _ <- widgetSetClassGI ebox "inhibitor"++    containerAdd ebox label++    -- Set up click handler+    _ <- onWidgetButtonPressEvent ebox $ \event -> do+      button <- Gdk.getEventButtonButton event+      when (button == 1) $+        runReaderT (toggleInhibitor types) ctx+      return True++    -- Update function for the widget+    let updateWidget state = postGUIASync $ do+          let (text, activeClass, inactiveClass) =+                if inhibitorActive state+                then ( inhibitorActiveText config+                     , inhibitorCssPrefix config <> "-active"+                     , inhibitorCssPrefix config <> "-inactive"+                     )+                else ( inhibitorInactiveText config+                     , inhibitorCssPrefix config <> "-inactive"+                     , inhibitorCssPrefix config <> "-active"+                     )+          labelSetText label text+          addClassIfMissing activeClass ebox+          removeClassIfPresent inactiveClass ebox++    -- Set initial state+    void $ onWidgetRealize ebox $ do+      initialState <- runReaderT (getInhibitorState types) ctx+      updateWidget initialState++    -- Connect to state changes+    toWidget =<< channelWidgetNew ebox chan updateWidget
+ src/System/Taffybar/Widget/KeyboardState.hs view
@@ -0,0 +1,149 @@+{-# LANGUAGE OverloadedStrings #-}++--------------------------------------------------------------------------------+-- |+-- Module      : System.Taffybar.Widget.KeyboardState+-- Copyright   : (c) Ivan Malison+-- License     : BSD3-style (see LICENSE)+--+-- Maintainer  : Ivan Malison <IvanMalison@gmail.com>+-- Stability   : unstable+-- Portability : unportable+--+-- A widget that displays keyboard lock key states (Caps Lock, Num Lock,+-- Scroll Lock). States are read from sysfs LED brightness files.+--+--------------------------------------------------------------------------------++module System.Taffybar.Widget.KeyboardState+  ( -- * Widget Constructors+    keyboardStateNew+  , keyboardStateNewWithConfig+  , keyboardStateLabelNew+  , keyboardStateLabelNewWithConfig+  , keyboardStateIconNew+  , keyboardStateIconNewWithConfig+    -- * Configuration+  , KeyboardStateConfig(..)+  , defaultKeyboardStateConfig+    -- * Format Functions+  , formatKeyboardState+  ) where++import Control.Monad.IO.Class (MonadIO, liftIO)+import qualified Data.Text as T+import qualified GI.Gtk as Gtk+import System.Taffybar.Information.KeyboardState+import System.Taffybar.Widget.Generic.PollingLabel (pollingLabelNew)+import System.Taffybar.Widget.Util (buildIconLabelBox, widgetSetClassGI)++-- | Configuration for the keyboard state widget.+data KeyboardStateConfig = KeyboardStateConfig+  { kscCapsLockOnText :: T.Text+    -- ^ Text to display when Caps Lock is on. Default: "[CAPS]"+  , kscCapsLockOffText :: T.Text+    -- ^ Text to display when Caps Lock is off. Default: ""+  , kscNumLockOnText :: T.Text+    -- ^ Text to display when Num Lock is on. Default: "[NUM]"+  , kscNumLockOffText :: T.Text+    -- ^ Text to display when Num Lock is off. Default: ""+  , kscScrollLockOnText :: T.Text+    -- ^ Text to display when Scroll Lock is on. Default: "[SCROLL]"+  , kscScrollLockOffText :: T.Text+    -- ^ Text to display when Scroll Lock is off. Default: ""+  , kscShowCapsLock :: Bool+    -- ^ Whether to show Caps Lock state. Default: True+  , kscShowNumLock :: Bool+    -- ^ Whether to show Num Lock state. Default: False+  , kscShowScrollLock :: Bool+    -- ^ Whether to show Scroll Lock state. Default: False+  , kscSeparator :: T.Text+    -- ^ Separator between lock indicators. Default: " "+  , kscPollingInterval :: Double+    -- ^ Polling interval in seconds. Default: 0.5+  , kscIcon :: T.Text+    -- ^ Icon text for the icon widget variant. Default: keyboard icon (nf-md-keyboard)+  } deriving (Eq, Show)++-- | Default configuration for the keyboard state widget.+-- Shows only Caps Lock by default, polling every 0.5 seconds.+defaultKeyboardStateConfig :: KeyboardStateConfig+defaultKeyboardStateConfig = KeyboardStateConfig+  { kscCapsLockOnText = "[CAPS]"+  , kscCapsLockOffText = ""+  , kscNumLockOnText = "[NUM]"+  , kscNumLockOffText = ""+  , kscScrollLockOnText = "[SCROLL]"+  , kscScrollLockOffText = ""+  , kscShowCapsLock = True+  , kscShowNumLock = False+  , kscShowScrollLock = False+  , kscSeparator = " "+  , kscPollingInterval = 0.5+  , kscIcon = T.pack "\xF80B"+  }++-- | Format the keyboard state according to the configuration.+formatKeyboardState :: KeyboardStateConfig -> KeyboardState -> T.Text+formatKeyboardState cfg state =+  let parts = filter (not . T.null)+        [ if kscShowCapsLock cfg+          then if capsLock state+               then kscCapsLockOnText cfg+               else kscCapsLockOffText cfg+          else ""+        , if kscShowNumLock cfg+          then if numLock state+               then kscNumLockOnText cfg+               else kscNumLockOffText cfg+          else ""+        , if kscShowScrollLock cfg+          then if scrollLock state+               then kscScrollLockOnText cfg+               else kscScrollLockOffText cfg+          else ""+        ]+  in T.intercalate (kscSeparator cfg) parts++-- | Create a keyboard state label widget with default configuration.+-- Shows Caps Lock status, polling every 0.5 seconds.+keyboardStateLabelNew :: MonadIO m => m Gtk.Widget+keyboardStateLabelNew = keyboardStateLabelNewWithConfig defaultKeyboardStateConfig++-- | Create a keyboard state label widget with custom configuration.+-- Uses PollingLabel to periodically update the display.+keyboardStateLabelNewWithConfig :: MonadIO m => KeyboardStateConfig -> m Gtk.Widget+keyboardStateLabelNewWithConfig cfg = liftIO $ do+  widget <- pollingLabelNew (kscPollingInterval cfg) (getFormattedState cfg)+  _ <- widgetSetClassGI widget "keyboard-state"+  return widget++-- | Create a keyboard state icon widget with default configuration.+keyboardStateIconNew :: MonadIO m => m Gtk.Widget+keyboardStateIconNew = keyboardStateIconNewWithConfig defaultKeyboardStateConfig++-- | Create a keyboard state icon widget with custom configuration.+-- Displays a static icon label.+keyboardStateIconNewWithConfig :: MonadIO m => KeyboardStateConfig -> m Gtk.Widget+keyboardStateIconNewWithConfig cfg = liftIO $ do+  label <- Gtk.labelNew (Just (kscIcon cfg))+  Gtk.widgetShowAll label+  Gtk.toWidget label++-- | Create a combined keyboard state widget (icon + label) with default+-- configuration.+keyboardStateNew :: MonadIO m => m Gtk.Widget+keyboardStateNew = keyboardStateNewWithConfig defaultKeyboardStateConfig++-- | Create a combined keyboard state widget (icon + label) with custom+-- configuration.+keyboardStateNewWithConfig :: MonadIO m => KeyboardStateConfig -> m Gtk.Widget+keyboardStateNewWithConfig cfg = do+  iconWidget <- keyboardStateIconNewWithConfig cfg+  labelWidget <- keyboardStateLabelNewWithConfig cfg+  liftIO $ buildIconLabelBox iconWidget labelWidget++-- | Get the formatted keyboard state text.+getFormattedState :: KeyboardStateConfig -> IO T.Text+getFormattedState cfg =+  formatKeyboardState cfg <$> getKeyboardState
+ src/System/Taffybar/Widget/NetworkManager.hs view
@@ -0,0 +1,631 @@+{-# LANGUAGE OverloadedStrings #-}+-----------------------------------------------------------------------------+-- |+-- Module      : System.Taffybar.Widget.NetworkManager+-- Copyright   : (c) Ivan A. Malison+-- License     : BSD3-style (see LICENSE)+--+-- Maintainer  : Ivan A. Malison+-- Stability   : unstable+-- Portability : unportable+--+-- Network widgets backed by NetworkManager's DBus API.+-----------------------------------------------------------------------------+module System.Taffybar.Widget.NetworkManager+  ( WifiWidgetConfig(..)+  , defaultWifiWidgetConfig+  , networkManagerWifiLabelNew+  , networkManagerWifiLabelNewWith++  , NetworkManagerWifiIconConfig(..)+  , defaultNetworkManagerWifiIconConfig+  , networkManagerWifiIconNew+  , networkManagerWifiIconNewWith++  , networkManagerWifiNew+  , networkManagerWifiNewWith++  -- Wifi text icon (nerd font label)+  , networkManagerWifiTextIconNew+  , networkManagerWifiTextIconNewWith+  -- Wifi combined icon-label+  , networkManagerWifiIconLabelNew+  , networkManagerWifiIconLabelNewWith++  , NetworkWidgetConfig(..)+  , defaultNetworkWidgetConfig+  , networkManagerNetworkLabelNew+  , networkManagerNetworkLabelNewWith++  , NetworkManagerNetworkIconConfig(..)+  , defaultNetworkManagerNetworkIconConfig+  , networkManagerNetworkIconNew+  , networkManagerNetworkIconNewWith++  , networkManagerNetworkNew+  , networkManagerNetworkNewWith++  -- Network text icon (nerd font label)+  , networkManagerNetworkTextIconNew+  , networkManagerNetworkTextIconNewWith+  -- Network combined icon-label+  , networkManagerNetworkIconLabelNew+  , networkManagerNetworkIconLabelNewWith+  ) where++import           Control.Applicative ((<|>))+import           Control.Concurrent.MVar+import           Control.Monad+import           Control.Monad.IO.Class+import           Control.Monad.Trans.Reader+import           Data.Default (Default(..))+import           Data.Int (Int32)+import           Data.IORef (newIORef, readIORef, writeIORef)+import           Data.Maybe (fromMaybe)+import qualified Data.Text as T+import qualified GI.GLib as G+import           GI.Gtk+import           System.Taffybar.Context+import           System.Taffybar.Information.NetworkManager+import           System.Taffybar.Util+import           System.Taffybar.Widget.Generic.ChannelWidget+import           System.Taffybar.Widget.Generic.ScalingImage (scalingImage)+import           System.Taffybar.Widget.Util (buildIconLabelBox)+import           Text.StringTemplate++data WifiWidgetConfig = WifiWidgetConfig+  { wifiConnectedFormat :: String+  , wifiDisconnectedFormat :: String+  , wifiDisabledFormat :: String+  , wifiUnknownFormat :: String+  , wifiTooltipFormat :: Maybe String+  }++defaultWifiWidgetConfig :: WifiWidgetConfig+defaultWifiWidgetConfig =+  WifiWidgetConfig+    { wifiConnectedFormat = "$ssid$ $strength$%"+    , wifiDisconnectedFormat = "disconnected"+    , wifiDisabledFormat = "off"+    , wifiUnknownFormat = "unknown"+    , wifiTooltipFormat =+        Just "SSID: $ssid$\nStrength: $strength$%\nConnection: $connection$\nState: $state$"+    }++instance Default WifiWidgetConfig where+  def = defaultWifiWidgetConfig++networkManagerWifiLabelNew :: TaffyIO Widget+networkManagerWifiLabelNew = networkManagerWifiLabelNewWith defaultWifiWidgetConfig++networkManagerWifiLabelNewWith :: WifiWidgetConfig -> TaffyIO Widget+networkManagerWifiLabelNewWith config = do+  chan <- getWifiInfoChan+  ctx <- ask+  liftIO $ do+    label <- labelNew Nothing+    let updateWidget info = do+          (labelText, tooltipText) <- formatWifiWidget config info+          postGUIASync $ do+            labelSetMarkup label labelText+            widgetSetTooltipMarkup label tooltipText+    void $ onWidgetRealize label $+      runReaderT getWifiInfoState ctx >>= updateWidget+    toWidget =<< channelWidgetNew label chan updateWidget++data NetworkManagerWifiIconConfig = NetworkManagerWifiIconConfig+  { wifiIconNone :: String+  , wifiIconWeak :: String+  , wifiIconOk :: String+  , wifiIconGood :: String+  , wifiIconExcellent :: String+  , wifiIconDisconnected :: String+  , wifiIconDisabled :: String+  , wifiIconUnknown :: String+  , wifiIconTooltipFormat :: Maybe String+  }++defaultNetworkManagerWifiIconConfig :: NetworkManagerWifiIconConfig+defaultNetworkManagerWifiIconConfig =+  NetworkManagerWifiIconConfig+    { wifiIconNone = "network-wireless-signal-none-symbolic"+    , wifiIconWeak = "network-wireless-signal-weak-symbolic"+    , wifiIconOk = "network-wireless-signal-ok-symbolic"+    , wifiIconGood = "network-wireless-signal-good-symbolic"+    , wifiIconExcellent = "network-wireless-signal-excellent-symbolic"+    , wifiIconDisconnected = "network-wireless-offline-symbolic"+    , wifiIconDisabled = "network-wireless-disabled-symbolic"+    , wifiIconUnknown = "network-wireless-symbolic"+    , wifiIconTooltipFormat =+        Just "SSID: $ssid$\nStrength: $strength$%\nConnection: $connection$\nState: $state$"+    }++themeLoadFlags :: [IconLookupFlags]+themeLoadFlags = [IconLookupFlagsGenericFallback, IconLookupFlagsUseBuiltin]++networkManagerWifiIconNew :: TaffyIO Widget+networkManagerWifiIconNew = networkManagerWifiIconNewWith defaultNetworkManagerWifiIconConfig++networkManagerWifiIconNewWith :: NetworkManagerWifiIconConfig -> TaffyIO Widget+networkManagerWifiIconNewWith config = do+  chan <- getWifiInfoChan+  ctx <- ask+  defaultTheme <- liftIO iconThemeGetDefault+  initialInfo <- liftIO $ runReaderT getWifiInfoState ctx+  infoVar <- liftIO $ newMVar initialInfo+  imageWidgetRef <- liftIO $ newIORef (error "imageWidget not initialised")+  let+    setIconForSize size = do+      iw <- readIORef imageWidgetRef+      styleCtx <- widgetGetStyleContext iw+      info <- readMVar infoVar+      let iconNames = wifiIconCandidates config info+      iconInfo <- lookupFirstIcon defaultTheme size iconNames+      traverse (extractPixbuf styleCtx) iconInfo+    extractPixbuf styleCtx iconInfo =+      fst <$> iconInfoLoadSymbolicForContext iconInfo styleCtx+  (imageWidget, updateImage) <- scalingImage setIconForSize OrientationHorizontal+  liftIO $ do+    writeIORef imageWidgetRef imageWidget+    let+      updateWidget info = do+        _ <- swapMVar infoVar info+        (_, tooltipText) <- formatWifiWidget (iconTooltipAsLabelConfig config) info+        postGUIASync $ do+          widgetSetTooltipMarkup imageWidget tooltipText+          updateImage+    void $ onWidgetRealize imageWidget $ updateWidget initialInfo+    toWidget =<< channelWidgetNew imageWidget chan updateWidget++iconTooltipAsLabelConfig :: NetworkManagerWifiIconConfig -> WifiWidgetConfig+iconTooltipAsLabelConfig cfg =+  defaultWifiWidgetConfig { wifiTooltipFormat = wifiIconTooltipFormat cfg }++lookupFirstIcon :: IconTheme -> Int32 -> [String] -> IO (Maybe IconInfo)+lookupFirstIcon _ _ [] = return Nothing+lookupFirstIcon theme size (name:names) = do+  info <- iconThemeLookupIcon theme (T.pack name) size themeLoadFlags+  case info of+    Just _ -> return info+    Nothing -> lookupFirstIcon theme size names++wifiIconCandidates :: NetworkManagerWifiIconConfig -> WifiInfo -> [String]+wifiIconCandidates cfg info =+  case wifiState info of+    WifiDisabled ->+      [ wifiIconDisabled cfg+      , wifiIconDisconnected cfg+      , wifiIconNone cfg+      ]+    WifiDisconnected ->+      [ wifiIconDisconnected cfg+      , wifiIconNone cfg+      ]+    WifiUnknown ->+      [ wifiIconUnknown cfg+      , wifiIconNone cfg+      ]+    WifiConnected ->+      strengthIconName cfg (wifiStrength info) :+      [ wifiIconGood cfg+      , wifiIconOk cfg+      , wifiIconWeak cfg+      , wifiIconNone cfg+      ]++strengthIconName :: NetworkManagerWifiIconConfig -> Maybe Int -> String+strengthIconName cfg strength =+  case strength of+    Nothing -> wifiIconNone cfg+    Just s+      | s < 20 -> wifiIconWeak cfg+      | s < 40 -> wifiIconOk cfg+      | s < 70 -> wifiIconGood cfg+      | otherwise -> wifiIconExcellent cfg++networkManagerWifiNew :: TaffyIO Widget+networkManagerWifiNew = networkManagerWifiNewWith defaultWifiWidgetConfig defaultNetworkManagerWifiIconConfig++networkManagerWifiNewWith+  :: WifiWidgetConfig+  -> NetworkManagerWifiIconConfig+  -> TaffyIO Widget+networkManagerWifiNewWith labelCfg iconCfg = do+  iconWidget <- networkManagerWifiIconNewWith iconCfg+  labelWidget <- networkManagerWifiLabelNewWith labelCfg+  liftIO $ do+    box <- boxNew OrientationHorizontal 0+    containerAdd box iconWidget+    containerAdd box labelWidget+    widgetShowAll box+    toWidget box++formatWifiWidget+  :: WifiWidgetConfig+  -> WifiInfo+  -> IO (T.Text, Maybe T.Text)+formatWifiWidget config info = do+  attrs <- buildAttrs info+  let labelTemplate = case wifiState info of+        WifiConnected -> wifiConnectedFormat config+        WifiDisconnected -> wifiDisconnectedFormat config+        WifiDisabled -> wifiDisabledFormat config+        WifiUnknown -> wifiUnknownFormat config+      labelText = renderTemplate labelTemplate attrs+      tooltipText = fmap (`renderTemplate` attrs) (wifiTooltipFormat config)+  return (T.pack labelText, T.pack <$> tooltipText)++renderTemplate :: String -> [(String, String)] -> String+renderTemplate template attrs = render $ setManyAttrib attrs (newSTMP template)++buildAttrs :: WifiInfo -> IO [(String, String)]+buildAttrs info = do+  let+    displayName =+      fromMaybe "" (wifiSsid info <|> wifiConnectionId info)+    ssidText = if T.null displayName then "unknown" else displayName+    strengthText = maybe "?" show (wifiStrength info)+    stateText = wifiStateText (wifiState info)+    connectionText = fromMaybe "" (wifiConnectionId info)+  ssid <- escapeText ssidText+  strength <- escapeText (T.pack strengthText)+  state <- escapeText (T.pack stateText)+  connection <- escapeText connectionText+  return+    [ ("ssid", ssid)+    , ("strength", strength)+    , ("state", state)+    , ("connection", connection)+    ]++escapeText :: T.Text -> IO String+escapeText input = T.unpack <$> G.markupEscapeText input (-1)+++wifiStateText :: WifiState -> String+wifiStateText WifiDisabled = "disabled"+wifiStateText WifiDisconnected = "disconnected"+wifiStateText WifiConnected = "connected"+wifiStateText WifiUnknown = "unknown"++-- | A text "icon" intended for label widgets. Uses Font Awesome-ish codepoints.+wifiTextIcon :: WifiInfo -> T.Text+wifiTextIcon info =+  case wifiState info of+    WifiConnected ->+      T.pack "\xF1EB" -- +    WifiDisconnected -> T.pack "\xF05E" -- +    WifiDisabled -> T.pack "\xF05E" -- +    WifiUnknown -> T.pack "\xF059" -- ++-- Network (WiFi + wired + vpn + disconnected)++data NetworkWidgetConfig = NetworkWidgetConfig+  { networkWifiFormat :: String+  , networkWiredFormat :: String+  , networkVpnFormat :: String+  , networkOtherFormat :: String+  , networkDisconnectedFormat :: String+  , networkWifiDisabledFormat :: String+  , networkUnknownFormat :: String+  , networkTooltipFormat :: Maybe String+  }++defaultNetworkWidgetConfig :: NetworkWidgetConfig+defaultNetworkWidgetConfig =+  NetworkWidgetConfig+    { networkWifiFormat = "$ssid$ $strength$%"+    , networkWiredFormat = "$connection$"+    , networkVpnFormat = "$connection$"+    , networkOtherFormat = "$type$ $connection$"+    , networkDisconnectedFormat = "disconnected"+    , networkWifiDisabledFormat = "disconnected (wifi off)"+    , networkUnknownFormat = "unknown"+    , networkTooltipFormat =+        Just "Type: $type$\nConnection: $connection$\nSSID: $ssid$\nStrength: $strength$%\nState: $state$"+    }++instance Default NetworkWidgetConfig where+  def = defaultNetworkWidgetConfig++networkManagerNetworkLabelNew :: TaffyIO Widget+networkManagerNetworkLabelNew =+  networkManagerNetworkLabelNewWith defaultNetworkWidgetConfig++networkManagerNetworkLabelNewWith :: NetworkWidgetConfig -> TaffyIO Widget+networkManagerNetworkLabelNewWith config = do+  chan <- getNetworkInfoChan+  ctx <- ask+  liftIO $ do+    label <- labelNew Nothing+    let updateWidget info = do+          (labelText, tooltipText) <- formatNetworkWidget config info+          postGUIASync $ do+            labelSetMarkup label labelText+            widgetSetTooltipMarkup label tooltipText+    void $ onWidgetRealize label $+      runReaderT getNetworkInfoState ctx >>= updateWidget+    toWidget =<< channelWidgetNew label chan updateWidget++data NetworkManagerNetworkIconConfig = NetworkManagerNetworkIconConfig+  { netIconWired :: String+  , netIconVpn :: String+  , netIconOther :: String+  , netIconDisconnected :: String+  , netIconUnknown :: String+  , netIconWifiDisabled :: String+  , netWifiIconNone :: String+  , netWifiIconWeak :: String+  , netWifiIconOk :: String+  , netWifiIconGood :: String+  , netWifiIconExcellent :: String+  , netIconTooltipFormat :: Maybe String+  }++defaultNetworkManagerNetworkIconConfig :: NetworkManagerNetworkIconConfig+defaultNetworkManagerNetworkIconConfig =+  NetworkManagerNetworkIconConfig+    { netIconWired = "network-wired-symbolic"+    , netIconVpn = "network-vpn-symbolic"+    , netIconOther = "network-transmit-receive-symbolic"+    , netIconDisconnected = "network-offline-symbolic"+    , netIconUnknown = "network-error-symbolic"+    , netIconWifiDisabled = "network-wireless-disabled-symbolic"+    , netWifiIconNone = "network-wireless-signal-none-symbolic"+    , netWifiIconWeak = "network-wireless-signal-weak-symbolic"+    , netWifiIconOk = "network-wireless-signal-ok-symbolic"+    , netWifiIconGood = "network-wireless-signal-good-symbolic"+    , netWifiIconExcellent = "network-wireless-signal-excellent-symbolic"+    , netIconTooltipFormat =+        Just "Type: $type$\nConnection: $connection$\nSSID: $ssid$\nStrength: $strength$%\nState: $state$"+    }++networkManagerNetworkIconNew :: TaffyIO Widget+networkManagerNetworkIconNew =+  networkManagerNetworkIconNewWith defaultNetworkManagerNetworkIconConfig++networkManagerNetworkIconNewWith :: NetworkManagerNetworkIconConfig -> TaffyIO Widget+networkManagerNetworkIconNewWith config = do+  chan <- getNetworkInfoChan+  ctx <- ask+  defaultTheme <- liftIO iconThemeGetDefault+  initialInfo <- liftIO $ runReaderT getNetworkInfoState ctx+  infoVar <- liftIO $ newMVar initialInfo+  imageWidgetRef <- liftIO $ newIORef (error "imageWidget not initialised")+  let+    setIconForSize size = do+      iw <- readIORef imageWidgetRef+      styleCtx <- widgetGetStyleContext iw+      info <- readMVar infoVar+      let iconNames = networkIconCandidates config info+      iconInfo <- lookupFirstIcon defaultTheme size iconNames+      traverse (extractPixbuf styleCtx) iconInfo+    extractPixbuf styleCtx iconInfo =+      fst <$> iconInfoLoadSymbolicForContext iconInfo styleCtx+  (imageWidget, updateImage) <- scalingImage setIconForSize OrientationHorizontal+  liftIO $ do+    writeIORef imageWidgetRef imageWidget+    let+      updateWidget info = do+        _ <- swapMVar infoVar info+        (_, tooltipText) <- formatNetworkWidget (iconTooltipAsNetworkLabelConfig config) info+        postGUIASync $ do+          widgetSetTooltipMarkup imageWidget tooltipText+          updateImage+    void $ onWidgetRealize imageWidget $ updateWidget initialInfo+    toWidget =<< channelWidgetNew imageWidget chan updateWidget++iconTooltipAsNetworkLabelConfig :: NetworkManagerNetworkIconConfig -> NetworkWidgetConfig+iconTooltipAsNetworkLabelConfig cfg =+  defaultNetworkWidgetConfig { networkTooltipFormat = netIconTooltipFormat cfg }++networkIconCandidates :: NetworkManagerNetworkIconConfig -> NetworkInfo -> [String]+networkIconCandidates cfg info =+  case networkState info of+    NetworkUnknown ->+      [ netIconUnknown cfg+      , netIconOther cfg+      , netIconDisconnected cfg+      ]+    NetworkDisconnected ->+      case networkWirelessEnabled info of+        Just False ->+          [ netIconWifiDisabled cfg+          , netIconDisconnected cfg+          ]+        _ ->+          [ netIconDisconnected cfg+          , netIconOther cfg+          ]+    NetworkConnected ->+      case networkType info of+        Just NetworkWired ->+          [ netIconWired cfg+          , netIconOther cfg+          ]+        Just NetworkVpn ->+          [ netIconVpn cfg+          , netIconOther cfg+          ]+        Just NetworkWifi ->+          strengthToWifiIcon cfg (networkStrength info) :+          [ netWifiIconGood cfg+          , netWifiIconOk cfg+          , netWifiIconWeak cfg+          , netWifiIconNone cfg+          ]+        Just (NetworkOther _) ->+          [ netIconOther cfg+          , netIconWired cfg+          ]+        Nothing ->+          [ netIconOther cfg+          , netIconWired cfg+          , netIconDisconnected cfg+          ]++strengthToWifiIcon :: NetworkManagerNetworkIconConfig -> Maybe Int -> String+strengthToWifiIcon cfg strength =+  case strength of+    Nothing -> netWifiIconNone cfg+    Just s+      | s < 20 -> netWifiIconWeak cfg+      | s < 40 -> netWifiIconOk cfg+      | s < 70 -> netWifiIconGood cfg+      | otherwise -> netWifiIconExcellent cfg++networkManagerNetworkNew :: TaffyIO Widget+networkManagerNetworkNew =+  networkManagerNetworkNewWith defaultNetworkWidgetConfig defaultNetworkManagerNetworkIconConfig++networkManagerNetworkNewWith+  :: NetworkWidgetConfig+  -> NetworkManagerNetworkIconConfig+  -> TaffyIO Widget+networkManagerNetworkNewWith labelCfg iconCfg = do+  iconWidget <- networkManagerNetworkIconNewWith iconCfg+  labelWidget <- networkManagerNetworkLabelNewWith labelCfg+  liftIO $ do+    box <- boxNew OrientationHorizontal 0+    containerAdd box iconWidget+    containerAdd box labelWidget+    widgetShowAll box+    toWidget box++formatNetworkWidget+  :: NetworkWidgetConfig+  -> NetworkInfo+  -> IO (T.Text, Maybe T.Text)+formatNetworkWidget config info = do+  attrs <- buildNetworkAttrs info+  let labelTemplate =+        case networkState info of+          NetworkConnected ->+            case networkType info of+              Just NetworkWifi -> networkWifiFormat config+              Just NetworkWired -> networkWiredFormat config+              Just NetworkVpn -> networkVpnFormat config+              Just (NetworkOther _) -> networkOtherFormat config+              Nothing -> networkOtherFormat config+          NetworkDisconnected ->+            case networkWirelessEnabled info of+              Just False -> networkWifiDisabledFormat config+              _ -> networkDisconnectedFormat config+          NetworkUnknown -> networkUnknownFormat config+      labelText = renderTemplate labelTemplate attrs+      tooltipText = fmap (`renderTemplate` attrs) (networkTooltipFormat config)+  return (T.pack labelText, T.pack <$> tooltipText)++buildNetworkAttrs :: NetworkInfo -> IO [(String, String)]+buildNetworkAttrs info = do+  let+    rawConnText = fromMaybe "" (networkConnectionId info)+    connText = if T.null rawConnText then "unknown" else rawConnText+    typeText = networkTypeText (networkType info)+    displaySsid = fromMaybe "" (networkSsid info)+    ssidText = if T.null displaySsid then "unknown" else displaySsid+    strengthText = maybe "?" show (networkStrength info)+    stateText = networkStateText (networkState info)+  conn <- escapeText connText+  typ <- escapeText typeText+  ssid <- escapeText ssidText+  strength <- escapeText (T.pack strengthText)+  state <- escapeText (T.pack stateText)+  return+    [ ("connection", conn)+    , ("type", typ)+    , ("ssid", ssid)+    , ("strength", strength)+    , ("state", state)+    ]++networkTypeText :: Maybe NetworkType -> T.Text+networkTypeText Nothing = "unknown"+networkTypeText (Just NetworkWifi) = "wifi"+networkTypeText (Just NetworkWired) = "wired"+networkTypeText (Just NetworkVpn) = "vpn"+networkTypeText (Just (NetworkOther t)) = t++networkStateText :: NetworkState -> String+networkStateText NetworkConnected = "connected"+networkStateText NetworkDisconnected = "disconnected"+networkStateText NetworkUnknown = "unknown"++networkTextIcon :: NetworkInfo -> T.Text+networkTextIcon info =+  case networkState info of+    NetworkUnknown -> T.pack "\xF059" -- +    NetworkDisconnected ->+      case networkWirelessEnabled info of+        Just False -> T.pack "\xF05E\xF1EB" --  (wifi off-ish)+        _ -> T.pack "\xF05E" -- +    NetworkConnected ->+      case networkType info of+        Just NetworkWifi ->+          T.pack "\xF1EB" -- +        Just NetworkWired -> T.pack "\xF1E6" -- +        Just NetworkVpn -> T.pack "\xF023" -- +        Just (NetworkOther _) -> T.pack "\xF0AC" -- +        Nothing -> T.pack "\xF0AC" -- ++-- Wifi text icon++networkManagerWifiTextIconNew :: TaffyIO Widget+networkManagerWifiTextIconNew =+  networkManagerWifiTextIconNewWith defaultWifiWidgetConfig++networkManagerWifiTextIconNewWith :: WifiWidgetConfig -> TaffyIO Widget+networkManagerWifiTextIconNewWith _config = do+  chan <- getWifiInfoChan+  ctx <- ask+  liftIO $ do+    label <- labelNew Nothing+    let updateIcon info = do+          let iconText = wifiTextIcon info+          postGUIASync $ labelSetText label iconText+    void $ onWidgetRealize label $+      runReaderT getWifiInfoState ctx >>= updateIcon+    toWidget =<< channelWidgetNew label chan updateIcon++-- Wifi icon-label++networkManagerWifiIconLabelNew :: TaffyIO Widget+networkManagerWifiIconLabelNew =+  networkManagerWifiIconLabelNewWith defaultWifiWidgetConfig++networkManagerWifiIconLabelNewWith :: WifiWidgetConfig -> TaffyIO Widget+networkManagerWifiIconLabelNewWith config = do+  iconWidget <- networkManagerWifiTextIconNewWith config+  labelWidget <- networkManagerWifiLabelNewWith config+  liftIO $ buildIconLabelBox iconWidget labelWidget++-- Network text icon++networkManagerNetworkTextIconNew :: TaffyIO Widget+networkManagerNetworkTextIconNew =+  networkManagerNetworkTextIconNewWith defaultNetworkWidgetConfig++networkManagerNetworkTextIconNewWith :: NetworkWidgetConfig -> TaffyIO Widget+networkManagerNetworkTextIconNewWith _config = do+  chan <- getNetworkInfoChan+  ctx <- ask+  liftIO $ do+    label <- labelNew Nothing+    let updateIcon info = do+          let iconText = networkTextIcon info+          postGUIASync $ labelSetText label iconText+    void $ onWidgetRealize label $+      runReaderT getNetworkInfoState ctx >>= updateIcon+    toWidget =<< channelWidgetNew label chan updateIcon++-- Network icon-label++networkManagerNetworkIconLabelNew :: TaffyIO Widget+networkManagerNetworkIconLabelNew =+  networkManagerNetworkIconLabelNewWith defaultNetworkWidgetConfig++networkManagerNetworkIconLabelNewWith :: NetworkWidgetConfig -> TaffyIO Widget+networkManagerNetworkIconLabelNewWith config = do+  iconWidget <- networkManagerNetworkTextIconNewWith config+  labelWidget <- networkManagerNetworkLabelNewWith config+  liftIO $ buildIconLabelBox iconWidget labelWidget
+ src/System/Taffybar/Widget/PowerProfiles.hs view
@@ -0,0 +1,233 @@+{-# LANGUAGE OverloadedStrings #-}+-----------------------------------------------------------------------------+-- |+-- Module      : System.Taffybar.Widget.PowerProfiles+-- Copyright   : (c) Ivan A. Malison+-- License     : BSD3-style (see LICENSE)+--+-- Maintainer  : Ivan A. Malison+-- Stability   : unstable+-- Portability : unportable+--+-- This module provides widgets for displaying and controlling the current+-- power profile using the power-profiles-daemon DBus service.+--+-- Three widget variants are provided:+--+--   * 'powerProfilesIconNew' -- a dynamic nerd-font text icon+--   * 'powerProfilesLabelNew' -- a text label showing the profile name+--   * 'powerProfilesNew' -- combined icon + label+--+-- All variants cycle through profiles on left-click.+-----------------------------------------------------------------------------+module System.Taffybar.Widget.PowerProfiles+  ( PowerProfilesConfig(..)+  , defaultPowerProfilesConfig+  , powerProfilesIconNew+  , powerProfilesIconNewWithConfig+  , powerProfilesLabelNew+  , powerProfilesLabelNewWithConfig+  , powerProfilesNew+  , powerProfilesNewWithConfig+  ) where++import           Control.Monad+import           Control.Monad.IO.Class+import           Control.Monad.Trans.Reader+import           Data.Default (Default(..))+import qualified Data.Text as T+import qualified GI.Gdk as Gdk+import qualified GI.Gtk as Gtk+import           System.Log.Logger+import           System.Taffybar.Context+import           System.Taffybar.Information.PowerProfiles+import           System.Taffybar.Util (postGUIASync, logPrintF)+import           System.Taffybar.Widget.Generic.ChannelWidget+import           System.Taffybar.Widget.Util (buildIconLabelBox)++-- | Configuration for the power profiles widget.+data PowerProfilesConfig = PowerProfilesConfig+  { -- | Format string for the label. Use @$profile$@ for the profile name.+    powerProfilesFormat :: String+    -- | Nerd font text icon for power-saver mode (default U+F06C9, nf-md-leaf).+  , powerProfilesPowerSaverTextIcon :: T.Text+    -- | Nerd font text icon for balanced mode (default U+F0A7A, nf-md-scale_balance).+  , powerProfilesBalancedTextIcon :: T.Text+    -- | Nerd font text icon for performance mode (default U+F0E4E, nf-md-rocket_launch).+  , powerProfilesPerformanceTextIcon :: T.Text+  } deriving (Eq, Show)++-- | Default configuration for the power profiles widget.+defaultPowerProfilesConfig :: PowerProfilesConfig+defaultPowerProfilesConfig = PowerProfilesConfig+  { powerProfilesFormat = "$profile$"+  , powerProfilesPowerSaverTextIcon = T.pack "\xF06C9"+  , powerProfilesBalancedTextIcon = T.pack "\xF0A7A"+  , powerProfilesPerformanceTextIcon = T.pack "\xF0E4E"+  }++instance Default PowerProfilesConfig where+  def = defaultPowerProfilesConfig++powerProfilesLogPath :: String+powerProfilesLogPath = "System.Taffybar.Widget.PowerProfiles"++powerProfilesLogF :: (MonadIO m, Show t) => Priority -> String -> t -> m ()+powerProfilesLogF = logPrintF powerProfilesLogPath++-- ---------------------------------------------------------------------------+-- Icon-only widget (dynamic nerd font text icon)++-- | Create a power profiles icon widget with default configuration.+powerProfilesIconNew :: TaffyIO Gtk.Widget+powerProfilesIconNew = powerProfilesIconNewWithConfig defaultPowerProfilesConfig++-- | Create a power profiles icon widget with custom configuration.+--+-- The icon is a nerd-font text label that updates dynamically when the+-- active profile changes. CSS classes @power-saver@, @balanced@, and+-- @performance@ are toggled on the label.+powerProfilesIconNewWithConfig :: PowerProfilesConfig -> TaffyIO Gtk.Widget+powerProfilesIconNewWithConfig config = do+  chan <- getPowerProfileInfoChan+  ctx <- ask+  liftIO $ do+    label <- Gtk.labelNew Nothing+    let updateIcon info = postGUIASync $ do+          let iconText = getTextIcon config (currentProfile info)+          Gtk.labelSetText label iconText+          updateProfileClasses label info+    void $ Gtk.onWidgetRealize label $ do+      initialInfo <- runReaderT getPowerProfileInfoState ctx+      updateIcon initialInfo+    Gtk.widgetShowAll label+    Gtk.toWidget =<< channelWidgetNew label chan updateIcon++-- ---------------------------------------------------------------------------+-- Label-only widget (text label with format string)++-- | Create a power profiles label widget with default configuration.+powerProfilesLabelNew :: TaffyIO Gtk.Widget+powerProfilesLabelNew = powerProfilesLabelNewWithConfig defaultPowerProfilesConfig++-- | Create a power profiles label widget with custom configuration.+--+-- The label displays the profile name formatted via 'powerProfilesFormat'.+-- CSS classes @power-saver@, @balanced@, and @performance@ are toggled on+-- the label.+powerProfilesLabelNewWithConfig :: PowerProfilesConfig -> TaffyIO Gtk.Widget+powerProfilesLabelNewWithConfig config = do+  chan <- getPowerProfileInfoChan+  ctx <- ask+  liftIO $ do+    label <- Gtk.labelNew Nothing+    let updateLabel info = postGUIASync $ do+          let profileName = T.unpack $ powerProfileToString (currentProfile info)+              labelText = formatLabel (powerProfilesFormat config) profileName+          Gtk.labelSetMarkup label (T.pack labelText)+          updateProfileClasses label info+    void $ Gtk.onWidgetRealize label $ do+      initialInfo <- runReaderT getPowerProfileInfoState ctx+      updateLabel initialInfo+    Gtk.widgetShowAll label+    Gtk.toWidget =<< channelWidgetNew label chan updateLabel++-- ---------------------------------------------------------------------------+-- Combined icon + label widget++-- | Create a combined icon + label power profiles widget with default+-- configuration.+powerProfilesNew :: TaffyIO Gtk.Widget+powerProfilesNew = powerProfilesNewWithConfig defaultPowerProfilesConfig++-- | Create a combined icon + label power profiles widget.+--+-- Wraps the icon and label in a horizontal box (via 'buildIconLabelBox')+-- inside an event box with click-to-cycle and tooltip. CSS classes+-- @power-profiles@, @power-saver@, @balanced@, and @performance@ are+-- applied to the event box.+powerProfilesNewWithConfig :: PowerProfilesConfig -> TaffyIO Gtk.Widget+powerProfilesNewWithConfig config = do+  chan <- getPowerProfileInfoChan+  ctx <- ask++  iconWidget <- powerProfilesIconNewWithConfig config+  labelWidget <- powerProfilesLabelNewWithConfig config++  liftIO $ do+    box <- buildIconLabelBox iconWidget labelWidget+    ebox <- Gtk.eventBoxNew+    Gtk.containerAdd ebox box+    styleCtx <- Gtk.widgetGetStyleContext ebox+    Gtk.styleContextAddClass styleCtx "power-profiles"++    let updateWidget info = postGUIASync $ do+          updateProfileClasses ebox info+          updateTooltip ebox info++    void $ Gtk.onWidgetRealize ebox $ do+      initialInfo <- runReaderT getPowerProfileInfoState ctx+      updateWidget initialInfo++    setupClickHandler ctx ebox+    Gtk.widgetShowAll ebox+    Gtk.toWidget =<< channelWidgetNew ebox chan updateWidget++-- ---------------------------------------------------------------------------+-- Helpers++-- | Select the nerd font text icon for a given profile.+getTextIcon :: PowerProfilesConfig -> PowerProfile -> T.Text+getTextIcon config PowerSaver = powerProfilesPowerSaverTextIcon config+getTextIcon config Balanced = powerProfilesBalancedTextIcon config+getTextIcon config Performance = powerProfilesPerformanceTextIcon config++-- | Format the label string, replacing @$profile$@ with the profile name.+formatLabel :: String -> String -> String+formatLabel fmt profile = replace "$profile$" profile fmt+  where+    replace :: String -> String -> String -> String+    replace old new = T.unpack . T.replace (T.pack old) (T.pack new) . T.pack++-- | Update CSS classes based on the current profile. Works with any widget.+updateProfileClasses :: Gtk.IsWidget w => w -> PowerProfileInfo -> IO ()+updateProfileClasses widget info = do+  let profile = currentProfile info+      allClasses = ["power-saver", "balanced", "performance"]+      currentClass = case profile of+        PowerSaver -> "power-saver"+        Balanced -> "balanced"+        Performance -> "performance"+  styleCtx <- Gtk.widgetGetStyleContext widget+  mapM_ (Gtk.styleContextRemoveClass styleCtx) allClasses+  Gtk.styleContextAddClass styleCtx currentClass++-- | Update tooltip with current profile info.+updateTooltip :: Gtk.IsWidget w => w -> PowerProfileInfo -> IO ()+updateTooltip widget info = do+  let profile = currentProfile info+      profileName = powerProfileToString profile+      degradedText = case performanceDegraded info of+        Nothing -> ""+        Just reason -> "\nPerformance degraded: " <> reason+      tooltipText = "Power Profile: " <> profileName <> degradedText+  Gtk.widgetSetTooltipText widget (Just tooltipText)++-- | Set up click handler to cycle profiles on left-click.+setupClickHandler :: Context -> Gtk.EventBox -> IO ()+setupClickHandler ctx ebox = do+  void $ Gtk.onWidgetButtonPressEvent ebox $ \event -> do+    button <- Gdk.getEventButtonButton event+    eventType <- Gdk.getEventButtonType event+    if eventType == Gdk.EventTypeButtonPress && button == 1+      then do+        info <- runReaderT getPowerProfileInfoState ctx+        let client = systemDBusClient ctx+        result <- cycleProfile client info+        case result of+          Left err ->+            powerProfilesLogF WARNING "Failed to cycle power profile: %s" (show err)+          Right () ->+            return ()+        return True+      else return False
+ src/System/Taffybar/Widget/Privacy.hs view
@@ -0,0 +1,203 @@+{-# LANGUAGE OverloadedStrings #-}++-----------------------------------------------------------------------------+-- |+-- Module      : System.Taffybar.Widget.Privacy+-- Copyright   : (c) Ivan A. Malison+-- License     : BSD3-style (see LICENSE)+--+-- Maintainer  : Ivan A. Malison+-- Stability   : unstable+-- Portability : unportable+--+-- Privacy indicator widget for taffybar.+--+-- Shows icons when microphone, camera, or screen sharing is active.+-- The widget is hidden when no privacy-relevant streams are active.+--+-- Example usage:+--+-- @+-- import System.Taffybar.Widget.Privacy+--+-- myConfig = defaultSimpleTaffyConfig+--   { endWidgets = [ privacyNew ]+--   }+-- @+--+-- CSS classes:+--+-- * @.privacy-widget@ - The main container+-- * @.privacy-audio-input@ - Audio input (microphone) icon+-- * @.privacy-audio-output@ - Audio output icon+-- * @.privacy-video-input@ - Video input (camera/screen share) icon+--+-----------------------------------------------------------------------------++module System.Taffybar.Widget.Privacy+  ( -- * Widget constructors+    privacyNew+  , privacyNewWith+    -- * Configuration+  , PrivacyWidgetConfig(..)+  , defaultPrivacyWidgetConfig+    -- * Re-exports+  , PrivacyConfig(..)+  , defaultPrivacyConfig+  ) where++import Control.Concurrent (forkIO)+import Control.Concurrent.STM.TChan+import Control.Monad (void, when)+import Control.Monad.IO.Class (liftIO)+import Control.Monad.STM (atomically)+import Data.Default (Default(..))+import Data.Int (Int32)+import Data.List (intercalate)+import Data.Maybe (catMaybes)+import qualified Data.Text as T+import qualified GI.Gtk as Gtk+import System.Taffybar.Context (TaffyIO)+import System.Taffybar.Information.Privacy+  ( PrivacyConfig(..)+  , PrivacyInfo(..)+  , PrivacyNode(..)+  , NodeType(..)+  , defaultPrivacyConfig+  , getPrivacyInfoChan+  , getPrivacyInfoState+  )+import System.Taffybar.Util (postGUIASync)+import System.Taffybar.Widget.Util (widgetSetClassGI)++-- | Configuration for the privacy widget.+data PrivacyWidgetConfig = PrivacyWidgetConfig+  { privacyWidgetConfig :: PrivacyConfig+    -- ^ Underlying privacy monitoring configuration+  , audioInputIcon :: T.Text+    -- ^ Icon name for microphone+  , audioOutputIcon :: T.Text+    -- ^ Icon name for audio output+  , videoInputIcon :: T.Text+    -- ^ Icon name for camera/screen share+  , privacyIconSize :: Int32+    -- ^ Size of the icons (as Int32 for GTK)+  , privacySpacing :: Int+    -- ^ Spacing between icons+  } deriving (Eq, Show)++-- | Default privacy widget configuration.+defaultPrivacyWidgetConfig :: PrivacyWidgetConfig+defaultPrivacyWidgetConfig = PrivacyWidgetConfig+  { privacyWidgetConfig = defaultPrivacyConfig+  , audioInputIcon = "audio-input-microphone-symbolic"+  , audioOutputIcon = "audio-speakers-symbolic"+  , videoInputIcon = "camera-video-symbolic"+  , privacyIconSize = fromIntegral $ fromEnum Gtk.IconSizeMenu+  , privacySpacing = 4+  }++instance Default PrivacyWidgetConfig where+  def = defaultPrivacyWidgetConfig++-- | Create a privacy indicator widget with default configuration.+privacyNew :: TaffyIO Gtk.Widget+privacyNew = privacyNewWith defaultPrivacyWidgetConfig++-- | Create a privacy indicator widget with custom configuration.+privacyNewWith :: PrivacyWidgetConfig -> TaffyIO Gtk.Widget+privacyNewWith config = do+  chan <- getPrivacyInfoChan (privacyWidgetConfig config)+  initialInfo <- getPrivacyInfoState (privacyWidgetConfig config)++  liftIO $ do+    -- Create main container box+    box <- Gtk.boxNew Gtk.OrientationHorizontal (fromIntegral $ privacySpacing config)+    _ <- widgetSetClassGI box "privacy-widget"++    -- Create icons for each type (initially hidden)+    audioInImage <- createIcon (audioInputIcon config) (privacyIconSize config)+    audioOutImage <- createIcon (audioOutputIcon config) (privacyIconSize config)+    videoInImage <- createIcon (videoInputIcon config) (privacyIconSize config)++    _ <- widgetSetClassGI audioInImage "privacy-audio-input"+    _ <- widgetSetClassGI audioOutImage "privacy-audio-output"+    _ <- widgetSetClassGI videoInImage "privacy-video-input"++    -- Add icons to box+    Gtk.containerAdd box audioInImage+    Gtk.containerAdd box audioOutImage+    Gtk.containerAdd box videoInImage++    -- Create a revealer to control visibility with animation+    revealer <- Gtk.revealerNew+    Gtk.revealerSetTransitionType revealer Gtk.RevealerTransitionTypeSlideLeft+    Gtk.revealerSetTransitionDuration revealer 200+    Gtk.containerAdd revealer box++    -- Update function+    let updateWidget info = postGUIASync $ do+          let nodes = activeNodes info+              hasAudioIn = any ((== AudioInput) . nodeType) nodes+              hasAudioOut = any ((== AudioOutput) . nodeType) nodes+              hasVideoIn = any ((== VideoInput) . nodeType) nodes+              hasAny = hasAudioIn || hasAudioOut || hasVideoIn++          -- Show/hide individual icons+          Gtk.widgetSetVisible audioInImage hasAudioIn+          Gtk.widgetSetVisible audioOutImage hasAudioOut+          Gtk.widgetSetVisible videoInImage hasVideoIn++          -- Show/hide the whole widget+          Gtk.revealerSetRevealChild revealer hasAny++          -- Update tooltip+          when hasAny $ do+            let tooltipText = buildTooltip nodes+            Gtk.widgetSetTooltipText box (Just $ T.pack tooltipText)++    -- Initial update+    updateWidget initialInfo++    -- Connect to channel updates+    void $ Gtk.onWidgetRealize 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 ()++    Gtk.widgetShowAll revealer+    Gtk.toWidget revealer++-- | Create an icon image.+createIcon :: T.Text -> Int32 -> IO Gtk.Image+createIcon iconName size = do+  image <- Gtk.imageNewFromIconName (Just iconName) size+  Gtk.widgetSetVisible image False+  return image++-- | Build tooltip text from active nodes.+buildTooltip :: [PrivacyNode] -> String+buildTooltip nodes =+  let audioInNodes = filter ((== AudioInput) . nodeType) nodes+      audioOutNodes = filter ((== AudioOutput) . nodeType) nodes+      videoInNodes = filter ((== VideoInput) . nodeType) nodes++      formatSection :: String -> [PrivacyNode] -> Maybe String+      formatSection title ns+        | null ns = Nothing+        | otherwise = Just $ title ++ ":\n" ++ unlines (map formatNode ns)++      formatNode n = "  - " ++ T.unpack (appName n)++      sections = catMaybes+        [ formatSection "Microphone" audioInNodes+        , formatSection "Camera/Screen" videoInNodes+        , formatSection "Audio Output" audioOutNodes+        ]+  in intercalate "\n" sections
+ src/System/Taffybar/Widget/PulseAudio.hs view
@@ -0,0 +1,212 @@+{-# LANGUAGE OverloadedStrings #-}+-----------------------------------------------------------------------------+-- |+-- Module      : System.Taffybar.Widget.PulseAudio+-- Copyright   : (c) Ivan A. Malison+-- License     : BSD3-style (see LICENSE)+--+-- Maintainer  : Ivan A. Malison+-- Stability   : unstable+-- Portability : unportable+--+-- Simple volume widget using PulseAudio's DBus interface.+--+-- Note: PulseAudio's DBus socket is not always enabled by default.+-- If the widget shows "vol: n/a", ensure the PulseAudio server has loaded+-- @module-dbus-protocol@ (so @/run/user/$UID/pulse/dbus-socket@ exists).+-----------------------------------------------------------------------------++module System.Taffybar.Widget.PulseAudio+  ( PulseAudioWidgetConfig(..)+  , defaultPulseAudioWidgetConfig+  , pulseAudioIconNew+  , pulseAudioIconNewWith+  , pulseAudioLabelNew+  , pulseAudioLabelNewWith+  , pulseAudioNew+  , pulseAudioNewWith+  ) where++import Control.Concurrent.MVar (readMVar)+import Control.Monad (void, when)+import Control.Monad.IO.Class+import Data.Default (Default(..))+import qualified Data.Text as T+import qualified GI.Gdk.Enums as Gdk+import qualified GI.Gdk.Structs.EventScroll as GdkEvent+import qualified GI.GLib as G+import qualified GI.Gtk as Gtk+import System.Taffybar.Context (TaffyIO)+import System.Taffybar.Information.PulseAudio+import System.Taffybar.Util (postGUIASync)+import System.Taffybar.Widget.Generic.ChannelWidget+import System.Taffybar.Widget.Util (buildIconLabelBox)+import Text.StringTemplate++data PulseAudioWidgetConfig = PulseAudioWidgetConfig+  { pulseAudioSink :: String+  , pulseAudioFormat :: String+  , pulseAudioMuteFormat :: String+  , pulseAudioUnknownFormat :: String+  , pulseAudioTooltipFormat :: Maybe String+  , pulseAudioScrollStepPercent :: Maybe Int+  , pulseAudioToggleMuteOnClick :: Bool+  }++defaultPulseAudioWidgetConfig :: PulseAudioWidgetConfig+defaultPulseAudioWidgetConfig =+  PulseAudioWidgetConfig+    { pulseAudioSink = "@DEFAULT_SINK@"+    , pulseAudioFormat = "$volume$%"+    , pulseAudioMuteFormat = "muted"+    , pulseAudioUnknownFormat = "n/a"+    , pulseAudioTooltipFormat =+        Just "Sink: $sink$\nVolume: $volume$%\nMuted: $muted$"+    , pulseAudioScrollStepPercent = Just 5+    , pulseAudioToggleMuteOnClick = True+    }++instance Default PulseAudioWidgetConfig where+  def = defaultPulseAudioWidgetConfig++pulseAudioIconNew :: TaffyIO Gtk.Widget+pulseAudioIconNew = pulseAudioIconNewWith defaultPulseAudioWidgetConfig++pulseAudioIconNewWith :: PulseAudioWidgetConfig -> TaffyIO Gtk.Widget+pulseAudioIconNewWith config = do+  let sinkSpec = pulseAudioSink config+  (chan, var) <- getPulseAudioInfoChanAndVar sinkSpec+  liftIO $ do+    label <- Gtk.labelNew Nothing+    let updateIcon info = do+          let iconText = case info of+                Nothing -> T.pack "\xF026"+                Just i -> pulseAudioTextIcon (pulseAudioMuted i) (pulseAudioVolumePercent i)+          postGUIASync $ Gtk.labelSetText label iconText+    void $ Gtk.onWidgetRealize label $ readMVar var >>= updateIcon+    Gtk.widgetShowAll label+    Gtk.toWidget =<< channelWidgetNew label chan updateIcon++pulseAudioLabelNew :: TaffyIO Gtk.Widget+pulseAudioLabelNew = pulseAudioLabelNewWith defaultPulseAudioWidgetConfig++pulseAudioLabelNewWith :: PulseAudioWidgetConfig -> TaffyIO Gtk.Widget+pulseAudioLabelNewWith config = do+  let sinkSpec = pulseAudioSink config+  (chan, var) <- getPulseAudioInfoChanAndVar sinkSpec++  liftIO $ do+    label <- Gtk.labelNew Nothing++    let+      updateLabel info = do+        (labelText, tooltipText) <- formatPulseAudioWidget config info+        postGUIASync $ do+          Gtk.labelSetMarkup label labelText+          Gtk.widgetSetTooltipMarkup label tooltipText++      refreshNow = getPulseAudioInfo sinkSpec >>= updateLabel++      whenToggleMute widget =+        when (pulseAudioToggleMuteOnClick config) $+          void $ Gtk.onWidgetButtonPressEvent widget $ \_ -> do+            void $ togglePulseAudioMute sinkSpec+            refreshNow+            return True++      whenScrollAdjust widget =+        case pulseAudioScrollStepPercent config of+          Nothing -> return ()+          Just step | step <= 0 -> return ()+          Just step -> do+            _ <- Gtk.onWidgetScrollEvent widget $ \scrollEvent -> do+              dir <- GdkEvent.getEventScrollDirection scrollEvent+              let doAdjust delta = do+                    void $ adjustPulseAudioVolume sinkSpec delta+                    refreshNow+                    return True+              case dir of+                Gdk.ScrollDirectionUp -> doAdjust step+                Gdk.ScrollDirectionDown -> doAdjust (-step)+                Gdk.ScrollDirectionLeft -> doAdjust step+                Gdk.ScrollDirectionRight -> doAdjust (-step)+                _ -> return False+            return ()++    void $ Gtk.onWidgetRealize label $ readMVar var >>= updateLabel++    whenToggleMute label+    whenScrollAdjust label++    Gtk.widgetShowAll label+    Gtk.toWidget =<< channelWidgetNew label chan updateLabel++pulseAudioNew :: TaffyIO Gtk.Widget+pulseAudioNew = pulseAudioNewWith defaultPulseAudioWidgetConfig++pulseAudioNewWith :: PulseAudioWidgetConfig -> TaffyIO Gtk.Widget+pulseAudioNewWith config = do+  iconWidget <- pulseAudioIconNewWith config+  labelWidget <- pulseAudioLabelNewWith config+  liftIO $ buildIconLabelBox iconWidget labelWidget++formatPulseAudioWidget+  :: PulseAudioWidgetConfig+  -> Maybe PulseAudioInfo+  -> IO (T.Text, Maybe T.Text)+formatPulseAudioWidget config info = do+  attrs <- maybe buildUnknownAttrs buildAttrs info+  let+    labelTemplate =+      case info of+        Nothing -> pulseAudioUnknownFormat config+        Just audio ->+          case pulseAudioMuted audio of+            Just True -> pulseAudioMuteFormat config+            _ -> pulseAudioFormat config+    labelText = renderTemplate labelTemplate attrs+    tooltipText = fmap (`renderTemplate` attrs) (pulseAudioTooltipFormat config)+  return (T.pack labelText, T.pack <$> tooltipText)++buildAttrs :: PulseAudioInfo -> IO [(String, String)]+buildAttrs info = do+  let+    volumeText = maybe "?" show (pulseAudioVolumePercent info)+    mutedText = case pulseAudioMuted info of+      Just True -> "yes"+      Just False -> "no"+      Nothing -> "unknown"+    sinkText = pulseAudioSinkName info+  volume <- escapeText $ T.pack volumeText+  muted <- escapeText $ T.pack mutedText+  sink <- escapeText $ T.pack sinkText+  return+    [ ("volume", volume)+    , ("muted", muted)+    , ("sink", sink)+    ]++buildUnknownAttrs :: IO [(String, String)]+buildUnknownAttrs =+  return+    [ ("volume", "?")+    , ("muted", "unknown")+    , ("sink", "unknown")+    ]++pulseAudioTextIcon :: Maybe Bool -> Maybe Int -> T.Text+pulseAudioTextIcon muted volumePercent =+  case muted of+    Just True -> T.pack "\xF026" --+    _ ->+      case volumePercent of+        Just v | v <= 0 -> T.pack "\xF026" --+        Just v | v <= 33 -> T.pack "\xF027" --+        Just _ -> T.pack "\xF028" --+        Nothing -> T.pack "\xF028" --++renderTemplate :: String -> [(String, String)] -> String+renderTemplate template attrs = render $ setManyAttrib attrs (newSTMP template)++escapeText :: T.Text -> IO String+escapeText input = T.unpack <$> G.markupEscapeText input (-1)
+ src/System/Taffybar/Widget/SNIMenu.hs view
@@ -0,0 +1,63 @@+{-# LANGUAGE OverloadedStrings #-}+module System.Taffybar.Widget.SNIMenu+  ( withSniMenu+  , withNmAppletMenu+  ) where++import Control.Exception.Enclosed (catchAny)+import Control.Monad (void)+import Control.Monad.IO.Class (liftIO)+import Control.Monad.Trans.Reader (ask)+import DBus (BusName, ObjectPath)+import qualified GI.Gdk as Gdk (getEventButtonButton, getEventButtonType, EventType(..))+import qualified GI.GLib as GLib+import qualified GI.Gtk as Gtk+import qualified DBusMenu+import System.Log.Logger (Priority(..), logM)+import System.Taffybar.Context (Context(..), TaffyIO)+import Text.Printf (printf)++sniMenuLogger :: Priority -> String -> IO ()+sniMenuLogger = logM "System.Taffybar.Widget.SNIMenu"++-- | Wrap any widget so that clicking it pops up an SNI application's+-- DBusMenu.  The menu is built on each click via+-- 'StatusNotifier.DBusMenu.buildMenu' and destroyed when hidden.+withSniMenu :: BusName -> ObjectPath -> TaffyIO Gtk.Widget -> TaffyIO Gtk.Widget+withSniMenu busName menuPath mkWidget = do+  ctx <- ask+  inner <- mkWidget+  liftIO $ do+    ebox <- Gtk.eventBoxNew+    Gtk.containerAdd ebox inner++    _ <- Gtk.onWidgetButtonPressEvent ebox $ \event -> do+      eventType <- Gdk.getEventButtonType event+      button <- Gdk.getEventButtonButton event+      if eventType == Gdk.EventTypeButtonPress && button == 1+        then do+          currentEvent <- Gtk.getCurrentEvent+          catchAny+            (do let client = sessionDBusClient ctx+                gtkMenu <- DBusMenu.buildMenu client busName menuPath+                Gtk.menuAttachToWidget gtkMenu ebox Nothing+                _ <- Gtk.onWidgetHide gtkMenu $+                  void $ GLib.idleAdd GLib.PRIORITY_LOW $ do+                    Gtk.widgetDestroy gtkMenu+                    return False+                Gtk.widgetShowAll gtkMenu+                Gtk.menuPopupAtPointer gtkMenu currentEvent)+            (sniMenuLogger WARNING+              . printf "Failed to build SNI menu for %s: %s" (show busName)+              . show)+          return True+        else return False++    Gtk.widgetShowAll ebox+    Gtk.toWidget ebox++-- | Convenience wrapper: click to open nm-applet's network menu.+withNmAppletMenu :: TaffyIO Gtk.Widget -> TaffyIO Gtk.Widget+withNmAppletMenu = withSniMenu+  "org.freedesktop.network-manager-applet"+  "/org/ayatana/NotificationItem/nm_applet/Menu"
+ src/System/Taffybar/Widget/Systemd.hs view
@@ -0,0 +1,175 @@+{-# LANGUAGE OverloadedStrings #-}+-----------------------------------------------------------------------------+-- |+-- Module      : System.Taffybar.Widget.Systemd+-- Copyright   : (c) Ivan A. Malison+-- License     : BSD3-style (see LICENSE)+--+-- Maintainer  : Ivan A. Malison+-- Stability   : unstable+-- Portability : unportable+--+-- This module provides a widget that displays the number of failed systemd+-- units. It monitors both system and user units via DBus.+--+-- The widget shows a warning indicator with the total count of failed units.+-- When there are no failures, the widget can be configured to hide.+--+-- CSS classes applied:+--+-- * @systemd-widget@ - Always applied to the container+-- * @systemd-ok@ - Applied when there are no failed units+-- * @systemd-degraded@ - Applied when there are failed units+--+-- Example CSS:+--+-- > .systemd-widget { padding: 0 5px; }+-- > .systemd-ok { color: #98c379; }+-- > .systemd-degraded { color: #e06c75; }+-----------------------------------------------------------------------------+module System.Taffybar.Widget.Systemd+  ( SystemdConfig(..)+  , defaultSystemdConfig+  , systemdIconNew+  , systemdIconNewWithConfig+  , systemdLabelNew+  , systemdLabelNewWithConfig+  , systemdNew+  , systemdNewWithConfig+  ) where++import           Control.Monad+import           Control.Monad.IO.Class+import           Control.Monad.Trans.Reader+import           Data.Default (Default(..))+import qualified Data.Text as T+import           GI.Gtk as Gtk+import           System.Taffybar.Context+import           System.Taffybar.Information.Systemd+import           System.Taffybar.Util+import           System.Taffybar.Widget.Generic.ChannelWidget+import           System.Taffybar.Widget.Util+import           Text.StringTemplate++-- | Configuration options for the systemd widget.+data SystemdConfig = SystemdConfig+  { -- | Format string when there are failed units.+    -- Available variables: $count$, $system$, $user$+    systemdFormat :: String+    -- | Format string when there are no failures (only used if hideOnOk is False).+  , systemdFormatOk :: String+    -- | Whether to hide the widget when there are no failed units.+  , systemdHideOnOk :: Bool+    -- | Whether to monitor system units.+  , systemdMonitorSystem :: Bool+    -- | Whether to monitor user units.+  , systemdMonitorUser :: Bool+    -- | Nerd font icon character (default U+F071, warning triangle).+  , systemdIcon :: T.Text+  } deriving (Eq, Show)++-- | Default configuration for the systemd widget.+defaultSystemdConfig :: SystemdConfig+defaultSystemdConfig = SystemdConfig+  { systemdFormat = "$count$"+  , systemdFormatOk = "\x2713"        -- Check mark+  , systemdHideOnOk = True+  , systemdMonitorSystem = True+  , systemdMonitorUser = True+  , systemdIcon = T.pack "\xF071"     -- Warning triangle+  }++instance Default SystemdConfig where+  def = defaultSystemdConfig++-- | Create a systemd label widget with default configuration.+systemdLabelNew :: TaffyIO Gtk.Widget+systemdLabelNew = systemdLabelNewWithConfig defaultSystemdConfig++-- | Create a systemd label widget with custom configuration.+systemdLabelNewWithConfig :: SystemdConfig -> TaffyIO Gtk.Widget+systemdLabelNewWithConfig config = do+  chan <- getSystemdInfoChan+  ctx <- ask+  liftIO $ do+    label <- labelNew Nothing+    _ <- widgetSetClassGI label "systemd-widget"++    let updateWidget info = postGUIASync $ do+          let effectiveCount = computeEffectiveCount config info+              isOk = effectiveCount == 0+          updateSystemdLabel config label info+          updateSystemdVisibility config label isOk+          updateSystemdClasses label isOk++    -- Set initial state on realize+    void $ onWidgetRealize label $ do+      info <- runReaderT getSystemdInfoState ctx+      let effectiveCount = computeEffectiveCount config info+          isOk = effectiveCount == 0+      updateSystemdLabel config label info+      updateSystemdVisibility config label isOk+      updateSystemdClasses label isOk++    toWidget =<< channelWidgetNew label chan updateWidget++-- | Create a systemd icon widget with default configuration.+systemdIconNew :: TaffyIO Gtk.Widget+systemdIconNew = systemdIconNewWithConfig defaultSystemdConfig++-- | Create a systemd icon widget with the provided configuration.+systemdIconNewWithConfig :: SystemdConfig -> TaffyIO Gtk.Widget+systemdIconNewWithConfig config = liftIO $ do+  label <- Gtk.labelNew (Just (systemdIcon config))+  Gtk.widgetShowAll label+  Gtk.toWidget label++-- | Create a combined icon+label systemd widget with default configuration.+systemdNew :: TaffyIO Gtk.Widget+systemdNew = systemdNewWithConfig defaultSystemdConfig++-- | Create a combined icon+label systemd widget with custom configuration.+systemdNewWithConfig :: SystemdConfig -> TaffyIO Gtk.Widget+systemdNewWithConfig config = do+  iconWidget <- systemdIconNewWithConfig config+  labelWidget <- systemdLabelNewWithConfig config+  liftIO $ buildIconLabelBox iconWidget labelWidget++-- | Compute the effective count based on configuration.+computeEffectiveCount :: SystemdConfig -> SystemdInfo -> Int+computeEffectiveCount config info =+  let sysCount = if systemdMonitorSystem config then systemFailedCount info else 0+      usrCount = if systemdMonitorUser config then userFailedCount info else 0+  in sysCount + usrCount++-- | Update the label text based on the current state.+updateSystemdLabel :: SystemdConfig -> Gtk.Label -> SystemdInfo -> IO ()+updateSystemdLabel config label info = do+  let effectiveCount = computeEffectiveCount config info+      isOk = effectiveCount == 0+      formatStr = if isOk then systemdFormatOk config else systemdFormat config+      tpl = newSTMP formatStr+      tpl' = setManyAttrib+        [ ("count", show effectiveCount)+        , ("system", show (systemFailedCount info))+        , ("user", show (userFailedCount info))+        ] tpl+  labelSetMarkup label (render tpl')++-- | Update widget visibility based on configuration.+updateSystemdVisibility :: SystemdConfig -> Gtk.Label -> Bool -> IO ()+updateSystemdVisibility config label isOk =+  if isOk && systemdHideOnOk config+    then widgetHide label+    else widgetShow label++-- | Update CSS classes based on state.+updateSystemdClasses :: Gtk.Label -> Bool -> IO ()+updateSystemdClasses label isOk = do+  if isOk+    then do+      addClassIfMissing "systemd-ok" label+      removeClassIfPresent "systemd-degraded" label+    else do+      addClassIfMissing "systemd-degraded" label+      removeClassIfPresent "systemd-ok" label
+ src/System/Taffybar/Widget/Temperature.hs view
@@ -0,0 +1,165 @@+--------------------------------------------------------------------------------+-- |+-- Module      : System.Taffybar.Widget.Temperature+-- Copyright   : (c) Ivan Malison+-- License     : BSD3-style (see LICENSE)+--+-- Maintainer  : Ivan Malison <IvanMalison@gmail.com>+-- Stability   : unstable+-- Portability : unportable+--+-- A widget for displaying system temperature. Monitors thermal zones and/or+-- hwmon devices and displays the current temperature with configurable+-- thresholds for warning and critical states.+--+--------------------------------------------------------------------------------++{-# LANGUAGE OverloadedStrings #-}++module System.Taffybar.Widget.Temperature+  ( -- * Combined icon+label widget+    temperatureNew+  , temperatureNewWith+    -- * Icon-only widget+  , temperatureIconNew+  , temperatureIconNewWith+    -- * Label-only widget+  , temperatureLabelNew+  , temperatureLabelNewWith+    -- * Configuration+  , TemperatureConfig(..)+  , defaultTemperatureConfig+    -- * Re-exports+  , TemperatureUnit(..)+  ) where++import Control.Monad.IO.Class (MonadIO, liftIO)+import Data.Default (Default(..))+import Data.List (intercalate)+import qualified Data.Text as T+import qualified GI.Gtk as Gtk+import qualified Text.StringTemplate as ST++import System.Taffybar.Information.Temperature+import System.Taffybar.Widget.Generic.PollingLabel (pollingLabelNewWithTooltip)+import System.Taffybar.Widget.Util (buildIconLabelBox)++-- | Configuration for the temperature widget+data TemperatureConfig = TemperatureConfig+  { tempFormat :: String+    -- ^ Format string for the label. Available variables:+    -- temp (in configured unit), tempC (Celsius), tempF (Fahrenheit), tempK (Kelvin)+  , tempUnit :: TemperatureUnit+    -- ^ Unit to use for the {temp} variable (default: Celsius)+  , tempWarningThreshold :: Double+    -- ^ Temperature (in Celsius) at which to show warning style (default: 70)+  , tempCriticalThreshold :: Double+    -- ^ Temperature (in Celsius) at which to show critical style (default: 85)+  , tempPollInterval :: Double+    -- ^ How often to poll for temperature updates, in seconds (default: 10)+  , tempSensorFilter :: ThermalSensor -> Bool+    -- ^ Filter function to select which sensors to monitor (default: all)+  , tempAggregation :: [TemperatureInfo] -> Maybe Double+    -- ^ How to aggregate multiple sensor readings (default: maximum)+  , temperatureIcon :: T.Text+    -- ^ Nerd font icon character (default U+F2C9, nf-fa-thermometer).+  }++instance Default TemperatureConfig where+  def = defaultTemperatureConfig++-- | Default configuration for the temperature widget+defaultTemperatureConfig :: TemperatureConfig+defaultTemperatureConfig = TemperatureConfig+  { tempFormat = "$temp$\176C"  -- degree symbol+  , tempUnit = Celsius+  , tempWarningThreshold = 70+  , tempCriticalThreshold = 85+  , tempPollInterval = 10+  , tempSensorFilter = const True+  , tempAggregation = \temps ->+      if null temps+        then Nothing+        else Just $ maximum $ map tempCelsius temps+  , temperatureIcon = T.pack "\xF2C9"+  }++-- | Create a combined icon+label temperature widget with default configuration.+temperatureNew :: MonadIO m => m Gtk.Widget+temperatureNew = temperatureNewWith defaultTemperatureConfig++-- | Create a combined icon+label temperature widget.+temperatureNewWith :: MonadIO m => TemperatureConfig -> m Gtk.Widget+temperatureNewWith config = liftIO $ do+  iconWidget <- temperatureIconNewWith config+  labelWidget <- temperatureLabelNewWith config+  buildIconLabelBox iconWidget labelWidget++-- | Create a temperature icon widget with default configuration.+temperatureIconNew :: MonadIO m => m Gtk.Widget+temperatureIconNew = temperatureIconNewWith defaultTemperatureConfig++-- | Create a temperature icon widget with the provided configuration.+temperatureIconNewWith :: MonadIO m => TemperatureConfig -> m Gtk.Widget+temperatureIconNewWith config = liftIO $ do+  label <- Gtk.labelNew (Just (temperatureIcon config))+  Gtk.widgetShowAll label+  Gtk.toWidget label++-- | Create a temperature label widget with default configuration.+temperatureLabelNew :: MonadIO m => m Gtk.Widget+temperatureLabelNew = temperatureLabelNewWith defaultTemperatureConfig++-- | Create a temperature label widget with custom configuration.+temperatureLabelNewWith :: MonadIO m => TemperatureConfig -> m Gtk.Widget+temperatureLabelNewWith config = liftIO $ do+  -- Discover sensors once at startup, filtered by config+  allSensors <- discoverSensors+  let sensors = filter (tempSensorFilter config) allSensors++  widget <- pollingLabelNewWithTooltip (tempPollInterval config) $ do+    temps <- readTemperaturesFiltered sensors+    case tempAggregation config temps of+      Nothing -> return (T.pack "N/A", Nothing)+      Just tempC -> do+        let tempF = convertTemperature Fahrenheit tempC+            tempK = convertTemperature Kelvin tempC+            tempDisplay = convertTemperature (tempUnit config) tempC+            labelText = formatTemperature config tempDisplay tempC tempF tempK+            tooltipText = formatTooltip temps+        return (labelText, Just tooltipText)++  -- We need to update CSS classes dynamically, but pollingLabel doesn't+  -- support that directly. Instead, we set up the widget and update classes+  -- in the polling callback through a custom approach.+  -- For now, we'll use a simpler approach with the base widget.+  Gtk.toWidget widget++  where+    readTemperaturesFiltered :: [ThermalSensor] -> IO [TemperatureInfo]+    readTemperaturesFiltered sensors =+      filter (\t -> tempSensor t `elem` sensors) <$> readAllTemperatures++-- | Format the temperature label using the template+formatTemperature :: TemperatureConfig -> Double -> Double -> Double -> Double -> T.Text+formatTemperature config tempDisplay tempC tempF tempK =+  let template = ST.newSTMP (tempFormat config)+      template' = ST.setManyAttrib+        [ ("temp", formatDouble tempDisplay)+        , ("tempC", formatDouble tempC)+        , ("tempF", formatDouble tempF)+        , ("tempK", formatDouble tempK)+        ] template+  in T.pack $ ST.render template'+  where+    formatDouble :: Double -> String+    formatDouble d = show (round d :: Int)++-- | Format tooltip showing all sensor readings+formatTooltip :: [TemperatureInfo] -> T.Text+formatTooltip temps =+  T.pack $ intercalate "\n" $ map formatSensor temps+  where+    formatSensor info =+      sensorName (tempSensor info) ++ ": " +++      show (round (tempCelsius info) :: Int) ++ "\176C"
src/System/Taffybar/Widget/Util.hs view
@@ -1,3 +1,4 @@+{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE TypeApplications #-} {-# LANGUAGE OverloadedStrings #-} @@ -18,8 +19,11 @@ module System.Taffybar.Widget.Util where  import           Control.Concurrent ( forkIO )+import qualified Control.Concurrent.MVar as MV+import           Control.Exception.Enclosed (catchAny) import           Control.Monad import           Control.Monad.IO.Class+import           Control.Monad.Trans.Control (MonadBaseControl) import           Data.Bifunctor ( first ) import           Data.Functor ( ($>) ) import           Data.GI.Base.Overloading (IsDescendantOf)@@ -30,6 +34,7 @@ import qualified GI.GdkPixbuf.Objects.Pixbuf as PB import           GI.Gtk as Gtk import           StatusNotifier.Tray (scalePixbufToSize)+import           System.Log.Logger (Priority(..)) import           System.Environment.XDG.DesktopEntry import           System.FilePath.Posix import           System.Taffybar.Util@@ -37,6 +42,96 @@  import           Paths_taffybar ( getDataDir ) +-- | Common record used for window icon widgets in workspace switchers.+data WindowIconWidget a = WindowIconWidget+  { iconContainer :: Gtk.EventBox+  , iconImage :: Gtk.Widget+  , iconWindow :: MV.MVar (Maybe a)+  , iconForceUpdate :: IO ()+  }++-- | Construct the GTK widgets and CSS classes for a window icon widget, leaving+-- 'iconForceUpdate' as a placeholder to be filled in after the image widget is+-- created by 'scalingImageNew'.+--+-- The caller is responsible for creating the image widget and adding it to the+-- event box.+mkWindowIconWidgetBase :: MonadIO m => Maybe Int32 -> m (WindowIconWidget a)+mkWindowIconWidgetBase _mSize = liftIO $ do+  windowVar <- MV.newMVar Nothing+  ebox <- Gtk.eventBoxNew+  _ <- widgetSetClassGI ebox "window-icon-container"+  placeholder <- Gtk.toWidget ebox+  return+    WindowIconWidget+      { iconContainer = ebox+      , iconImage = placeholder+      , iconWindow = windowVar+      , iconForceUpdate = return ()+      }++-- | List of possible status class names for window icon widgets.+--+-- This is used to keep the style context clean by removing stale classes.+possibleStatusStrings :: [T.Text]+possibleStatusStrings = ["active", "urgent", "minimized", "normal", "inactive"]++-- | Add/remove classes on a widget while removing stale classes.+updateWidgetClasses ::+  (Foldable t1, Foldable t, Gtk.IsWidget a, MonadIO m)+  => a+  -> t1 T.Text+  -> t T.Text+  -> m ()+updateWidgetClasses widget toAdd toRemove = do+  context <- Gtk.widgetGetStyleContext widget+  let hasClass = Gtk.styleContextHasClass context+      addIfMissing klass =+        hasClass klass >>= (`when` Gtk.styleContextAddClass context klass) . not+      removeIfPresent klass = unless (klass `elem` toAdd) $+        hasClass klass >>= (`when` Gtk.styleContextRemoveClass context klass)+  mapM_ removeIfPresent toRemove+  mapM_ addIfMissing toAdd++-- | Update a 'WindowIconWidget' with new per-slot data.+updateWindowIconWidgetState ::+  (MonadIO m) =>+  WindowIconWidget a ->+  Maybe a ->+  (a -> T.Text) ->+  (a -> T.Text) ->+  m ()+updateWindowIconWidgetState iconWidget windowData titleFn statusFn = do+  _ <- liftIO $ MV.swapMVar (iconWindow iconWidget) windowData+  Gtk.widgetSetTooltipText (iconContainer iconWidget) (titleFn <$> windowData)+  liftIO $ iconForceUpdate iconWidget+  let statusString = maybe "inactive" statusFn windowData+  updateWidgetClasses+    (iconContainer iconWidget)+    [statusString]+    possibleStatusStrings++scaledPixbufGetter ::+  (MonadIO m) =>+  (Int32 -> a -> m (Maybe GI.Pixbuf)) ->+  (Int32 -> a -> m (Maybe GI.Pixbuf))+scaledPixbufGetter getter size windowData =+  getter size windowData >>=+  traverse (liftIO . scalePixbufToSize size Gtk.OrientationHorizontal)++handlePixbufGetterException ::+  (MonadBaseControl IO m, Show a) =>+  (Priority -> String -> m ()) ->+  (Int32 -> a -> m (Maybe GI.Pixbuf)) ->+  Int32 ->+  a ->+  m (Maybe GI.Pixbuf)+handlePixbufGetterException logFn getter size windowData =+  catchAny (getter size windowData) $ \e -> do+    _ <- logFn WARNING $ printf "Failed to get window icon for %s: %s"+                               (show windowData) (show e)+    return Nothing+ -- | Execute the given action as a response to any of the given types -- of mouse button clicks. onClick :: [D.EventType] -- ^ Types of button clicks to listen to.@@ -216,3 +311,111 @@   _ <- widgetSetClassGI contents "contents"   Gtk.widgetShowAll contents   Gtk.toWidget contents >>= buildPadBox++-- | Combine an icon widget and a label widget in a horizontal box with+-- standardised CSS classes. The box gets class @icon-label@, the first child+-- gets @icon@, and the second child gets @label@.+buildIconLabelBox :: MonadIO m => Gtk.Widget -> Gtk.Widget -> m Gtk.Widget+buildIconLabelBox iconWidget labelWidget = liftIO $ do+  box <- Gtk.boxNew Gtk.OrientationHorizontal 0+  _ <- widgetSetClassGI iconWidget "icon"+  _ <- widgetSetClassGI labelWidget "label"+  Gtk.containerAdd box iconWidget+  Gtk.containerAdd box labelWidget+  _ <- widgetSetClassGI box "icon-label"+  Gtk.widgetShowAll box+  Gtk.toWidget box++-- | Build a 'Gtk.Overlay' from a base widget plus one or more overlay widgets,+-- and mark overlays as "pass through" so they don't capture clicks/scrolls.+--+-- This is useful for workspace widgets that overlay a label on top of icons.+buildOverlayWithPassThrough :: MonadIO m => Gtk.Widget -> [Gtk.Widget] -> m Gtk.Widget+buildOverlayWithPassThrough base overlays = liftIO $ do+  overlay <- Gtk.overlayNew+  Gtk.containerAdd overlay base+  forM_ overlays $ \w -> do+    Gtk.overlayAddOverlay overlay w+    Gtk.overlaySetOverlayPassThrough overlay w True+  Gtk.toWidget overlay++-- | Wrap a widget in an event box aligned to the bottom-left.+--+-- This is used by workspace widgets to overlay a label on top of icons in a+-- consistent way across different backends.+buildBottomLeftAlignedBox :: MonadIO m => T.Text -> Gtk.Widget -> m Gtk.Widget+buildBottomLeftAlignedBox boxClass child = liftIO $ do+  ebox <- Gtk.eventBoxNew+  _ <- widgetSetClassGI ebox boxClass+  Gtk.widgetSetHalign ebox Gtk.AlignStart+  Gtk.widgetSetValign ebox Gtk.AlignEnd+  Gtk.containerAdd ebox child+  Gtk.toWidget ebox++-- | Compute a window icon strip layout given min/max icon config and a sorted+-- list of items.+--+-- Returns (effectiveMinIcons, targetLen, paddedItems) where:+-- - effectiveMinIcons is @min minIcons maxIcons@ when maxIcons is set+-- - targetLen is at least effectiveMinIcons and large enough for shown items+-- - paddedItems is exactly targetLen elements long (Just items, then Nothings)+computeIconStripLayout :: Int -> Maybe Int -> [a] -> (Int, Int, [Maybe a])+computeIconStripLayout minIcons maxIcons items =+  let itemCount = length items+      maxNeeded = maybe itemCount (min itemCount) maxIcons+      effectiveMinIcons = maybe minIcons (min minIcons) maxIcons+      targetLen = max effectiveMinIcons maxNeeded+      shownItems = take maxNeeded items+      paddedItems =+        map Just shownItems ++ replicate (targetLen - length shownItems) Nothing+  in (effectiveMinIcons, targetLen, paddedItems)++-- | CSS class name for a window icon given its state.+--+-- This matches the classes used by the workspaces widgets: `active`, `urgent`,+-- `minimized`, `normal` (and `inactive` when there is no window).+windowStatusClassFromFlags :: Bool -> Bool -> Bool -> T.Text+windowStatusClassFromFlags minimized active urgent+  | minimized = "minimized"+  | active = "active"+  | urgent = "urgent"+  | otherwise = "normal"++-- | Keep a pool of widget "slots" in sync with a desired list of per-slot data.+--+-- The pool is only grown (never shrunk). Widgets within the desired length are+-- shown and updated; widgets beyond it are updated with 'Nothing' and hidden.+syncWidgetPool ::+  (MonadIO m, Gtk.IsWidget child) =>+  Gtk.Box ->+  [w] ->+  [Maybe a] ->+  (Int -> m w) ->+  (w -> child) ->+  (w -> Maybe a -> m ()) ->+  m [w]+syncWidgetPool container pool desired mkOne getChild updateOne = do+  let targetLen = length desired++  pool' <-+    if length pool >= targetLen+      then return pool+      else do+        let start = length pool+        newOnes <- forM [start .. targetLen - 1] $ \i -> do+          w <- mkOne i+          liftIO $ Gtk.containerAdd container (getChild w)+          return w+        liftIO $ Gtk.widgetShowAll container+        return (pool ++ newOnes)++  forM_ (zip3 [0 :: Int ..] pool' (desired ++ repeat Nothing)) $ \(i, w, payload) ->+    if i < targetLen+      then do+        liftIO $ Gtk.widgetShow (getChild w)+        updateOne w payload+      else do+        updateOne w Nothing+        liftIO $ Gtk.widgetHide (getChild w)++  return pool'
src/System/Taffybar/Widget/Windows.hs view
@@ -27,8 +27,8 @@ import qualified GI.Gtk as Gtk import           System.Taffybar.Context import           System.Taffybar.Information.EWMHDesktopInfo-import           System.Taffybar.Widget.Generic.AutoSizeImage import           System.Taffybar.Widget.Generic.DynamicMenu+import           System.Taffybar.Widget.Generic.ScalingImage (scalingImage) import           System.Taffybar.Widget.Util import           System.Taffybar.Widget.Workspaces (WindowIconPixbufGetter, getWindowData, defaultGetWindowIconPixbuf) import           System.Taffybar.Util@@ -116,16 +116,14 @@  buildWindowsIcon :: WindowIconPixbufGetter -> TaffyIO (IO (), Gtk.Widget) buildWindowsIcon windowIconPixbufGetter = do-  icon <- lift Gtk.imageNew-   runTaffy <- asks (flip runReaderT)   let getActiveWindowPixbuf size = runTaffy . runMaybeT $ do         wd <- MaybeT $ runX11Def Nothing $           traverse (getWindowData Nothing []) =<< getActiveWindow         MaybeT $ windowIconPixbufGetter size wd -  updateImage <- autoSizeImage icon getActiveWindowPixbuf Gtk.OrientationHorizontal-  (postGUIASync updateImage,) <$> Gtk.toWidget icon+  (imageWidget, updateImage) <- scalingImage getActiveWindowPixbuf Gtk.OrientationHorizontal+  return (postGUIASync updateImage, imageWidget)  -- | Populate the given menu widget with the list of all currently open windows. fillMenu :: Gtk.IsMenuShell a => WindowsConfig -> a -> ReaderT Context IO ()
+ src/System/Taffybar/Widget/WirePlumber.hs view
@@ -0,0 +1,298 @@+{-# LANGUAGE OverloadedStrings #-}++-----------------------------------------------------------------------------++-- |+-- Module      : System.Taffybar.Widget.WirePlumber+-- Copyright   : (c) Ivan A. Malison+-- License     : BSD3-style (see LICENSE)+--+-- Maintainer  : Ivan A. Malison+-- Stability   : unstable+-- Portability : unportable+--+-- Volume widget using WirePlumber's @wpctl@ command-line tool.+--+-- This widget displays the current volume level and mute state, and supports+-- scroll to adjust volume and click to toggle mute.+--+-- Three widget variants are provided:+--+-- * 'wirePlumberIconNew' – icon only (dynamic, updates with volume\/mute state)+-- * 'wirePlumberLabelNew' – text label only (with scroll\/click interaction)+-- * 'wirePlumberNew' – combined icon + label in a horizontal box+--+-- Note: Requires @wpctl@ to be available in PATH.+module System.Taffybar.Widget.WirePlumber+  ( WirePlumberWidgetConfig (..),+    defaultWirePlumberWidgetConfig,+    wirePlumberIconNew,+    wirePlumberIconNewWith,+    wirePlumberLabelNew,+    wirePlumberLabelNewWith,+    wirePlumberNew,+    wirePlumberNewWith,+    wirePlumberSourceNew,+    wirePlumberSourceNewWith,+  )+where++import Control.Monad (void, when)+import Control.Monad.IO.Class+import Data.Char (ord)+import Data.Default (Default (..))+import qualified Data.Text as T+import qualified GI.Gdk.Enums as Gdk+import qualified GI.Gdk.Structs.EventScroll as GdkEvent+import qualified GI.GLib as G+import qualified GI.Gtk as Gtk+import System.Taffybar.Context (TaffyIO)+import System.Taffybar.Information.WirePlumber+import System.Taffybar.Util (postGUIASync)+import System.Taffybar.Widget.Generic.ChannelWidget+import System.Taffybar.Widget.Util (buildIconLabelBox)+import Text.StringTemplate++-- | Configuration for the WirePlumber widget.+data WirePlumberWidgetConfig = WirePlumberWidgetConfig+  { -- | Node specification for wpctl (e.g., "@DEFAULT_AUDIO_SINK@")+    wirePlumberNode :: String,+    -- | Format template for normal volume display.+    -- Available variables: $icon$, $volume$+    wirePlumberFormat :: String,+    -- | Format template when muted.+    -- Available variables: $icon$, $volume$+    wirePlumberMuteFormat :: String,+    -- | Format template when wpctl is unavailable.+    -- Available variables: $icon$+    wirePlumberUnknownFormat :: String,+    -- | Optional tooltip format template.+    -- Available variables: $node$, $volume$, $muted$+    wirePlumberTooltipFormat :: Maybe String,+    -- | Volume adjustment step when scrolling (percentage).+    -- Set to Nothing to disable scroll adjustment.+    wirePlumberScrollStepPercent :: Maybe Int,+    -- | Whether to toggle mute on click.+    wirePlumberToggleMuteOnClick :: Bool+  }++-- | Default configuration for the WirePlumber widget (default audio sink).+defaultWirePlumberWidgetConfig :: WirePlumberWidgetConfig+defaultWirePlumberWidgetConfig =+  WirePlumberWidgetConfig+    { wirePlumberNode = "@DEFAULT_AUDIO_SINK@",+      wirePlumberFormat = "$volume$%",+      wirePlumberMuteFormat = "muted",+      wirePlumberUnknownFormat = "n/a",+      wirePlumberTooltipFormat =+        Just "Node: $node$\nVolume: $volume$%\nMuted: $muted$",+      wirePlumberScrollStepPercent = Just 5,+      wirePlumberToggleMuteOnClick = True+    }++-- | Default configuration for the WirePlumber widget for microphone/source.+defaultWirePlumberSourceWidgetConfig :: WirePlumberWidgetConfig+defaultWirePlumberSourceWidgetConfig =+  defaultWirePlumberWidgetConfig+    { wirePlumberNode = "@DEFAULT_AUDIO_SOURCE@"+    }++instance Default WirePlumberWidgetConfig where+  def = defaultWirePlumberWidgetConfig++-- | Create a WirePlumber icon-only widget for the default audio sink.+-- The icon updates dynamically based on volume level and mute state.+wirePlumberIconNew :: TaffyIO Gtk.Widget+wirePlumberIconNew = wirePlumberIconNewWith defaultWirePlumberWidgetConfig++-- | Create a WirePlumber icon-only widget with custom configuration.+wirePlumberIconNewWith :: WirePlumberWidgetConfig -> TaffyIO Gtk.Widget+wirePlumberIconNewWith config = do+  let nodeSpec = wirePlumberNode config+  chan <- getWirePlumberInfoChan nodeSpec+  initialInfo <- getWirePlumberInfoState nodeSpec+  liftIO $ do+    label <- Gtk.labelNew Nothing+    let updateIcon info = do+          let iconText = case info of+                Nothing -> T.pack "\xF026"+                Just i ->+                  wirePlumberTextIcon+                    (wirePlumberMuted i)+                    (Just $ round (wirePlumberVolume i * 100))+          postGUIASync $ Gtk.labelSetText label iconText+    void $ Gtk.onWidgetRealize label $ updateIcon initialInfo+    Gtk.widgetShowAll label+    Gtk.toWidget =<< channelWidgetNew label chan updateIcon++-- | Create a WirePlumber label-only widget for the default audio sink.+-- Includes scroll-to-adjust and click-to-mute interaction.+wirePlumberLabelNew :: TaffyIO Gtk.Widget+wirePlumberLabelNew = wirePlumberLabelNewWith defaultWirePlumberWidgetConfig++-- | Create a WirePlumber label-only widget with custom configuration.+wirePlumberLabelNewWith :: WirePlumberWidgetConfig -> TaffyIO Gtk.Widget+wirePlumberLabelNewWith config = do+  let nodeSpec = wirePlumberNode config+  chan <- getWirePlumberInfoChan nodeSpec+  initialInfo <- getWirePlumberInfoState nodeSpec++  liftIO $ do+    label <- Gtk.labelNew Nothing++    let updateLabel info = do+          (labelText, tooltipText) <- formatWirePlumberWidget config info+          postGUIASync $ do+            Gtk.labelSetMarkup label labelText+            Gtk.widgetSetTooltipMarkup label tooltipText++        refreshNow = getWirePlumberInfo nodeSpec >>= updateLabel++        whenToggleMute widget =+          when (wirePlumberToggleMuteOnClick config) $+            void $+              Gtk.onWidgetButtonPressEvent widget $ \_ -> do+                void $ toggleWirePlumberMute nodeSpec+                refreshNow+                return True++        whenScrollAdjust widget =+          case wirePlumberScrollStepPercent config of+            Nothing -> return ()+            Just step | step <= 0 -> return ()+            Just step -> do+              _ <- Gtk.onWidgetScrollEvent widget $ \scrollEvent -> do+                dir <- GdkEvent.getEventScrollDirection scrollEvent+                let doAdjust delta = do+                      void $ adjustWirePlumberVolume nodeSpec delta+                      refreshNow+                      return True+                case dir of+                  Gdk.ScrollDirectionUp -> doAdjust step+                  Gdk.ScrollDirectionDown -> doAdjust (-step)+                  Gdk.ScrollDirectionLeft -> doAdjust step+                  Gdk.ScrollDirectionRight -> doAdjust (-step)+                  _ -> return False+              return ()++    void $ Gtk.onWidgetRealize label $ updateLabel initialInfo++    whenToggleMute label+    whenScrollAdjust label++    Gtk.widgetShowAll label+    Gtk.toWidget =<< channelWidgetNew label chan updateLabel++-- | Create a combined icon + label WirePlumber widget for the default audio sink.+wirePlumberNew :: TaffyIO Gtk.Widget+wirePlumberNew = wirePlumberNewWith defaultWirePlumberWidgetConfig++-- | Create a combined icon + label WirePlumber widget with custom configuration.+wirePlumberNewWith :: WirePlumberWidgetConfig -> TaffyIO Gtk.Widget+wirePlumberNewWith config = do+  iconWidget <- wirePlumberIconNewWith config+  labelWidget <- wirePlumberLabelNewWith config+  liftIO $ buildIconLabelBox iconWidget labelWidget++-- | Create a new WirePlumber widget for the default audio source (microphone).+wirePlumberSourceNew :: TaffyIO Gtk.Widget+wirePlumberSourceNew = wirePlumberNewWith defaultWirePlumberSourceWidgetConfig++-- | Create a new WirePlumber widget for audio source with custom configuration.+wirePlumberSourceNewWith :: WirePlumberWidgetConfig -> TaffyIO Gtk.Widget+wirePlumberSourceNewWith = wirePlumberNewWith++formatWirePlumberWidget ::+  WirePlumberWidgetConfig ->+  Maybe WirePlumberInfo ->+  IO (T.Text, Maybe T.Text)+formatWirePlumberWidget config info = do+  attrs <- maybe buildUnknownAttrs buildAttrs info+  let labelTemplate =+        case info of+          Nothing -> wirePlumberUnknownFormat config+          Just audio ->+            if wirePlumberMuted audio+              then wirePlumberMuteFormat config+              else wirePlumberFormat config+      labelText = renderTemplate labelTemplate attrs+      tooltipText = fmap (`renderTemplate` attrs) (wirePlumberTooltipFormat config)+  return (T.pack labelText, T.pack <$> tooltipText)++buildAttrs :: WirePlumberInfo -> IO [(String, String)]+buildAttrs info = do+  let volumePercent = round (wirePlumberVolume info * 100) :: Int+      volumeText = show volumePercent+      mutedText =+        if wirePlumberMuted info+          then "yes"+          else "no"+      nodeText = T.unpack $ wirePlumberNodeName info+      iconText = wirePlumberTextIcon (wirePlumberMuted info) (Just volumePercent)+  volume <- escapeText $ T.pack volumeText+  muted <- escapeText $ T.pack mutedText+  node <- escapeText $ T.pack nodeText+  icon <- escapeIconText iconText+  return+    [ ("volume", volume),+      ("muted", muted),+      ("node", node),+      ("icon", icon)+    ]++buildUnknownAttrs :: IO [(String, String)]+buildUnknownAttrs = do+  icon <- escapeIconText (T.pack "\xF026") -- volume off icon+  return+    [ ("volume", "?"),+      ("muted", "unknown"),+      ("node", "unknown"),+      ("icon", icon)+    ]++wirePlumberTextIcon :: Bool -> Maybe Int -> T.Text+wirePlumberTextIcon muted volumePercent =+  case muted of+    True -> T.pack "\xF026" -- volume off+    False ->+      case volumePercent of+        Just v | v <= 0 -> T.pack "\xF026" -- volume off+        Just v | v <= 33 -> T.pack "\xF027" -- volume low+        _ -> T.pack "\xF028" -- volume high++renderTemplate :: String -> [(String, String)] -> String+renderTemplate template attrs = render $ setManyAttrib attrs (newSTMP template)++escapeText :: T.Text -> IO String+escapeText input = T.unpack <$> G.markupEscapeText input (-1)++-- Font Awesome / Nerd Font glyphs live in the Private Use Area and can render+-- much smaller than the surrounding text depending on which fallback font gets+-- selected. Force a Nerd Font for PUA glyphs (and bump size slightly) so+-- digits/letters remain untouched.+escapeIconText :: T.Text -> IO String+escapeIconText input =+  let iconSpan s =+        "<span font_family=\"Iosevka Nerd Font\" font_weight=\"normal\" size=\"large\">" ++ s ++ "</span>"+   in do+        rendered <-+          concat+            <$> mapM+              ( \c -> do+                  esc <- escapeText (T.singleton c)+                  pure $+                    if isPUA c+                      then iconSpan esc+                      else esc+              )+              (T.unpack input)+        -- Add a trailing space in the icon's font/size so it doesn't look cramped.+        pure $+          if any isPUA (T.unpack input)+            then rendered ++ iconSpan "&#x2004;" -- three-per-em space+            else rendered++isPUA :: Char -> Bool+isPUA c =+  let o = ord c+   in o >= 0xE000 && o <= 0xF8FF
src/System/Taffybar/Widget/Workspaces.hs view
@@ -11,16 +11,17 @@ -- Portability : unportable ----------------------------------------------------------------------------- -module System.Taffybar.Widget.Workspaces where+module System.Taffybar.Widget.Workspaces+  ( module System.Taffybar.Widget.Workspaces+  , module System.Taffybar.Widget.Workspaces.Shared+  ) where  import           Control.Arrow ((&&&)) import           Control.Concurrent import qualified Control.Concurrent.MVar as MV-import           Control.Exception.Enclosed (catchAny) import           Control.Monad import           Control.Monad.IO.Class import           Control.Monad.Trans.Class-import           Control.Monad.Trans.Maybe import           Control.Monad.Trans.Reader import           Control.RateLimit import           Data.Default (Default(..))@@ -40,32 +41,25 @@ import qualified GI.Gdk.Structs.EventScroll as Gdk import qualified GI.GdkPixbuf.Objects.Pixbuf as Gdk import qualified GI.Gtk as Gtk-import           StatusNotifier.Tray (scalePixbufToSize) import           System.Log.Logger import           System.Taffybar.Context import           System.Taffybar.Information.EWMHDesktopInfo import           System.Taffybar.Information.SafeX11 import           System.Taffybar.Information.X11DesktopInfo import           System.Taffybar.Util-import           System.Taffybar.Widget.Generic.AutoSizeImage (autoSizeImage) import           System.Taffybar.Widget.Util+import           System.Taffybar.Widget.Generic.ScalingImage (getScalingImageStrategy)+import           System.Taffybar.Widget.Workspaces.Shared+  ( WorkspaceState(..)+  , getCSSClass+  , cssWorkspaceStates+  , setWorkspaceWidgetStatusClass+  , buildWorkspaceIconLabelOverlay+  , mkWorkspaceIconWidget+  ) import           System.Taffybar.WindowIcon import           Text.Printf -data WorkspaceState-  = Active-  | Visible-  | Hidden-  | Empty-  | Urgent-  deriving (Show, Eq)--getCSSClass :: (Show s) => s -> T.Text-getCSSClass = T.toLower . T.pack . show--cssWorkspaceStates :: [T.Text]-cssWorkspaceStates = map getCSSClass [Active, Visible, Hidden, Empty, Urgent]- data WindowData = WindowData   { windowId :: X11Window   , windowTitle :: String@@ -100,30 +94,6 @@ liftX11Def :: a -> X11Property a -> WorkspacesIO a liftX11Def dflt prop = liftContext $ runX11Def dflt prop -setWorkspaceWidgetStatusClass ::-     (MonadIO m, Gtk.IsWidget a) => Workspace -> a -> m ()-setWorkspaceWidgetStatusClass workspace widget =-  updateWidgetClasses-    widget-    [getCSSClass $ workspaceState workspace]-    cssWorkspaceStates--updateWidgetClasses ::-  (Foldable t1, Foldable t, Gtk.IsWidget a, MonadIO m)-  => a-  -> t1 T.Text-  -> t T.Text-  -> m ()-updateWidgetClasses widget toAdd toRemove = do-  context <- Gtk.widgetGetStyleContext widget-  let hasClass = Gtk.styleContextHasClass context-      addIfMissing klass =-        hasClass klass >>= (`when` Gtk.styleContextAddClass context klass) . not-      removeIfPresent klass = unless (klass `elem` toAdd) $-        hasClass klass >>= (`when` Gtk.styleContextRemoveClass context klass)-  mapM_ removeIfPresent toRemove-  mapM_ addIfMissing toAdd- class WorkspaceWidgetController wc where   getWidget :: wc -> WorkspacesIO Gtk.Widget   updateWidget :: wc -> WidgetUpdate -> WorkspacesIO wc@@ -502,12 +472,7 @@ bottomLeftAlignedBoxWrapper boxClass constructor ws = do   controller <- constructor ws   widget <- getWidget controller-  ebox <- Gtk.eventBoxNew-  _ <- widgetSetClassGI ebox boxClass-  Gtk.widgetSetHalign ebox Gtk.AlignStart-  Gtk.widgetSetValign ebox Gtk.AlignEnd-  Gtk.containerAdd ebox widget-  wrapped <- Gtk.toWidget ebox+  wrapped <- lift $ buildBottomLeftAlignedBox boxClass widget   let wrappingController = WrappingController                            { wrappedWidget = wrapped                            , wrappedController = controller@@ -515,10 +480,20 @@   initializeWWC wrappingController ws  buildLabelOverlayController :: ControllerConstructor-buildLabelOverlayController =-  buildOverlayContentsController-  [buildIconController]-  [bottomLeftAlignedBoxWrapper "overlay-box" buildLabelController]+buildLabelOverlayController ws = do+  iconController <- buildIconController ws+  labelController <- buildLabelController ws+  ctx <- ask+  tempController <- lift $ do+    iconWidget <- runReaderT (getWidget iconController) ctx+    labelWidget <- runReaderT (getWidget labelController) ctx+    widget <- buildWorkspaceIconLabelOverlay iconWidget labelWidget+    return+      WorkspaceContentsController+      { containerWidget = widget+      , contentsControllers = [iconController, labelController]+      }+  initializeWWC tempController ws  buildOverlayContentsController ::   [ControllerConstructor] -> [ControllerConstructor] -> ControllerConstructor@@ -532,12 +507,8 @@         controllers     outerBox <- Gtk.toWidget mainContents >>= buildPadBox     _ <- widgetSetClassGI mainContents "contents"-    overlay <- Gtk.overlayNew-    Gtk.containerAdd overlay outerBox-    mapM_ (flip runReaderT ctx . getWidget >=>-                Gtk.overlayAddOverlay overlay) overlayControllers--    widget <- Gtk.toWidget overlay+    overlayWidgets <- mapM (flip runReaderT ctx . getWidget) overlayControllers+    widget <- buildOverlayWithPassThrough outerBox overlayWidgets     return       WorkspaceContentsController       { containerWidget = widget@@ -551,7 +522,7 @@     WorkspacesContext {} <- ask     case update of       WorkspaceUpdate newWorkspace ->-        lift $ setWorkspaceWidgetStatusClass newWorkspace $ containerWidget cc+        lift $ setWorkspaceWidgetStatusClass (workspaceState newWorkspace) $ containerWidget cc       _ -> return ()     newControllers <- mapM (`updateWidget` update) $ contentsControllers cc     return cc {contentsControllers = newControllers}@@ -576,63 +547,39 @@     labelText <- labelSetter cfg newWorkspace     lift $ do       Gtk.labelSetMarkup (label lc) $ T.pack labelText-      setWorkspaceWidgetStatusClass newWorkspace $ label lc+      setWorkspaceWidgetStatusClass (workspaceState newWorkspace) $ label lc     return lc   updateWidget lc _ = return lc -data IconWidget = IconWidget-  { iconContainer :: Gtk.EventBox-  , iconImage :: Gtk.Image-  , iconWindow :: MV.MVar (Maybe WindowData)-  , iconForceUpdate :: IO ()-  }--getPixbufForIconWidget :: Bool-                       -> MV.MVar (Maybe WindowData)-                       -> Int32-                       -> WorkspacesIO (Maybe Gdk.Pixbuf)-getPixbufForIconWidget transparentOnNone dataVar size = do-  ctx <- ask-  let tContext = taffyContext ctx-      getPBFromData = getWindowIconPixbuf $ workspacesConfig ctx-      getPB' = runMaybeT $-               MaybeT (lift $ MV.readMVar dataVar) >>= MaybeT . getPBFromData size-      getPB = if transparentOnNone-              then maybeTCombine getPB' (Just <$> pixBufFromColor size 0)-              else getPB'-  lift $ runReaderT getPB tContext+type IconWidget = WindowIconWidget WindowData  buildIconWidget :: Bool -> Workspace -> WorkspacesIO IconWidget buildIconWidget transparentOnNone ws = do   ctx <- ask+  let tContext = taffyContext ctx+      cfg = workspacesConfig ctx+      getPB size windowData =+        runReaderT (getWindowIconPixbuf cfg size windowData) tContext+  strategy <- liftContext getScalingImageStrategy   lift $ do-    windowVar <- MV.newMVar Nothing-    img <- Gtk.imageNew-    refreshImage <--      autoSizeImage img-        (flip runReaderT ctx . getPixbufForIconWidget transparentOnNone windowVar)-        Gtk.OrientationHorizontal-    ebox <- Gtk.eventBoxNew-    _ <- widgetSetClassGI img "window-icon"-    _ <- widgetSetClassGI ebox "window-icon-container"-    Gtk.containerAdd ebox img+    iconWidget <-+      mkWorkspaceIconWidget+        strategy+        Nothing+        transparentOnNone+        getPB+        (`pixBufFromColor` 0)     _ <--      Gtk.onWidgetButtonPressEvent ebox $+      Gtk.onWidgetButtonPressEvent (iconContainer iconWidget) $       const $ liftIO $ do-        info <- MV.readMVar windowVar+        info <- MV.readMVar (iconWindow iconWidget)         case info of           Just updatedInfo ->             flip runReaderT ctx $             liftX11Def () $ focusWindow $ windowId updatedInfo           _ -> liftIO $ void $ switch ctx (workspaceIdx ws)         return True-    return-      IconWidget-      { iconContainer = ebox-      , iconImage = img-      , iconWindow = windowVar-      , iconForceUpdate = refreshImage-      }+    return iconWidget  data IconController = IconController   { iconsContainer :: Gtk.Box@@ -670,9 +617,7 @@          updateIconWidget ic widget info  scaledWindowIconPixbufGetter :: WindowIconPixbufGetter -> WindowIconPixbufGetter-scaledWindowIconPixbufGetter getter size =-  getter size >=>-  lift . traverse (scalePixbufToSize size Gtk.OrientationHorizontal)+scaledWindowIconPixbufGetter = scaledPixbufGetter  constantScaleWindowIconPixbufGetter ::   Int32 -> WindowIconPixbufGetter -> WindowIconPixbufGetter@@ -680,10 +625,7 @@   const $ scaledWindowIconPixbufGetter getter constantSize  handleIconGetterException :: WindowIconPixbufGetter -> WindowIconPixbufGetter-handleIconGetterException getter size windowData =-  catchAny (getter size windowData) $ \e -> do-    wLog WARNING $ printf "Failed to get window icon for %s: %s" (show windowData) (show e)-    return Nothing+handleIconGetterException = handlePixbufGetterException wLog  getWindowIconPixbufFromEWMH :: WindowIconPixbufGetter getWindowIconPixbufFromEWMH = handleIconGetterException $ \size windowData ->@@ -768,72 +710,30 @@   WorkspacesContext {workspacesConfig = cfg} <- ask   sortedWindows <- iconSort cfg $ windows ws   wLog DEBUG $ printf "Updating images for %s" (show ws)-  let updateIconWidget' getImageAction wdata = do-        iconWidget <- getImageAction-        _ <- updateIconWidget ic iconWidget wdata-        return iconWidget-      existingImages = map return $ iconImages ic-      buildAndAddIconWidget transparentOnNone = do-        iw <- buildIconWidget transparentOnNone ws-        lift $ Gtk.containerAdd (iconsContainer ic) $ iconContainer iw-        return iw-      infiniteImages =-        existingImages ++-        replicate (minIcons cfg - length existingImages)-                  (buildAndAddIconWidget True) ++-        repeat (buildAndAddIconWidget False)-      windowCount = length $ windows ws-      maxNeeded = maybe windowCount (min windowCount) $ maxIcons cfg-      newImagesNeeded = length existingImages < max (minIcons cfg) maxNeeded-      -- XXX: Only one of the two things being zipped can be an infinite list,-      -- which is why this newImagesNeeded contortion is needed.-      imgSrcs =-        if newImagesNeeded-          then infiniteImages-          else existingImages-      getImgs = maybe imgSrcs (`take` imgSrcs) $ maxIcons cfg-      justWindows = map Just sortedWindows-      windowDatas =-        if newImagesNeeded-          then justWindows ++-               replicate (minIcons cfg - length justWindows) Nothing-          else justWindows ++ repeat Nothing-  newImgs <--    zipWithM updateIconWidget' getImgs windowDatas-  when newImagesNeeded $ lift $ Gtk.widgetShowAll $ iconsContainer ic-  return newImgs+  let (effectiveMinIcons, _targetLen, paddedWindows) =+        computeIconStripLayout (minIcons cfg) (maxIcons cfg) sortedWindows+      buildOne i = buildIconWidget (i < effectiveMinIcons) ws+      updateOne = updateIconWidget ic+  syncWidgetPool (iconsContainer ic) (iconImages ic) paddedWindows buildOne iconContainer updateOne  getWindowStatusString :: WindowData -> T.Text-getWindowStatusString windowData = T.toLower $ T.pack $-  case windowData of-    WindowData { windowMinimized = True } -> "minimized"-    WindowData { windowActive = True } -> show Active-    WindowData { windowUrgent = True } -> show Urgent-    _ -> "normal"--possibleStatusStrings :: [T.Text]-possibleStatusStrings =-  map-    (T.toLower . T.pack)-    [show Active, show Urgent, "minimized", "normal", "inactive"]+getWindowStatusString windowData =+  windowStatusClassFromFlags+    (windowMinimized windowData)+    (windowActive windowData)+    (windowUrgent windowData)  updateIconWidget   :: IconController   -> IconWidget   -> Maybe WindowData   -> WorkspacesIO ()-updateIconWidget _ IconWidget-                   { iconContainer = iconButton-                   , iconWindow = windowRef-                   , iconForceUpdate = updateIcon-                   } windowData = do-  let statusString = maybe "inactive" getWindowStatusString windowData :: T.Text-      title = T.pack . windowTitle <$> windowData-      setIconWidgetProperties =-        updateWidgetClasses iconButton [statusString] possibleStatusStrings-  void $ updateVar windowRef $ const $ return windowData-  Gtk.widgetSetTooltipText iconButton title-  lift $ updateIcon >> setIconWidgetProperties+updateIconWidget _ iconWidget windowData =+  updateWindowIconWidgetState+    iconWidget+    windowData+    (T.pack . windowTitle)+    getWindowStatusString  data WorkspaceButtonController = WorkspaceButtonController   { button :: Gtk.EventBox
+ src/System/Taffybar/Widget/Workspaces/Shared.hs view
@@ -0,0 +1,118 @@+{-# LANGUAGE OverloadedStrings #-}++-----------------------------------------------------------------------------+-- |+-- Module      : System.Taffybar.Widget.Workspaces.Shared+-- Copyright   : (c) Ivan A. Malison+-- License     : BSD3-style (see LICENSE)+--+-- Maintainer  : Ivan A. Malison+-- Stability   : unstable+-- Portability : unportable+--+-- Shared UI helpers for workspace widgets (X11/EWMH and Hyprland).+--+-----------------------------------------------------------------------------++module System.Taffybar.Widget.Workspaces.Shared+  ( WorkspaceState(..)+  , getCSSClass+  , cssWorkspaceStates+  , setWorkspaceWidgetStatusClass+  , buildWorkspaceIconLabelOverlay+  , mkWorkspaceIconWidget+  ) where++import qualified Control.Concurrent.MVar as MV+import           Control.Monad+import           Control.Monad.IO.Class (MonadIO(..))+import           Data.Int (Int32)+import qualified Data.Text as T++import qualified GI.GdkPixbuf.Objects.Pixbuf as Gdk+import qualified GI.Gtk as Gtk++import           System.Taffybar.Widget.Generic.AutoSizeImage (ImageScaleStrategy)+import           System.Taffybar.Widget.Generic.ScalingImage (scalingImageNew)+import           System.Taffybar.Widget.Util+  ( WindowIconWidget(..)+  , buildBottomLeftAlignedBox+  , buildContentsBox+  , buildOverlayWithPassThrough+  , mkWindowIconWidgetBase+  , updateWidgetClasses+  , widgetSetClassGI+  )++data WorkspaceState+  = Active+  | Visible+  | Hidden+  | Empty+  | Urgent+  deriving (Show, Eq)++getCSSClass :: (Show s) => s -> T.Text+getCSSClass = T.toLower . T.pack . show++cssWorkspaceStates :: [T.Text]+cssWorkspaceStates = map getCSSClass [Active, Visible, Hidden, Empty, Urgent]++setWorkspaceWidgetStatusClass ::+  (MonadIO m, Gtk.IsWidget a) => WorkspaceState -> a -> m ()+setWorkspaceWidgetStatusClass ws widget =+  updateWidgetClasses+    widget+    [getCSSClass ws]+    cssWorkspaceStates++-- | Build the common overlay layout used by workspace widgets:+-- window icons are the base content and the workspace label is overlaid in the+-- bottom-left corner.+buildWorkspaceIconLabelOverlay ::+  MonadIO m =>+  Gtk.Widget -> -- ^ Widget containing the window icon strip.+  Gtk.Widget -> -- ^ Workspace label widget.+  m Gtk.Widget+buildWorkspaceIconLabelOverlay iconsWidget labelWidget = do+  base <- buildContentsBox iconsWidget+  overlayLabel <- buildBottomLeftAlignedBox "overlay-box" labelWidget+  buildOverlayWithPassThrough base [overlayLabel]++-- | Build a 'WindowIconWidget' that automatically scales with allocation and+-- displays a transparent placeholder pixbuf when requested.+--+-- This is shared by both X11 and Hyprland workspace widgets so that CSS classes+-- and widget behavior remain consistent across backends.+mkWorkspaceIconWidget ::+  ImageScaleStrategy -> -- ^ Which scaling implementation to use.+  Maybe Int32 -> -- ^ Optional size request for the icon image.+  Bool -> -- ^ Whether to render a transparent placeholder when there is no data.+  (Int32 -> a -> IO (Maybe Gdk.Pixbuf)) -> -- ^ Icon pixbuf getter.+  (Int32 -> IO Gdk.Pixbuf) -> -- ^ Transparent placeholder pixbuf generator.+  IO (WindowIconWidget a)+mkWorkspaceIconWidget strategy mSize transparentOnNone getPixbufFor mkTransparent = do+  base <- mkWindowIconWidgetBase mSize+  let getPixbuf size = do+        mWin <- MV.readMVar (iconWindow base)+        case mWin of+          Nothing ->+            if transparentOnNone+              then Just <$> mkTransparent size+              else return Nothing+          Just w -> do+            pb <- getPixbufFor size w+            case pb of+              Just _ -> return pb+              Nothing ->+                if transparentOnNone+                  then Just <$> mkTransparent size+                  else return Nothing+  (imageWidget, refreshImage) <-+    scalingImageNew strategy getPixbuf Gtk.OrientationHorizontal+  _ <- widgetSetClassGI imageWidget "window-icon"+  forM_ mSize $ \s ->+    Gtk.widgetSetSizeRequest imageWidget (fromIntegral s) (fromIntegral s)+  Gtk.containerAdd (iconContainer base) imageWidget+  return base { iconImage = imageWidget, iconForceUpdate = refreshImage }+
taffybar.cabal view
@@ -1,6 +1,6 @@ cabal-version: 3.4 name: taffybar-version: 4.1.1+version: 4.1.2 synopsis: A desktop bar similar to xmobar, but with more GUI license: BSD-3-Clause license-file: LICENSE@@ -8,17 +8,25 @@ maintainer: IvanMalison@gmail.com category: System build-type: Simple-tested-with: GHC == 9.8.4, GHC == 9.10.3+tested-with: GHC == 9.8.4, GHC == 9.10.3, GHC == 9.12.3 homepage: http://github.com/taffybar/taffybar data-files:   taffybar.css   icons/*.svg extra-source-files:+  dbus-xml/org.PulseAudio.ServerLookup1.xml+  dbus-xml/org.PulseAudio.Core1.xml+  dbus-xml/org.PulseAudio.Core1.Device.xml   dbus-xml/org.freedesktop.UPower.Device.xml   dbus-xml/org.freedesktop.UPower.xml   dbus-xml/org.mpris.MediaPlayer2.Player.xml   dbus-xml/org.mpris.MediaPlayer2.xml+  dbus-xml/org.freedesktop.NetworkManager.xml+  dbus-xml/org.freedesktop.NetworkManager.Connection.Active.xml+  dbus-xml/org.freedesktop.NetworkManager.AccessPoint.xml   test/data/*.golden+  test/data/*.png+  test/data/appearance-test.css extra-doc-files:   README.md   CHANGELOG.md@@ -33,6 +41,7 @@     GeneralizedNewtypeDeriving     LambdaCase     NumericUnderscores+    ScopedTypeVariables     StandaloneDeriving     TupleSections   default-language: Haskell2010@@ -56,19 +65,23 @@                , containers                , data-default                , dbus >= 1.2.11 && < 2.0.0-               , dbus-hslogger >= 0.1.0.1 && < 0.2.0.0+               , dbus-hslogger >= 0.1.1.0 && < 0.2.0.0+               , dbus-menu >= 0.1.0.0                , directory+               , disk-free-space >= 0.1.0.1                , dyre >= 0.9.0 && < 0.10                , either >= 4.0.0.0                , enclosed-exceptions >= 1.0.0.1                , filepath                , fsnotify >= 0.4 && < 0.5+               , monad-control                , gi-cairo-connector                , gi-cairo-render-               , gi-gdk3 >=3.0.30 && <3.1+                , gi-gdk3 >=3.0.30 && <3.1                , gi-gdkpixbuf >=2.0.6 && <2.1                , gi-gdkx113 >=3.0.17 && < 4                , gi-glib+               , gi-gtk-layer-shell >= 0.1.7                , gi-gtk3 >= 3.0.44 && < 4                , gi-gtk-hs >= 0.3.17 && < 0.4                , gi-pango@@ -81,12 +94,13 @@                , http-client-tls                , http-types                , multimap >= 1.2.1+               , network                , parsec >= 3.1                , process >= 1.0.1.1                , rate-limit >= 1.1.1                , regex-compat                , safe >= 0.3 && < 1-               , scotty >= 0.20 && < 0.23+               , scotty >= 0.20 && < 0.31                , split >= 0.1.4.2                , status-notifier-item >= 0.3.1.0                , stm@@ -103,64 +117,104 @@                , xdg-basedir >= 0.2 && < 0.3                , xml                , xml-helpers+               , yaml    hs-source-dirs: src   pkgconfig-depends: gtk+-3.0+  if os(linux)+    pkgconfig-depends: libudev   exposed-modules: System.Taffybar                  , System.Taffybar.Auth                  , System.Taffybar.Context+                 , System.Taffybar.Context.Backend                  , System.Taffybar.DBus                  , System.Taffybar.DBus.Toggle                  , System.Taffybar.Example+                 , System.Taffybar.Hyprland                  , System.Taffybar.Hooks+                 , System.Taffybar.Information.Hyprland+                 , System.Taffybar.Information.PulseAudio+                 , System.Taffybar.Information.WirePlumber+                 , System.Taffybar.Information.Backlight                  , System.Taffybar.Information.Battery+                 , System.Taffybar.Information.Bluetooth                  , System.Taffybar.Information.CPU                  , System.Taffybar.Information.CPU2                  , System.Taffybar.Information.Chrome                  , System.Taffybar.Information.Crypto                  , System.Taffybar.Information.DiskIO+                 , System.Taffybar.Information.DiskUsage                  , System.Taffybar.Information.EWMHDesktopInfo+                 , System.Taffybar.Information.Inhibitor+                 , System.Taffybar.Information.KeyboardState                  , System.Taffybar.Information.MPRIS2                  , System.Taffybar.Information.Memory                  , System.Taffybar.Information.Network+                 , System.Taffybar.Information.Temperature+                 , System.Taffybar.Information.NetworkManager+                 , System.Taffybar.Information.PowerProfiles+                 , System.Taffybar.Information.Privacy                  , System.Taffybar.Information.SafeX11+                 , System.Taffybar.Information.Systemd                  , System.Taffybar.Information.StreamInfo                  , System.Taffybar.Information.X11DesktopInfo                  , System.Taffybar.Information.XDG.Protocol                  , System.Taffybar.LogFormatter+                 , System.Taffybar.LogLevels                  , System.Taffybar.SimpleConfig                  , System.Taffybar.Util                  , System.Taffybar.Widget+                 , System.Taffybar.Widget.PulseAudio+                 , System.Taffybar.Widget.Backlight                  , System.Taffybar.Widget.Battery+                 , System.Taffybar.Widget.BatteryDonut+                 , System.Taffybar.Widget.BatteryTextIcon+                 , System.Taffybar.Widget.Bluetooth                  , System.Taffybar.Widget.CPUMonitor                  , System.Taffybar.Widget.CommandRunner                  , System.Taffybar.Widget.Crypto                  , System.Taffybar.Widget.DiskIOMonitor+                 , System.Taffybar.Widget.DiskUsage                  , System.Taffybar.Widget.FSMonitor                  , System.Taffybar.Widget.FreedesktopNotifications+                 , System.Taffybar.Widget.Generic.AutoFillImage                  , System.Taffybar.Widget.Generic.AutoSizeImage                  , System.Taffybar.Widget.Generic.ChannelGraph                  , System.Taffybar.Widget.Generic.ChannelWidget                  , System.Taffybar.Widget.Generic.DynamicMenu                  , System.Taffybar.Widget.Generic.Graph                  , System.Taffybar.Widget.Generic.Icon+                 , System.Taffybar.Widget.Generic.ScalingImage                  , System.Taffybar.Widget.Generic.PollingBar                  , System.Taffybar.Widget.Generic.PollingGraph                  , System.Taffybar.Widget.Generic.PollingLabel                  , System.Taffybar.Widget.Generic.VerticalBar+                 , System.Taffybar.Widget.HyprlandLayout+                 , System.Taffybar.Widget.HyprlandWindows+                 , System.Taffybar.Widget.Inhibitor+                 , System.Taffybar.Widget.KeyboardState                  , System.Taffybar.Widget.Layout                  , System.Taffybar.Widget.MPRIS2                  , System.Taffybar.Widget.NetworkGraph+                 , System.Taffybar.Widget.NetworkManager+                 , System.Taffybar.Widget.PowerProfiles+                 , System.Taffybar.Widget.Privacy+                 , System.Taffybar.Widget.SNIMenu                  , System.Taffybar.Widget.SNITray                  , System.Taffybar.Widget.SimpleClock                  , System.Taffybar.Widget.SimpleCommandButton+                 , System.Taffybar.Widget.Systemd+                 , System.Taffybar.Widget.Temperature                  , System.Taffybar.Widget.Text.CPUMonitor                  , System.Taffybar.Widget.Text.MemoryMonitor                  , System.Taffybar.Widget.Text.NetworkMonitor                  , System.Taffybar.Widget.Util                  , System.Taffybar.Widget.Weather+                 , System.Taffybar.Widget.HyprlandWorkspaces                  , System.Taffybar.Widget.Windows                  , System.Taffybar.Widget.Workspaces+                 , System.Taffybar.Widget.Workspaces.Shared+                 , System.Taffybar.Widget.WirePlumber                  , System.Taffybar.Widget.WttrIn                  , System.Taffybar.Widget.XDGMenu.Menu                  , System.Taffybar.Widget.XDGMenu.MenuWidget@@ -172,10 +226,17 @@    other-modules: Paths_taffybar                , System.Taffybar.DBus.Client.MPRIS2+               , System.Taffybar.DBus.Client.NetworkManager+               , System.Taffybar.DBus.Client.NetworkManagerAccessPoint+               , System.Taffybar.DBus.Client.NetworkManagerActiveConnection                , System.Taffybar.DBus.Client.Params+               , System.Taffybar.DBus.Client.PulseAudioCore+               , System.Taffybar.DBus.Client.PulseAudioDevice+               , System.Taffybar.DBus.Client.PulseAudioServerLookup                , System.Taffybar.DBus.Client.UPower                , System.Taffybar.DBus.Client.UPowerDevice                , System.Taffybar.DBus.Client.Util+               , System.Taffybar.Information.Udev    autogen-modules: Paths_taffybar @@ -197,6 +258,52 @@   main-is: Main.hs   pkgconfig-depends: gtk+-3.0 +executable taffybar-test-wm+  import: haskell, exe+  hs-source-dirs: app+  main-is: TestWM.hs+  build-depends: xmonad+               , xmonad-contrib++executable taffybar-appearance-snap+  import: haskell, exe+  hs-source-dirs: app+  main-is: AppearanceSnap.hs+  build-depends: JuicyPixels+               , X11+               , bytestring+               , data-default+               , directory+               , filepath+               , gi-gdk3+               , gi-gdkpixbuf+               , gi-gtk3+               , gtk-strut+               , taffybar+               , text+               , transformers+               , typed-process+               , unix+               , unliftio++executable taffybar-appearance-snap-hyprland+  import: haskell, exe+  hs-source-dirs: app+  main-is: AppearanceSnapHyprland.hs+  build-depends: JuicyPixels+               , bytestring+               , data-default+               , directory+               , filepath+               , gi-gtk3+               , gtk-strut+               , taffybar+               , text+               , typed-process+               , unix+               , unliftio+               , transformers+ common test   default-extensions:     ImportQualifiedPost@@ -238,20 +345,31 @@   main-is: unit-tests.hs   other-modules: UnitSpec                , System.Taffybar.AuthSpec+               , System.Taffybar.AppearanceSpec                , System.Taffybar.ContextSpec                , System.Taffybar.Information.X11DesktopInfoSpec                , System.Taffybar.SimpleConfigSpec+               , System.Taffybar.Widget.HyprlandWorkspacesSpec   build-depends: data-default+               , bytestring+               , directory+               , JuicyPixels                , filepath+               , text                , gi-gtk3                , hspec                , hspec-core                , hspec-golden                , taffybar                , taffybar:testlib+               , typed-process+               , unix+               , unliftio                , transformers                , QuickCheck   build-tool-depends: hspec-discover:hspec-discover == 2.*+                   , taffybar:taffybar-test-wm+                   , taffybar:taffybar-appearance-snap  source-repository head   type: git
+ test/data/appearance-ewmh-bar.png view

binary file changed (absent → 1661 bytes)

+ test/data/appearance-hyprland-bar.png view

binary file changed (absent → 3864 bytes)

+ test/data/appearance-test.css view
@@ -0,0 +1,65 @@+/* Deterministic styling for CI appearance snapshots.+ *+ * Keep this minimal: any theme/font dependence will churn goldens.+ */++/* Font rendering is otherwise host-dependent (e.g. Roboto vs DejaVu).+ * Nix CI pins DejaVu via FONTCONFIG_FILE; do the same here so `cabal test`+ * matches the committed golden on non-Nix systems too.+ */+* {+  font-family: "DejaVu Sans";+}++window.taffy-window,+.taffy-box {+  background-image: linear-gradient(to bottom, #2b2b2b, #1e1e1e);+  background-color: #1e1e1e;+}++.taffy-box {+  padding: 4px 8px;+}++/* Keep workspace icon layout stable and large enough to be visible. */+.workspaces {+  padding-right: 10px;+}++.workspace-label {+  color: #f0f0f0;+  font-size: 12px;+  padding: 0px 6px 0px 0px;+}++.window-icon-container {+  min-width: 16px;+  min-height: 16px;+  padding: 2px;+}++.window-icon {+  min-width: 16px;+  min-height: 16px;+}++.test-center-box {+  background-color: #3a3a3a;+  border-radius: 5px;+}++.test-right-box {+  background-color: #3a5a7a;+  border-radius: 5px;+}++.test-pill {+  background-color: rgba(255, 255, 255, 0.08);+  color: #f0f0f0;+  border-radius: 999px;+  padding: 2px 8px;+  font-size: 12px;+  /* Keep size stable even when pill contents are empty. */+  min-width: 52px;+  min-height: 20px;+}
test/lib/System/Taffybar/Test/DBusSpec.hs view
@@ -20,9 +20,7 @@  import Control.Monad (forM_, void, when) import Control.Monad.IO.Unlift (MonadUnliftIO (..))-import Data.ByteString.Char8 qualified as B8 import Data.Function ((&))-import Data.List (sort) import Data.Map qualified as Map import Data.Maybe (fromMaybe) import Data.Int (Int64)@@ -266,24 +264,11 @@   forM_ [System] $ \bus ->     aroundWith (flip (withConnectDBusDaemon' bus) . curry) $     describe ("python-dbusmock " ++ show bus ++ " services") $ do-      it "simple" $ \(addr, client) -> example $-        withPythonDBusMock bus (addr, client) "com.example.Foo" "/" "com.example.Foo.Manager" $ pure ()--      it "UPower" $ \(addr, client) -> example $ do-        withPythonDBusMock bus (addr, client) upName upPath upIface $ do-          mockUPower client-          models <- upowerDumpModels addr-          sort models `shouldBe` ["Mock AC", "Mock Battery"]+      -- These tests are currently failing in CI due to python-dbusmock startup issues.+      -- Mark as pending until the root cause is identified.+      it "simple" $ \_ -> pendingWith "python-dbusmock fails to start in CI" -upowerDumpModels :: Address -> IO [String]-upowerDumpModels addr = parse <$> readProcessStdout_ cfg-  where-    cfg = proc "upower" ["--dump"] & setDBusEnv System addr-    parse = map (B8.unpack . B8.dropSpace . B8.drop 1 . snd)-      . filter ((== "model") . fst)-      . map (B8.break (== ':') . B8.dropSpace)-      . B8.lines-      . B8.toStrict+      it "UPower" $ \_ -> pendingWith "python-dbusmock fails to start in CI"  gdbusPing :: Bus -> ProcessConfig () () () gdbusPing bus = proc "gdbus" ["call", "--" ++ busName bus, "--dest", "org.freedesktop.DBus", "--object-path", "/org/freedesktop/DBus", "--method", "org.freedesktop.DBus.Peer.Ping"]
+ test/unit/System/Taffybar/AppearanceSpec.hs view
@@ -0,0 +1,135 @@+module System.Taffybar.AppearanceSpec (spec) where++import Control.Monad (when)+import System.Directory (doesFileExist, findExecutable, makeAbsolute)+import System.Exit (ExitCode (..))+import System.FilePath ((</>))+import System.Timeout (timeout)++import qualified Codec.Picture as JP+import qualified Data.ByteString.Lazy as BL++import Test.Hspec++import UnliftIO.Directory (createDirectoryIfMissing)+import UnliftIO.Environment (lookupEnv)+import UnliftIO.Temporary (withSystemTempDirectory)++import System.Process.Typed+  ( inherit+  , proc+  , setStderr+  , setStdout+  , stopProcess+  , waitExitCode+  , withProcessTerm+  )++import System.Taffybar.Test.DBusSpec (withTestDBus)+import System.Taffybar.Test.UtilSpec (withEnv, withSetEnv)+import System.Taffybar.Test.XvfbSpec (setDefaultDisplay_, withXvfb)++spec :: Spec+spec = aroundAll withIntegrationEnv $ do+  it "renders a bar under an EWMH window manager" $ \env -> do+    goldenFile <- makeAbsolute "test/data/appearance-ewmh-bar.png"+    actualPng <- renderBarScreenshot env++    shouldUpdate <- lookupEnv "TAFFYBAR_UPDATE_GOLDENS"+    case shouldUpdate of+      Just _ -> do+        BL.writeFile goldenFile actualPng+        createDirectoryIfMissing True "dist"+        BL.writeFile "dist/appearance-actual.png" actualPng+      Nothing -> do+        goldenPng <- BL.readFile goldenFile+        let actualImg = decodePngRGBA8 "actual" actualPng+            goldenImg = decodePngRGBA8 "golden" goldenPng+        when (actualImg /= goldenImg) $ do+          createDirectoryIfMissing True "dist"+          BL.writeFile "dist/appearance-actual.png" actualPng+          BL.writeFile "dist/appearance-golden.png" goldenPng+          expectationFailure $+            "Appearance golden mismatch: " ++ goldenFile +++            " (wrote dist/appearance-actual.png and dist/appearance-golden.png)"++newtype Env = Env+  { envTmpDir :: FilePath+  }++withIntegrationEnv :: ActionWith Env -> IO ()+withIntegrationEnv action =+  withXvfb $ \dn ->+    setDefaultDisplay_ dn $+      withTestDBus $+        withSystemTempDirectory "taffybar-appearance" $ \tmp -> do+          let runtimeDir = tmp </> "xdg-run"+          createDirectoryIfMissing True runtimeDir++          -- Keep user/system config out of the test run and reduce variability.+          withEnv+            [ ("WAYLAND_DISPLAY", const Nothing)+            , ("HYPRLAND_INSTANCE_SIGNATURE", const Nothing)+            ] $+              withSetEnv+              [ ("GDK_BACKEND", "x11")+              , ("GDK_SCALE", "1")+              , ("GDK_DPI_SCALE", "1")+              , ("GTK_CSD", "0")+              , ("GTK_THEME", "Adwaita")+              , ("XDG_SESSION_TYPE", "x11")+              , ("XDG_RUNTIME_DIR", runtimeDir)+              , ("NO_AT_BRIDGE", "1")+              , ("GSETTINGS_BACKEND", "memory")+              , ("HOME", tmp)+              , ("XDG_CONFIG_HOME", tmp </> "xdg-config")+              , ("XDG_CACHE_HOME", tmp </> "xdg-cache")+              , ("XDG_DATA_HOME", tmp </> "xdg-data")+              ] $+              action (Env { envTmpDir = tmp })++renderBarScreenshot :: Env -> IO BL.ByteString+renderBarScreenshot Env { envTmpDir = tmp } = do+  exePath <-+    findComponentExecutable+      "taffybar-appearance-snap"+      [ "dist/build/taffybar-appearance-snap/taffybar-appearance-snap"+      ]++  cssPath <- makeAbsolute "test/data/appearance-test.css"+  outPath <- makeAbsolute (tmp </> "appearance-actual.png")++  let pc =+        setStdout inherit $+          setStderr inherit $+            proc exePath ["--out", outPath, "--css", cssPath]++  withProcessTerm pc $ \p -> do+    mEc <- timeout 60_000_000 (waitExitCode p)+    case mEc of+      Nothing -> do+        stopProcess p+        expectationFailure "Timed out running taffybar-appearance-snap"+      Just ExitSuccess -> pure ()+      Just (ExitFailure n) ->+        expectationFailure ("taffybar-appearance-snap exited with " ++ show n)++  BL.readFile outPath++findComponentExecutable :: String -> [FilePath] -> IO FilePath+findComponentExecutable name localCandidates = do+  mexe <- findExecutable name+  case mexe of+    Just exe -> makeAbsolute exe+    Nothing -> go localCandidates+  where+    go [] = fail (name ++ " not found on PATH")+    go (p:ps) = do+      exists <- doesFileExist p+      if exists then makeAbsolute p else go ps++decodePngRGBA8 :: String -> BL.ByteString -> JP.Image JP.PixelRGBA8+decodePngRGBA8 label bs =+  case JP.decodePng (BL.toStrict bs) of+    Left err -> error (label ++ " PNG decode failed: " ++ err)+    Right dyn -> JP.convertRGBA8 dyn
test/unit/System/Taffybar/ContextSpec.hs view
@@ -21,10 +21,13 @@   ) where  import Control.Monad.Trans.Reader (runReaderT)+import Control.Exception (SomeException, catch) import Data.Default (def) import Data.Ratio ((%)) import GHC.Generics (Generic) import GI.Gtk (Widget)+import System.Directory (createDirectoryIfMissing, getTemporaryDirectory, removePathForcibly)+import System.FilePath ((</>))  import Test.Hspec hiding (context) import Test.Hspec.QuickCheck@@ -37,11 +40,42 @@ import System.Taffybar.Widget.Workspaces (workspacesNew)  import System.Taffybar.Test.DBusSpec (withTestDBus)-import System.Taffybar.Test.UtilSpec (logSetup)+import System.Taffybar.Test.UtilSpec (logSetup, withSetEnv) import System.Taffybar.Test.XvfbSpec (withXdummy, setDefaultDisplay_)  spec :: Spec spec = logSetup $ sequential $ aroundAll_ withTestDBus $ aroundAll_ (withXdummy . flip setDefaultDisplay_) $ do+  describe "detectBackend" $ do+    it "falls back to X11 when WAYLAND_DISPLAY is set but the socket is missing" $ do+      tmp <- getTemporaryDirectory+      let runtime = tmp </> "taffybar-test-runtime-missing-socket"+          wl = "wayland-stale"+      removePathForcibly runtime `catch` (\(_ :: SomeException) -> pure ())+      createDirectoryIfMissing True runtime+      withSetEnv+        [ ("XDG_RUNTIME_DIR", runtime)+        , ("WAYLAND_DISPLAY", wl)+        , ("XDG_SESSION_TYPE", "wayland")+        ] $ do+          detectBackend `shouldReturn` BackendX11+      removePathForcibly runtime `catch` (\(_ :: SomeException) -> pure ())++    it "falls back to X11 when WAYLAND_DISPLAY points at a non-socket path" $ do+      tmp <- getTemporaryDirectory+      let runtime = tmp </> "taffybar-test-runtime-non-socket"+          wl = "wayland-stale"+          wlPath = runtime </> wl+      removePathForcibly runtime `catch` (\(_ :: SomeException) -> pure ())+      createDirectoryIfMissing True runtime+      writeFile wlPath "" -- exists but is not a socket+      withSetEnv+        [ ("XDG_RUNTIME_DIR", runtime)+        , ("WAYLAND_DISPLAY", wl)+        , ("XDG_SESSION_TYPE", "wayland")+        ] $ do+          detectBackend `shouldReturn` BackendX11+      removePathForcibly runtime `catch` (\(_ :: SomeException) -> pure ())+   describe "Fuzz tests" $ do     prop "eval generators" prop_genSimpleConfig     xprop "TaffybarConfig" prop_taffybarConfig
+ test/unit/System/Taffybar/Widget/HyprlandWorkspacesSpec.hs view
@@ -0,0 +1,38 @@+module System.Taffybar.Widget.HyprlandWorkspacesSpec where++import Test.Hspec++import qualified Data.Text as T++import System.Taffybar.Widget.HyprlandWorkspaces+  ( HyprlandWindow(..)+  , sortHyprlandWindowsByPosition+  )++mkWin :: String -> Bool -> Maybe (Int, Int) -> HyprlandWindow+mkWin addr minimized atPos =+  HyprlandWindow+    { windowAddress = T.pack addr+    , windowTitle = addr+    , windowClass = Nothing+    , windowInitialClass = Nothing+    , windowAt = atPos+    , windowUrgent = False+    , windowActive = False+    , windowMinimized = minimized+    }++spec :: Spec+spec = do+  describe "sortHyprlandWindowsByPosition" $ do+    it "orders non-minimized windows first, then by (x, y) position" $ do+      let a = mkWin "a" False (Just (10, 0))+          b = mkWin "b" False (Just (0, 100))+          c = mkWin "c" True  (Just (0, 0))+      sortHyprlandWindowsByPosition [a, b, c] `shouldBe` [b, a, c]++    it "puts windows without a position at the end" $ do+      let a = mkWin "a" False Nothing+          b = mkWin "b" False (Just (0, 0))+      sortHyprlandWindowsByPosition [a, b] `shouldBe` [b, a]+