packages feed

taffybar 5.1.3 → 5.2.0

raw patch · 166 files changed

+19005/−9001 lines, 166 filesdep +dhalldep ~dbus-menudep ~gi-gtk3dep ~gtk-sni-traybinary-added

Dependencies added: dhall

Dependency ranges changed: dbus-menu, gi-gtk3, gtk-sni-tray, status-notifier-item

Files

CHANGELOG.md view
@@ -1,5 +1,63 @@ # Unreleased +# 5.2.0++## New Features++* Add optional `barLevels` support to `BarConfig`/`SimpleTaffyConfig` for+  stacked multi-row bars with per-level `start`/`center`/`end` widget lists.+* Keep backward compatibility for existing configs: when `barLevels` is+  `Nothing`, the legacy single-row widget fields are used unchanged.+* Add `mpris2NewWithControls`, an opt-in MPRIS2 constructor that shows+  previous/play-pause/next controls gated by player capabilities+  (`CanGoPrevious`, `CanPlay`, `CanPause`, `CanGoNext`).+* Add channel-based CPU sampling via+  `System.Taffybar.Information.CPU2.getCPULoadChan`, and switch CPU widgets to+  use the channel-backed implementation.++## Deprecations++* Deprecate `System.Taffybar.Information.CPU` and+  `System.Taffybar.Information.CPU.cpuLoad`.+* Deprecate non-channel CPU2 polling/parsing entry points:+  `System.Taffybar.Information.CPU2.getCPUInfo` and+  `System.Taffybar.Information.CPU2.getCPULoad`.++## Dependency Bumps++ * Bump `gtk-sni-tray` lower bound to 0.1.14.0.+ * Bump `status-notifier-item` lower bound to 0.3.2.6, pulling in important+   robustness fixes for the StatusNotifier host/watcher implementations+   (registration ownership checks, restart deduplication, cache-backed restore,+   and better reconciliation after watcher restarts).++## Tray++ * Add optional SNI tray priority pass-through via new additive constructors+   while keeping existing tray constructors backwards compatible.+ * Add a collapsible SNI tray widget with overflow indicator and expand/collapse+   interaction.+ * Add a prioritized collapsible SNI tray variant with:+   persisted icon priorities, a button-driven priority edit mode, explicit+   expand/collapse toggle, and priority threshold filtering.+ * Put prioritized-collapsible tray implementation in its own module:+   `System.Taffybar.Widget.SNITray.PrioritizedCollapsible`.+ * Make equal-priority icon ordering stable in the prioritized collapsible tray+   using deterministic per-item identity tie-breaking.+ * Improve prioritized collapsible tray UX:+   separate icon buttons for expand/edit/settings, menu-based priority editing,+   and menu controls for max-visible and threshold settings.+ * StatusNotifier host/watcher behavior is now significantly more robust via the+   `status-notifier-item` update (better restart handling, deduplication, and+   state reconciliation).++## Tests++ * Add a new X11 appearance golden test for two-level bars+   (`appearance-ewmh-bar-levels.png`).+ * Extend Hyprland VM appearance checks to exercise `--levels` rendering and+   assert multi-row output markers.+ # 5.1.3  ## Dependency Bumps
app/AppearanceSnap.hs view
@@ -8,101 +8,123 @@ -- this executable in CI. module Main (main) where -import Control.Concurrent (MVar, forkIO, newEmptyMVar, threadDelay, takeMVar)+import qualified Codec.Picture as JP+import Control.Concurrent (MVar, forkIO, newEmptyMVar, takeMVar, threadDelay) 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.Bits (shiftL, (.|.))+import qualified Data.ByteString as B+import qualified Data.ByteString.Lazy as BL import Data.Default (def)-import Data.Maybe (listToMaybe)-import Data.Unique (newUnique)+import Data.List (nub)+import Data.Maybe (fromMaybe, listToMaybe) 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.Unique (Unique, newUnique) 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.UI.GIGtkStrut+  ( StrutConfig (..),+    StrutPosition (TopPos),+    StrutSize (ExactSize),+    defaultStrutConfig,+  ) import Graphics.X11.Xlib-  ( Atom-  , Display-  , Window-  , closeDisplay-  , createSimpleWindow-  , defaultRootWindow-  , internAtom-  , mapWindow-  , openDisplay-  , storeName-  , sync+  ( 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+  ( ClassHint (..),+    changeProperty32,+    getWindowProperty32,+    propModeReplace,+    queryTree,+    setClassHint,   )+import System.Directory (createDirectoryIfMissing, doesFileExist, 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.Info (arch, os) import System.Posix.Files (createSymbolicLink, removeLink)+import System.Posix.Process (exitImmediately)+import System.Posix.Signals (sigKILL, sigTERM, signalProcess) import System.Process.Typed (Process, getPid, proc, startProcess)- import System.Taffybar (startTaffybar) import System.Taffybar.Context-  ( BarConfig (..)-  , Context (..)-  , TaffyIO-  , TaffybarConfig (..)-  , exitTaffybar+  ( BarConfig (..),+    BarLevelConfig (..),+    Context (..),+    TaffyIO,+    TaffybarConfig (..),+    exitTaffybar,   ) import System.Taffybar.Util (postGUIASync)-import System.Taffybar.Widget.Workspaces-  ( WorkspacesConfig (..)-  , getWindowIconPixbufFromEWMH-  , sortWindowsByStackIndex-  , workspacesNew+import qualified System.Taffybar.Widget.Windows as Windows+import qualified System.Taffybar.Widget.Workspaces as ChannelWorkspaces+import qualified System.Taffybar.Widget.Workspaces.Config as WorkspaceConfig+import System.Taffybar.Widget.Workspaces.EWMH+  ( WorkspacesConfig,+    getWindowIconPixbufFromEWMH,+    sortWindowsByStackIndex,+    workspacesNew,   )+import qualified System.Taffybar.Widget.Workspaces.EWMH as Workspaces+import Text.Read (readMaybe)+import UnliftIO.Temporary (withSystemTempDirectory)  data Args = Args-  { outFile :: FilePath-  , cssFile :: FilePath+  { outFile :: FilePath,+    cssFile :: FilePath,+    layoutMode :: LayoutMode,+    workspaceWidgetMode :: WorkspaceWidgetMode,+    expectedTopStrut :: Maybe Int   } +data LayoutMode = LayoutLegacy | LayoutLevels | LayoutWindowsTitleStress+  deriving (Eq, Show)++data WorkspaceWidgetMode+  = UseLegacyWorkspaces+  | UseChannelWorkspaces+  deriving (Eq, Show)++snapshotWatchdogTimeoutUsec :: Int+snapshotWatchdogTimeoutUsec = 60_000_000+ main :: IO () main = do-  Args { outFile = outPath, cssFile = cssPath } <- parseArgs =<< getArgs+  Args+    { outFile = outPath,+      cssFile = cssPath,+      layoutMode = mode,+      workspaceWidgetMode = wsMode,+      expectedTopStrut = mExpectedTopStrut+    } <-+    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"+  setEnvDefault "GDK_SCALE" "1"+  setEnvDefault "GDK_DPI_SCALE" "1"   setEnv "GTK_CSD" "0"   setEnv "GTK_THEME" "Adwaita"   setEnv "NO_AT_BRIDGE" "1"@@ -134,14 +156,21 @@     --     -- If this fails, the parent Xvfb teardown will still kill the X server,     -- which causes the WM to exit.-    res <- runUnderWm wmProc outPath cssPath+    res <- runUnderWm wmProc outPath cssPath mode wsMode mExpectedTopStrut     killProcessNoWait wmProc     pure res    exitWith ec -runUnderWm :: Process () () () -> FilePath -> FilePath -> IO ExitCode-runUnderWm wmProc outPath cssPath = do+runUnderWm ::+  Process () () () ->+  FilePath ->+  FilePath ->+  LayoutMode ->+  WorkspaceWidgetMode ->+  Maybe Int ->+  IO ExitCode+runUnderWm wmProc outPath cssPath mode wsMode mExpectedTopStrut = do   ctxVar <- (newEmptyMVar :: IO (MVar Context))   resultVar <- (newEmptyMVar :: IO (MVar (Either String BL.ByteString)))   doneVar <- (newEmptyMVar :: IO (MVar ExitCode))@@ -153,44 +182,42 @@    -- 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+  void $ forkIO $ watchdogThread wmProc ctxVar resultVar doneVar snapshotWatchdogTimeoutUsec    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+  let wsCfgDefault = def :: WorkspacesConfig+      legacyWsCfg =+        wsCfgDefault+          { Workspaces.workspacesConfig =+              (Workspaces.workspacesConfig wsCfgDefault)+                { -- Avoid font-dependent output in the appearance golden: we only care+                  -- that icons/layout render deterministically.+                  WorkspaceConfig.labelSetter = const (pure ""),+                  WorkspaceConfig.maxIcons = Just 1,+                  WorkspaceConfig.minIcons = 1,+                  WorkspaceConfig.getWindowIconPixbuf = getWindowIconPixbufFromEWMH,+                  WorkspaceConfig.iconSort = sortWindowsByStackIndex                 }-          , 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           }+      channelWsCfg =+        ChannelWorkspaces.defaultEWMHWorkspacesConfig+          { ChannelWorkspaces.labelSetter = const (pure ""),+            ChannelWorkspaces.maxIcons = Just 1,+            ChannelWorkspaces.minIcons = 1,+            ChannelWorkspaces.showWorkspaceFn = const True+          }+      workspaceWidget =+        case wsMode of+          UseLegacyWorkspaces -> workspacesNew legacyWsCfg+          UseChannelWorkspaces -> ChannelWorkspaces.workspacesNew channelWsCfg+      barCfg = buildBarConfig workspaceWidget barUnique mode       cfg =         def-          { dbusClientParam = Nothing-          , cssPaths = [cssPath]-          , getBarConfigsParam = pure [barCfg]-          , startupHook = scheduleSnapshot ctxVar resultVar-          , errorMsg = Nothing+          { dbusClientParam = Nothing,+            cssPaths = [cssPath],+            getBarConfigsParam = pure [barCfg],+            startupHook = scheduleSnapshot ctxVar resultVar wsMode mExpectedTopStrut,+            errorMsg = Nothing           }    withTestWindows $ do@@ -200,6 +227,71 @@     -- Should have been set by finalizeThread or watchdogThread.     takeMVar doneVar +buildBarConfig :: TaffyIO Gtk.Widget -> Unique -> LayoutMode -> BarConfig+buildBarConfig workspaceWidget barUnique mode =+  case mode of+    LayoutLegacy ->+      BarConfig+        { strutConfig = baseStrutConfig 40,+          widgetSpacing = 8,+          startWidgets = [workspaceWidget],+          centerWidgets = [testBoxWidget "test-center-box" 200 20],+          endWidgets =+            [ testBoxWidget "test-pill" 52 20,+              testBoxWidget "test-pill" 52 20,+              testBoxWidget "test-right-box" 16 16+            ],+          barLevels = Nothing,+          barId = barUnique+        }+    LayoutLevels ->+      BarConfig+        { strutConfig = baseStrutConfig 72,+          widgetSpacing = 8,+          startWidgets = [testBoxWidget "test-ignored-old-left" 40 16],+          centerWidgets = [testBoxWidget "test-ignored-old-center" 120 16],+          endWidgets = [testBoxWidget "test-ignored-old-right" 40 16],+          barLevels =+            Just+              [ BarLevelConfig+                  { levelStartWidgets = [workspaceWidget],+                    levelCenterWidgets = [testBoxWidget "test-center-box" 200 20],+                    levelEndWidgets =+                      [ testBoxWidget "test-pill" 52 20,+                        testBoxWidget "test-right-box" 16 16+                      ]+                  },+                BarLevelConfig+                  { levelStartWidgets = [testBoxWidget "test-level2-left" 78 14],+                    levelCenterWidgets = [testBoxWidget "test-level2-center" 150 14],+                    levelEndWidgets = [testBoxWidget "test-level2-right" 78 14]+                  }+              ],+          barId = barUnique+        }+    LayoutWindowsTitleStress ->+      BarConfig+        { strutConfig = baseStrutConfig 55,+          widgetSpacing = 8,+          startWidgets = [workspaceWidget, Windows.windowsNew windowsCfg],+          centerWidgets = [],+          endWidgets = [testBoxWidget "test-pill" 52 20],+          barLevels = Nothing,+          barId = barUnique+        }+  where+    windowsCfg =+      def+        { Windows.getActiveLabel = const $ pure "line 1\nline 2\nline 3\nline 4",+          Windows.getActiveWindowIconPixbuf = Nothing+        }+    baseStrutConfig h =+      defaultStrutConfig+        { strutHeight = ExactSize h,+          strutMonitor = Just 0,+          strutPosition = TopPos+        }+ testBoxWidget :: T.Text -> Int -> Int -> TaffyIO Gtk.Widget testBoxWidget klass w h = liftIO $ do   box <- Gtk.eventBoxNew@@ -248,7 +340,6 @@        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@@ -266,8 +357,13 @@       pixels = replicate (w * h) (fromIntegral px)    in header ++ pixels -scheduleSnapshot :: MVar Context -> MVar (Either String BL.ByteString) -> TaffyIO ()-scheduleSnapshot ctxVar resultVar = do+scheduleSnapshot ::+  MVar Context ->+  MVar (Either String BL.ByteString) ->+  WorkspaceWidgetMode ->+  Maybe Int ->+  TaffyIO ()+scheduleSnapshot ctxVar resultVar wsMode mExpectedTopStrut = do   ctx <- ask   liftIO $ void (tryPutMVar ctxVar ctx)   liftIO $ void $ forkIO (pollLoop ctx)@@ -277,16 +373,16 @@       case done of         Just _ -> pure ()         Nothing -> do-          postGUIASync (trySnapshotOnGuiThread ctx' resultVar)+          postGUIASync (trySnapshotOnGuiThread ctx' resultVar wsMode mExpectedTopStrut)           threadDelay 50_000           pollLoop ctx' -finalizeThread-  :: MVar Context-  -> MVar (Either String BL.ByteString)-  -> MVar ExitCode-  -> FilePath-  -> IO ()+finalizeThread ::+  MVar Context ->+  MVar (Either String BL.ByteString) ->+  MVar ExitCode ->+  FilePath ->+  IO () finalizeThread ctxVar resultVar doneVar outPath = do   res <- takeMVar resultVar   case res of@@ -303,13 +399,13 @@     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 ::+  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")@@ -343,7 +439,7 @@     Nothing -> do       existing <- filterM doesFileExist localCandidates       case existing of-        (p:_) -> makeAbsolute p+        (p : _) -> makeAbsolute p         [] -> die (name ++ " not found on PATH")  waitForEwmh :: Int -> IO ()@@ -368,8 +464,13 @@             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+trySnapshotOnGuiThread ::+  Context ->+  MVar (Either String BL.ByteString) ->+  WorkspaceWidgetMode ->+  Maybe Int ->+  IO ()+trySnapshotOnGuiThread ctx resultVar wsMode mExpectedTopStrut = do   -- Read the windows list and snapshot the first bar window.   ws <- readMVar (existingWindows ctx)   case listToMaybe ws of@@ -378,14 +479,51 @@       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) $+        Right img -> do+          strutReady <- case mExpectedTopStrut of+            Nothing -> pure True+            Just expectedTop -> do+              mActualTop <- getDockTopStrut+              pure (mActualTop == Just expectedTop)+          -- Don't accept a snapshot until the bar has actually rendered.+          -- Legacy mode checks icon colors, while channel mode has a weaker+          -- readiness check because it does not use the legacy EWMH icon path.+          when (strutReady && isSnapshotReady wsMode img) $             void (tryPutMVar resultVar (Right (JP.encodePng img))) +getDockTopStrut :: IO (Maybe Int)+getDockTopStrut = do+  ed <- try (openDisplay "") :: IO (Either SomeException Display)+  case ed of+    Left _ -> pure Nothing+    Right d -> do+      let root = defaultRootWindow d+      clientListAtom <- internAtom d "_NET_CLIENT_LIST" False+      strutPartialAtom <- internAtom d "_NET_WM_STRUT_PARTIAL" False+      mClientIds <- getWindowProperty32 d clientListAtom root+      let clientWindows = maybe [] (map fromIntegral) mClientIds+      treeResult <- try (queryTree d root) :: IO (Either SomeException (Window, Window, [Window]))+      let treeWindows = either (const []) (\(_, _, ws) -> ws) treeResult+          candidateWindows = nub (clientWindows ++ treeWindows)+      tops <- mapM (windowTopStrut d strutPartialAtom) candidateWindows+      closeDisplay d+      pure $ case [top | Just top <- tops, top > 0] of+        [] -> Nothing+        xs -> Just (maximum xs)+  where+    windowTopStrut :: Display -> Atom -> Window -> IO (Maybe Int)+    windowTopStrut d strutPartialAtom win = do+      mStrut <- getWindowProperty32 d strutPartialAtom win+      pure $ do+        (_left : _right : top : _rest) <- mStrut+        pure (fromIntegral top)++isSnapshotReady :: WorkspaceWidgetMode -> JP.Image JP.PixelRGBA8 -> Bool+isSnapshotReady wsMode img =+  case wsMode of+    UseLegacyWorkspaces -> imageHasTestIcons img+    UseChannelWorkspaces -> imageHasOpaqueContent img+ imageHasTestIcons :: JP.Image JP.PixelRGBA8 -> Bool imageHasTestIcons img =   let tol :: Int@@ -393,10 +531,10 @@       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+        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)@@ -419,6 +557,27 @@              in goX 0 seenR seenG opaqueCount    in go 0 False False (0 :: Int) +imageHasOpaqueContent :: JP.Image JP.PixelRGBA8 -> Bool+imageHasOpaqueContent img =+  let w = JP.imageWidth img+      h = JP.imageHeight img+      opaqueThreshold = 5000 :: Int+      go y count+        | y >= h = count > opaqueThreshold+        | otherwise =+            let goX x c+                  | x >= w = go (y + 1) c+                  | otherwise =+                      let px = JP.pixelAt img x y+                          c' =+                            c+                              + ( case px of+                                    JP.PixelRGBA8 _ _ _ a -> if a > 200 then 1 else 0+                                )+                       in c' > opaqueThreshold || goX (x + 1) c'+             in goX 0 count+   in go 0 0+ snapshotGtkWindowImageRGBA8 :: Gtk.Window -> IO (JP.Image JP.PixelRGBA8) snapshotGtkWindowImageRGBA8 win = do   drainGtkEvents 200@@ -465,10 +624,59 @@  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"+  let selectedLayoutMode+        | "--windows-title-stress" `elem` args = LayoutWindowsTitleStress+        | "--levels" `elem` args = LayoutLevels+        | otherwise = LayoutLegacy+      selectedWorkspaceWidgetMode =+        if "--channel-workspaces" `elem` args+          then UseChannelWorkspaces+          else UseLegacyWorkspaces+      (mExpectedTopStrut, argsSansTopStrutFlag) = parseTopStrutFlag args+      argsSansFlags =+        filter+          (`notElem` ["--levels", "--windows-title-stress", "--channel-workspaces"])+          argsSansTopStrutFlag+   in case argsSansFlags of+        ["--out", outPath, "--css", cssPath] ->+          pure+            Args+              { outFile = outPath,+                cssFile = cssPath,+                layoutMode = selectedLayoutMode,+                workspaceWidgetMode = selectedWorkspaceWidgetMode,+                expectedTopStrut = mExpectedTopStrut+              }+        ["--css", cssPath, "--out", outPath] ->+          pure+            Args+              { outFile = outPath,+                cssFile = cssPath,+                layoutMode = selectedLayoutMode,+                workspaceWidgetMode = selectedWorkspaceWidgetMode,+                expectedTopStrut = mExpectedTopStrut+              }+        _ ->+          die "usage: taffybar-appearance-snap --out OUT.png --css appearance-test.css [--levels|--windows-title-stress] [--channel-workspaces] [--expect-top-strut N]"+  where+    parseTopStrutFlag :: [String] -> (Maybe Int, [String])+    parseTopStrutFlag [] = (Nothing, [])+    parseTopStrutFlag ("--expect-top-strut" : raw : rest) =+      case readMaybe raw of+        Nothing -> (Nothing, "--expect-top-strut" : raw : rest)+        Just n ->+          let (mFromRest, restArgs) = parseTopStrutFlag rest+           in (Just (fromMaybe n mFromRest), restArgs)+    parseTopStrutFlag (x : rest) =+      let (mValue, restArgs) = parseTopStrutFlag rest+       in (mValue, x : restArgs)++setEnvDefault :: String -> String -> IO ()+setEnvDefault name value = do+  existing <- lookupEnv name+  case existing of+    Just _ -> pure ()+    Nothing -> setEnv name value  die :: String -> IO a die msg = do
app/AppearanceSnapHyprland.hs view
@@ -8,63 +8,79 @@ -- this executable in CI. module Main (main) where -import Control.Concurrent (MVar, forkIO, newEmptyMVar, threadDelay, takeMVar)+import qualified Codec.Picture as JP+import Control.Concurrent (MVar, forkIO, newEmptyMVar, takeMVar, threadDelay) 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 qualified Data.ByteString as B+import qualified Data.ByteString.Lazy as BL import Data.Default (def) import Data.IORef (IORef, newIORef, readIORef, writeIORef)-import Data.Unique (newUnique)+import qualified Data.Text as T+import Data.Unique (Unique, newUnique)+import qualified GI.Gtk as Gtk+import Graphics.UI.GIGtkStrut+  ( StrutConfig (..),+    StrutPosition (TopPos),+    StrutSize (ExactSize),+    defaultStrutConfig,+  ) import System.Directory-  ( createDirectoryIfMissing-  , findExecutable-  , makeAbsolute+  ( 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+  ( proc,+    readProcess,   )- import System.Taffybar (startTaffybar) import System.Taffybar.Context-  ( BarConfig (..)-  , Context (..)-  , TaffyIO-  , TaffybarConfig (..)-  , exitTaffybar+  ( BarConfig (..),+    BarLevelConfig (..),+    Context (..),+    TaffyIO,+    TaffybarConfig (..),+    exitTaffybar,   )+import qualified System.Taffybar.Widget.Workspaces as ChannelWorkspaces+import UnliftIO.Temporary (withSystemTempDirectory)  data Args = Args-  { outFile :: FilePath-  , cssFile :: FilePath+  { outFile :: FilePath,+    cssFile :: FilePath,+    layoutMode :: LayoutMode,+    workspaceWidgetMode :: WorkspaceWidgetMode   } +data LayoutMode = LayoutLegacy | LayoutLevels+  deriving (Eq, Show)++data WorkspaceWidgetMode+  = UseLegacyWorkspaces+  | UseChannelWorkspaces+  deriving (Eq, Show)++snapshotWatchdogTimeoutUsec :: Int+snapshotWatchdogTimeoutUsec = 60_000_000+ main :: IO () main = do-  Args { outFile = outPath, cssFile = cssPath } <- parseArgs =<< getArgs+  Args+    { outFile = outPath,+      cssFile = cssPath,+      layoutMode = mode,+      workspaceWidgetMode = wsMode+    } <-+    parseArgs =<< getArgs    -- Reduce variability (but do not clobber WAYLAND_DISPLAY / XDG_RUNTIME_DIR /   -- HYPRLAND_INSTANCE_SIGNATURE; those are provided by the compositor session).@@ -101,12 +117,17 @@      createDirectoryIfMissing True (takeDirectory outPath) -    runUnderHyprland outPath cssPath+    runUnderHyprland outPath cssPath mode wsMode    exitWith ec -runUnderHyprland :: FilePath -> FilePath -> IO ExitCode-runUnderHyprland outPath cssPath = do+runUnderHyprland ::+  FilePath ->+  FilePath ->+  LayoutMode ->+  WorkspaceWidgetMode ->+  IO ExitCode+runUnderHyprland outPath cssPath mode wsMode = do   ctxVar :: MVar Context <- newEmptyMVar   resultVar :: MVar (Either String BL.ByteString) <- newEmptyMVar   doneVar :: MVar ExitCode <- newEmptyMVar@@ -116,36 +137,19 @@   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+  void $ forkIO $ watchdogThread ctxVar resultVar doneVar lastShotRef snapshotWatchdogTimeoutUsec    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-          }+  let barCfg = buildBarConfig barUnique mode wsMode        cfg =         def-          { dbusClientParam = Nothing-          , cssPaths = [cssPath]-          , getBarConfigsParam = pure [barCfg]-          , startupHook = scheduleSnapshot ctxVar resultVar lastShotRef-          , errorMsg = Nothing+          { dbusClientParam = Nothing,+            cssPaths = [cssPath],+            getBarConfigsParam = pure [barCfg],+            startupHook = scheduleSnapshot ctxVar resultVar lastShotRef mode,+            errorMsg = Nothing           }    -- Blocks in Gtk.main until we request shutdown.@@ -174,8 +178,69 @@   Gtk.widgetShowAll widget   pure widget -scheduleSnapshot :: MVar Context -> MVar (Either String BL.ByteString) -> IORef (Maybe BL.ByteString) -> TaffyIO ()-scheduleSnapshot ctxVar resultVar lastShotRef = do+buildBarConfig :: Unique -> LayoutMode -> WorkspaceWidgetMode -> BarConfig+buildBarConfig barUnique mode wsMode =+  case mode of+    LayoutLegacy ->+      BarConfig+        { strutConfig = baseStrutConfig 40,+          widgetSpacing = 8,+          startWidgets = [startWidget],+          centerWidgets = [testBoxWidget "test-center-box" 200 20],+          endWidgets =+            [ testPillBoxWidget "test-pill" 52 20,+              testPillBoxWidget "test-pill" 46 20,+              testBoxWidget "test-right-box" 16 16+            ],+          barLevels = Nothing,+          barId = barUnique+        }+    LayoutLevels ->+      BarConfig+        { strutConfig = baseStrutConfig 72,+          widgetSpacing = 8,+          startWidgets = [testBoxWidget "test-ignored-old-left" 40 16],+          centerWidgets = [testBoxWidget "test-ignored-old-center" 120 16],+          endWidgets = [testBoxWidget "test-ignored-old-right" 40 16],+          barLevels =+            Just+              [ BarLevelConfig+                  { levelStartWidgets = [startWidget],+                    levelCenterWidgets = [testBoxWidget "test-center-box" 200 20],+                    levelEndWidgets =+                      [ testPillBoxWidget "test-pill" 52 20,+                        testBoxWidget "test-right-box" 16 16+                      ]+                  },+                BarLevelConfig+                  { levelStartWidgets = [testBoxWidget "test-level2-left" 78 14],+                    levelCenterWidgets = [testBoxWidget "test-level2-center" 150 14],+                    levelEndWidgets = [testBoxWidget "test-level2-right" 78 14]+                  }+              ],+          barId = barUnique+        }+  where+    baseStrutConfig h =+      defaultStrutConfig+        { strutHeight = ExactSize h,+          strutMonitor = Just 0,+          strutPosition = TopPos+        }+    startWidget =+      case wsMode of+        UseLegacyWorkspaces -> testPillBoxWidget "test-pill" 56 20+        UseChannelWorkspaces ->+          ChannelWorkspaces.workspacesNew $+            ChannelWorkspaces.defaultWorkspacesConfig+              { ChannelWorkspaces.labelSetter = const (pure ""),+                ChannelWorkspaces.maxIcons = Just 1,+                ChannelWorkspaces.minIcons = 1,+                ChannelWorkspaces.showWorkspaceFn = const True+              }++scheduleSnapshot :: MVar Context -> MVar (Either String BL.ByteString) -> IORef (Maybe BL.ByteString) -> LayoutMode -> TaffyIO ()+scheduleSnapshot ctxVar resultVar lastShotRef mode = do   ctx <- ask   liftIO $ void (tryPutMVar ctxVar ctx) @@ -185,38 +250,44 @@     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 lastShotRef resultVar mode 60 -takeSnapshotWithRetries :: IORef (Maybe BL.ByteString) -> MVar (Either String BL.ByteString) -> Int -> IO ()-takeSnapshotWithRetries _ resultVar 0 =+takeSnapshotWithRetries :: IORef (Maybe BL.ByteString) -> MVar (Either String BL.ByteString) -> LayoutMode -> Int -> IO ()+takeSnapshotWithRetries _ resultVar _ 0 =   void $ tryPutMVar resultVar (Left "Failed to capture Hyprland appearance snapshot")-takeSnapshotWithRetries lastShotRef resultVar n = do+takeSnapshotWithRetries lastShotRef resultVar mode n = do   done <- tryReadMVar resultVar   case done of     Just _ -> pure ()     Nothing -> do-      shot <- takeSnapshot+      shot <- takeSnapshot mode       case shot of         Left _ -> do           threadDelay 200_000-          takeSnapshotWithRetries lastShotRef resultVar (n - 1)+          takeSnapshotWithRetries lastShotRef resultVar mode (n - 1)         Right encoded -> do           prev <- readIORef lastShotRef           writeIORef lastShotRef (Just encoded)           case prev of-            Just prevEncoded | prevEncoded == encoded ->-              void $ tryPutMVar resultVar (Right encoded)+            Just prevEncoded+              | prevEncoded == encoded ->+                  void $ tryPutMVar resultVar (Right encoded)             _ -> do               threadDelay 200_000-              takeSnapshotWithRetries lastShotRef resultVar (n - 1)+              takeSnapshotWithRetries lastShotRef resultVar mode (n - 1) -takeSnapshot :: IO (Either String BL.ByteString)-takeSnapshot =+takeSnapshot :: LayoutMode -> IO (Either String BL.ByteString)+takeSnapshot mode =   withSystemTempDirectory "tbshot" $ \tmp -> do     let shotPath = tmp </> "shot.png"+        shotHeight :: Int+        shotHeight =+          case mode of+            LayoutLegacy -> 40+            LayoutLevels -> 72     e <--      try (readProcess (proc "grim" ["-s", "1", "-l", "1", "-g", "0,0 1024x40", shotPath]))-        :: IO (Either SomeException (ExitCode, BL.ByteString, BL.ByteString))+      try (readProcess (proc "grim" ["-s", "1", "-l", "1", "-g", "0,0 1024x" ++ show shotHeight, shotPath])) ::+        IO (Either SomeException (ExitCode, BL.ByteString, BL.ByteString))     case e of       Left _ -> pure (Left ("grim failed" :: String))       Right (ec, _stdout, _stderr) ->@@ -228,39 +299,41 @@               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)")+                 in if hasExpectedMarkers mode 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 =+hasExpectedMarkers :: LayoutMode -> JP.Image JP.PixelRGBA8 -> Bool+hasExpectedMarkers mode 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+      level2Center = JP.PixelRGBA8 0x3a 0x7a 0x5a 0xff       centerCount = countColor img centerBox       rightCount = countColor img rightBox-   in centerCount >= 200 && rightCount >= 50+      level2Count = countColor img level2Center+   in case mode of+        LayoutLegacy -> centerCount >= 200 && rightCount >= 50+        LayoutLevels -> centerCount >= 200 && rightCount >= 50 && level2Count >= 100  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-      ]+   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 ::+  MVar Context ->+  MVar (Either String BL.ByteString) ->+  MVar ExitCode ->+  FilePath ->+  IO () finalizeThread ctxVar resultVar doneVar outPath = do   res <- takeMVar resultVar   case res of@@ -277,13 +350,13 @@     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 ::+  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)@@ -316,10 +389,38 @@  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"+  let selectedLayoutMode =+        if "--levels" `elem` args+          then LayoutLevels+          else LayoutLegacy+      selectedWorkspaceWidgetMode =+        if "--channel-workspaces" `elem` args+          then UseChannelWorkspaces+          else UseLegacyWorkspaces+      argsSansFlags =+        filter+          (`notElem` ["--levels", "--channel-workspaces"])+          args+   in case argsSansFlags of+        ["--out", outPath, "--css", cssPath] ->+          pure+            Args+              { outFile = outPath,+                cssFile = cssPath,+                layoutMode = selectedLayoutMode,+                workspaceWidgetMode = selectedWorkspaceWidgetMode+              }+        ["--css", cssPath, "--out", outPath] ->+          pure+            Args+              { outFile = outPath,+                cssFile = cssPath,+                layoutMode = selectedLayoutMode,+                workspaceWidgetMode = selectedWorkspaceWidgetMode+              }+        _ ->+          fail+            "usage: taffybar-appearance-snap-hyprland --out OUT.png --css appearance-test.css [--levels] [--channel-workspaces]"  die :: String -> IO a die msg = do
+ app/DhallConfig.hs view
@@ -0,0 +1,534 @@+{-# LANGUAGE DeriveAnyClass #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE DerivingStrategies #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE NamedFieldPuns #-}+{-# LANGUAGE OverloadedStrings #-}++module DhallConfig+  ( runDhallConfigFromFile,+  )+where++import Control.Monad.IO.Class (liftIO)+import Data.Default (def)+import Data.Maybe (fromMaybe)+import qualified Data.Text as T+import qualified Dhall+import GHC.Generics (Generic)+import qualified GI.Gtk as Gtk+import Numeric.Natural (Natural)+import System.Taffybar (startTaffybar)+import System.Taffybar.Context (TaffyIO, TaffybarConfig)+import System.Taffybar.DBus (withLogServer, withToggleServer)+import System.Taffybar.Hooks (withBatteryRefresh, withLogLevels)+import qualified System.Taffybar.Information.Wlsunset as WlsunsetInfo+import System.Taffybar.SimpleConfig+import System.Taffybar.Widget+import qualified System.Taffybar.Widget.Backlight as Backlight+import qualified System.Taffybar.Widget.DiskUsage as DiskUsage+import qualified System.Taffybar.Widget.NetworkManager as NetworkManager+import qualified System.Taffybar.Widget.PulseAudio as PulseAudio+import qualified System.Taffybar.Widget.ScreenLock as ScreenLock+import qualified System.Taffybar.Widget.Windows as Windows+import qualified System.Taffybar.Widget.Wlsunset as Wlsunset+import qualified System.Taffybar.Widget.Workspaces.Config as WorkspaceConfig+import qualified System.Taffybar.Widget.Workspaces.EWMH as EWMHWorkspaces+import qualified System.Taffybar.Widget.Workspaces.Hyprland as HyprlandWorkspaces+import qualified System.Taffybar.Widget.Workspaces.Shared as WorkspaceShared++runDhallConfigFromFile :: FilePath -> IO ()+runDhallConfigFromFile path = do+  cfg <- Dhall.inputFile Dhall.auto path+  let simpleConfig = toSimpleConfig cfg+      taffyConfig = applyHookSpec (dhallHooks cfg) (toTaffybarConfig simpleConfig)+  startTaffybar taffyConfig++data DhallTaffybarConfig = DhallTaffybarConfig+  { dhallMonitors :: MonitorSpec,+    dhallBar :: BarSpec,+    dhallHooks :: HookSpec,+    dhallWidgets :: WidgetSections+  }+  deriving stock (Eq, Show, Generic)+  deriving anyclass (Dhall.FromDhall)++data MonitorSpec+  = AllMonitors+  | PrimaryMonitor+  | MonitorList [Natural]+  deriving stock (Eq, Show, Generic)+  deriving anyclass (Dhall.FromDhall)++data PositionSpec = TopBar | BottomBar+  deriving stock (Eq, Show, Generic)+  deriving anyclass (Dhall.FromDhall)++data BarHeightSpec+  = ScreenRatioHeight Double+  | ExactPixelHeight Natural+  deriving stock (Eq, Show, Generic)+  deriving anyclass (Dhall.FromDhall)++data BarSpec = BarSpec+  { barPositionSpec :: PositionSpec,+    barHeightSpec :: BarHeightSpec,+    barPaddingPx :: Natural,+    barWidgetSpacing :: Natural,+    barCssPaths :: [T.Text]+  }+  deriving stock (Eq, Show, Generic)+  deriving anyclass (Dhall.FromDhall)++data HookSpec = HookSpec+  { hookLogServer :: Bool,+    hookToggleServer :: Bool,+    hookLogLevels :: Bool,+    hookBatteryRefresh :: Bool+  }+  deriving stock (Eq, Show, Generic)+  deriving anyclass (Dhall.FromDhall)++data WidgetSections = WidgetSections+  { widgetStart :: [WidgetSpec],+    widgetCenter :: [WidgetSpec],+    widgetEnd :: [WidgetSpec]+  }+  deriving stock (Eq, Show, Generic)+  deriving anyclass (Dhall.FromDhall)++data WidgetSpec+  = Clock (Maybe ClockSpec)+  | PulseAudio (Maybe PulseAudioSpec)+  | Backlight (Maybe BacklightSpec)+  | DiskUsage (Maybe DiskUsageSpec)+  | Windows (Maybe WindowsSpec)+  | WorkspacesEWMH (Maybe EWMHWorkspacesSpec)+  | WorkspacesHyprland (Maybe HyprlandWorkspacesSpec)+  | ScreenLock (Maybe ScreenLockSpec)+  | Wlsunset (Maybe WlsunsetSpec)+  | Layout+  | SNITray+  | SNITrayWithWatcher+  | MPRIS2+  | Battery+  | NetworkManagerWifi+  | WithClass WithClassSpec+  | WithContentsBox WidgetSpec+  | Box BoxSpec+  deriving stock (Eq, Show, Generic)+  deriving anyclass (Dhall.FromDhall)++data WithClassSpec = WithClassSpec+  { withClassName :: T.Text,+    withClassWidget :: WidgetSpec+  }+  deriving stock (Eq, Show, Generic)+  deriving anyclass (Dhall.FromDhall)++data BoxOrientation = Horizontal | Vertical+  deriving stock (Eq, Show, Generic)+  deriving anyclass (Dhall.FromDhall)++data BoxSpec = BoxSpec+  { boxOrientation :: BoxOrientation,+    boxSpacing :: Natural,+    boxChildren :: [WidgetSpec]+  }+  deriving stock (Eq, Show, Generic)+  deriving anyclass (Dhall.FromDhall)++data ClockUpdateSpec+  = ConstantUpdateInterval Double+  | RoundedTarget RoundedTargetSpec+  deriving stock (Eq, Show, Generic)+  deriving anyclass (Dhall.FromDhall)++data RoundedTargetSpec = RoundedTargetSpec+  { roundedSeconds :: Natural,+    roundedOffset :: Double+  }+  deriving stock (Eq, Show, Generic)+  deriving anyclass (Dhall.FromDhall)++data ClockSpec = ClockSpec+  { clockFormat :: T.Text,+    clockUpdateSpec :: ClockUpdateSpec+  }+  deriving stock (Eq, Show, Generic)+  deriving anyclass (Dhall.FromDhall)++data PulseAudioSpec = PulseAudioSpec+  { pulseSink :: T.Text,+    pulseFormat :: T.Text,+    pulseMuteFormat :: T.Text,+    pulseUnknownFormat :: T.Text,+    pulseTooltipFormat :: Maybe T.Text,+    pulseScrollStepPercent :: Maybe Natural,+    pulseToggleMuteOnClick :: Bool+  }+  deriving stock (Eq, Show, Generic)+  deriving anyclass (Dhall.FromDhall)++data BacklightSpec = BacklightSpec+  { backlightPollInterval :: Double,+    backlightDeviceName :: Maybe T.Text,+    backlightFormatSpec :: T.Text,+    backlightUnknownFormatSpec :: T.Text,+    backlightTooltipFormatSpec :: Maybe T.Text,+    backlightScrollStepPercentSpec :: Maybe Natural,+    backlightBrightnessctlPathSpec :: T.Text,+    backlightIconSpec :: T.Text+  }+  deriving stock (Eq, Show, Generic)+  deriving anyclass (Dhall.FromDhall)++data DiskUsageSpec = DiskUsageSpec+  { diskPath :: T.Text,+    diskPollInterval :: Double,+    diskFormat :: T.Text,+    diskTooltipFormat :: Maybe T.Text,+    diskIcon :: T.Text+  }+  deriving stock (Eq, Show, Generic)+  deriving anyclass (Dhall.FromDhall)++data WindowsSpec = WindowsSpec+  { windowsMenuLabelLength :: Natural,+    windowsActiveLabelLength :: Natural,+    windowsShowIcon :: Bool+  }+  deriving stock (Eq, Show, Generic)+  deriving anyclass (Dhall.FromDhall)++data EWMHWorkspacesSpec = EWMHWorkspacesSpec+  { ewmhMinIcons :: Natural,+    ewmhMaxIcons :: Maybe Natural,+    ewmhWidgetGap :: Natural,+    ewmhShowEmpty :: Bool,+    ewmhUrgentWorkspaceState :: Bool,+    ewmhBorderWidth :: Natural,+    ewmhUpdateRateLimitMicroseconds :: Natural+  }+  deriving stock (Eq, Show, Generic)+  deriving anyclass (Dhall.FromDhall)++data HyprlandWorkspacesSpec = HyprlandWorkspacesSpec+  { hyprlandMinIcons :: Natural,+    hyprlandMaxIcons :: Maybe Natural,+    hyprlandWidgetGap :: Natural,+    hyprlandShowEmpty :: Bool,+    hyprlandShowSpecial :: Bool,+    hyprlandUrgentWorkspaceState :: Bool,+    hyprlandUpdateIntervalSeconds :: Double,+    hyprlandIconSize :: Natural+  }+  deriving stock (Eq, Show, Generic)+  deriving anyclass (Dhall.FromDhall)++data ScreenLockSpec = ScreenLockSpec+  { screenLockIconSpec :: T.Text,+    screenLockManageIdle :: Bool,+    screenLockManageSleep :: Bool,+    screenLockManageShutdown :: Bool+  }+  deriving stock (Eq, Show, Generic)+  deriving anyclass (Dhall.FromDhall)++data WlsunsetSpec = WlsunsetSpec+  { wlsunsetCommandSpec :: T.Text,+    wlsunsetHighTempSpec :: Natural,+    wlsunsetLowTempSpec :: Natural,+    wlsunsetPollIntervalSpec :: Natural,+    wlsunsetIconSpec :: T.Text+  }+  deriving stock (Eq, Show, Generic)+  deriving anyclass (Dhall.FromDhall)++toSimpleConfig :: DhallTaffybarConfig -> SimpleTaffyConfig+toSimpleConfig DhallTaffybarConfig {dhallMonitors, dhallBar, dhallWidgets} =+  defaultSimpleTaffyConfig+    { monitorsAction = monitorSpecAction dhallMonitors,+      barHeight = barHeightFromSpec (barHeightSpec dhallBar),+      barPadding = naturalToInt (barPaddingPx dhallBar),+      barPosition = positionFromSpec (barPositionSpec dhallBar),+      widgetSpacing = naturalToInt (barWidgetSpacing dhallBar),+      cssPaths = map T.unpack (barCssPaths dhallBar),+      startWidgets = map widgetFromSpec (widgetStart dhallWidgets),+      centerWidgets = map widgetFromSpec (widgetCenter dhallWidgets),+      endWidgets = map widgetFromSpec (widgetEnd dhallWidgets)+    }++monitorSpecAction :: MonitorSpec -> TaffyIO [Int]+monitorSpecAction = \case+  AllMonitors -> useAllMonitors+  PrimaryMonitor -> usePrimaryMonitor+  MonitorList monitors -> pure (map naturalToInt monitors)++barHeightFromSpec :: BarHeightSpec -> StrutSize+barHeightFromSpec = \case+  ScreenRatioHeight r -> ScreenRatio (toRational r)+  ExactPixelHeight px -> ExactSize (fromIntegral px)++positionFromSpec :: PositionSpec -> Position+positionFromSpec = \case+  TopBar -> Top+  BottomBar -> Bottom++applyHookSpec :: HookSpec -> TaffybarConfig -> TaffybarConfig+applyHookSpec HookSpec {hookLogServer, hookToggleServer, hookLogLevels, hookBatteryRefresh} =+  applyWhen hookBatteryRefresh withBatteryRefresh+    . applyWhen hookLogLevels withLogLevels+    . applyWhen hookToggleServer withToggleServer+    . applyWhen hookLogServer withLogServer+  where+    applyWhen True f = f+    applyWhen False _ = id++widgetFromSpec :: WidgetSpec -> TaffyIO Gtk.Widget+widgetFromSpec = \case+  Clock maybeClockSpec -> textClockNewWith (clockConfigFromSpec maybeClockSpec)+  PulseAudio maybePulseSpec -> PulseAudio.pulseAudioNewWith (pulseAudioConfigFromSpec maybePulseSpec)+  Backlight maybeBacklightSpec -> Backlight.backlightNewChanWith (backlightConfigFromSpec maybeBacklightSpec)+  DiskUsage maybeDiskSpec -> DiskUsage.diskUsageNewWith (diskUsageConfigFromSpec maybeDiskSpec)+  Windows maybeWindowsSpec -> Windows.windowsNew (windowsConfigFromSpec maybeWindowsSpec)+  WorkspacesEWMH maybeSpec -> EWMHWorkspaces.workspacesNew (ewmhConfigFromSpec maybeSpec)+  WorkspacesHyprland maybeSpec -> HyprlandWorkspaces.hyprlandWorkspacesNew (hyprlandConfigFromSpec maybeSpec)+  ScreenLock maybeSpec -> ScreenLock.screenLockNewWithConfig (screenLockConfigFromSpec maybeSpec)+  Wlsunset maybeSpec -> Wlsunset.wlsunsetNewWithConfig (wlsunsetConfigFromSpec maybeSpec)+  Layout -> layoutNew defaultLayoutConfig+  SNITray -> sniTrayNew+  SNITrayWithWatcher -> sniTrayThatStartsWatcherEvenThoughThisIsABadWayToDoIt+  MPRIS2 -> mpris2New+  Battery -> batteryIconNew+  NetworkManagerWifi -> NetworkManager.networkManagerWifiIconLabelNew+  WithClass WithClassSpec {withClassName, withClassWidget} ->+    widgetFromSpec withClassWidget >>= flip widgetSetClassGI withClassName+  WithContentsBox wrappedWidget ->+    widgetFromSpec wrappedWidget >>= buildContentsBox+  Box BoxSpec {boxOrientation, boxSpacing, boxChildren} -> do+    children <- mapM widgetFromSpec boxChildren+    let orientation = case boxOrientation of+          Horizontal -> Gtk.OrientationHorizontal+          Vertical -> Gtk.OrientationVertical+    liftIO $ do+      box <- Gtk.boxNew orientation (fromIntegral boxSpacing)+      mapM_ (\child -> Gtk.boxPackStart box child False False 0) children+      Gtk.widgetShowAll box+      Gtk.toWidget box++clockConfigFromSpec :: Maybe ClockSpec -> ClockConfig+clockConfigFromSpec Nothing = defaultClockConfig+clockConfigFromSpec (Just ClockSpec {clockFormat, clockUpdateSpec}) =+  defaultClockConfig+    { clockFormatString = T.unpack clockFormat,+      clockUpdateStrategy =+        case clockUpdateSpec of+          ConstantUpdateInterval interval -> ConstantInterval interval+          RoundedTarget RoundedTargetSpec {roundedSeconds, roundedOffset} ->+            RoundedTargetInterval (naturalToInt roundedSeconds) roundedOffset+    }++pulseAudioConfigFromSpec :: Maybe PulseAudioSpec -> PulseAudio.PulseAudioWidgetConfig+pulseAudioConfigFromSpec Nothing = PulseAudio.defaultPulseAudioWidgetConfig+pulseAudioConfigFromSpec+  ( Just+      PulseAudioSpec+        { pulseSink,+          pulseFormat,+          pulseMuteFormat,+          pulseUnknownFormat,+          pulseTooltipFormat,+          pulseScrollStepPercent,+          pulseToggleMuteOnClick+        }+    ) =+    PulseAudio.defaultPulseAudioWidgetConfig+      { PulseAudio.pulseAudioSink = T.unpack pulseSink,+        PulseAudio.pulseAudioFormat = T.unpack pulseFormat,+        PulseAudio.pulseAudioMuteFormat = T.unpack pulseMuteFormat,+        PulseAudio.pulseAudioUnknownFormat = T.unpack pulseUnknownFormat,+        PulseAudio.pulseAudioTooltipFormat = fmap T.unpack pulseTooltipFormat,+        PulseAudio.pulseAudioScrollStepPercent = fmap naturalToInt pulseScrollStepPercent,+        PulseAudio.pulseAudioToggleMuteOnClick = pulseToggleMuteOnClick+      }++backlightConfigFromSpec :: Maybe BacklightSpec -> Backlight.BacklightWidgetConfig+backlightConfigFromSpec Nothing = Backlight.defaultBacklightWidgetConfig+backlightConfigFromSpec+  ( Just+      BacklightSpec+        { backlightPollInterval,+          backlightDeviceName,+          backlightFormatSpec,+          backlightUnknownFormatSpec,+          backlightTooltipFormatSpec,+          backlightScrollStepPercentSpec,+          backlightBrightnessctlPathSpec,+          backlightIconSpec+        }+    ) =+    Backlight.defaultBacklightWidgetConfig+      { Backlight.backlightPollingInterval = backlightPollInterval,+        Backlight.backlightDevice = fmap T.unpack backlightDeviceName,+        Backlight.backlightFormat = T.unpack backlightFormatSpec,+        Backlight.backlightUnknownFormat = T.unpack backlightUnknownFormatSpec,+        Backlight.backlightTooltipFormat = fmap T.unpack backlightTooltipFormatSpec,+        Backlight.backlightScrollStepPercent = fmap naturalToInt backlightScrollStepPercentSpec,+        Backlight.backlightBrightnessctlPath = T.unpack backlightBrightnessctlPathSpec,+        Backlight.backlightIcon = backlightIconSpec+      }++diskUsageConfigFromSpec :: Maybe DiskUsageSpec -> DiskUsage.DiskUsageWidgetConfig+diskUsageConfigFromSpec Nothing = DiskUsage.defaultDiskUsageWidgetConfig+diskUsageConfigFromSpec+  ( Just+      DiskUsageSpec+        { diskPath,+          diskPollInterval,+          diskFormat,+          diskTooltipFormat,+          diskIcon+        }+    ) =+    DiskUsage.defaultDiskUsageWidgetConfig+      { DiskUsage.diskUsagePath = T.unpack diskPath,+        DiskUsage.diskUsagePollInterval = diskPollInterval,+        DiskUsage.diskUsageFormat = T.unpack diskFormat,+        DiskUsage.diskUsageTooltipFormat = fmap T.unpack diskTooltipFormat,+        DiskUsage.diskUsageIcon = diskIcon+      }++windowsConfigFromSpec :: Maybe WindowsSpec -> Windows.WindowsConfig+windowsConfigFromSpec Nothing = Windows.defaultWindowsConfig+windowsConfigFromSpec+  (Just WindowsSpec {windowsMenuLabelLength, windowsActiveLabelLength, windowsShowIcon}) =+    Windows.defaultWindowsConfig+      { Windows.getMenuLabel = Windows.truncatedGetMenuLabel (naturalToInt windowsMenuLabelLength),+        Windows.getActiveLabel = Windows.truncatedGetActiveLabel (naturalToInt windowsActiveLabelLength),+        Windows.getActiveWindowIconPixbuf =+          if windowsShowIcon+            then Windows.getActiveWindowIconPixbuf Windows.defaultWindowsConfig+            else Nothing+      }++defaultEWMHWorkspacesSpec :: EWMHWorkspacesSpec+defaultEWMHWorkspacesSpec =+  EWMHWorkspacesSpec+    { ewmhMinIcons = 0,+      ewmhMaxIcons = Nothing,+      ewmhWidgetGap = 0,+      ewmhShowEmpty = True,+      ewmhUrgentWorkspaceState = False,+      ewmhBorderWidth = 2,+      ewmhUpdateRateLimitMicroseconds = 100000+    }++ewmhConfigFromSpec :: Maybe EWMHWorkspacesSpec -> EWMHWorkspaces.WorkspacesConfig+ewmhConfigFromSpec maybeSpec =+  let spec = fromMaybe defaultEWMHWorkspacesSpec maybeSpec+      base = EWMHWorkspaces.defaultWorkspacesConfig+      common = EWMHWorkspaces.workspacesCommonConfig base+      common' =+        common+          { WorkspaceConfig.minIcons = naturalToInt (ewmhMinIcons spec),+            WorkspaceConfig.maxIcons = fmap naturalToInt (ewmhMaxIcons spec),+            WorkspaceConfig.widgetGap = naturalToInt (ewmhWidgetGap spec),+            WorkspaceConfig.showWorkspaceFn = if ewmhShowEmpty spec then const True else EWMHWorkspaces.hideEmpty,+            WorkspaceConfig.urgentWorkspaceState = ewmhUrgentWorkspaceState spec+          }+      base' = EWMHWorkspaces.applyCommonWorkspacesConfig common' base+   in base'+        { EWMHWorkspaces.borderWidth = naturalToInt (ewmhBorderWidth spec),+          EWMHWorkspaces.updateRateLimitMicroseconds = fromIntegral (ewmhUpdateRateLimitMicroseconds spec)+        }++defaultHyprlandWorkspacesSpec :: HyprlandWorkspacesSpec+defaultHyprlandWorkspacesSpec =+  HyprlandWorkspacesSpec+    { hyprlandMinIcons = 0,+      hyprlandMaxIcons = Nothing,+      hyprlandWidgetGap = 0,+      hyprlandShowEmpty = False,+      hyprlandShowSpecial = False,+      hyprlandUrgentWorkspaceState = False,+      hyprlandUpdateIntervalSeconds = 1.0,+      hyprlandIconSize = 16+    }++hyprlandConfigFromSpec :: Maybe HyprlandWorkspacesSpec -> HyprlandWorkspaces.HyprlandWorkspacesConfig+hyprlandConfigFromSpec maybeSpec =+  let spec = fromMaybe defaultHyprlandWorkspacesSpec maybeSpec+      base = HyprlandWorkspaces.defaultHyprlandWorkspacesConfig+      common = HyprlandWorkspaces.hyprlandWorkspacesCommonConfig base+      shouldShowWorkspace ws =+        let isEmpty = HyprlandWorkspaces.workspaceState ws == WorkspaceShared.Empty+            isSpecial =+              let name = T.toLower $ T.pack $ HyprlandWorkspaces.workspaceName ws+               in T.isPrefixOf "special" name || HyprlandWorkspaces.workspaceIdx ws < 0+            emptyAllowed = hyprlandShowEmpty spec || not isEmpty+            specialAllowed = hyprlandShowSpecial spec || not isSpecial+         in emptyAllowed && specialAllowed+      common' =+        common+          { WorkspaceConfig.minIcons = naturalToInt (hyprlandMinIcons spec),+            WorkspaceConfig.maxIcons = fmap naturalToInt (hyprlandMaxIcons spec),+            WorkspaceConfig.widgetGap = naturalToInt (hyprlandWidgetGap spec),+            WorkspaceConfig.showWorkspaceFn = shouldShowWorkspace,+            WorkspaceConfig.urgentWorkspaceState = hyprlandUrgentWorkspaceState spec+          }+      base' = HyprlandWorkspaces.applyCommonHyprlandWorkspacesConfig common' base+   in base'+        { HyprlandWorkspaces.updateIntervalSeconds = hyprlandUpdateIntervalSeconds spec,+          HyprlandWorkspaces.iconSize = fromIntegral (hyprlandIconSize spec)+        }++screenLockConfigFromSpec :: Maybe ScreenLockSpec -> ScreenLock.ScreenLockConfig+screenLockConfigFromSpec Nothing = ScreenLock.defaultScreenLockConfig+screenLockConfigFromSpec+  ( Just+      ScreenLockSpec+        { screenLockIconSpec,+          screenLockManageIdle,+          screenLockManageSleep,+          screenLockManageShutdown+        }+    ) =+    let inhibitTypes =+          concat+            [ [InhibitIdle | screenLockManageIdle],+              [InhibitSleep | screenLockManageSleep],+              [InhibitShutdown | screenLockManageShutdown]+            ]+        selectedTypes = if null inhibitTypes then [InhibitIdle] else inhibitTypes+     in ScreenLock.defaultScreenLockConfig+          { ScreenLock.screenLockIcon = screenLockIconSpec,+            ScreenLock.screenLockInhibitTypes = selectedTypes+          }++wlsunsetConfigFromSpec :: Maybe WlsunsetSpec -> Wlsunset.WlsunsetWidgetConfig+wlsunsetConfigFromSpec Nothing = Wlsunset.defaultWlsunsetWidgetConfig+wlsunsetConfigFromSpec+  ( Just+      WlsunsetSpec+        { wlsunsetCommandSpec,+          wlsunsetHighTempSpec,+          wlsunsetLowTempSpec,+          wlsunsetPollIntervalSpec,+          wlsunsetIconSpec+        }+    ) =+    let infoConfig =+          (def :: WlsunsetInfo.WlsunsetConfig)+            { WlsunsetInfo.wlsunsetCommand = T.unpack wlsunsetCommandSpec,+              WlsunsetInfo.wlsunsetHighTemp = naturalToInt wlsunsetHighTempSpec,+              WlsunsetInfo.wlsunsetLowTemp = naturalToInt wlsunsetLowTempSpec,+              WlsunsetInfo.wlsunsetPollIntervalSec = naturalToInt wlsunsetPollIntervalSpec+            }+     in Wlsunset.defaultWlsunsetWidgetConfig+          { Wlsunset.wlsunsetWidgetInfoConfig = infoConfig,+            Wlsunset.wlsunsetWidgetIcon = wlsunsetIconSpec+          }++naturalToInt :: Natural -> Int+naturalToInt = fromIntegral
app/Main.hs view
@@ -1,63 +1,148 @@ {-# OPTIONS_GHC -fno-warn-unused-imports #-}+ -- | This is just a stub executable that uses dyre to read the config file and -- recompile itself.-module Main ( main ) where+module Main (main) where  import Data.Default (def)+import Data.Maybe (fromMaybe) import Data.Semigroup ((<>)) import Data.Version+import DhallConfig (runDhallConfigFromFile) import Options.Applicative+import Paths_taffybar (version) import System.Directory+import System.Exit (exitFailure) import System.Log.Logger import System.Taffybar import System.Taffybar.Context import System.Taffybar.Example import Text.Printf -import Paths_taffybar (version)+data StartupMode+  = StartupAuto+  | StartupDyre+  | StartupExample+  | StartupDhall+  deriving (Eq, Show) +data Options = Options+  { optsLogLevel :: Priority,+    optsStartupMode :: StartupMode+  }+ logP :: Parser Priority logP =-  option auto-  (  long "log-level"-  <> short 'l'-  <> help "Set the log level"-  <> metavar "LEVEL"-  <> value WARNING-  )+  option+    auto+    ( long "log-level"+        <> short 'l'+        <> help "Set the log level"+        <> metavar "LEVEL"+        <> value WARNING+    )  versionOption :: Parser (a -> a)-versionOption = infoOption-                (printf "taffybar %s" $ showVersion version)-                (  long "version"-                <> help "Show the version number of taffybar"-                )+versionOption =+  infoOption+    (printf "taffybar %s" $ showVersion version)+    ( long "version"+        <> help "Show the version number of taffybar"+    ) +startupModeP :: Parser StartupMode+startupModeP =+  fromMaybe StartupAuto+    <$> optional+      ( hsubparser+          ( command+              "auto"+              (info (pure StartupAuto) (progDesc "Use config autodetection (default)"))+              <> command+                "dyre"+                (info (pure StartupDyre) (progDesc "Run dyre with ~/.config/taffybar/taffybar.hs"))+              <> command+                "example"+                (info (pure StartupExample) (progDesc "Run built-in example configuration"))+              <> command+                "dhall"+                (info (pure StartupDhall) (progDesc "Run ~/.config/taffybar/taffybar.dhall"))+          )+      )++optionsP :: Parser Options+optionsP =+  Options+    <$> logP+    <*> startupModeP++runExampleForDetectedBackend :: IO ()+runExampleForDetectedBackend = do+  detectedBackend <- detectBackend+  let exampleConfig = case detectedBackend of+        BackendWayland -> exampleWaylandTaffybarConfig+        BackendX11 -> exampleTaffybarConfig+  logM+    "System.Taffybar"+    WARNING+    (printf "Starting with example configuration for %s." (show detectedBackend))+  startTaffybar exampleConfig++runDhall :: IO ()+runDhall = do+  dhallFilepath <- getTaffyFile "taffybar.dhall"+  dhallExists <- doesFileExist dhallFilepath+  if dhallExists+    then runDhallConfigFromFile dhallFilepath+    else do+      logM+        "System.Taffybar"+        ERROR+        ( printf+            "Dhall mode selected, but %s does not exist."+            dhallFilepath+        )+      exitFailure++runAuto :: IO ()+runAuto = do+  taffyFilepath <- getTaffyFile "taffybar.hs"+  dhallFilepath <- getTaffyFile "taffybar.dhall"+  hasHaskellConfig <- doesFileExist taffyFilepath+  hasDhallConfig <- doesFileExist dhallFilepath++  if hasHaskellConfig+    -- XXX: The configuration record here does not get used, this just calls in to dyre.+    then dyreTaffybar def+    else+      if hasDhallConfig+        then runDhall+        else do+          logM+            "System.Taffybar"+            WARNING+            ( printf "No taffybar configuration file found at %s or %s." taffyFilepath dhallFilepath+                ++ " Falling back to built-in example configuration."+            )+          runExampleForDetectedBackend+ main :: IO () main = do-  logLevel <- execParser $ info (helper <*> versionOption <*> logP)-              (  fullDesc-              <> progDesc "Start taffybar, recompiling if necessary"-              )+  opts <-+    execParser $+      info+        (helper <*> versionOption <*> optionsP)+        ( fullDesc+            <> progDesc "Start taffybar"+        )+  let logLevel = optsLogLevel opts+      startupMode = optsStartupMode opts    logger <- getLogger "System.Taffybar"   saveGlobalLogger $ setLevel logLevel logger -  taffyFilepath <- getTaffyFile "taffybar.hs"-  configurationExists <- doesFileExist taffyFilepath--  if configurationExists-  -- 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 for "-           ++ show detectedBackend-           ++ "."-           )-    startTaffybar exampleConfig+  case startupMode of+    StartupAuto -> runAuto+    StartupDyre -> dyreTaffybar def+    StartupExample -> runExampleForDetectedBackend+    StartupDhall -> runDhall
app/TestWM.hs view
@@ -4,12 +4,12 @@ import XMonad.Hooks.EwmhDesktops (ewmh, ewmhFullscreen) import XMonad.Hooks.ManageDocks (docks) import XMonad.ManageHook-  ( (-->)-  , (<+>)-  , className-  , composeAll-  , doShift-  , (=?)+  ( className,+    composeAll,+    doShift,+    (-->),+    (<+>),+    (=?),   )  -- Minimal EWMH-compliant WM used by CI appearance tests.@@ -26,5 +26,6 @@             { manageHook =                 composeAll                   [ className =? "GreenWin" --> doShift "2"-                  ] <+> manageHook def+                  ]+                  <+> manageHook def             }
+ dbus-xml/org.freedesktop.login1.Manager.xml view
@@ -0,0 +1,10 @@+<!DOCTYPE node PUBLIC "-//freedesktop//DTD D-BUS Object Introspection 1.0//EN"+"https://www.freedesktop.org/standards/dbus/1.0/introspect.dtd">+<node>+ <interface name="org.freedesktop.login1.Manager">+  <signal name="PrepareForSleep">+   <arg type="b" name="start"/>+  </signal>+ </interface>+</node>+
doc/config.md view
@@ -10,6 +10,15 @@ 3. Compile your Taffybar executable some other way. Typically this    would be done with the "Project Approach" (see below). +The `taffybar` binary also supports explicit startup subcommands:++- `taffybar auto` (default behavior when no subcommand is provided)+- `taffybar dyre`+- `taffybar example`+- `taffybar dhall`++See [`doc/dhall-config.md`](./dhall-config.md) for the experimental Dhall schema.+ ## Before installing  Taffybar's [installation procedure](./install.md) varies depending
doc/custom.md view
@@ -73,3 +73,21 @@ the same type.  [widgetSetClassGI]: https://hackage.haskell.org/package/taffybar/docs/System-Taffybar-Widget-Util.html#v:widgetSetClassGI++### Built-in widget classes++Most built-in widgets now expose a stable root CSS class by default, so+you can style them without wrapping constructors in your config.++Examples:+- `.backlight`, `.backlight-icon`, `.backlight-label`+- `.pulse-audio`, `.pulse-audio-icon`, `.pulse-audio-label`+- `.wire-plumber`, `.wire-plumber-icon`, `.wire-plumber-label`+- `.disk-usage`, `.disk-usage-icon`, `.disk-usage-label`+- `.network-manager-wifi*` and `.network-manager-network*`+- `.text-clock`, `.weather`, `.cpu-monitor`, `.network-graph`++Taffybar also applies shared classes for common internals:+- `.icon-label`, `.icon`, `.label`+- `.polling-label`, `.polling-label-container`, `.polling-label-text`+- `.graph`, `.graph-canvas`
+ doc/dhall-config-proposal.md view
@@ -0,0 +1,214 @@+# Dhall Config Proposal for `taffybar` (Issue #462)++## Context+Issue [#462](https://github.com/taffybar/taffybar/issues/462) asks for a plain text config path so users do not need a local GHC toolchain just to customize Taffybar.++Current startup behavior in `app/Main.hs` is:++1. If `~/.config/taffybar/taffybar.hs` exists, run Dyre (compile Haskell config).+2. Otherwise, run built-in example config.++There is no middle path for data-driven configuration.++## Goals+1. Allow users to configure Taffybar without compiling a Haskell config.+2. Keep existing `taffybar.hs` + Dyre workflow fully supported.+3. Cover a meaningful subset of real-world configs (including most of the structure in `imalison`'s current config).+4. Preserve an escape hatch for advanced behavior that fundamentally needs Haskell.++## Non-goals+1. Full parity with arbitrary Haskell configuration in v1.+2. Serializing every existing widget config type directly as-is.+3. Removing Dyre or `taffybar.hs` support.++## Investigation Findings++### 1. Existing config types are mixed data + functions+Many useful widget config records are data-oriented and Dhall-friendly:+- `PulseAudioWidgetConfig`+- `BacklightWidgetConfig`+- `DiskUsageWidgetConfig`+- `ClockConfig`+- `ScreenLockConfig`+- `WlsunsetWidgetConfig`++But key types include function fields, so they are not directly serializable:+- `LayoutConfig` (`formatLayout :: Text -> TaffyIO Text`)+- `WindowsConfig` (menu label and active label builders)+- `MPRIS2Config` (widget wrapper + update function)+- workspace configs (`EWMH` and `Hyprland`) with many callback fields+- `SimpleTaffyConfig` and `TaffybarConfig` hold widget constructors (`TaffyIO Gtk.Widget`) and hooks++### 2. Direct `dhall-haskell` derivation on current types is not enough+Even with `dhall` + `dhall-haskell`, we cannot derive `FromDhall` for function-valued fields. A direct "just decode existing records" approach only works for a narrow subset.++### 3. User config parity requires a widget DSL, not only record decoding+The referenced local config includes:+- backend and hostname conditional widget sets+- wrapper/composition patterns (boxed widgets, vertical stacks)+- custom callbacks (workspace label/icon behavior, MPRIS label formatting, custom polling rows)++A viable plain-text path needs a small interpreted widget/config AST.++## Options Considered++### Option A: Decode existing config records directly (minimal)+Approach:+- Add `FromDhall` instances for data-only records.+- Expose a few fixed widget constructors.++Pros:+- Smallest initial patch.++Cons:+- Low coverage; cannot express many commonly customized widgets.+- Does not get close to "mostly parity" with advanced configs.++### Option B: Dhall AST + interpreter to runtime config (recommended)+Approach:+- Introduce Dhall-specific config ADTs (pure data).+- Decode Dhall to those ADTs.+- Interpret ADTs into `SimpleTaffyConfig` / `TaffybarConfig` + widget constructors.++Pros:+- Solves plain-text requirement without requiring local GHC.+- Allows structured growth of supported features.+- Keeps hard-to-serialize internals private.++Cons:+- More design and implementation effort.+- Requires maintaining interpreter + schema docs.++### Option C: Dhall generates Haskell, still run Dyre+Approach:+- Dhall expression renders `taffybar.hs`, then Dyre compiles.++Pros:+- Reuses existing Haskell pipeline.++Cons:+- Does not solve core issue (still needs compilation toolchain).++## Recommended Design++### 1. Make startup mode explicit via subcommands+Add subcommands for all current startup behaviors:++- `taffybar auto` (default when no subcommand is given)+- `taffybar dyre`+- `taffybar example`+- `taffybar dhall`++Semantics:++- `dyre`: run current `taffybar.hs` + Dyre flow.+- `example`: run built-in example config only.+- `dhall`: load and run `taffybar.dhall` only.+- `auto` (compatibility mode):+  1. if `taffybar.hs` exists -> `dyre`+  2. else if `taffybar.dhall` exists -> `dhall`+  3. else -> `example`++Rationale:+- Keeps `taffybar.hs` as the primary/first-class path.+- Makes Dhall support explicit and discoverable.+- Preserves existing behavior for users who run `taffybar` with no args.++### 2. Introduce a data-only Dhall schema + interpreter+New modules (proposed):+- `System.Taffybar.Config.Dhall.Types`+- `System.Taffybar.Config.Dhall.Decode`+- `System.Taffybar.Config.Dhall.Interpret`++Core schema shape:+- top-level bar settings (position, height, padding, spacing, css paths)+- monitor policy (`all`, `primary`, explicit list)+- conditional blocks:+  - `whenBackend` (`x11` / `wayland`)+  - `whenHostIn` (hostname allow-list)+- widget spec sum type:+  - builtin widgets (pulse, backlight, disk, clock, tray, etc.)+  - wrappers/combinators:+    - `WithClass`+    - `WithContentsBox`+    - `Box` (`horizontal`/`vertical`, spacing)+    - `Sequence` (list of widgets)+- optional hook toggles:+  - `enableLogServer`+  - `enableToggleServer`+  - `enableLogLevels`++### 3. Keep an explicit Haskell escape hatch+Document that these remain Haskell-only (initially):+- arbitrary callback functions+- deeply custom workspace icon/label logic+- custom MPRIS widget update functions+- bespoke polling loops not represented by existing widget primitives++Recommendation: if a feature does not fit the Dhall DSL, use `taffybar.hs`.++### 4. Use `dhall-haskell` where it helps, not as the whole model+Use `dhall-haskell` for decoding the Dhall-facing ADTs. Do not try to decode internal runtime config records directly.++## Coverage vs `imalison` current `taffybar.hs`++Likely supportable in v1/v2:+- widget list composition by section (start/center/end)+- host/backend-dependent widget selection+- css file selection+- most standard widget options (clock, pulse, backlight, disk, tray basics)+- wrapper patterns (class + boxed + stacked groups)++Needs additional design (v2+ or Haskell-only):+- custom workspace callbacks (`labelSetter`, `getWindowIconPixbuf`, custom `widgetBuilder`)+- custom MPRIS text transformation callback+- custom runtime icon remap algorithm for Hyprland windows+- fully custom polling widgets (e.g., bespoke RAM/SWAP row loop)++Practical outcome: "mostly possible" for this config is realistic if we include compositional widgets + conditional logic; full parity is not realistic without embedding a programmable language layer beyond Dhall data.++## Implementation Plan++### Phase 0: RFC and schema freeze+1. Add this proposal and request feedback on schema scope.+2. Lock v1 supported widgets/combinators.++### Phase 1: MVP Dhall path+1. Refactor CLI to add startup subcommands (`auto`, `dyre`, `example`, `dhall`).+2. Preserve current no-arg behavior by mapping it to `auto`.+3. Add `dhall` and `dhall-haskell` dependencies.+4. Implement Dhall decoding for top-level config + 6-10 common widgets.+5. Implement interpreter to `SimpleTaffyConfig`.+6. Wire `taffybar dhall` path in `app/Main.hs`.+7. Add docs in `doc/config.md` with CLI usage and a `taffybar.dhall` example.++### Phase 2: Composition + conditions+1. Add widget combinators (`WithClass`, `WithContentsBox`, `Box`, `Sequence`).+2. Add backend and hostname conditions.+3. Add hook toggles.++### Phase 3: Advanced widget presets+1. Add workspace preset options (data-only toggles for common settings).+2. Add tray/menu backend options and more widget-specific fields.+3. Add compatibility test fixtures for several real configs.++## Testing Strategy+1. Unit test Dhall decode (valid + invalid schema cases).+2. Unit test interpreter for deterministic mapping from spec to config structures.+3. Integration smoke test: load sample `taffybar.dhall`, build widget trees, no runtime exceptions during startup path.+4. Golden tests for error messages from invalid Dhall.++## Risks+1. Schema drift: adding widgets over time can bloat schema.+2. User expectations of full Haskell parity.+3. Long-term maintenance cost of interpreter.++Mitigations:+- Version schema docs.+- Clearly label unsupported features and Haskell escape hatch.+- Keep v1 scope intentionally small, then iterate.++## Open Questions+1. Should `taffybar auto` and plain `taffybar` remain strict compatibility mode forever, or eventually warn users toward explicit subcommands?+2. For unsupported advanced behavior, should we add a limited plugin hook system, or keep explicit "use Haskell config" guidance only?+3. Do we want a built-in converter to help migrate from common `SimpleTaffyConfig` Haskell patterns to Dhall templates?
+ doc/dhall-config.md view
@@ -0,0 +1,163 @@+# Dhall Config (Experimental)++The `taffybar dhall` subcommand reads `~/.config/taffybar/taffybar.dhall` and decodes it into a data-only configuration.++`taffybar auto` (and plain `taffybar`) prefers `taffybar.hs` first, then `taffybar.dhall`, then built-in example config.++## Top-level shape++The Dhall expression must decode to a record with these fields:++- `dhallMonitors : MonitorSpec`+- `dhallBar : BarSpec`+- `dhallHooks : HookSpec`+- `dhallWidgets : WidgetSections`++## MonitorSpec constructors++- `AllMonitors`+- `PrimaryMonitor`+- `MonitorList [Natural]`++## BarSpec fields++- `barPositionSpec : PositionSpec` (`TopBar` or `BottomBar`)+- `barHeightSpec : BarHeightSpec` (`ScreenRatioHeight Double` or `ExactPixelHeight Natural`)+- `barPaddingPx : Natural`+- `barWidgetSpacing : Natural`+- `barCssPaths : List Text`++## HookSpec fields++- `hookLogServer : Bool`+- `hookToggleServer : Bool`+- `hookLogLevels : Bool`+- `hookBatteryRefresh : Bool`++## Widget sections++`WidgetSections` has:++- `widgetStart : List WidgetSpec`+- `widgetCenter : List WidgetSpec`+- `widgetEnd : List WidgetSpec`++## WidgetSpec constructors++Plain/default constructors:++- `Layout`+- `SNITray`+- `SNITrayWithWatcher`+- `MPRIS2`+- `Battery`+- `NetworkManagerWifi`++Configurable constructors (payload type is `Optional ...`; use `None` for defaults):++- `Clock (Optional ClockSpec)`+- `PulseAudio (Optional PulseAudioSpec)`+- `Backlight (Optional BacklightSpec)`+- `DiskUsage (Optional DiskUsageSpec)`+- `Windows (Optional WindowsSpec)`+- `WorkspacesEWMH (Optional EWMHWorkspacesSpec)`+- `WorkspacesHyprland (Optional HyprlandWorkspacesSpec)`+- `ScreenLock (Optional ScreenLockSpec)`+- `Wlsunset (Optional WlsunsetSpec)`++Wrappers/combinators:++- `WithClass WithClassSpec`+- `WithContentsBox WidgetSpec`+- `Box BoxSpec`++## Wrapper specs++`WithClassSpec`:++- `withClassName : Text`+- `withClassWidget : WidgetSpec`++`BoxSpec`:++- `boxOrientation : BoxOrientation` (`Horizontal` or `Vertical`)+- `boxSpacing : Natural`+- `boxChildren : List WidgetSpec`++## Config record field names++`ClockSpec`++- `clockFormat : Text`+- `clockUpdateSpec : ClockUpdateSpec` (`ConstantUpdateInterval Double` or `RoundedTarget { roundedSeconds : Natural, roundedOffset : Double }`)++`PulseAudioSpec`++- `pulseSink : Text`+- `pulseFormat : Text`+- `pulseMuteFormat : Text`+- `pulseUnknownFormat : Text`+- `pulseTooltipFormat : Optional Text`+- `pulseScrollStepPercent : Optional Natural`+- `pulseToggleMuteOnClick : Bool`++`BacklightSpec`++- `backlightPollInterval : Double`+- `backlightDeviceName : Optional Text`+- `backlightFormatSpec : Text`+- `backlightUnknownFormatSpec : Text`+- `backlightTooltipFormatSpec : Optional Text`+- `backlightScrollStepPercentSpec : Optional Natural`+- `backlightBrightnessctlPathSpec : Text`+- `backlightIconSpec : Text`++`DiskUsageSpec`++- `diskPath : Text`+- `diskPollInterval : Double`+- `diskFormat : Text`+- `diskTooltipFormat : Optional Text`+- `diskIcon : Text`++`WindowsSpec`++- `windowsMenuLabelLength : Natural`+- `windowsActiveLabelLength : Natural`+- `windowsShowIcon : Bool`++`EWMHWorkspacesSpec`++- `ewmhMinIcons : Natural`+- `ewmhMaxIcons : Optional Natural`+- `ewmhWidgetGap : Natural`+- `ewmhShowEmpty : Bool`+- `ewmhUrgentWorkspaceState : Bool`+- `ewmhBorderWidth : Natural`+- `ewmhUpdateRateLimitMicroseconds : Natural`++`HyprlandWorkspacesSpec`++- `hyprlandMinIcons : Natural`+- `hyprlandMaxIcons : Optional Natural`+- `hyprlandWidgetGap : Natural`+- `hyprlandShowEmpty : Bool`+- `hyprlandShowSpecial : Bool`+- `hyprlandUrgentWorkspaceState : Bool`+- `hyprlandUpdateIntervalSeconds : Double`+- `hyprlandIconSize : Natural`++`ScreenLockSpec`++- `screenLockIconSpec : Text`+- `screenLockManageIdle : Bool`+- `screenLockManageSleep : Bool`+- `screenLockManageShutdown : Bool`++`WlsunsetSpec`++- `wlsunsetCommandSpec : Text`+- `wlsunsetHighTempSpec : Natural`+- `wlsunsetLowTempSpec : Natural`+- `wlsunsetPollIntervalSpec : Natural`+- `wlsunsetIconSpec : Text`
doc/faq.md view
@@ -1,6 +1,220 @@ # FAQ -For the time being, Taffybar's frequently asked questions page lives in+This page collects common setup and troubleshooting questions for Taffybar.+It is the successor to [issue #332 - Add a FAQ section to README/Docs/Wiki](https://github.com/taffybar/taffybar/issues/332). -Some of this information is collected in [Running Taffybar](./run.md).+For detailed runtime setup, also see [Running Taffybar](./run.md).++## What services and runtime prerequisites are required?++If Taffybar starts but parts of it do not work, check these first:++1. D-Bus system and session buses are running.+2. `status-notifier-watcher` is running before Taffybar if you use `SNITray`.+3. `upower` is running if you use battery widgets.+4. A compositor (for example picom) is running if you want transparency/rounded corners.+5. Non-Haskell C dependencies are installed, including `libdbusmenu-gtk3`+   (or distro equivalent), as described in [Installation](./install.md).++## Where should I put `taffybar.hs` and `taffybar.css`?++Use `$XDG_CONFIG_HOME/taffybar/` (usually `~/.config/taffybar/`).++`taffybar.css` placed there is loaded automatically.+Taffybar also watches CSS files for changes and reloads them.++## Why is my tray empty or missing icons?++### Does `SNITray` support XEmbed tray icons?++No. `SNITray` supports StatusNotifierItem/AppIndicator icons, not legacy XEmbed.++For XEmbed-only apps, run a bridge such as:+<https://github.com/KDE/plasma-workspace/tree/master/xembed-sni-proxy>++### Why does `nm-applet` not show up?++Start it with `--indicator`:++```bash+nm-applet --indicator+```++If you use XDG autostart, edit `~/.config/autostart/nm-applet.desktop` and+ensure `Exec=` includes `--indicator`.+If your setup still uses session-management flags, `--sm-disable --indicator`+also works.++Related issues:++- <https://github.com/taffybar/taffybar/issues/491>++## Why do I get "Could not load a pixbuf..." or "null pixbuf" errors?++Most icon/pixbuf failures come from environment or theme setup:++1. Ensure `GDK_PIXBUF_MODULE_FILE` is set correctly.+2. Ensure `XDG_DATA_DIRS` includes directories containing your desktop files and icons.+3. Ensure icon themes are installed (for example `hicolor-icon-theme`, and your chosen GTK theme/icon theme).+4. If menu icons are missing, set `gtk-menu-images = 1` in `~/.config/gtk-3.0/settings.ini`.++Example `settings.ini`:++```ini+[Settings]+gtk-icon-theme-name = Adwaita+gtk-menu-images = 1+```++If you are on NixOS and start Taffybar with `systemd --user`, read the+NixOS sections in [Running Taffybar](./run.md) for+`GDK_PIXBUF_MODULE_FILE` and `XDG_DATA_DIRS` import details.++Some older posts mention `GDK_PIXBUF_ICON_LOADER`; in current Nix/NixOS setup,+the relevant variable is `GDK_PIXBUF_MODULE_FILE`.++Related issues:++- <https://github.com/taffybar/taffybar/issues/367>+- <https://github.com/taffybar/taffybar/issues/373>+- <https://github.com/NixOS/nixpkgs/issues/43836>++## How do I size workspace/tray icons with CSS?++Taffybar icon widgets include CSS classes such as `.auto-size-image`,+`.sni-tray`, and `.window-icon`.++Example:++```css+/* Increase icon vertical size and spacing */+.auto-size-image, .sni-tray {+  padding-top: 4px;+  padding-bottom: 4px;+}++.window-icon {+  opacity: 1;+}+```++Use `GTK_DEBUG=interactive taffybar` to inspect live widget classes in GTK Inspector.++## How do workspace window icon getters work?++By default, workspace icon lookup tries desktop entries, then WM class, then EWMH.+You can override this with `getWindowIconPixbuf`.++Example forcing EWMH icons at a fixed size:++```haskell+import System.Taffybar.Widget.Workspaces++myWorkspacesConfig :: WorkspacesConfig+myWorkspacesConfig =+  defaultWorkspacesConfig+    { getWindowIconPixbuf =+        constantScaleWindowIconPixbufGetter 18 getWindowIconPixbufFromEWMH+    }+```++`defaultGetWindowIconPixbuf` is still the recommended default for most users.++## Why do windows appear in the active workspace on multi-monitor XMonad?++This is usually an older XMonad EWMH implementation issue, not a Taffybar bug.+See:++- <https://github.com/xmonad/xmonad-contrib/pull/238>+- <https://github.com/taffybar/taffybar/issues/239>+- <https://github.com/taffybar/taffybar/issues/369>++Use a recent `xmonad-contrib` that includes the EWMH fix from the PR above.++## Why does Taffybar segfault on older GHC versions?++There were known crash issues around GHC 8.4.x (for example `8.4.2`).+See:++- <https://github.com/taffybar/taffybar/issues/358>++Use a GHC version listed in `tested-with` in `taffybar.cabal`.++## Do you have startup examples (`.xprofile` and `systemd --user`)?++### `.xprofile` example++```bash+# Start tray watcher first when using SNITray+status-notifier-watcher &++# Optional bridge for legacy XEmbed-only tray apps+# xembed-sni-proxy &++# AppIndicator mode+nm-applet --sm-disable --indicator &++taffybar &+```++### `systemd --user` example++`~/.config/systemd/user/taffybar.service`:++```ini+[Unit]+Description=Taffybar+After=graphical-session.target+Wants=graphical-session.target++[Service]+ExecStart=/usr/bin/env taffybar+Restart=on-failure++[Install]+WantedBy=default.target+```++Before starting the unit, import session environment variables once per login:++```bash+systemctl --user import-environment DISPLAY XAUTHORITY \+  DBUS_SESSION_BUS_ADDRESS XDG_DATA_DIRS GDK_PIXBUF_MODULE_FILE+```++On NixOS, you can instead use:+`services.xserver.displayManager.importedVariables`.++## How do I use Cachix with Nix builds?++Taffybar does not require a specific project Cachix cache, but you can use your own:++```bash+nix build .#taffybar+cachix use my-cache+cachix push my-cache "$(readlink -f result)"+```++For team use, add your cache URL/key to Nix `substituters` and+`trusted-public-keys`.++## How do I add click handling to a widget?++Wrap the widget in a `Gtk.EventBox` and handle button press events:++```haskell+import Control.Monad (void)+import Control.Monad.IO.Class (liftIO)+import qualified GI.Gtk as Gtk++makeClickable :: IO Gtk.Widget -> IO () -> IO Gtk.Widget+makeClickable mkInner onClick = do+  inner <- mkInner+  box <- Gtk.eventBoxNew+  Gtk.containerAdd box inner+  Gtk.eventBoxSetVisibleWindow box False+  void $ Gtk.onWidgetButtonPressEvent box $ liftIO onClick >> pure False+  Gtk.widgetShowAll box+  Gtk.toWidget box+```
src/System/Taffybar.hs view
@@ -1,6 +1,10 @@ {-# LANGUAGE NamedFieldPuns #-} {-# OPTIONS_GHC -fno-warn-missing-signatures #-}+ -----------------------------------------------------------------------------++-----------------------------------------------------------------------------+ -- | -- Module      : System.Taffybar -- Copyright   : (c) Ivan A. Malison@@ -9,163 +13,154 @@ -- Maintainer  : Ivan A. Malison -- Stability   : unstable -- Portability : unportable------------------------------------------------------------------------------ module System.Taffybar-  (-  -- | Taffybar is a system status bar meant for use with window managers like-  -- "XMonad" and i3wm. Taffybar is somewhat similar to xmobar, but it opts to use-  -- more heavy weight GUI in the form of GTK rather than the mostly textual-  -- approach favored by the latter. This allows it to provide features like an-  -- SNI system tray, and a workspace widget with window icons.-  --+  ( -- | Taffybar is a system status bar meant for use with window managers like+    -- "XMonad" and i3wm. Taffybar is somewhat similar to xmobar, but it opts to use+    -- more heavy weight GUI in the form of GTK rather than the mostly textual+    -- approach favored by the latter. This allows it to provide features like an+    -- SNI system tray, and a workspace widget with window icons. -  -- * Configuration-  -- |-  -- The interface that Taffybar provides to the end user is roughly as follows:-  -- you give Taffybar a list of ('TaffyIO' actions that build) GTK widgets and-  -- it renders them in a horizontal bar for you (taking care of ugly details-  -- like reserving strut space so that window managers don't put windows over-  -- it).-  ---  -- The config file in which you specify the GTK widgets to render is just a-  -- Haskell source file which is used to produce a custom executable with the-  -- desired set of widgets. This approach requires that Taffybar be installed-  -- as a Haskell library (not merely as an executable), and that the GHC-  -- compiler be available for recompiling the configuration. The upshot of this-  -- approach is that Taffybar's behavior and widget set are not limited to the-  -- set of widgets provided by the library, because custom code and widgets can-  -- be provided to Taffybar for instantiation and execution.-  ---  -- The following code snippet is a simple example of what a Taffybar-  -- configuration might look like (also see "System.Taffybar.Example"):-  ---  -- > {-# LANGUAGE OverloadedStrings #-}-  -- > import Data.Default (def)-  -- > import System.Taffybar-  -- > import System.Taffybar.Information.CPU-  -- > import System.Taffybar.SimpleConfig-  -- > import System.Taffybar.Widget-  -- > import System.Taffybar.Widget.Generic.Graph-  -- > import System.Taffybar.Widget.Generic.PollingGraph-  -- >-  -- > cpuCallback = do-  -- >   (_, systemLoad, totalLoad) <- cpuLoad-  -- >   return [ totalLoad, systemLoad ]-  -- >-  -- > main = do-  -- >   let cpuCfg = def-  -- >                  { graphDataColors = [ (0, 1, 0, 1), (1, 0, 1, 0.5)]-  -- >                  , graphLabel = Just "cpu"-  -- >                  }-  -- >       clock = textClockNewWith def-  -- >       cpu = pollingGraphNew cpuCfg 0.5 cpuCallback-  -- >       workspaces = workspacesNew def-  -- >       simpleConfig = def-  -- >                        { startWidgets = [ workspaces ]-  -- >                        , endWidgets = [ sniTrayNew, clock, cpu ]-  -- >                        }-  -- >   simpleTaffybar simpleConfig-  ---  -- This configuration creates a bar with four widgets. On the left is a widget-  -- that shows information about the workspace configuration. The rightmost-  -- widget is the system tray, with a clock and then a CPU graph.-  ---  -- The CPU widget plots two graphs on the same widget: total CPU use in green-  -- and then system CPU use in a kind of semi-transparent purple on top of the-  -- green.-  ---  -- It is important to note that the widget lists are __not__ @'GI.Gtk.Widget'@. They are-  -- actually @'TaffyIO' 'GI.Gtk.Widget'@ since the bar needs to construct them after-  -- performing some GTK initialization.+    -- * Configuration -    getTaffyFile+    -- |+    -- The interface that Taffybar provides to the end user is roughly as follows:+    -- you give Taffybar a list of ('TaffyIO' actions that build) GTK widgets and+    -- it renders them in a horizontal bar for you (taking care of ugly details+    -- like reserving strut space so that window managers don't put windows over+    -- it).+    --+    -- The config file in which you specify the GTK widgets to render is just a+    -- Haskell source file which is used to produce a custom executable with the+    -- desired set of widgets. This approach requires that Taffybar be installed+    -- as a Haskell library (not merely as an executable), and that the GHC+    -- compiler be available for recompiling the configuration. The upshot of this+    -- approach is that Taffybar's behavior and widget set are not limited to the+    -- set of widgets provided by the library, because custom code and widgets can+    -- be provided to Taffybar for instantiation and execution.+    --+    -- The following code snippet is a simple example of what a Taffybar+    -- configuration might look like (also see "System.Taffybar.Example"):+    --+    -- > {-# LANGUAGE OverloadedStrings #-}+    -- > import Data.Default (def)+    -- > import System.Taffybar+    -- > import System.Taffybar.SimpleConfig+    -- > import System.Taffybar.Widget+    -- >+    -- > main = do+    -- >   let cpuCfg = def+    -- >                  { graphDataColors = [ (0, 1, 0, 1), (1, 0, 1, 0.5)]+    -- >                  , graphLabel = Just "cpu"+    -- >                  }+    -- >       clock = textClockNewWith def+    -- >       cpu = cpuMonitorNew cpuCfg 0.5 "cpu"+    -- >       workspaces = workspacesNew def+    -- >       simpleConfig = def+    -- >                        { startWidgets = [ workspaces ]+    -- >                        , endWidgets = [ sniTrayNew, clock, cpu ]+    -- >                        }+    -- >   simpleTaffybar simpleConfig+    --+    -- This configuration creates a bar with four widgets. On the left is a widget+    -- that shows information about the workspace configuration. The rightmost+    -- widget is the system tray, with a clock and then a CPU graph.+    --+    -- The CPU widget plots two graphs on the same widget: total CPU use in green+    -- and then system CPU use in a kind of semi-transparent purple on top of the+    -- green.+    --+    -- It is important to note that the widget lists are __not__ @'GI.Gtk.Widget'@. They are+    -- actually @'TaffyIO' 'GI.Gtk.Widget'@ since the bar needs to construct them after+    -- performing some GTK initialization.+    getTaffyFile, -  -- ** Colors-  ---  -- | Although Taffybar is based on GTK, it ignores your GTK theme. The default-  -- theme that it uses lives at-  -- https://github.com/taffybar/taffybar/blob/master/taffybar.css You can alter-  -- this theme by editing @~\/.config\/taffybar\/taffybar.css@ to your liking.-  -- For an idea of the customizations you can make, see-  -- <https://live.gnome.org/GnomeArt/Tutorials/GtkThemes>.+    -- ** Colors +    -- -  -- * Taffybar and DBus-  ---  -- | Taffybar has a strict dependency on "DBus", so you must ensure that the DBus daemon is-  -- started before starting Taffybar.-  ---  -- * If you start your window manager using a graphical login manager like @gdm@-  -- or @kdm@, DBus should be started automatically for you.-  ---  -- * If you start xmonad with a different graphical login manager that does-  -- not start DBus for you automatically, put the line-  -- @eval \`dbus-launch --auto-syntax\`@ into your @~\/.xsession@ *before* xmonad and taffybar are-  -- started. This command sets some environment variables that the two must-  -- agree on.-  ---  -- * If you start xmonad via @startx@ or a similar command, add the-  -- above command to @~\/.xinitrc@-  ---  -- * System tray compatability-  ---  -- "System.Taffybar.Widget.SNITray" only supports the newer-  -- StatusNotifierItem (SNI) protocol; older xembed applets will not work.-  -- AppIndicator is also a valid implementation of SNI.-  ---  -- Additionally, this module does not handle recognising new tray applets.-  -- Instead it is necessary to run status-notifier-watcher from the-  -- [status-notifier-item](https://github.com/taffybar/status-notifier-item)-  -- package early on system startup.-  -- In case this is not possible, the alternative widget-  -- 'System.Taffybar.Widget.SNITray.sniTrayThatStartsWatcherEvenThoughThisIsABadWayToDoIt' is available, but-  -- this may not necessarily be able to pick up everything.+    -- | Although Taffybar is based on GTK, it ignores your GTK theme. The default+    -- theme that it uses lives at+    -- https://github.com/taffybar/taffybar/blob/master/taffybar.css You can alter+    -- this theme by editing @~\/.config\/taffybar\/taffybar.css@ to your liking.+    -- For an idea of the customizations you can make, see+    -- <https://live.gnome.org/GnomeArt/Tutorials/GtkThemes>. -  -- * Starting-  ,  startTaffybar+    -- * Taffybar and DBus -  -- ** Using Dyre-  , dyreTaffybar-  , dyreTaffybarMain-  , taffybarDyreParams-  ) where+    -- -import qualified Control.Concurrent.MVar as MV+    -- | Taffybar has a strict dependency on "DBus", so you must ensure that the DBus daemon is+    -- started before starting Taffybar.+    --+    -- * If you start your window manager using a graphical login manager like @gdm@+    -- or @kdm@, DBus should be started automatically for you.+    --+    -- * If you start xmonad with a different graphical login manager that does+    -- not start DBus for you automatically, put the line+    -- @eval \`dbus-launch --auto-syntax\`@ into your @~\/.xsession@ *before* xmonad and taffybar are+    -- started. This command sets some environment variables that the two must+    -- agree on.+    --+    -- * If you start xmonad via @startx@ or a similar command, add the+    -- above command to @~\/.xinitrc@+    --+    -- * System tray compatability+    --+    -- "System.Taffybar.Widget.SNITray" only supports the newer+    -- StatusNotifierItem (SNI) protocol; older xembed applets will not work.+    -- AppIndicator is also a valid implementation of SNI.+    --+    -- Additionally, this module does not handle recognising new tray applets.+    -- Instead it is necessary to run status-notifier-watcher from the+    -- [status-notifier-item](https://github.com/taffybar/status-notifier-item)+    -- package early on system startup.+    -- In case this is not possible, the alternative widget+    -- 'System.Taffybar.Widget.SNITray.sniTrayThatStartsWatcherEvenThoughThisIsABadWayToDoIt' is available, but+    -- this may not necessarily be able to pick up everything.++    -- * Starting+    startTaffybar,++    -- ** Using Dyre+    dyreTaffybar,+    dyreTaffybarMain,+    taffybarDyreParams,+  )+where+ import qualified Config.Dyre as Dyre import qualified Config.Dyre.Params as Dyre-import           Control.Exception ( finally )-import           Data.Function ( on )-import           Data.Maybe (isJust)-import           Control.Monad+import qualified Control.Concurrent.MVar as MV+import Control.Exception (finally)+import Control.Monad+import Data.Function (on) import qualified Data.GI.Gtk.Threading as GIThreading-import           Data.List ( groupBy, sort, isPrefixOf )+import Data.List (groupBy, isPrefixOf, sort) import qualified Data.Text as T-import           Data.Word (Word32)+import Data.Word (Word32)+import qualified GI.GLib as G import qualified GI.Gdk as Gdk import qualified GI.Gtk as Gtk-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 )-import           System.FSNotify ( startManager, watchDir, stopManager, EventIsDirectory (..), Event (..) )+import Graphics.X11.Xlib.Misc (initThreads)+import Paths_taffybar (getDataDir)+import System.Directory+import System.Environment.XDG.BaseDir (getUserConfigFile)+import System.Exit (exitFailure)+import System.FSNotify (Event (..), EventIsDirectory (..), startManager, stopManager, watchDir)+import System.FilePath (normalise, takeDirectory, takeFileName, (</>)) import qualified System.IO as IO-import           System.Log.Logger-import           System.Taffybar.Context-import           System.Taffybar.Hooks-import           System.Taffybar.Util ( onSigINT, maybeHandleSigHUP, rebracket_ )--import           Paths_taffybar ( getDataDir )+import System.Log.Logger+import System.Taffybar.Context+import System.Taffybar.Hooks+import System.Taffybar.Util (maybeHandleSigHUP, onSigINT, rebracket_)  -- | The parameters that are passed to Dyre when taffybar is invoked with -- 'dyreTaffybar'. taffybarDyreParams =   (Dyre.newParams "taffybar" dyreTaffybarMain showError)-  { Dyre.ghcOpts = ["-threaded", "-rtsopts"]-  , Dyre.rtsOptsHandling = Dyre.RTSAppend ["-I0", "-V0"]-  }+    { Dyre.ghcOpts = ["-threaded", "-rtsopts"],+      Dyre.rtsOptsHandling = Dyre.RTSAppend ["-I0", "-V0"]+    }  -- | Use Dyre to configure and start Taffybar. This will automatically recompile -- Taffybar whenever there are changes to your @taffybar.hs@ configuration file.@@ -173,7 +168,7 @@ dyreTaffybar = Dyre.wrapMain taffybarDyreParams  showError :: TaffybarConfig -> String -> TaffybarConfig-showError cfg msg = cfg { errorMsg = Just msg }+showError cfg msg = cfg {errorMsg = Just msg}  -- | The main function that Dyre should run. This is used in 'taffybarDyreParams'. dyreTaffybarMain :: TaffybarConfig -> IO ()@@ -197,13 +192,14 @@  -- | Return CSS files which should be loaded for the given config. getCSSPaths :: TaffybarConfig -> IO [FilePath]-getCSSPaths TaffybarConfig{cssPaths} = sequence (defaultCSS:userCSS)+getCSSPaths TaffybarConfig {cssPaths} = sequence (defaultCSS : userCSS)   where     -- Vendor CSS file, which is always loaded before user's CSS.     defaultCSS = getDataFile "taffybar.css"     -- User's configured CSS files, with XDG config file being the default.-    userCSS | null cssPaths = [getTaffyFile "taffybar.css"]-            | otherwise     = map return cssPaths+    userCSS+      | null cssPaths = [getTaffyFile "taffybar.css"]+      | otherwise = map return cssPaths  -- | Overrides the default GTK theme and settings with CSS styles from -- the given files (if they exist).@@ -232,7 +228,7 @@ --  * @GTK_STYLE_PROVIDER_PRIORITY_USER@ = 800 -- -- The file @XDG_CONFIG_HOME/gtk-3.0/gtk.css@ uses priority 800.-startCSS' :: Word32  -> [FilePath] -> IO (IO (), Gtk.CssProvider)+startCSS' :: Word32 -> [FilePath] -> IO (IO (), Gtk.CssProvider) startCSS' prio cssFilePaths = do   provider <- Gtk.cssProviderNew   mapM_ (logLoadCSSFile provider) =<< filterM doesFileExist cssFilePaths@@ -281,14 +277,18 @@   mapM_ (\(dir, fs) -> watchDir mgr dir (eventP fs) callback) cssDirs   pure (stopManager mgr)   where-    getDirs = filterM (doesDirectoryExist . fst)-      . filter (not . isPrefixOf "/nix/store/" . fst)-      . dirGroups-      . sort-    dirGroups xs = [ (takeDirectory f, map takeFileName (f:fs))-                   | (f:fs) <- groupBy ((==) `on` takeDirectory) xs]-    eventP fs ev = eventIsDirectory ev == IsFile-      && takeFileName (eventPath ev) `elem` fs+    getDirs =+      filterM (doesDirectoryExist . fst)+        . filter (not . isPrefixOf "/nix/store/" . fst)+        . dirGroups+        . sort+    dirGroups xs =+      [ (takeDirectory f, map takeFileName (f : fs))+      | (f : fs) <- groupBy ((==) `on` takeDirectory) xs+      ]+    eventP fs ev =+      eventIsDirectory ev == IsFile+        && takeFileName (eventPath ev) `elem` fs      -- inotify events arrive in batches. To avoid unnecessary reloads,     -- accumulate events in an MVar and call the notifier after a@@ -296,11 +296,11 @@     debounce msec cb = do       buffer <- MV.newMVar []       let mainLoopCallback = do-             evs <- MV.modifyMVar buffer (pure . ([],))-             unless (null evs) cb-             pure G.SOURCE_REMOVE+            evs <- MV.modifyMVar buffer (pure . ([],))+            unless (null evs) cb+            pure G.SOURCE_REMOVE       pure $ \ev -> do-        MV.modifyMVar_ buffer (pure . (ev:))+        MV.modifyMVar_ buffer (pure . (ev :))         void $ G.timeoutAdd G.PRIORITY_LOW msec mainLoopCallback  -- | Start Taffybar with the provided 'TaffybarConfig'. This function will not@@ -314,27 +314,26 @@   updateGlobalLogger "" removeHandler   setTaffyLogFormatter "System.Taffybar"   setTaffyLogFormatter "StatusNotifier"-  useX11 <- shouldInitX11-  when useX11 $ void initThreads++  -- Detect backend once up-front so any environment fixups happen before GTK+  -- initialization, and so we don't have multiple ad-hoc checks spread around.+  backendType <- detectBackend+  when (backendType == BackendX11) $ void initThreads+   _ <- Gtk.init Nothing   GIThreading.setCurrentThreadAsGUIThread    cssPathsToLoad <- getCSSPaths config-  context <- buildContext config+  context <- buildContextWithBackend backendType config -  withCSSReloadable cssPathsToLoad $ Gtk.main-    `finally` logTaffy DEBUG "Finished main loop"-    `onSigINT` do-      logTaffy INFO "Interrupted"-      exitTaffybar context+  withCSSReloadable cssPathsToLoad $+    Gtk.main+      `finally` logTaffy DEBUG "Finished main loop"+      `onSigINT` do+        logTaffy INFO "Interrupted"+        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/Auth.hs view
@@ -1,22 +1,31 @@ {-# LANGUAGE OverloadedStrings #-}++-- | Helpers for retrieving and parsing credentials from the @pass@ password+-- store. module System.Taffybar.Auth where -import           Control.Monad.IO.Class-import           Data.Maybe-import           System.Taffybar.Util-import           Text.Regex+import Control.Monad.IO.Class+import Data.Maybe+import System.Taffybar.Util+import Text.Regex +-- | Regex for @field: value@ lines in @pass show@ output. fieldRegex :: Regex fieldRegex = mkRegexWithOpts "^(.*?): *(.*?)$" True True -passGet :: MonadIO m => String -> m (Either String (String, [(String, String)]))+-- | Read a secret with @pass show@ and parse additional fields from subsequent+-- lines.+--+-- Returns either an error string or @(primarySecret, extraFields)@.+passGet :: (MonadIO m) => String -> m (Either String (String, [(String, String)])) passGet credentialName = (>>= getPassComponents . lines) <$> runPassShow-  where runPassShow = runCommand "pass" ["show", credentialName]+  where+    runPassShow = runCommand "pass" ["show", credentialName] -        getPassComponents [] = Left "pass show command produced no output"-        getPassComponents (key:rest) = Right (key, buildEntries rest)+    getPassComponents [] = Left "pass show command produced no output"+    getPassComponents (key : rest) = Right (key, buildEntries rest) -        buildEntries = mapMaybe buildEntry . mapMaybe (matchRegex fieldRegex)+    buildEntries = mapMaybe buildEntry . mapMaybe (matchRegex fieldRegex) -        buildEntry [fieldName, fieldValue] = Just (fieldName, fieldValue)-        buildEntry _ = Nothing+    buildEntry [fieldName, fieldValue] = Just (fieldName, fieldValue)+    buildEntry _ = Nothing
src/System/Taffybar/Context.hs view
@@ -1,685 +1,1033 @@-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE ExistentialQuantification #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE MonoLocalBinds #-}-{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE ImpredicativeTypes #-}--------------------------------------------------------------------------------- |--- Module      : System.Taffybar.Context--- Copyright   : (c) Ivan A. Malison--- License     : BSD3-style (see LICENSE)------ Maintainer  : Ivan A. Malison--- Stability   : unstable--- Portability : unportable------ The "System.Taffybar.Context" module provides the core functionality of the--- taffybar library. It gets its name from the 'Context' record, which stores--- runtime information and objects, which are used by many of the widgets that--- taffybar provides. 'Context' is typically accessed through the 'Reader'--- interface of 'TaffyIO'.--------------------------------------------------------------------------------module System.Taffybar.Context-  ( -- * Configuration-    TaffybarConfig(..)-  , defaultTaffybarConfig-  , appendHook-  -- ** Bars-  , BarConfig(..)-  , BarConfigGetter-  , showBarId--  -- * Taffy monad-  , Taffy-  , TaffyIO-  -- ** Context-  , Context(..)-  , buildContext-  , buildEmptyContext-  -- ** Context State-  , getState-  , getStateDefault-  , putState-  , setState--  -- * Control-  , refreshTaffyWindows-  , exitTaffybar--  -- * X11-  , runX11-  , runX11Def-  -- ** Event subscription-  , subscribeToAll-  , subscribeToPropertyEvents-  , unsubscribe--  -- * Threading-  , taffyFork-  -- * Backend (re-exported from "System.Taffybar.Context.Backend")-  , Backend(..)-  , detectBackend-  ) where--import           Control.Arrow ((&&&), (***))-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.Class-import           Control.Monad.Trans.Maybe-import           Control.Monad.Trans.Reader-import qualified DBus.Client as DBus-import           Data.Data-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-import           Data.Tuple.Select-import           Data.Tuple.Sequence-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.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-import           Text.Printf-import           Unsafe.Coerce--logIO :: Priority -> String -> IO ()-logIO = logM "System.Taffybar.Context"--logC :: MonadIO m => Priority -> String -> m ()-logC p = liftIO . logIO p---- | 'Taffy' is a monad transformer that provides 'ReaderT' for 'Context'.-type Taffy m v = ReaderT Context m v---- | 'TaffyIO' is 'IO' wrapped with a 'ReaderT' providing 'Context'. This is the--- type of most widgets and callback in Taffybar.-type TaffyIO v = ReaderT Context IO v--type Listener = Event -> Taffy IO ()-type SubscriptionList = [(Unique, Listener)]-data Value = forall t. Typeable t => Value t--fromValue :: forall t. Typeable t => Value -> Maybe t-fromValue (Value v) =-  if typeOf v == typeRep (Proxy :: Proxy t) then-    Just $ unsafeCoerce v-  else-    Nothing---- | 'BarConfig' specifies the configuration for a single taffybar window.-data BarConfig = BarConfig-  {-  -- | The strut configuration to use for the bar-    strutConfig :: StrutConfig-  -- | The amount of spacing in pixels between bar widgets-  , widgetSpacing :: Int32-  -- | Constructors for widgets that should be placed at the beginning of the bar.-  , startWidgets :: [TaffyIO Gtk.Widget]-  -- | Constructors for widgets that should be placed in the center of the bar.-  , centerWidgets :: [TaffyIO Gtk.Widget]-  -- | Constructors for widgets that should be placed at the end of the bar.-  , endWidgets :: [TaffyIO Gtk.Widget]-  -- | A unique identifier for the bar, that can be used e.g. when toggling.-  , barId :: Unique-  }--instance Eq BarConfig where-  a == b = barId a == barId b--type BarConfigGetter = TaffyIO [BarConfig]---- | 'TaffybarConfig' provides an advanced interface for configuring taffybar.--- Through the 'getBarConfigsParam', it is possible to specify different--- taffybar configurations depending on the number of monitors present, and even--- to specify different taffybar configurations for each monitor.-data TaffybarConfig = TaffybarConfig-  {-  -- | An optional dbus client to use.-    dbusClientParam :: Maybe DBus.Client-  -- | Hooks that should be executed at taffybar startup.-  , startupHook :: TaffyIO ()-  -- | A 'TaffyIO' action that returns a list of 'BarConfig' where each element-  -- describes a taffybar window that should be spawned.-  , getBarConfigsParam :: BarConfigGetter-  -- | A list of 'FilePath' each of which should be loaded as css files at-  -- startup.-  , cssPaths :: [FilePath]-  -- | A field used (only) by dyre to provide an error message.-  , errorMsg :: Maybe String-  }----- | Append the provided 'TaffyIO' hook to the 'startupHook' of the given--- 'TaffybarConfig'.-appendHook :: TaffyIO () -> TaffybarConfig -> TaffybarConfig-appendHook hook config = config-  { startupHook = startupHook config >> hook }---- | Default values for a 'TaffybarConfig'. Not usuable without at least--- properly setting 'getBarConfigsParam'.-defaultTaffybarConfig :: TaffybarConfig-defaultTaffybarConfig = TaffybarConfig-  { dbusClientParam = Nothing-  , startupHook = return ()-  , getBarConfigsParam = return []-  , cssPaths = []-  , errorMsg = Nothing-  }--instance Default TaffybarConfig where-  def = defaultTaffybarConfig---- | A "Context" value holds all of the state associated with a single running--- instance of taffybar. It is typically accessed from a widget constructor--- through the "TaffyIO" monad transformer stack.-data Context = Context-  {-  -- | The X11Context that will be used to service X11Property requests.-    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-  -- types. Most new pieces of state should go here, rather than in a new field-  -- in 'Context'. State stored here is typically accessed through-  -- 'getStateDefault'.-  , contextState :: MV.MVar (M.Map TypeRep Value)-  -- | Used to track the windows that taffybar is currently controlling, and-  -- which 'BarConfig' objects they are associated with.-  , existingWindows :: MV.MVar [(BarConfig, Gtk.Window)]-  -- | The shared user session 'DBus.Client'.-  , sessionDBusClient :: DBus.Client-  -- | The shared system session 'DBus.Client'.-  , systemDBusClient :: DBus.Client-  -- | 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-  -- different for widgets belonging to bar windows on different monitors.-  , contextBarConfig :: Maybe BarConfig-  }---- | Build the "Context" for a taffybar process.-buildContext :: TaffybarConfig -> IO Context-buildContext TaffybarConfig-               { dbusClientParam = maybeDBus-               , getBarConfigsParam = barConfigGetter-               , startupHook = startup-               } = do-  logIO DEBUG "Building context"-  dbusC <- maybe DBus.connectSession return maybeDBus-  sDBusC <- DBus.connectSystem-  _ <- DBus.requestName dbusC "org.taffybar.Bar"-       [DBus.nameAllowReplacement, DBus.nameReplaceExisting]-  backendType <- detectBackend-  listenersVar <- MV.newMVar []-  state <- MV.newMVar M.empty-  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-                , listeners = listenersVar-                , contextState = state-                , sessionDBusClient = dbusC-                , systemDBusClient = sDBusC-                , getBarConfigs = barConfigGetter-                , hyprlandClient = hyprClient-                , hyprlandEventChanVar = hyprEventChanVar-                , existingWindows = windowsVar-                , backend = backendType-                , contextBarConfig = Nothing-                }-  _ <- runMaybeT $ MaybeT GI.Gdk.displayGetDefault >>=-              (lift . GI.Gdk.displayGetDefaultScreen) >>=-              (lift . flip GI.Gdk.afterScreenMonitorsChanged-               -- XXX: We have to do a force refresh here because there is no-               -- way to reliably move windows, since the window manager can do-               -- whatever it pleases.-               (runReaderT forceRefreshTaffyWindows context))-  flip runReaderT context $ do-    logC DEBUG "Starting X11 Handler"-    startX11EventHandler-    logC DEBUG "Running startup hook"-    startup-    logC DEBUG "Queing build windows command"-    refreshTaffyWindows-  logIO DEBUG "Context build finished"-  return context---- | Build an empty taffybar context. This function is mostly useful for--- invoking functions that yield 'TaffyIO' values in a testing setting (e.g. in--- a repl).-buildEmptyContext :: IO Context-buildEmptyContext = buildContext def---- | Format the 'barId' as a numeric string.-showBarId :: BarConfig -> String-showBarId = show . hashUnique . barId--buildBarWindow :: Context -> BarConfig -> IO Gtk.Window-buildBarWindow context barConfig = do-  let thisContext = context { contextBarConfig = Just barConfig }-  logC INFO $-      printf "Building window for Taffybar(id=%s) with %s"-      (showBarId barConfig)-      (show $ strutConfig barConfig)--  window <- Gtk.windowNew Gtk.WindowTypeToplevel--  void $ Gtk.onWidgetDestroy window $ do-    let bId = showBarId barConfig-    logC INFO $ printf "Window for Taffybar(id=%s) destroyed" bId-    MV.modifyMVar_ (existingWindows context) (pure . filter ((/=) window . sel2))-    logC DEBUG $ printf "Window for Taffybar(id=%s) unregistered" bId--  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--  _ <- widgetSetClassGI centerBox "center-box"-  Gtk.widgetSetVexpand centerBox True-  Gtk.setWidgetValign centerBox Gtk.AlignFill-  Gtk.setWidgetHalign centerBox Gtk.AlignCenter-  Gtk.boxSetCenterWidget box (Just centerBox)--  setupBarWindow context (strutConfig barConfig) window-  Gtk.containerAdd window box--  _ <- widgetSetClassGI window "taffy-window"--  let addWidgetWith widgetAdd (count, buildWidget) =-        runReaderT buildWidget thisContext >>= widgetAdd count-      addToStart count widget = do-        _ <- widgetSetClassGI widget $ T.pack $ printf "left-%d" (count :: Int)-        Gtk.boxPackStart box widget False False 0-      addToEnd count widget = do-        _ <- widgetSetClassGI widget $ T.pack $ printf "right-%d" (count :: Int)-        Gtk.boxPackEnd box widget False False 0-      addToCenter count widget = do-        _ <- widgetSetClassGI widget $ T.pack $ printf "center-%d" (count :: Int)-        Gtk.boxPackStart centerBox widget False False 0--  logIO DEBUG "Building start widgets"-  mapM_ (addWidgetWith addToStart) $ zip [1..] (startWidgets barConfig)-  logIO DEBUG "Building center widgets"-  mapM_ (addWidgetWith addToCenter) $ zip [1..] (centerWidgets barConfig)-  logIO DEBUG "Building end widgets"-  mapM_ (addWidgetWith addToEnd) $ zip [1..] (endWidgets barConfig)--  makeWindowTransparent window--  logIO DEBUG "Showing window"-  Gtk.widgetShow window-  Gtk.widgetShow box-  Gtk.widgetShow centerBox--  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---- | Use the "barConfigGetter" field of "Context" to get the set of taffybar--- windows that should active. Will avoid recreating windows if there is already--- a window with the appropriate geometry and "BarConfig".-refreshTaffyWindows :: TaffyIO ()-refreshTaffyWindows = mapReaderT postGUIASync $ do-  logC DEBUG "Refreshing windows"-  ctx <- ask-  windowsVar <- asks existingWindows--  let rebuildWindows currentWindows = flip runReaderT ctx $-        do-          barConfigs <- join $ asks getBarConfigs--          let currentConfigs = map sel1 currentWindows-              newConfs = filter (`notElem` currentConfigs) barConfigs-              (remainingWindows, removedWindows) =-                partition ((`elem` barConfigs) . sel1) currentWindows-              setPropertiesFromPair (barConf, window) =-                setupBarWindow ctx (strutConfig barConf) window--          newWindowPairs <- lift $ do-            logIO DEBUG $ printf "removedWindows: %s" $-                  show $ map (strutConfig . sel1) removedWindows-            logIO DEBUG $ printf "remainingWindows: %s" $-                  show $ map (strutConfig . sel1) remainingWindows-            logIO DEBUG $ printf "newWindows: %s" $-                  show $ map strutConfig newConfs-            logIO DEBUG $ printf "barConfigs: %s" $-                  show $ map strutConfig barConfigs--            -- TODO: This should actually use the config that is provided from-            -- getBarConfigs so that the strut properties of the window can be-            -- altered.-            logIO DEBUG "Updating strut properties for existing windows"-            mapM_ setPropertiesFromPair remainingWindows--            logIO DEBUG "Constructing new windows"-            mapM (sequenceT . ((return :: a -> IO a) &&& buildBarWindow ctx))-                 newConfs--          return (newWindowPairs ++ remainingWindows, map sel2 removedWindows)--  -- Destroy removed windows AFTER releasing the MVar to avoid deadlock-  -- with the onWidgetDestroy handler, which also modifies existingWindows.-  windowsToDestroy <- lift $ MV.modifyMVar windowsVar rebuildWindows-  lift $ do-    logIO DEBUG "Removing windows"-    mapM_ Gtk.widgetDestroy windowsToDestroy-  logC DEBUG "Finished refreshing windows"-  return ()---- | Unconditionally delete all existing Taffybar top-level windows.-removeTaffyWindows :: TaffyIO ()-removeTaffyWindows = asks existingWindows >>= liftIO . MV.readMVar >>= deleteWindows-  where-    deleteWindows = mapM_ (sequenceT . (msg *** del))--    msg :: BarConfig -> TaffyIO ()-    msg barConfig = logC INFO $-      printf "Destroying window for Taffybar(id=%s)" (showBarId barConfig)--    del :: Gtk.Window -> TaffyIO ()-    del = Gtk.widgetDestroy---- | Forcibly refresh taffybar windows, even if there are existing windows that--- correspond to the uniques in the bar configs yielded by 'barConfigGetter'.-forceRefreshTaffyWindows :: TaffyIO ()-forceRefreshTaffyWindows = removeTaffyWindows >> refreshTaffyWindows---- | Destroys all top-level windows belonging to Taffybar, then--- requests the GTK main loop to exit.------ This ensures that the windows disappear promptly. For GTK windows--- to be destroyed, the main loop still needs to be running.-exitTaffybar :: Context -> IO ()-exitTaffybar ctx = do-  postGUIASync $ runReaderT removeTaffyWindows ctx-  Gtk.mainQuit--asksContextVar :: (r -> MV.MVar b) -> ReaderT r IO b-asksContextVar getter = asks getter >>= lift . MV.readMVar---- | Run a function needing an X11 connection in 'TaffyIO'.-runX11 :: X11Property a -> TaffyIO a-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--- 'postX11RequestSyncProp'.-runX11Def :: a -> X11Property a -> TaffyIO a-runX11Def dflt prop = runX11 $ postX11RequestSyncProp prop dflt--runX11Context :: MonadIO m => Context -> a -> X11Property a -> m a-runX11Context context dflt prop =-  liftIO $ runReaderT (runX11Def dflt prop) context---- | Get a state value by type from the 'contextState' field of 'Context'.-getState :: forall t. Typeable t => Taffy IO (Maybe t)-getState = do-  stateMap <- asksContextVar contextState-  let maybeValue = M.lookup (typeRep (Proxy :: Proxy t)) stateMap-  return $ maybeValue >>= fromValue---- | Like "putState", but avoids aquiring a lock if the value is already in the--- map.-getStateDefault :: Typeable t => Taffy IO t -> Taffy IO t-getStateDefault defaultGetter =-  getState >>= maybe (putState defaultGetter) return---- | Get a value of the type returned by the provided action from the the--- current taffybar state, unless the state does not exist, in which case the--- action will be called to populate the state map.-putState :: forall t. Typeable t => Taffy IO t -> Taffy IO t-putState getValue = do-  contextVar <- asks contextState-  ctx <- ask-  lift $ MV.modifyMVar contextVar $ \contextStateMap ->-    let theType = typeRep (Proxy :: Proxy t)-        currentValue = M.lookup theType contextStateMap-        insertAndReturn value =-          (M.insert theType (Value value) contextStateMap, value)-    in flip runReaderT ctx $  maybe-         (insertAndReturn  <$> getValue)-         (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 = 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 ()-unsubscribe identifier = do-  listenersVar <- asks listeners-  lift $ MV.modifyMVar_ listenersVar $ return . filter ((== identifier) . fst)---- | Subscribe to all incoming events on the X11 event loop. The returned--- "Unique" value can be used to unregister the listener using "unsuscribe".-subscribeToAll :: Listener -> Taffy IO Unique-subscribeToAll listener = do-  identifier <- lift newUnique-  listenersVar <- asks listeners-  let-    -- XXX: This type annotation probably has something to do with the warnings-    -- that occur without MonoLocalBinds, but it still seems to be necessary-    addListener :: SubscriptionList -> SubscriptionList-    addListener = ((identifier, listener):)-  lift $ MV.modifyMVar_ listenersVar (return . addListener)-  return identifier---- | Subscribe to X11 "PropertyEvent"s where the property changed is in the--- provided list.-subscribeToPropertyEvents :: [String] -> Listener -> Taffy IO Unique-subscribeToPropertyEvents eventNames listener = do-  eventAtoms <- mapM (runX11 . getAtom) eventNames-  let filteredListener event@PropertyEvent { ev_atom = atom } =-        when (atom `elem` eventAtoms) $-             catchAny (listener event) (const $ return ())-      filteredListener _ = return ()-  subscribeToAll filteredListener--handleX11Event :: Event -> Taffy IO ()-handleX11Event event =-  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+{-# LANGUAGE ExistentialQuantification #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE ImpredicativeTypes #-}+{-# LANGUAGE MonoLocalBinds #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE ScopedTypeVariables #-}++-----------------------------------------------------------------------------++-----------------------------------------------------------------------------++-- |+-- Module      : System.Taffybar.Context+-- Copyright   : (c) Ivan A. Malison+-- License     : BSD3-style (see LICENSE)+--+-- Maintainer  : Ivan A. Malison+-- Stability   : unstable+-- Portability : unportable+--+-- The "System.Taffybar.Context" module provides the core functionality of the+-- taffybar library. It gets its name from the 'Context' record, which stores+-- runtime information and objects, which are used by many of the widgets that+-- taffybar provides. 'Context' is typically accessed through the 'Reader'+-- interface of 'TaffyIO'.+module System.Taffybar.Context+  ( -- * Configuration+    TaffybarConfig (..),+    defaultTaffybarConfig,+    appendHook,++    -- ** Bars+    BarLevelConfig (..),+    BarConfig (..),+    BarConfigGetter,+    showBarId,++    -- * Taffy monad+    Taffy,+    TaffyIO,++    -- ** Context+    Context (..),+    buildContext,+    buildContextWithBackend,+    buildEmptyContext,++    -- ** Context State+    getState,+    getStateDefault,+    putState,+    setState,++    -- * Control+    refreshTaffyWindows,+    exitTaffybar,++    -- * X11+    runX11,+    runX11Def,++    -- ** Event subscription+    subscribeToAll,+    subscribeToPropertyEvents,+    unsubscribe,++    -- * Threading+    taffyFork,++    -- * Backend (re-exported from "System.Taffybar.Context.Backend")+    Backend (..),+    detectBackend,+  )+where++import Control.Arrow ((&&&), (***))+import Control.Concurrent (forkIO, threadDelay)+import qualified Control.Concurrent.MVar as MV+import Control.Concurrent.STM.TChan (TChan)+import Control.Exception (SomeException, try)+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 qualified DBus as D+import qualified DBus.Client as DBus+import Data.Data+import Data.Default (Default (..))+import Data.GI.Base.ManagedPtr (unsafeCastTo)+import Data.IORef+import Data.Int+import Data.List+import qualified Data.Map as M+import qualified Data.Text as T+import Data.Tuple.Select+import Data.Tuple.Sequence+import Data.Unique+import qualified GI.Gdk+import qualified GI.GdkX11 as GdkX11+import GI.GdkX11.Objects.X11Window+import qualified GI.Gtk as Gtk+import qualified GI.GtkLayerShell as GtkLayerShell+import Graphics.UI.GIGtkStrut+import StatusNotifier.TransparentWindow+import System.Log.Logger (Priority (..), logM)+import System.Taffybar.Context.Backend (Backend (..), detectBackend)+import qualified System.Taffybar.DBus.Client.Params as DBusParams+import System.Taffybar.Information.EWMHDesktopInfo+  ( ewmhActiveWindow,+    ewmhCurrentDesktop,+    getActiveWindow,+    getWindows,+  )+import System.Taffybar.Information.Hyprland+  ( HyprlandClient,+    HyprlandEventChan,+    buildHyprlandEventChan,+    defaultHyprlandClientConfig,+    getFocusedMonitorPosition,+    newHyprlandClient,+    subscribeHyprlandEvents,+  )+import System.Taffybar.Information.SafeX11 hiding (setState)+import System.Taffybar.Information.Wakeup.Manager+  ( WakeupManager,+    newWakeupManager,+  )+import System.Taffybar.Information.X11DesktopInfo+import System.Taffybar.Util+import System.Taffybar.Widget.Util+import System.Taffybar.Window.FocusedMonitor+  ( FocusedMonitorHooks (..),+    setupFocusedMonitorClassUpdates,+  )+import Text.Printf+import Unsafe.Coerce++logIO :: Priority -> String -> IO ()+logIO = logM "System.Taffybar.Context"++logC :: (MonadIO m) => Priority -> String -> m ()+logC p = liftIO . logIO p++-- | 'Taffy' is a monad transformer that provides 'ReaderT' for 'Context'.+type Taffy m v = ReaderT Context m v++-- | 'TaffyIO' is 'IO' wrapped with a 'ReaderT' providing 'Context'. This is the+-- type of most widgets and callback in Taffybar.+type TaffyIO v = ReaderT Context IO v++type Listener = Event -> Taffy IO ()++type SubscriptionList = [(Unique, Listener)]++data Value = forall t. (Typeable t) => Value t++fromValue :: forall t. (Typeable t) => Value -> Maybe t+fromValue (Value v) =+  if typeOf v == typeRep (Proxy :: Proxy t)+    then+      Just $ unsafeCoerce v+    else+      Nothing++-- | 'BarConfig' specifies the configuration for a single taffybar window.+data BarLevelConfig = BarLevelConfig+  { -- | Constructors for widgets that should be placed at the beginning of the level.+    levelStartWidgets :: [TaffyIO Gtk.Widget],+    -- | Constructors for widgets that should be placed in the center of the level.+    levelCenterWidgets :: [TaffyIO Gtk.Widget],+    -- | Constructors for widgets that should be placed at the end of the level.+    levelEndWidgets :: [TaffyIO Gtk.Widget]+  }++-- | 'BarConfig' specifies the configuration for a single taffybar window.+data BarConfig = BarConfig+  { -- | The strut configuration to use for the bar+    strutConfig :: StrutConfig,+    -- | The amount of spacing in pixels between bar widgets+    widgetSpacing :: Int32,+    -- | Constructors for widgets that should be placed at the beginning of the bar.+    startWidgets :: [TaffyIO Gtk.Widget],+    -- | Constructors for widgets that should be placed in the center of the bar.+    centerWidgets :: [TaffyIO Gtk.Widget],+    -- | Constructors for widgets that should be placed at the end of the bar.+    endWidgets :: [TaffyIO Gtk.Widget],+    -- | Optional level-based widget configuration. If this field is set,+    -- 'startWidgets', 'centerWidgets' and 'endWidgets' are ignored.+    barLevels :: Maybe [BarLevelConfig],+    -- | A unique identifier for the bar, that can be used e.g. when toggling.+    barId :: Unique+  }++instance Eq BarConfig where+  a == b = barId a == barId b++-- | Action that returns the list of bar configurations to realize.+type BarConfigGetter = TaffyIO [BarConfig]++-- | 'TaffybarConfig' provides an advanced interface for configuring taffybar.+-- Through the 'getBarConfigsParam', it is possible to specify different+-- taffybar configurations depending on the number of monitors present, and even+-- to specify different taffybar configurations for each monitor.+data TaffybarConfig = TaffybarConfig+  { -- | An optional dbus client to use.+    dbusClientParam :: Maybe DBus.Client,+    -- | Hooks that should be executed at taffybar startup.+    startupHook :: TaffyIO (),+    -- | A 'TaffyIO' action that returns a list of 'BarConfig' where each element+    -- describes a taffybar window that should be spawned.+    getBarConfigsParam :: BarConfigGetter,+    -- | A list of 'FilePath' each of which should be loaded as css files at+    -- startup.+    cssPaths :: [FilePath],+    -- | A field used (only) by dyre to provide an error message.+    errorMsg :: Maybe String+  }++-- | Append the provided 'TaffyIO' hook to the 'startupHook' of the given+-- 'TaffybarConfig'.+appendHook :: TaffyIO () -> TaffybarConfig -> TaffybarConfig+appendHook hook config =+  config+    { startupHook = startupHook config >> hook+    }++-- | Default values for a 'TaffybarConfig'. Not usuable without at least+-- properly setting 'getBarConfigsParam'.+defaultTaffybarConfig :: TaffybarConfig+defaultTaffybarConfig =+  TaffybarConfig+    { dbusClientParam = Nothing,+      startupHook = return (),+      getBarConfigsParam = return [],+      cssPaths = [],+      errorMsg = Nothing+    }++instance Default TaffybarConfig where+  def = defaultTaffybarConfig++-- | A "Context" value holds all of the state associated with a single running+-- instance of taffybar. It is typically accessed from a widget constructor+-- through the "TaffyIO" monad transformer stack.+data Context = Context+  { -- | The X11Context that will be used to service X11Property requests.+    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+    -- types. Most new pieces of state should go here, rather than in a new field+    -- in 'Context'. State stored here is typically accessed through+    -- 'getStateDefault'.+    contextState :: MV.MVar (M.Map TypeRep Value),+    -- | Used to track the windows that taffybar is currently controlling, and+    -- which 'BarConfig' objects they are associated with.+    existingWindows :: MV.MVar [(BarConfig, Gtk.Window)],+    -- | The shared user session 'DBus.Client'.+    sessionDBusClient :: DBus.Client,+    -- | The shared system session 'DBus.Client'.+    systemDBusClient :: DBus.Client,+    -- | 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),+    -- | Shared wakeup manager for coordinated polling intervals.+    --+    -- Stored outside 'contextState' so wakeup registration cannot deadlock when+    -- called from state initializers that already hold the context-state lock.+    wakeupManager :: WakeupManager,+    -- | 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+    -- different for widgets belonging to bar windows on different monitors.+    contextBarConfig :: Maybe BarConfig+  }++-- | Build the "Context" for a taffybar process.+buildContext :: TaffybarConfig -> IO Context+buildContext cfg = do+  backendType <- detectBackend+  buildContextWithBackend backendType cfg++-- | Build the "Context" for a taffybar process using a pre-detected backend.+--+-- This avoids duplicated backend detection and ensures backend-related+-- environment fixups happen before any downstream initialization that depends+-- on them (e.g. GTK/GDK backend selection).+buildContextWithBackend :: Backend -> TaffybarConfig -> IO Context+buildContextWithBackend+  backendType+  TaffybarConfig+    { dbusClientParam = maybeDBus,+      getBarConfigsParam = barConfigGetter,+      startupHook = startup+    } = do+    logIO DEBUG "Building context"+    dbusC <- maybe DBus.connectSession return maybeDBus+    sDBusC <- DBus.connectSystem+    _ <-+      DBus.requestName+        dbusC+        "org.taffybar.Bar"+        [DBus.nameAllowReplacement, DBus.nameReplaceExisting]+    listenersVar <- MV.newMVar []+    state <- MV.newMVar M.empty+    wakeupMgr <- newWakeupManager+    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,+              listeners = listenersVar,+              contextState = state,+              sessionDBusClient = dbusC,+              systemDBusClient = sDBusC,+              getBarConfigs = barConfigGetter,+              hyprlandClient = hyprClient,+              hyprlandEventChanVar = hyprEventChanVar,+              wakeupManager = wakeupMgr,+              existingWindows = windowsVar,+              backend = backendType,+              contextBarConfig = Nothing+            }+    _ <-+      runMaybeT $+        MaybeT GI.Gdk.displayGetDefault+          >>= (lift . GI.Gdk.displayGetDefaultScreen)+          >>= ( lift+                  . flip+                    GI.Gdk.afterScreenMonitorsChanged+                    -- XXX: We have to do a force refresh here because there is no+                    -- way to reliably move windows, since the window manager can do+                    -- whatever it pleases.+                    (runReaderT forceRefreshTaffyWindows context)+              )++    -- Some compositors/backends will keep the reserved space for a layer-shell+    -- surface/strut window after suspend, but fail to properly re-display the+    -- window. Listen for systemd-logind resume and force a refresh.+    registerResumeRefresh context++    flip runReaderT context $ do+      logC DEBUG "Starting X11 Handler"+      startX11EventHandler+      logC DEBUG "Running startup hook"+      startup+      logC DEBUG "Queing build windows command"+      refreshTaffyWindows+    logIO DEBUG "Context build finished"+    return context++-- | Register a logind sleep/resume listener that forces a window refresh after+-- resume. This is a pragmatic workaround for cases where the bar stays "reserved"+-- (exclusive zone/strut) but stops being visible after resume.+registerResumeRefresh :: Context -> IO ()+registerResumeRefresh ctx = do+  let client = systemDBusClient ctx+      rule =+        DBus.matchAny+          { DBus.matchInterface = Just DBusParams.login1ManagerInterfaceName,+            DBus.matchMember = Just "PrepareForSleep",+            DBus.matchPath = Just DBusParams.login1ObjectPath+          }++  -- Debounce: on some systems we can see multiple resume-related events close+  -- together. Avoid spamming refreshes.+  pendingVar <- MV.newMVar False++  let scheduleRefresh :: IO ()+      scheduleRefresh = do+        wasPending <- MV.swapMVar pendingVar True+        unless wasPending $ void $ forkIO $ do+          -- Give the compositor a moment to re-establish outputs/surfaces.+          threadDelay 1_000_000+          _ <- MV.swapMVar pendingVar False+          logIO NOTICE "Resumed from sleep - forcing taffybar window refresh"+          postGUIASync $ runReaderT forceRefreshTaffyWindows ctx++      callback :: D.Signal -> IO ()+      callback sig =+        case D.signalBody sig of+          [v] ->+            case D.fromVariant v :: Maybe Bool of+              Just True -> logIO DEBUG "PrepareForSleep(True) received"+              Just False -> scheduleRefresh+              Nothing -> logIO WARNING "PrepareForSleep signal had unexpected body type"+          _ -> logIO WARNING "PrepareForSleep signal had unexpected body arity"++  result <- try (DBus.addMatch client rule callback) :: IO (Either SomeException DBus.SignalHandler)+  case result of+    Left e ->+      logIO WARNING $+        "Failed to register logind PrepareForSleep handler (resume refresh disabled): "+          ++ show e+    Right _ -> pure ()++-- | Build an empty taffybar context. This function is mostly useful for+-- invoking functions that yield 'TaffyIO' values in a testing setting (e.g. in+-- a repl).+buildEmptyContext :: IO Context+buildEmptyContext = buildContext def++-- | Format the 'barId' as a numeric string.+showBarId :: BarConfig -> String+showBarId = show . hashUnique . barId++getActiveWindowCenterPoint :: TaffyIO (Maybe (Int, Int))+getActiveWindowCenterPoint = runX11 $ do+  maybeActiveWindow <- getActiveWindow+  allWindows <- getWindows+  case maybeActiveWindow >>= \activeWindow -> activeWindow `guardElem` allWindows of+    Nothing -> return Nothing+    Just activeWindow -> do+      display <- getDisplay+      (_, x, y, width, height, _, _) <- lift $ safeGetGeometry display activeWindow+      let centerX = fromIntegral x + fromIntegral width `div` 2+          centerY = fromIntegral y + fromIntegral height `div` 2+      return $ Just (centerX, centerY)+  where+    guardElem value values =+      if value `elem` values+        then Just value+        else Nothing++getPointerMonitor :: GI.Gdk.Display -> IO (Maybe GI.Gdk.Monitor)+getPointerMonitor display = runMaybeT $ do+  seat <- lift $ GI.Gdk.displayGetDefaultSeat display+  pointer <- MaybeT $ GI.Gdk.seatGetPointer seat+  (_, x, y) <- lift $ GI.Gdk.deviceGetPosition pointer+  MaybeT $ Just <$> GI.Gdk.displayGetMonitorAtPoint display x y++getFocusedMonitorX11 :: Context -> IO (Maybe GI.Gdk.Monitor)+getFocusedMonitorX11 context = runMaybeT $ do+  display <- MaybeT GI.Gdk.displayGetDefault+  maybeCenterPoint <- lift $ runReaderT getActiveWindowCenterPoint context+  case maybeCenterPoint of+    Just (x, y) ->+      MaybeT $+        Just+          <$> GI.Gdk.displayGetMonitorAtPoint+            display+            (fromIntegral x)+            (fromIntegral y)+    Nothing -> MaybeT $ getPointerMonitor display++getFocusedMonitorWayland :: Context -> IO (Maybe GI.Gdk.Monitor)+getFocusedMonitorWayland context = runMaybeT $ do+  display <- MaybeT GI.Gdk.displayGetDefault+  maybeFocusedMonitorPosition <- lift $ getFocusedMonitorPosition (hyprlandClient context)+  case maybeFocusedMonitorPosition of+    Just (x, y) ->+      MaybeT $+        Just+          <$> GI.Gdk.displayGetMonitorAtPoint+            display+            (fromIntegral x)+            (fromIntegral y)+    Nothing -> MaybeT $ getPointerMonitor display++withHyprlandEventChan :: Context -> IO HyprlandEventChan+withHyprlandEventChan context =+  MV.modifyMVar (hyprlandEventChanVar context) $ \existing ->+    case existing of+      Just eventChan -> return (existing, eventChan)+      Nothing -> do+        eventChan <- buildHyprlandEventChan (hyprlandClient context)+        return (Just eventChan, eventChan)++getHyprlandFocusedMonitorEvents :: Context -> IO (TChan T.Text)+getHyprlandFocusedMonitorEvents context = do+  eventChan <- withHyprlandEventChan context+  subscribeHyprlandEvents eventChan++buildBarWindow :: Context -> BarConfig -> IO Gtk.Window+buildBarWindow context barConfig = do+  let thisContext = context {contextBarConfig = Just barConfig}+  logC INFO $+    printf+      "Building window for Taffybar(id=%s) with %s"+      (showBarId barConfig)+      (show $ strutConfig barConfig)++  window <- Gtk.windowNew Gtk.WindowTypeToplevel++  void $ Gtk.onWidgetDestroy window $ do+    let bId = showBarId barConfig+    logC INFO $ printf "Window for Taffybar(id=%s) destroyed" bId+    MV.modifyMVar_ (existingWindows context) (pure . filter ((/=) window . sel2))+    logC DEBUG $ printf "Window for Taffybar(id=%s) unregistered" bId++  setupBarWindow context (strutConfig barConfig) window++  let focusedMonitorHooks =+        case backend thisContext of+          BackendX11 ->+            FocusedMonitorHooksX11+              { resolveFocusedMonitorX11 = getFocusedMonitorX11 thisContext,+                subscribeToFocusedMonitorX11Events =+                  flip runReaderT thisContext+                    . subscribeToPropertyEvents [ewmhActiveWindow, ewmhCurrentDesktop]+                    . const+                    . lift,+                unsubscribeFromFocusedMonitorX11Events =+                  flip runReaderT thisContext . unsubscribe+              }+          BackendWayland ->+            FocusedMonitorHooksWayland+              { resolveFocusedMonitorWayland = getFocusedMonitorWayland thisContext,+                getFocusedMonitorHyprlandEvents = getHyprlandFocusedMonitorEvents thisContext+              }++  _ <- widgetSetClassGI window "taffy-window"+  setupFocusedMonitorClassUpdates+    focusedMonitorHooks+    window+    (strutMonitor (strutConfig barConfig))++  let addWidgetWith widgetAdd (count, buildWidget) =+        runReaderT buildWidget thisContext >>= widgetAdd count++  shownBoxes <-+    case barLevels barConfig of+      Nothing -> do+        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++        _ <- widgetSetClassGI centerBox "center-box"+        Gtk.widgetSetVexpand centerBox True+        Gtk.setWidgetValign centerBox Gtk.AlignFill+        Gtk.setWidgetHalign centerBox Gtk.AlignCenter+        Gtk.boxSetCenterWidget box (Just centerBox)++        Gtk.containerAdd window box++        let addToStart count widget = do+              _ <- widgetSetClassGI widget $ T.pack $ printf "left-%d" (count :: Int)+              Gtk.boxPackStart box widget False False 0+            addToEnd count widget = do+              _ <- widgetSetClassGI widget $ T.pack $ printf "right-%d" (count :: Int)+              Gtk.boxPackEnd box widget False False 0+            addToCenter count widget = do+              _ <- widgetSetClassGI widget $ T.pack $ printf "center-%d" (count :: Int)+              Gtk.boxPackStart centerBox widget False False 0++        logIO DEBUG "Building start widgets"+        mapM_ (addWidgetWith addToStart) $ zip [1 ..] (startWidgets barConfig)+        logIO DEBUG "Building center widgets"+        mapM_ (addWidgetWith addToCenter) $ zip [1 ..] (centerWidgets barConfig)+        logIO DEBUG "Building end widgets"+        mapM_ (addWidgetWith addToEnd) $ zip [1 ..] (endWidgets barConfig)++        return [box, centerBox]+      Just levels -> do+        levelsBox <- Gtk.boxNew Gtk.OrientationVertical 0+        _ <- widgetSetClassGI levelsBox "taffy-levels"+        Gtk.widgetSetVexpand levelsBox False+        Gtk.setWidgetValign levelsBox Gtk.AlignFill+        Gtk.containerAdd window levelsBox++        let flattenRows = concatMap (\(box, centerBox) -> [box, centerBox])+            buildLevel (levelCount, BarLevelConfig {levelStartWidgets = starts, levelCenterWidgets = centers, levelEndWidgets = ends}) = do+              box <-+                Gtk.boxNew Gtk.OrientationHorizontal $+                  fromIntegral $+                    widgetSpacing barConfig+              _ <- widgetSetClassGI box "taffy-box"+              _ <- widgetSetClassGI box $ T.pack $ printf "level-%d" (levelCount :: Int)+              Gtk.widgetSetVexpand box False+              Gtk.setWidgetValign box Gtk.AlignFill++              centerBox <-+                Gtk.boxNew Gtk.OrientationHorizontal $+                  fromIntegral $+                    widgetSpacing barConfig+              _ <- widgetSetClassGI centerBox "center-box"+              _ <- widgetSetClassGI centerBox $ T.pack $ printf "level-%d-center" (levelCount :: Int)+              Gtk.widgetSetVexpand centerBox True+              Gtk.setWidgetValign centerBox Gtk.AlignFill+              Gtk.setWidgetHalign centerBox Gtk.AlignCenter+              Gtk.boxSetCenterWidget box (Just centerBox)++              Gtk.boxPackStart levelsBox box False True 0++              let addToStart count widget = do+                    _ <- widgetSetClassGI widget $ T.pack $ printf "left-%d" (count :: Int)+                    Gtk.boxPackStart box widget False False 0+                  addToEnd count widget = do+                    _ <- widgetSetClassGI widget $ T.pack $ printf "right-%d" (count :: Int)+                    Gtk.boxPackEnd box widget False False 0+                  addToCenter count widget = do+                    _ <- widgetSetClassGI widget $ T.pack $ printf "center-%d" (count :: Int)+                    Gtk.boxPackStart centerBox widget False False 0++              logIO DEBUG $ printf "Building level %d start widgets" (levelCount :: Int)+              mapM_ (addWidgetWith addToStart) $ zip [1 ..] starts+              logIO DEBUG $ printf "Building level %d center widgets" (levelCount :: Int)+              mapM_ (addWidgetWith addToCenter) $ zip [1 ..] centers+              logIO DEBUG $ printf "Building level %d end widgets" (levelCount :: Int)+              mapM_ (addWidgetWith addToEnd) $ zip [1 ..] ends++              return (box, centerBox)++        levelRows <- mapM buildLevel $ zip [1 ..] levels+        return $ levelsBox : flattenRows levelRows++  makeWindowTransparent window++  logIO DEBUG "Showing window"+  Gtk.widgetShow window+  mapM_ Gtk.widgetShow shownBoxes++  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++-- | Use the "barConfigGetter" field of "Context" to get the set of taffybar+-- windows that should active. Will avoid recreating windows if there is already+-- a window with the appropriate geometry and "BarConfig".+refreshTaffyWindows :: TaffyIO ()+refreshTaffyWindows = mapReaderT postGUIASync $ do+  logC DEBUG "Refreshing windows"+  ctx <- ask+  windowsVar <- asks existingWindows++  let rebuildWindows currentWindows = flip runReaderT ctx $+        do+          barConfigs <- join $ asks getBarConfigs++          let currentConfigs = map sel1 currentWindows+              newConfs = filter (`notElem` currentConfigs) barConfigs+              (remainingWindows, removedWindows) =+                partition ((`elem` barConfigs) . sel1) currentWindows+              setPropertiesFromPair (barConf, window) =+                setupBarWindow ctx (strutConfig barConf) window++          newWindowPairs <- lift $ do+            logIO DEBUG $+              printf "removedWindows: %s" $+                show $+                  map (strutConfig . sel1) removedWindows+            logIO DEBUG $+              printf "remainingWindows: %s" $+                show $+                  map (strutConfig . sel1) remainingWindows+            logIO DEBUG $+              printf "newWindows: %s" $+                show $+                  map strutConfig newConfs+            logIO DEBUG $+              printf "barConfigs: %s" $+                show $+                  map strutConfig barConfigs++            -- TODO: This should actually use the config that is provided from+            -- getBarConfigs so that the strut properties of the window can be+            -- altered.+            logIO DEBUG "Updating strut properties for existing windows"+            mapM_ setPropertiesFromPair remainingWindows++            logIO DEBUG "Constructing new windows"+            mapM+              (sequenceT . ((return :: a -> IO a) &&& buildBarWindow ctx))+              newConfs++          return (newWindowPairs ++ remainingWindows, map sel2 removedWindows)++  -- Destroy removed windows AFTER releasing the MVar to avoid deadlock+  -- with the onWidgetDestroy handler, which also modifies existingWindows.+  windowsToDestroy <- lift $ MV.modifyMVar windowsVar rebuildWindows+  lift $ do+    logIO DEBUG "Removing windows"+    mapM_ Gtk.widgetDestroy windowsToDestroy+  logC DEBUG "Finished refreshing windows"+  return ()++-- | Unconditionally delete all existing Taffybar top-level windows.+removeTaffyWindows :: TaffyIO ()+removeTaffyWindows = asks existingWindows >>= liftIO . MV.readMVar >>= deleteWindows+  where+    deleteWindows = mapM_ (sequenceT . (msg *** del))++    msg :: BarConfig -> TaffyIO ()+    msg barConfig =+      logC INFO $+        printf "Destroying window for Taffybar(id=%s)" (showBarId barConfig)++    del :: Gtk.Window -> TaffyIO ()+    del = Gtk.widgetDestroy++-- | Forcibly refresh taffybar windows, even if there are existing windows that+-- correspond to the uniques in the bar configs yielded by 'barConfigGetter'.+forceRefreshTaffyWindows :: TaffyIO ()+forceRefreshTaffyWindows = removeTaffyWindows >> refreshTaffyWindows++-- | Destroys all top-level windows belonging to Taffybar, then+-- requests the GTK main loop to exit.+--+-- This ensures that the windows disappear promptly. For GTK windows+-- to be destroyed, the main loop still needs to be running.+exitTaffybar :: Context -> IO ()+exitTaffybar ctx = do+  postGUIASync $ runReaderT removeTaffyWindows ctx+  Gtk.mainQuit++asksContextVar :: (r -> MV.MVar b) -> ReaderT r IO b+asksContextVar getter = asks getter >>= lift . MV.readMVar++-- | Run a function needing an X11 connection in 'TaffyIO'.+runX11 :: X11Property a -> TaffyIO a+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+-- 'postX11RequestSyncProp'.+runX11Def :: a -> X11Property a -> TaffyIO a+runX11Def dflt prop = runX11 $ postX11RequestSyncProp prop dflt++runX11Context :: (MonadIO m) => Context -> a -> X11Property a -> m a+runX11Context context dflt prop =+  liftIO $ runReaderT (runX11Def dflt prop) context++-- | Get a state value by type from the 'contextState' field of 'Context'.+getState :: forall t. (Typeable t) => Taffy IO (Maybe t)+getState = do+  stateMap <- asksContextVar contextState+  let maybeValue = M.lookup (typeRep (Proxy :: Proxy t)) stateMap+  return $ maybeValue >>= fromValue++-- | Like "putState", but avoids aquiring a lock if the value is already in the+-- map.+getStateDefault :: (Typeable t) => Taffy IO t -> Taffy IO t+getStateDefault defaultGetter =+  getState >>= maybe (putState defaultGetter) return++-- | Get a value of the type returned by the provided action from the the+-- current taffybar state, unless the state does not exist, in which case the+-- action will be called to populate the state map.+putState :: forall t. (Typeable t) => Taffy IO t -> Taffy IO t+putState getValue = do+  contextVar <- asks contextState+  ctx <- ask+  lift $ MV.modifyMVar contextVar $ \contextStateMap ->+    let theType = typeRep (Proxy :: Proxy t)+        currentValue = M.lookup theType contextStateMap+        insertAndReturn value =+          (M.insert theType (Value value) contextStateMap, value)+     in flip runReaderT ctx $+          maybe+            (insertAndReturn <$> getValue)+            (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 = 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 -> do+      setupStrutWindow config window+      setX11WindowSizeFromStrut config window+    BackendWayland -> setupLayerShellWindow config window++-- | Remove the listener associated with the provided "Unique" from the+-- collection of listeners.+unsubscribe :: Unique -> Taffy IO ()+unsubscribe identifier = do+  listenersVar <- asks listeners+  lift $ MV.modifyMVar_ listenersVar $ return . filter ((== identifier) . fst)++-- | Subscribe to all incoming events on the X11 event loop. The returned+-- "Unique" value can be used to unregister the listener using "unsuscribe".+subscribeToAll :: Listener -> Taffy IO Unique+subscribeToAll listener = do+  identifier <- lift newUnique+  listenersVar <- asks listeners+  let -- XXX: This type annotation probably has something to do with the warnings+      -- that occur without MonoLocalBinds, but it still seems to be necessary+      addListener :: SubscriptionList -> SubscriptionList+      addListener = ((identifier, listener) :)+  lift $ MV.modifyMVar_ listenersVar (return . addListener)+  return identifier++-- | Subscribe to X11 "PropertyEvent"s where the property changed is in the+-- provided list.+subscribeToPropertyEvents :: [String] -> Listener -> Taffy IO Unique+subscribeToPropertyEvents eventNames listener = do+  eventAtoms <- mapM (runX11 . getAtom) eventNames+  let filteredListener event@PropertyEvent {ev_atom = atom} =+        when (atom `elem` eventAtoms) $+          catchAny (listener event) (const $ return ())+      filteredListener _ = return ()+  subscribeToAll filteredListener++handleX11Event :: Event -> Taffy IO ()+handleX11Event event =+  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++setX11WindowSizeFromStrut :: StrutConfig -> Gtk.Window -> IO ()+setX11WindowSizeFromStrut+  StrutConfig+    { strutWidth = widthSize,+      strutHeight = heightSize,+      strutXPadding = xpadding,+      strutYPadding = ypadding,+      strutMonitor = monitorNumber,+      strutPosition = position,+      strutDisplayName = maybeDisplayName+    }+  window = do+    maybeDisplay <- maybe GI.Gdk.displayGetDefault GI.Gdk.displayOpen maybeDisplayName+    case maybeDisplay of+      Nothing -> pure ()+      Just display -> do+        maybeMonitor <-+          maybe+            (GI.Gdk.displayGetPrimaryMonitor display)+            (GI.Gdk.displayGetMonitor display)+            monitorNumber+        case maybeMonitor of+          Nothing -> pure ()+          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))+                (reqWidth, reqHeight) =+                  case position of+                    TopPos -> (-1, height)+                    BottomPos -> (-1, height)+                    LeftPos -> (width, -1)+                    RightPos -> (width, -1)+            Gtk.windowSetDefaultSize window (fromIntegral width) (fromIntegral height)+            Gtk.widgetSetSizeRequest+              window+              (fromIntegral reqWidth)+              (fromIntegral reqHeight)
src/System/Taffybar/Context/Backend.hs view
@@ -1,4 +1,7 @@ -----------------------------------------------------------------------------++-----------------------------------------------------------------------------+ -- | -- Module      : System.Taffybar.Context.Backend -- Copyright   : (c) Ivan A. Malison@@ -14,31 +17,34 @@ -- 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+  ( Backend (..),+    detectBackend, -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)+    -- * 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" +-- | Backend selected for the current taffybar process. data Backend-  = BackendX11-  | BackendWayland+  = -- | Use the X11 backend.+    BackendX11+  | -- | Use the Wayland backend.+    BackendWayland   deriving (Eq, Show)  -- | Try to find a @wayland-*@ socket in the given runtime directory.@@ -50,17 +56,19 @@ discoverWaylandSocket runtime = do   entries <- listDirectory runtime   let candidates =-        [ e | e <- entries-        , "wayland-" `isPrefixOf` e-        , not (".lock" `isSuffixOf` e)+        [ 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)+    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/@.@@ -78,7 +86,7 @@       go hyprDir entries   where     go _ [] = pure Nothing-    go hyprDir (e:es) = do+    go hyprDir (e : es) = do       isSig <- doesPathExist (hyprDir </> e </> "hyprland.lock")       if isSig then pure (Just e) else go hyprDir es
src/System/Taffybar/DBus.hs view
@@ -1,10 +1,12 @@+-- | Convenience combinators for enabling taffybar DBus services. module System.Taffybar.DBus-  ( module System.Taffybar.DBus.Toggle-  , appendHook-  , startTaffyLogServer-  , withLogServer-  , withToggleServer-  ) where+  ( module System.Taffybar.DBus.Toggle,+    appendHook,+    startTaffyLogServer,+    withLogServer,+    withToggleServer,+  )+where  import Control.Monad.Trans.Class import Control.Monad.Trans.Reader@@ -12,12 +14,15 @@ import System.Taffybar.Context import System.Taffybar.DBus.Toggle +-- | Start the DBus-backed log sink using the shared session client. startTaffyLogServer :: TaffyIO () startTaffyLogServer =   asks sessionDBusClient >>= lift . startLogServer +-- | Extend a config to start the DBus log server during startup. withLogServer :: TaffybarConfig -> TaffybarConfig withLogServer = appendHook startTaffyLogServer +-- | Extend a config with the DBus toggle service. withToggleServer :: TaffybarConfig -> TaffybarConfig withToggleServer = handleDBusToggles
+ src/System/Taffybar/DBus/Client/Login1Manager.hs view
@@ -0,0 +1,21 @@+{-# LANGUAGE TemplateHaskell #-}++module System.Taffybar.DBus.Client.Login1Manager where++import DBus.Generation+import System.FilePath+import System.Taffybar.DBus.Client.Params+import System.Taffybar.DBus.Client.Util++-- NOTE: The corresponding introspection XML is intentionally minimal (signal-only).+-- The full logind Manager interface contains method/arg names that collide with+-- Haskell reserved words and with generated property setters, which causes TH+-- generation to fail.+generateClientFromFile+  defaultRecordGenerationParams+    { recordName = Just "Login1ManagerInfo",+      recordPrefix = "login1"+    }+  login1GenerationParams {genObjectPath = Just login1ObjectPath}+  False+  $ "dbus-xml" </> "org.freedesktop.login1.Manager.xml"
src/System/Taffybar/DBus/Client/MPRIS2.hs view
@@ -1,12 +1,13 @@ {-# LANGUAGE TemplateHaskell #-}+ module System.Taffybar.DBus.Client.MPRIS2 where -import System.Taffybar.DBus.Client.Util import System.FilePath import System.Taffybar.DBus.Client.Params+import System.Taffybar.DBus.Client.Util  generateClientFromFile defaultRecordGenerationParams playerGenerationParams False $-                       "dbus-xml" </> "org.mpris.MediaPlayer2.xml"+  "dbus-xml" </> "org.mpris.MediaPlayer2.xml"  generateClientFromFile defaultRecordGenerationParams playerGenerationParams False $-                       "dbus-xml" </> "org.mpris.MediaPlayer2.Player.xml"+  "dbus-xml" </> "org.mpris.MediaPlayer2.Player.xml"
src/System/Taffybar/DBus/Client/NetworkManager.hs view
@@ -1,4 +1,5 @@ {-# LANGUAGE TemplateHaskell #-}+ module System.Taffybar.DBus.Client.NetworkManager where  import DBus.Generation@@ -8,9 +9,9 @@  generateClientFromFile   defaultRecordGenerationParams-  { recordName = Just "NetworkManagerInfo"-  , recordPrefix = "nm"-  }-  nmGenerationParams { genObjectPath = Just nmObjectPath }-  False $-  "dbus-xml" </> "org.freedesktop.NetworkManager.xml"+    { recordName = Just "NetworkManagerInfo",+      recordPrefix = "nm"+    }+  nmGenerationParams {genObjectPath = Just nmObjectPath}+  False+  $ "dbus-xml" </> "org.freedesktop.NetworkManager.xml"
src/System/Taffybar/DBus/Client/NetworkManagerAccessPoint.hs view
@@ -1,4 +1,5 @@ {-# LANGUAGE TemplateHaskell #-}+ module System.Taffybar.DBus.Client.NetworkManagerAccessPoint where  import System.FilePath@@ -7,9 +8,9 @@  generateClientFromFile   defaultRecordGenerationParams-  { recordName = Just "AccessPointInfo"-  , recordPrefix = "nmap"-  }+    { recordName = Just "AccessPointInfo",+      recordPrefix = "nmap"+    }   nmGenerationParams-  False $-  "dbus-xml" </> "org.freedesktop.NetworkManager.AccessPoint.xml"+  False+  $ "dbus-xml" </> "org.freedesktop.NetworkManager.AccessPoint.xml"
src/System/Taffybar/DBus/Client/NetworkManagerActiveConnection.hs view
@@ -1,4 +1,5 @@ {-# LANGUAGE TemplateHaskell #-}+ module System.Taffybar.DBus.Client.NetworkManagerActiveConnection where  import System.FilePath@@ -7,9 +8,9 @@  generateClientFromFile   defaultRecordGenerationParams-  { recordName = Just "ActiveConnectionInfo"-  , recordPrefix = "nmac"-  }+    { recordName = Just "ActiveConnectionInfo",+      recordPrefix = "nmac"+    }   nmGenerationParams-  False $-  "dbus-xml" </> "org.freedesktop.NetworkManager.Connection.Active.xml"+  False+  $ "dbus-xml" </> "org.freedesktop.NetworkManager.Connection.Active.xml"
src/System/Taffybar/DBus/Client/Params.hs view
@@ -1,5 +1,6 @@-{-# LANGUAGE TemplateHaskellQuotes #-} {-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TemplateHaskellQuotes #-}+ module System.Taffybar.DBus.Client.Params where  import DBus@@ -8,10 +9,11 @@ import System.Taffybar.DBus.Client.Util  playerGenerationParams :: GenerationParams-playerGenerationParams = defaultGenerationParams-  { genTakeSignalErrorHandler = True-  , genObjectPath = Just "/org/mpris/MediaPlayer2"-  }+playerGenerationParams =+  defaultGenerationParams+    { genTakeSignalErrorHandler = True,+      genObjectPath = Just "/org/mpris/MediaPlayer2"+    }  -- | The bus name for NetworkManager. nmBusName :: BusName@@ -41,11 +43,11 @@   "/org/freedesktop/NetworkManager/AccessPoint"  nmGenerationParams :: GenerationParams-nmGenerationParams = defaultGenerationParams-  { genTakeSignalErrorHandler = True-  , genBusName = Just nmBusName-  }-+nmGenerationParams =+  defaultGenerationParams+    { genTakeSignalErrorHandler = True,+      genBusName = Just nmBusName+    }  -- | The base object path for the UPower interface uPowerBaseObjectPath :: ObjectPath@@ -59,11 +61,31 @@ uPowerDeviceInterfaceName = "org.freedesktop.UPower.Device"  uPowerGenerationParams :: GenerationParams-uPowerGenerationParams = defaultGenerationParams-  { genTakeSignalErrorHandler = True-  , genBusName = Just uPowerBusName-  }+uPowerGenerationParams =+  defaultGenerationParams+    { genTakeSignalErrorHandler = True,+      genBusName = Just uPowerBusName+    } +-- | The bus name for systemd-logind.+login1BusName :: BusName+login1BusName = "org.freedesktop.login1"++-- | The object path for the systemd-logind manager.+login1ObjectPath :: ObjectPath+login1ObjectPath = "/org/freedesktop/login1"++-- | The interface name for the systemd-logind manager.+login1ManagerInterfaceName :: InterfaceName+login1ManagerInterfaceName = "org.freedesktop.login1.Manager"++login1GenerationParams :: GenerationParams+login1GenerationParams =+  defaultGenerationParams+    { genTakeSignalErrorHandler = True,+      genBusName = Just login1BusName+    }+ -- | The bus name for PulseAudio's server lookup on the session bus. paServerLookupBusName :: BusName paServerLookupBusName = "org.PulseAudio1"@@ -86,23 +108,27 @@ paDeviceInterfaceName = "org.PulseAudio.Core1.Device"  paServerLookupGenerationParams :: GenerationParams-paServerLookupGenerationParams = defaultGenerationParams-  { genTakeSignalErrorHandler = True-  , genBusName = Just paServerLookupBusName-  , genObjectPath = Just paServerLookupObjectPath-  }+paServerLookupGenerationParams =+  defaultGenerationParams+    { genTakeSignalErrorHandler = True,+      genBusName = Just paServerLookupBusName,+      genObjectPath = Just paServerLookupObjectPath+    }  paCoreGenerationParams :: GenerationParams-paCoreGenerationParams = defaultGenerationParams-  { genTakeSignalErrorHandler = True-  , genObjectPath = Just paCoreObjectPath-  }+paCoreGenerationParams =+  defaultGenerationParams+    { genTakeSignalErrorHandler = True,+      genObjectPath = Just paCoreObjectPath+    }  paDeviceGenerationParams :: GenerationParams-paDeviceGenerationParams = defaultGenerationParams-  { genTakeSignalErrorHandler = True-  }+paDeviceGenerationParams =+  defaultGenerationParams+    { genTakeSignalErrorHandler = True+    } +-- | UPower device type enum. data BatteryType   = BatteryTypeUnknown   | BatteryTypeLinePower@@ -115,6 +141,7 @@   | BatteryTypePhone   deriving (Show, Ord, Eq, Enum) +-- | UPower battery charging state enum. data BatteryState   = BatteryStateUnknown   | BatteryStateCharging@@ -125,6 +152,7 @@   | BatteryStatePendingDischarge   deriving (Show, Ord, Eq, Enum) +-- | UPower battery chemistry enum. data BatteryTechnology   = BatteryTechnologyUnknown   | BatteryTechnologyLithiumIon@@ -142,4 +170,5 @@     "State" -> yes ''BatteryState     "Technology" -> yes ''BatteryTechnology     _ -> Nothing-  where yes = Just . ConT+  where+    yes = Just . ConT
src/System/Taffybar/DBus/Client/PulseAudioCore.hs view
@@ -1,4 +1,5 @@ {-# LANGUAGE TemplateHaskell #-}+ module System.Taffybar.DBus.Client.PulseAudioCore where  import DBus.Generation ()@@ -8,9 +9,9 @@  generateClientFromFile   defaultRecordGenerationParams-  { recordName = Just "PulseAudioCoreInfo"-  , recordPrefix = "pac"-  }+    { recordName = Just "PulseAudioCoreInfo",+      recordPrefix = "pac"+    }   paCoreGenerationParams-  False $-  "dbus-xml" </> "org.PulseAudio.Core1.xml"+  False+  $ "dbus-xml" </> "org.PulseAudio.Core1.xml"
src/System/Taffybar/DBus/Client/PulseAudioDevice.hs view
@@ -1,4 +1,5 @@ {-# LANGUAGE TemplateHaskell #-}+ module System.Taffybar.DBus.Client.PulseAudioDevice where  import DBus.Generation ()@@ -8,9 +9,9 @@  generateClientFromFile   defaultRecordGenerationParams-  { recordName = Just "PulseAudioDeviceInfo"-  , recordPrefix = "pad"-  }+    { recordName = Just "PulseAudioDeviceInfo",+      recordPrefix = "pad"+    }   paDeviceGenerationParams-  False $-  "dbus-xml" </> "org.PulseAudio.Core1.Device.xml"+  False+  $ "dbus-xml" </> "org.PulseAudio.Core1.Device.xml"
src/System/Taffybar/DBus/Client/PulseAudioServerLookup.hs view
@@ -1,4 +1,5 @@ {-# LANGUAGE TemplateHaskell #-}+ module System.Taffybar.DBus.Client.PulseAudioServerLookup where  import DBus.Generation ()@@ -8,9 +9,9 @@  generateClientFromFile   defaultRecordGenerationParams-  { recordName = Just "PulseAudioServerLookupInfo"-  , recordPrefix = "pasl"-  }+    { recordName = Just "PulseAudioServerLookupInfo",+      recordPrefix = "pasl"+    }   paServerLookupGenerationParams-  False $-  "dbus-xml" </> "org.PulseAudio.ServerLookup1.xml"+  False+  $ "dbus-xml" </> "org.PulseAudio.ServerLookup1.xml"
src/System/Taffybar/DBus/Client/UPower.hs view
@@ -1,4 +1,5 @@ {-# LANGUAGE TemplateHaskell #-}+ module System.Taffybar.DBus.Client.UPower where  import DBus.Generation@@ -7,9 +8,10 @@ import System.Taffybar.DBus.Client.Util  generateClientFromFile-  defaultRecordGenerationParams { recordName = Just "UPowerInfo"-                                , recordPrefix = "upi"-                                }-  uPowerGenerationParams { genObjectPath = Just uPowerBaseObjectPath }-  False $-  "dbus-xml" </> "org.freedesktop.UPower.xml"+  defaultRecordGenerationParams+    { recordName = Just "UPowerInfo",+      recordPrefix = "upi"+    }+  uPowerGenerationParams {genObjectPath = Just uPowerBaseObjectPath}+  False+  $ "dbus-xml" </> "org.freedesktop.UPower.xml"
src/System/Taffybar/DBus/Client/UPowerDevice.hs view
@@ -1,15 +1,19 @@ {-# LANGUAGE TemplateHaskell #-}++-- | Generated DBus client bindings for @org.freedesktop.UPower.Device@. module System.Taffybar.DBus.Client.UPowerDevice where  import System.FilePath import System.Taffybar.DBus.Client.Params import System.Taffybar.DBus.Client.Util +-- | Generate the UPower device client and the 'BatteryInfo' record type. generateClientFromFile   defaultRecordGenerationParams-  { recordName = Just "BatteryInfo"-  , recordPrefix = "battery"-  , recordTypeForName = batteryTypeForName-  }+    { recordName = Just "BatteryInfo",+      recordPrefix = "battery",+      recordTypeForName = batteryTypeForName+    }   uPowerGenerationParams-  False $ "dbus-xml" </> "org.freedesktop.UPower.Device.xml"+  False+  $ "dbus-xml" </> "org.freedesktop.UPower.Device.xml"
src/System/Taffybar/DBus/Client/Util.hs view
@@ -1,17 +1,18 @@ {-# LANGUAGE CPP #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE TemplateHaskellQuotes #-}+ module System.Taffybar.DBus.Client.Util where  import Control.Monad (forM)-import           DBus.Generation+import DBus.Generation import qualified DBus.Internal.Types as T import qualified DBus.Introspection as I import qualified Data.Char as Char-import           Data.Coerce-import           Data.Maybe-import           Language.Haskell.TH-import           StatusNotifier.Util (getIntrospectionObjectFromFile)+import Data.Coerce+import Data.Maybe+import Language.Haskell.TH+import StatusNotifier.Util (getIntrospectionObjectFromFile)  deriveShowAndEQ :: [DerivClause] deriveShowAndEQ =@@ -19,11 +20,16 @@  buildDataFromNameTypePairs :: Name -> [(Name, Type)] -> Dec buildDataFromNameTypePairs name pairs =-  DataD [] name [] Nothing [RecC name (map mkVarBangType pairs)]-        deriveShowAndEQ-  where mkVarBangType (fieldName, fieldType) =-          (fieldName, Bang NoSourceUnpackedness NoSourceStrictness, fieldType)-+  DataD+    []+    name+    []+    Nothing+    [RecC name (map mkVarBangType pairs)]+    deriveShowAndEQ+  where+    mkVarBangType (fieldName, fieldType) =+      (fieldName, Bang NoSourceUnpackedness NoSourceStrictness, fieldType)  standaloneDeriveEqShow :: Name -> [Dec] standaloneDeriveEqShow _ = []@@ -31,47 +37,53 @@ type GetTypeForName = String -> T.Type -> Maybe Type  data RecordGenerationParams = RecordGenerationParams-  { recordName :: Maybe String-  , recordPrefix :: String-  , recordTypeForName :: GetTypeForName+  { recordName :: Maybe String,+    recordPrefix :: String,+    recordTypeForName :: GetTypeForName   }  defaultRecordGenerationParams :: RecordGenerationParams-defaultRecordGenerationParams = RecordGenerationParams-  { recordName = Nothing-  , recordPrefix = "_"-  , recordTypeForName = const $ const Nothing-  }+defaultRecordGenerationParams =+  RecordGenerationParams+    { recordName = Nothing,+      recordPrefix = "_",+      recordTypeForName = const $ const Nothing+    } -generateGetAllRecord-  :: RecordGenerationParams-  -> GenerationParams-  -> I.Interface-  -> Q [Dec]+generateGetAllRecord ::+  RecordGenerationParams ->+  GenerationParams ->+  I.Interface ->+  Q [Dec] generateGetAllRecord-               RecordGenerationParams-               { recordName = recordNameString-               , recordPrefix = prefix-               , recordTypeForName = getTypeForName-               }-               GenerationParams { getTHType = getArgType }-               I.Interface { I.interfaceName = interfaceName-                           , I.interfaceProperties = properties-                           } = do-  let theRecordName =-        maybe (mkName $ map Char.toUpper $ filter Char.isLetter $ coerce interfaceName)-              mkName recordNameString-  let getPairFromProperty I.Property-                            { I.propertyName = propName-                            , I.propertyType = propType-                            } =-                            ( mkName $ prefix ++ propName-                            , fromMaybe (getArgType propType) $ getTypeForName propName propType-                            )-      getAllRecord =-        buildDataFromNameTypePairs-        theRecordName $ map getPairFromProperty properties-  return $ getAllRecord:standaloneDeriveEqShow theRecordName+  RecordGenerationParams+    { recordName = recordNameString,+      recordPrefix = prefix,+      recordTypeForName = getTypeForName+    }+  GenerationParams {getTHType = getArgType}+  I.Interface+    { I.interfaceName = interfaceName,+      I.interfaceProperties = properties+    } = do+    let theRecordName =+          maybe+            (mkName $ map Char.toUpper $ filter Char.isLetter $ coerce interfaceName)+            mkName+            recordNameString+    let getPairFromProperty+          I.Property+            { I.propertyName = propName,+              I.propertyType = propType+            } =+            ( mkName $ prefix ++ propName,+              fromMaybe (getArgType propType) $ getTypeForName propName propType+            )+        getAllRecord =+          buildDataFromNameTypePairs+            theRecordName+            $ map getPairFromProperty properties+    return $ getAllRecord : standaloneDeriveEqShow theRecordName  generateClientFromFile :: RecordGenerationParams -> GenerationParams -> Bool -> FilePath -> Q [Dec] generateClientFromFile recordGenerationParams params useObjectPath filepath = do@@ -83,6 +95,6 @@           else params       (<++>) = liftA2 (++)   fmap concat $ forM (I.objectInterfaces object) $ \interface -> do-    generateGetAllRecord recordGenerationParams params interface <++>-      generateClient realParams interface <++>-      generateSignalsFromInterface realParams interface+    generateGetAllRecord recordGenerationParams params interface+      <++> generateClient realParams interface+      <++> generateSignalsFromInterface realParams interface
src/System/Taffybar/DBus/Toggle.hs view
@@ -1,5 +1,9 @@ {-# LANGUAGE OverloadedStrings #-}+ -----------------------------------------------------------------------------++-----------------------------------------------------------------------------+ -- | -- Module      : System.Taffybar.DBus.Toggle -- Copyright   : (c) Ivan A. Malison@@ -11,32 +15,30 @@ -- -- This module provides a dbus interface that allows users to toggle the display -- of taffybar on each monitor while it is running.--------------------------------------------------------------------------------module System.Taffybar.DBus.Toggle ( handleDBusToggles ) where+module System.Taffybar.DBus.Toggle (handleDBusToggles) where  import qualified Control.Concurrent.MVar as MV-import           Control.Exception-import           Control.Monad-import           Control.Monad.IO.Class-import           Control.Monad.Trans.Class-import           Control.Monad.Trans.Maybe-import           Control.Monad.Trans.Reader-import           DBus-import           DBus.Client-import           Data.Int+import Control.Exception+import Control.Monad+import Control.Monad.IO.Class+import Control.Monad.Trans.Class+import Control.Monad.Trans.Maybe+import Control.Monad.Trans.Reader+import DBus+import DBus.Client+import Data.Int import qualified Data.Map as M-import           Data.Maybe+import Data.Maybe import qualified GI.Gdk as Gdk-import           Graphics.UI.GIGtkStrut-import           System.Directory-import           System.FilePath.Posix-import           System.Log.Logger-import           System.Taffybar.Context-import           System.Taffybar.Information.Hyprland (getFocusedMonitorPosition)-import           System.Taffybar.Util-import           Text.Printf-import           Text.Read ( readMaybe )+import Graphics.UI.GIGtkStrut+import System.Directory+import System.FilePath.Posix+import System.Log.Logger+import System.Taffybar.Context+import System.Taffybar.Information.Hyprland (getFocusedMonitorPosition)+import System.Taffybar.Util+import Text.Printf+import Text.Read (readMaybe)  -- $usage --@@ -53,7 +55,7 @@ logIO :: System.Log.Logger.Priority -> String -> IO () logIO = logM "System.Taffybar.DBus.Toggle" -logT :: MonadIO m => System.Log.Logger.Priority -> String -> m ()+logT :: (MonadIO m) => System.Log.Logger.Priority -> String -> m () logT p = liftIO . logIO p  getActiveMonitorNumber :: Context -> MaybeT IO Int@@ -75,26 +77,30 @@ getActiveMonitorNumberWayland ctx = do   (x, y) <- MaybeT $ getFocusedMonitorPosition (hyprlandClient ctx)   display <- MaybeT Gdk.displayGetDefault-  monitor <- lift $ Gdk.displayGetMonitorAtPoint display-               (fromIntegral x) (fromIntegral y)+  monitor <-+    lift $+      Gdk.displayGetMonitorAtPoint+        display+        (fromIntegral x)+        (fromIntegral y)   lift $ getMonitorNumber monitor  getMonitorNumber :: Gdk.Monitor -> IO Int getMonitorNumber monitor = do   display <- Gdk.monitorGetDisplay monitor   monitorCount <- Gdk.displayGetNMonitors display-  monitors <- mapM (Gdk.displayGetMonitor display) [0..(monitorCount-1)]+  monitors <- mapM (Gdk.displayGetMonitor display) [0 .. (monitorCount - 1)]   monitorGeometry <- Gdk.getMonitorGeometry monitor   let equalsMonitor (Just other, _) =         do           otherGeometry <- Gdk.getMonitorGeometry other           case (otherGeometry, monitorGeometry) of-               (Nothing, Nothing) -> return True-               (Just g1, Just g2) -> Gdk.rectangleEqual g1 g2-               _ -> return False+            (Nothing, Nothing) -> return True+            (Just g1, Just g2) -> Gdk.rectangleEqual g1 g2+            _ -> return False       equalsMonitor _ = return False-  snd . fromMaybe (Nothing, 0) . listToMaybe <$>-      filterM equalsMonitor (zip monitors [0..])+  snd . fromMaybe (Nothing, 0) . listToMaybe+    <$> filterM equalsMonitor (zip monitors [0 ..])  taffybarTogglePath :: ObjectPath taffybarTogglePath = "/taffybar/toggle"@@ -130,11 +136,17 @@         lift $ MV.modifyMVar_ enabledVar $ \numToEnabled -> do           let current = fromMaybe True $ M.lookup mon numToEnabled               result = M.insert mon (fn current) numToEnabled-          logIO DEBUG $ printf "Toggle state before: %s, after %s"-                  (show numToEnabled) (show result)+          logIO DEBUG $+            printf+              "Toggle state before: %s, after %s"+              (show numToEnabled)+              (show result)           catch (writeFile stateFile (show result)) $ \e ->-            logIO WARNING $ printf "Unable to write to toggle state file %s, error: %s"-                  (show stateFile) (show (e :: SomeException))+            logIO WARNING $+              printf+                "Unable to write to toggle state file %s, error: %s"+                (show stateFile)+                (show (e :: SomeException))           return result         refreshTaffyWindows       toggleTaffy = do@@ -145,21 +157,26 @@   client <- asks sessionDBusClient   let interface =         defaultInterface-        { interfaceName = taffybarToggleInterface-        , interfaceMethods =-          [ autoMethod "toggleCurrent" toggleTaffy-          , autoMethod "toggleOnMonitor" $ takeInt $ toggleTaffyOnMon not-          , autoMethod "hideOnMonitor" $-            takeInt $ toggleTaffyOnMon (const False)-          , autoMethod "showOnMonitor" $-            takeInt $ toggleTaffyOnMon (const True)-          , autoMethod "refresh" $ runReaderT refreshTaffyWindows ctx-          , autoMethod "exit" $ exitTaffybar ctx-          ]-        }+          { interfaceName = taffybarToggleInterface,+            interfaceMethods =+              [ autoMethod "toggleCurrent" toggleTaffy,+                autoMethod "toggleOnMonitor" $ takeInt $ toggleTaffyOnMon not,+                autoMethod "hideOnMonitor" $+                  takeInt $+                    toggleTaffyOnMon (const False),+                autoMethod "showOnMonitor" $+                  takeInt $+                    toggleTaffyOnMon (const True),+                autoMethod "refresh" $ runReaderT refreshTaffyWindows ctx,+                autoMethod "exit" $ exitTaffybar ctx+              ]+          }   lift $ do-    _ <- requestName client "taffybar.toggle"-       [nameAllowReplacement, nameReplaceExisting]+    _ <-+      requestName+        client+        "taffybar.toggle"+        [nameAllowReplacement, nameReplaceExisting]     export client taffybarTogglePath interface  dbusTogglesStartupHook :: TaffyIO ()@@ -171,17 +188,20 @@     filepathExists <- doesFileExist stateFilepath     mStartingMap <-       if filepathExists-      then-        readMaybe <$> readFile stateFilepath-      else-        return Nothing+        then+          readMaybe <$> readFile stateFilepath+        else+          return Nothing     MV.modifyMVar_ enabledVar $ const $ return $ fromMaybe M.empty mStartingMap   logT DEBUG "Exporting toggles interface"   exportTogglesInterface +-- | Extend a 'TaffybarConfig' with a DBus toggle interface and persisted+-- per-monitor visibility state. handleDBusToggles :: TaffybarConfig -> TaffybarConfig handleDBusToggles config =-  config { getBarConfigsParam =-             toggleBarConfigGetter $ getBarConfigsParam config-         , startupHook = startupHook config >> dbusTogglesStartupHook-         }+  config+    { getBarConfigsParam =+        toggleBarConfigGetter $ getBarConfigsParam config,+      startupHook = startupHook config >> dbusTogglesStartupHook+    }
src/System/Taffybar/Example.hs view
@@ -1,6 +1,10 @@ {-# LANGUAGE DisambiguateRecordFields #-} {-# LANGUAGE OverloadedStrings #-}+ -----------------------------------------------------------------------------++-----------------------------------------------------------------------------+ -- | -- Module      : System.Taffybar.Example -- Copyright   : (c) Ivan A. Malison@@ -9,7 +13,8 @@ -- Maintainer  : Ivan A. Malison -- Stability   : unstable -- Portability : unportable------------------------------------------------------------------------------+--+-- Example taffybar configurations used as reference defaults. module System.Taffybar.Example where  -- XXX: in an actual taffybar.hs configuration file, you will need the module@@ -19,69 +24,95 @@ -- > main = dyreTaffybar exampleTaffybarConfig  import Data.Default (def)-import System.Taffybar.Context (TaffybarConfig(..))+import System.Taffybar.Context (TaffybarConfig (..)) import System.Taffybar.Hooks-import System.Taffybar.Information.CPU import System.Taffybar.Information.Memory import System.Taffybar.SimpleConfig import System.Taffybar.Widget import System.Taffybar.Widget.Generic.PollingGraph-import qualified System.Taffybar.Widget.Workspaces as Workspaces+import qualified System.Taffybar.Widget.Workspaces.Config as WorkspaceConfig+import qualified System.Taffybar.Widget.Workspaces.EWMH as Workspaces -transparent, yellow1, yellow2, green1, green2, taffyBlue-  :: (Double, Double, Double, Double)+-- | Fully transparent RGBA color.+transparent :: (Double, Double, Double, Double) transparent = (0.0, 0.0, 0.0, 0.0)++-- | Accent yellow color (dark).+yellow1 :: (Double, Double, Double, Double) yellow1 = (0.9453125, 0.63671875, 0.2109375, 1.0)++-- | Accent yellow color (light).+yellow2 :: (Double, Double, Double, Double) yellow2 = (0.9921875, 0.796875, 0.32421875, 1.0)++-- | Accent green color.+green1 :: (Double, Double, Double, Double) green1 = (0, 1, 0, 1)++-- | Accent translucent magenta color.+green2 :: (Double, Double, Double, Double) green2 = (1, 0, 1, 0.5)++-- | Primary blue accent.+taffyBlue :: (Double, Double, Double, Double) taffyBlue = (0.129, 0.588, 0.953, 1) -myGraphConfig, netCfg, memCfg, cpuCfg :: GraphConfig+-- | Base graph configuration used by example graphs.+myGraphConfig :: GraphConfig myGraphConfig =   def-  { graphPadding = 0-  , graphBorderWidth = 0-  , graphWidth = 75-  , graphBackgroundColor = transparent-  }+    { graphPadding = 0,+      graphBorderWidth = 0,+      graphWidth = 75,+      graphBackgroundColor = transparent+    } -netCfg = myGraphConfig-  { graphDataColors = [yellow1, yellow2]-  , graphLabel = Just "net"-  }+-- | Network graph configuration for the example bar.+netCfg :: GraphConfig+netCfg =+  myGraphConfig+    { graphDataColors = [yellow1, yellow2],+      graphLabel = Just "net"+    } -memCfg = myGraphConfig-  { graphDataColors = [taffyBlue]-  , graphLabel = Just "mem"-  }+-- | Memory graph configuration for the example bar.+memCfg :: GraphConfig+memCfg =+  myGraphConfig+    { graphDataColors = [taffyBlue],+      graphLabel = Just "mem"+    } -cpuCfg = myGraphConfig-  { graphDataColors = [green1, green2]-  , graphLabel = Just "cpu"-  }+-- | CPU graph configuration for the example bar.+cpuCfg :: GraphConfig+cpuCfg =+  myGraphConfig+    { graphDataColors = [green1, green2],+      graphLabel = Just "cpu"+    } +-- | Callback used by the example memory graph. memCallback :: IO [Double] memCallback = do   mi <- parseMeminfo   return [memoryUsedRatio mi] -cpuCallback :: IO [Double]-cpuCallback = do-  (_, systemLoad, totalLoad) <- cpuLoad-  return [totalLoad, systemLoad]-+-- | Example X11-oriented taffybar configuration. exampleTaffybarConfig :: TaffybarConfig exampleTaffybarConfig =-  let myWorkspacesConfig :: WorkspacesConfig+  let myWorkspacesConfig :: Workspaces.WorkspacesConfig       myWorkspacesConfig =-        def-        { Workspaces.minIcons = 1-        , Workspaces.widgetGap = 0-        , Workspaces.showWorkspaceFn = hideEmpty-        }-      workspaces = workspacesNew myWorkspacesConfig-      cpu = pollingGraphNew cpuCfg 0.5 cpuCallback+        let cfg = def+         in cfg+              { Workspaces.workspacesConfig =+                  (Workspaces.workspacesConfig cfg)+                    { WorkspaceConfig.minIcons = 1,+                      WorkspaceConfig.widgetGap = 0,+                      WorkspaceConfig.showWorkspaceFn = Workspaces.hideEmpty+                    }+              }+      workspaces = Workspaces.workspacesNew myWorkspacesConfig+      cpu = cpuMonitorNew cpuCfg 0.5 "cpu"       mem = pollingGraphNew memCfg 1 memCallback       net = networkGraphNew netCfg Nothing       clock = textClockNewWith def@@ -90,36 +121,41 @@       -- See https://github.com/taffybar/gtk-sni-tray#statusnotifierwatcher       -- for a better way to set up the sni tray       tray = sniTrayThatStartsWatcherEvenThoughThisIsABadWayToDoIt-      myConfig = def-        { startWidgets =-            workspaces : map (>>= buildContentsBox) [ layout, windowsW ]-        , endWidgets = map (>>= buildContentsBox)-          [ batteryIconNew-          , clock-          , tray-          , cpu-          , mem-          , net-          , mpris2New-          ]-        , barPosition = Top-        , barPadding = 10-        , barHeight = ExactSize 50-        , widgetSpacing = 0-        }-  in withLogServer $ withToggleServer $ toTaffybarConfig myConfig+      myConfig =+        def+          { startWidgets =+              workspaces : map (>>= buildContentsBox) [layout, windowsW],+            endWidgets =+              map+                (>>= buildContentsBox)+                [ batteryIconNew,+                  clock,+                  tray,+                  cpu,+                  mem,+                  net,+                  mpris2New+                ],+            barPosition = Top,+            barPadding = 10,+            barHeight = ExactSize 50,+            widgetSpacing = 0+          }+   in withLogServer $ withToggleServer $ toTaffybarConfig myConfig +-- | Example minimal Wayland-oriented taffybar configuration. 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+      cpu = cpuMonitorNew cpuCfg 1 "cpu"+      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
@@ -1,4 +1,7 @@ -----------------------------------------------------------------------------++-----------------------------------------------------------------------------+ -- | -- Module      : System.Taffybar.Hooks -- Copyright   : (c) Ivan A. Malison@@ -10,51 +13,55 @@ -- -- This module provides various startup hooks that can be added to -- 'TaffybarConfig'.------------------------------------------------------------------------------- module System.Taffybar.Hooks-  ( module System.Taffybar.DBus-  , module System.Taffybar.Hooks-  , module System.Taffybar.LogLevels-  , ChromeTabImageData(..)-  , getChromeTabImageDataChannel-  , getChromeTabImageDataTable-  , getX11WindowToChromeTabId-  , refreshBatteriesOnPropChange-  ) where+  ( module System.Taffybar.DBus,+    module System.Taffybar.Hooks,+    module System.Taffybar.LogLevels,+    ChromeTabImageData (..),+    getChromeTabImageDataChannel,+    getChromeTabImageDataTable,+    getX11WindowToChromeTabId,+    refreshBatteriesOnPropChange,+  )+where -import           Control.Concurrent-import           Control.Concurrent.STM.TChan-import           Control.Monad-import           Control.Monad.STM (atomically)-import           Control.Monad.Trans.Class-import           Control.Monad.Trans.Reader+import Control.Concurrent+import qualified Control.Concurrent.MVar as MV+import Control.Concurrent.STM.TChan+import Control.Monad+import Control.Monad.IO.Class (liftIO)+import Control.Monad.STM (atomically)+import Control.Monad.Trans.Class+import Control.Monad.Trans.Reader+import Data.List (isSuffixOf, nub) import qualified Data.MultiMap as MM-import           System.Log.Logger-import           System.Taffybar.Context-import           System.Taffybar.DBus-import           System.Taffybar.Information.Battery-import           System.Taffybar.Information.Chrome-import           System.Taffybar.Information.Network-import           System.Environment.XDG.DesktopEntry-import           System.Taffybar.LogFormatter-import           System.Taffybar.LogLevels-import           System.Taffybar.Util+import System.Directory (doesDirectoryExist)+import System.Environment.XDG.DesktopEntry+import System.FSNotify (Event (eventIsDirectory, eventPath), EventIsDirectory (IsFile), startManager, watchDir)+import System.FilePath ((</>))+import System.Log.Logger+import System.Taffybar.Context+import System.Taffybar.DBus+import System.Taffybar.Information.Battery+import System.Taffybar.Information.Chrome+import System.Taffybar.Information.Network+import System.Taffybar.LogFormatter+import System.Taffybar.LogLevels  -- | The type of the channel that provides network information in taffybar.-newtype NetworkInfoChan =-  NetworkInfoChan (TChan [(String, (Rational, Rational))])+newtype NetworkInfoChan+  = NetworkInfoChan (TChan [(String, (Rational, Rational))])  -- | Build a 'NetworkInfoChan' that refreshes at the provided interval.-buildNetworkInfoChan :: Double -> IO NetworkInfoChan+buildNetworkInfoChan :: Double -> TaffyIO NetworkInfoChan buildNetworkInfoChan interval = do-  chan <- newBroadcastTChanIO-  _ <- forkIO $ monitorNetworkInterfaces interval (void . atomically . writeTChan chan)+  chan <- liftIO newBroadcastTChanIO+  monitorNetworkInterfaces interval (void . atomically . writeTChan chan)   return $ NetworkInfoChan chan  -- | Get the 'NetworkInfoChan' from 'Context', creating it if it does not exist. getNetworkChan :: TaffyIO NetworkInfoChan-getNetworkChan = getStateDefault $ lift $ buildNetworkInfoChan 2.0+getNetworkChan = getStateDefault $ buildNetworkInfoChan 2.0  -- | Set the log formatter used in the taffybar process setTaffyLogFormatter :: String -> IO ()@@ -83,22 +90,77 @@ -- -- To use a custom path instead, call 'loadLogLevelsFromFile' directly. withLogLevels :: TaffybarConfig -> TaffybarConfig-withLogLevels = appendHook $-  lift $ defaultLogLevelsPath >>= loadLogLevelsFromFile+withLogLevels =+  appendHook $+    lift $+      defaultLogLevelsPath >>= loadLogLevelsFromFile +newtype DesktopEntryCacheWatch+  = DesktopEntryCacheWatch (IO ())+ -- | Load the 'DesktopEntry' cache from 'Context' state. getDirectoryEntriesByClassName :: TaffyIO (MM.MultiMap String DesktopEntry) getDirectoryEntriesByClassName =   getStateDefault readDirectoryEntriesDefault --- | Update the 'DesktopEntry' cache every 60 seconds.+-- | Keep the 'DesktopEntry' cache fresh by watching XDG application directories+-- for desktop entry file updates. updateDirectoryEntriesCache :: TaffyIO ()-updateDirectoryEntriesCache = ask >>= \ctx ->-  void $ lift $ foreverWithDelay (60 :: Double) $ flip runReaderT ctx $-       void $ putState readDirectoryEntriesDefault+updateDirectoryEntriesCache = do+  _ <- getStateDefault startDesktopEntryCacheWatch+  return () +startDesktopEntryCacheWatch :: TaffyIO DesktopEntryCacheWatch+startDesktopEntryCacheWatch = do+  ctx <- ask+  appDirs <- lift getDesktopEntryApplicationDirs+  updateSignal <- lift MV.newEmptyMVar+  mgr <- lift startManager+  stopActions <-+    lift $+      forM appDirs $+        \dir ->+          watchDir mgr dir isDesktopEntryEvent $+            const $+              void $+                MV.tryPutMVar updateSignal ()+  _ <-+    lift $+      forkIO $+        forever $ do+          _ <- MV.takeMVar updateSignal+          threadDelay 200000+          flushUpdates updateSignal+          void $ runReaderT refreshDirectoryEntriesCache ctx+  void refreshDirectoryEntriesCache+  return $+    DesktopEntryCacheWatch $+      sequence_ stopActions++refreshDirectoryEntriesCache :: TaffyIO (MM.MultiMap String DesktopEntry)+refreshDirectoryEntriesCache = do+  entries <- readDirectoryEntriesDefault+  setState entries++flushUpdates :: MV.MVar () -> IO ()+flushUpdates updateSignal = do+  next <- MV.tryTakeMVar updateSignal+  case next of+    Nothing -> return ()+    Just _ -> flushUpdates updateSignal++isDesktopEntryEvent :: Event -> Bool+isDesktopEntryEvent event =+  eventIsDirectory event == IsFile && ".desktop" `isSuffixOf` eventPath event++getDesktopEntryApplicationDirs :: IO [FilePath]+getDesktopEntryApplicationDirs = do+  xdgDataDirs <- getXDGDataDirs+  filterM doesDirectoryExist $ map (</> "applications") $ nub xdgDataDirs+ -- | Read 'DesktopEntry' values into a 'MM.Multimap', where they are indexed by -- the class name specified in the 'DesktopEntry'. readDirectoryEntriesDefault :: TaffyIO (MM.MultiMap String DesktopEntry)-readDirectoryEntriesDefault = lift $-  indexDesktopEntriesByClassName <$> getDirectoryEntriesDefault+readDirectoryEntriesDefault =+  lift $+    indexDesktopEntriesByClassName <$> getDirectoryEntriesDefault
src/System/Taffybar/Hyprland.hs view
@@ -1,4 +1,7 @@ -----------------------------------------------------------------------------++-----------------------------------------------------------------------------+ -- | -- Module      : System.Taffybar.Hyprland -- Copyright   : (c) Ivan A. Malison@@ -13,46 +16,43 @@ -- 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+    getHyprlandClient,+    getHyprlandClientWith,      -- * Hyprland Monad In TaffyIO-  , HyprlandIO-  , runHyprland+    HyprlandIO,+    runHyprland,      -- * Shared Event Channel-  , getHyprlandEventChan-  , getHyprlandEventChanWith+    getHyprlandEventChan,+    getHyprlandEventChanWith,      -- * Convenience Runners-  , runHyprlandCommandRawT-  , runHyprlandCommandJsonT-  ) where+    runHyprlandCommandRawT,+    runHyprlandCommandJsonT,+  )+where  import qualified Control.Concurrent.MVar as MV-import           Control.Monad.IO.Class (liftIO)-import           Data.Aeson (FromJSON)+import Control.Monad.IO.Class (liftIO)+import Control.Monad.Trans.Reader (ReaderT, asks)+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+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.@@ -75,6 +75,7 @@ -- applied. We therefore spell out the underlying 'ReaderT Context IO' here. type HyprlandIO a = HyprlandT (ReaderT Context IO) a +-- | Run a Hyprland action using the shared client from 'Context'. runHyprland :: HyprlandIO a -> TaffyIO a runHyprland action = getHyprlandClient >>= \client -> runHyprlandT client action @@ -100,10 +101,12 @@         c <- buildHyprlandEventChan client         pure (Just c, c) +-- | Run a raw Hyprland command in 'TaffyIO'. runHyprlandCommandRawT :: HyprlandCommand -> TaffyIO (Either HyprlandError BS.ByteString) runHyprlandCommandRawT cmd =   getHyprlandClient >>= \client -> liftIO $ runHyprlandCommandRaw client cmd -runHyprlandCommandJsonT :: FromJSON a => HyprlandCommand -> TaffyIO (Either HyprlandError a)+-- | Run a JSON-decoded Hyprland command in 'TaffyIO'.+runHyprlandCommandJsonT :: (FromJSON a) => HyprlandCommand -> TaffyIO (Either HyprlandError a) runHyprlandCommandJsonT cmd =   getHyprlandClient >>= \client -> liftIO $ runHyprlandCommandJson client cmd
+ src/System/Taffybar/Information/ASUS.hs view
@@ -0,0 +1,341 @@+{-# LANGUAGE OverloadedStrings #-}++-----------------------------------------------------------------------------++-----------------------------------------------------------------------------++-- |+-- Module      : System.Taffybar.Information.ASUS+-- 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 ASUS platform profile+-- and CPU state using the asusd DBus API (xyz.ljones.Asusd) and sysfs.+module System.Taffybar.Information.ASUS+  ( ASUSPlatformProfile (..),+    ASUSInfo (..),+    getASUSInfo,+    getASUSInfoFromClient,+    getASUSInfoChan,+    getASUSInfoState,+    cycleASUSProfile,+    setASUSProfile,+    asusProfileToString,+    asusProfileFromUInt,+  )+where++import Control.Concurrent.MVar+import Control.Concurrent.STM.TChan+import Control.Exception (SomeException, try)+import Control.Monad (forM, forever, void)+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 (catMaybes, fromMaybe, listToMaybe)+import Data.Text (Text)+import Data.Word (Word32)+import System.Directory (doesDirectoryExist, doesFileExist, listDirectory)+import System.FilePath ((</>))+import System.Log.Logger+import System.Taffybar.Context+import System.Taffybar.Information.Wakeup (getWakeupChannelForDelay)+import System.Taffybar.Util (logPrintF, maybeToEither)+import Text.Read (readMaybe)++-- | ASUS platform profile modes.+data ASUSPlatformProfile = Quiet | Performance | Balanced+  deriving (Eq, Show, Ord, Enum, Bounded)++-- | Combined ASUS platform info with CPU state.+data ASUSInfo = ASUSInfo+  { asusProfile :: ASUSPlatformProfile,+    -- | Average CPU frequency across all cores+    asusCpuFreqGHz :: Double,+    -- | CPU package temperature in Celsius+    asusCpuTempC :: Double+  }+  deriving (Eq, Show)++-- DBus constants++asusBusName :: BusName+asusBusName = "xyz.ljones.Asusd"++asusObjectPath :: ObjectPath+asusObjectPath = "/xyz/ljones"++asusInterfaceName :: InterfaceName+asusInterfaceName = "xyz.ljones.Platform"++asusLogPath :: String+asusLogPath = "System.Taffybar.Information.ASUS"++asusLogF :: (MonadIO m, Show t) => Priority -> String -> t -> m ()+asusLogF = logPrintF asusLogPath++-- | Convert profile enum to string.+asusProfileToString :: ASUSPlatformProfile -> Text+asusProfileToString Quiet = "Quiet"+asusProfileToString Balanced = "Balanced"+asusProfileToString Performance = "Performance"++-- | Parse profile from asusd uint32: 0=Quiet, 1=Performance, 2=Balanced.+asusProfileFromUInt :: Word32 -> Maybe ASUSPlatformProfile+asusProfileFromUInt 0 = Just Quiet+asusProfileFromUInt 1 = Just Performance+asusProfileFromUInt 2 = Just Balanced+asusProfileFromUInt _ = Nothing++asusProfileToUInt :: ASUSPlatformProfile -> Word32+asusProfileToUInt Quiet = 0+asusProfileToUInt Performance = 1+asusProfileToUInt Balanced = 2++-- | Default info when asusd is unavailable.+unknownASUSInfo :: ASUSInfo+unknownASUSInfo =+  ASUSInfo+    { asusProfile = Balanced,+      asusCpuFreqGHz = 0,+      asusCpuTempC = 0+    }++-- 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 asusObjectPath asusInterfaceName "FakeMethod")+          { methodCallDestination = Just asusBusName+          }+  ExceptT $+    return $+      maybeToEither dummyMethodError $+        listToMaybe (methodReturnBody reply) >>= fromVariant++-- | Read current platform profile from DBus.+readProfileFromClient :: Client -> IO ASUSPlatformProfile+readProfileFromClient client = do+  propsResult <- getProperties client+  case propsResult of+    Left err -> do+      asusLogF WARNING "Failed to read ASUS properties: %s" err+      return Balanced+    Right props ->+      let profileVal = readDictMaybe props "PlatformProfile" :: Maybe Word32+       in return $ fromMaybe Balanced (profileVal >>= asusProfileFromUInt)++-- | Set the ASUS platform profile via DBus property.+setASUSProfile :: Client -> ASUSPlatformProfile -> IO (Either MethodError ())+setASUSProfile client profile = do+  result <-+    setProperty+      client+      (methodCall asusObjectPath asusInterfaceName "PlatformProfile")+        { methodCallDestination = Just asusBusName+        }+      (toVariant (asusProfileToUInt profile))+  return $ case result of+    Left err -> Left err+    Right _ -> Right ()++-- | Cycle to the next profile by calling the NextPlatformProfile method.+cycleASUSProfile :: Client -> IO (Either MethodError ())+cycleASUSProfile client = do+  let mc =+        (methodCall asusObjectPath asusInterfaceName "NextPlatformProfile")+          { methodCallDestination = Just asusBusName+          }+  result <- call client mc+  return $ case result of+    Left err -> Left err+    Right _ -> Right ()++-- sysfs CPU frequency reading++-- | Read average CPU frequency in GHz from sysfs.+readCpuFreqGHz :: IO Double+readCpuFreqGHz = do+  let cpuDir = "/sys/devices/system/cpu"+  exists <- doesDirectoryExist cpuDir+  if not exists+    then return 0+    else do+      entries <- listDirectory cpuDir+      let cpuDirs = filter isCpuDir entries+      freqs <- forM cpuDirs $ \cpu -> do+        let freqPath = cpuDir </> cpu </> "cpufreq" </> "scaling_cur_freq"+        readFreqFile freqPath+      let validFreqs = catMaybes freqs+      if null validFreqs+        then return 0+        else return $ (sum validFreqs / fromIntegral (length validFreqs)) / 1_000_000+  where+    isCpuDir name =+      take 3 name == "cpu" && all (`elem` ("0123456789" :: String)) (drop 3 name)+    readFreqFile 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 s -> return $ fmap fromIntegral (readMaybe (strip s) :: Maybe Integer)+    strip = dropWhile (== ' ') . reverse . dropWhile (== '\n') . reverse . dropWhile (== ' ')++-- sysfs CPU temperature reading++-- | Read CPU package temperature in Celsius from sysfs.+-- Prefers x86_pkg_temp zone, falls back to highest temperature.+readCpuTempC :: IO Double+readCpuTempC = do+  let thermalDir = "/sys/class/thermal"+  exists <- doesDirectoryExist thermalDir+  if not exists+    then return 0+    else do+      entries <- listDirectory thermalDir+      let zones = filter (\e -> take 12 e == "thermal_zone") entries+      readings <- forM zones $ \zone -> do+        let typePath = thermalDir </> zone </> "type"+            tempPath = thermalDir </> zone </> "temp"+        zoneType <- readFileSafe typePath+        tempVal <- readTempFile tempPath+        return $ case tempVal of+          Nothing -> Nothing+          Just t -> Just (fromMaybe zone zoneType, t)+      let validReadings = catMaybes readings+          pkgTemp = lookup "x86_pkg_temp" validReadings+      case pkgTemp of+        Just t -> return t+        Nothing ->+          if null validReadings+            then return 0+            else return $ maximum $ map snd validReadings+  where+    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 s -> return $ Just $ strip s+    readTempFile 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 s -> case readMaybe (strip s) :: Maybe Integer of+              Nothing -> return Nothing+              Just milliDeg -> return $ Just (fromIntegral milliDeg / 1000.0)+    strip = dropWhile (== ' ') . reverse . dropWhile (== '\n') . reverse . dropWhile (== ' ')++-- | Get current ASUS info using the system DBus client from Context.+getASUSInfo :: TaffyIO ASUSInfo+getASUSInfo = asks systemDBusClient >>= liftIO . getASUSInfoFromClient++-- | Get current ASUS info from a DBus client.+getASUSInfoFromClient :: Client -> IO ASUSInfo+getASUSInfoFromClient client = do+  profile <- readProfileFromClient client+  freq <- readCpuFreqGHz+  temp <- readCpuTempC+  return+    ASUSInfo+      { asusProfile = profile,+        asusCpuFreqGHz = freq,+        asusCpuTempC = temp+      }++-- State management for monitoring++newtype ASUSInfoChanVar+  = ASUSInfoChanVar (TChan ASUSInfo, MVar ASUSInfo)++-- | Get the current ASUS info state.+getASUSInfoState :: TaffyIO ASUSInfo+getASUSInfoState = do+  ASUSInfoChanVar (_, theVar) <- getASUSInfoChanVar+  lift $ readMVar theVar++-- | Get a broadcast channel for ASUS info updates.+getASUSInfoChan :: TaffyIO (TChan ASUSInfo)+getASUSInfoChan = do+  ASUSInfoChanVar (chan, _) <- getASUSInfoChanVar+  return chan++getASUSInfoChanVar :: TaffyIO ASUSInfoChanVar+getASUSInfoChanVar =+  getStateDefault $ ASUSInfoChanVar <$> monitorASUSInfo++monitorASUSInfo :: TaffyIO (TChan ASUSInfo, MVar ASUSInfo)+monitorASUSInfo = do+  infoVar <- lift $ newMVar unknownASUSInfo+  chan <- liftIO newBroadcastTChanIO+  wakeupChan <- getWakeupChannelForDelay (2 :: Double)+  ourWakeupChan <- liftIO $ atomically $ dupTChan wakeupChan+  taffyFork $ do+    ctx <- ask+    let updateInfo = updateASUSInfo chan infoVar+        signalCallback _ _ _ _ = runReaderT updateInfo ctx+        waitForNextPoll = void $ atomically $ readTChan ourWakeupChan+    _ <- registerForASUSPropertiesChanged signalCallback+    -- Do an initial update+    updateInfo+    -- Then poll every 2 seconds for CPU freq/temp changes+    lift $ forever $ do+      waitForNextPoll+      runReaderT updateInfo ctx+  return (chan, infoVar)++registerForASUSPropertiesChanged ::+  (Signal -> String -> Map String Variant -> [String] -> IO ()) ->+  ReaderT Context IO SignalHandler+registerForASUSPropertiesChanged signalHandler = do+  client <- asks systemDBusClient+  lift $+    DBus.registerForPropertiesChanged+      client+      matchAny+        { matchInterface = Just asusInterfaceName,+          matchPath = Just asusObjectPath+        }+      signalHandler++updateASUSInfo ::+  TChan ASUSInfo ->+  MVar ASUSInfo ->+  TaffyIO ()+updateASUSInfo chan var = do+  info <- getASUSInfo+  lift $ do+    void $ swapMVar var info+    atomically $ writeTChan chan info
src/System/Taffybar/Information/Backlight.hs view
@@ -5,6 +5,9 @@ {-# LANGUAGE TypeApplications #-}  -----------------------------------------------------------------------------++-----------------------------------------------------------------------------+ -- | -- Module      : System.Taffybar.Information.Backlight -- Copyright   : (c) Ivan A. Malison@@ -15,41 +18,40 @@ -- Portability : unportable -- -- Simple helpers to read backlight status from /sys/class/backlight.---------------------------------------------------------------------------------- module System.Taffybar.Information.Backlight-  ( BacklightInfo(..)-  , getBacklightDevices-  , getBacklightInfo-  , getBacklightInfoChan-  , getBacklightInfoChanWithInterval-  , getBacklightInfoState-  ) where+  ( BacklightInfo (..),+    getBacklightDevices,+    getBacklightInfo,+    getBacklightInfoChan,+    getBacklightInfoChanWithInterval,+    getBacklightInfoState,+  )+where -import Control.Concurrent (forkIO, threadDelay)+import Control.Concurrent (forkIO) import Control.Concurrent.MVar import Control.Concurrent.STM.TChan import Control.Exception (SomeException, bracket, catch, try)-import Control.Monad (forever)+import Control.Monad (forever, void) 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 Data.Ord (Down (..), comparing)+import Data.Proxy (Proxy (..)) import GHC.Conc (threadWaitRead)-import GHC.TypeLits (KnownSymbol, SomeSymbol(..), Symbol, someSymbolVal)+import GHC.TypeLits (KnownSymbol, SomeSymbol (..), Symbol, someSymbolVal) import System.Directory (doesDirectoryExist, listDirectory) import System.FilePath ((</>))-import System.Log.Logger (Priority(..))+import System.Log.Logger (Priority (..)) import System.Taffybar.Context (TaffyIO, getStateDefault) import System.Taffybar.Information.Udev-  ( backlightMonitorFd-  , closeBacklightMonitor-  , drainBacklightMonitor-  , openBacklightMonitor+  ( backlightMonitorFd,+    closeBacklightMonitor,+    drainBacklightMonitor,+    openBacklightMonitor,   )+import System.Taffybar.Information.Wakeup (getWakeupChannelForDelay) import System.Taffybar.Util (logPrintF) import System.Timeout (timeout) import Text.Read (readMaybe)@@ -62,11 +64,12 @@  -- | Information about a backlight device. data BacklightInfo = BacklightInfo-  { backlightDevice :: FilePath-  , backlightBrightness :: Int-  , backlightMaxBrightness :: Int-  , backlightPercent :: Int-  } deriving (Eq, Show)+  { backlightDevice :: FilePath,+    backlightBrightness :: Int,+    backlightMaxBrightness :: Int,+    backlightPercent :: Int+  }+  deriving (Eq, Show)  -- | List all backlight device names under /sys/class/backlight. getBacklightDevices :: IO [FilePath]@@ -89,7 +92,7 @@ backlightLogPath :: String backlightLogPath = "System.Taffybar.Information.Backlight" -backlightLogF :: Show t => Priority -> String -> t -> IO ()+backlightLogF :: (Show t) => Priority -> String -> t -> IO () backlightLogF = logPrintF backlightLogPath  newtype BacklightInfoChanVar (a :: Symbol)@@ -123,65 +126,67 @@   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 ::+  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 ::+  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 ::+  forall (a :: Symbol).+  (KnownSymbol a) =>+  Maybe FilePath ->+  Double ->+  TaffyIO (BacklightInfoChanVar a) getBacklightInfoChanVarFor deviceOverride intervalSeconds =   getStateDefault $ do+    wakeupChan <- getWakeupChannelForDelay (max 0.000001 intervalSeconds)+    ourWakeupChan <- liftIO $ atomically $ dupTChan wakeupChan     liftIO $ do       chan <- newBroadcastTChanIO       var <- newMVar Nothing-      _ <- forkIO $ monitorBacklightInfo deviceOverride intervalSeconds chan var+      _ <- forkIO $ monitorBacklightInfo deviceOverride intervalSeconds ourWakeupChan chan var       pure $ BacklightInfoChanVar (chan, var)  monitorBacklightInfo ::   Maybe FilePath ->   Double ->+  TChan a ->   TChan (Maybe BacklightInfo) ->   MVar (Maybe BacklightInfo) ->   IO ()-monitorBacklightInfo deviceOverride intervalSeconds chan var = do-  let-    intervalMicros :: Int-    intervalMicros = max 1 (floor (intervalSeconds * 1000000))+monitorBacklightInfo deviceOverride intervalSeconds wakeupChan chan var = do+  let intervalMicros :: Int+      intervalMicros = max 1 (floor (intervalSeconds * 1000000)) -    writeInfo info = do-      _ <- swapMVar var info-      atomically $ writeTChan chan info+      writeInfo info = do+        _ <- swapMVar var info+        atomically $ writeTChan chan info -    refresh = getBacklightInfo deviceOverride >>= writeInfo+      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+      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+          void $ atomically $ readTChan wakeupChan+          refresh    monitorResult <- try openBacklightMonitor   case monitorResult of@@ -219,12 +224,14 @@   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 $+        Just+          BacklightInfo+            { backlightDevice = device,+              backlightBrightness = current,+              backlightMaxBrightness = maxVal,+              backlightPercent = percent+            }     _ -> return Nothing  readMaxBrightness :: FilePath -> IO (Maybe Int)@@ -233,9 +240,11 @@  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+  catch+    ( do+        contents <- readFile path+        case words contents of+          (val : _) -> return $ readMaybe val+          _ -> return Nothing+    )+    $ \(_ :: SomeException) -> return Nothing
src/System/Taffybar/Information/Battery.hs view
@@ -1,5 +1,9 @@ {-# LANGUAGE OverloadedStrings #-}+ -----------------------------------------------------------------------------++-----------------------------------------------------------------------------+ -- | -- Module      : System.Taffybar.Information.Battery -- Copyright   : (c) Ivan A. Malison@@ -12,52 +16,55 @@ -- This module provides functions for querying battery information using the -- UPower dbus, as well as a broadcast "TChan" system for allowing multiple -- readers to receive 'BatteryState' updates without duplicating requests.------------------------------------------------------------------------------ module System.Taffybar.Information.Battery-  ( BatteryInfo(..)-  , BatteryState(..)-  , BatteryTechnology(..)-  , BatteryType(..)-  , module System.Taffybar.Information.Battery-  ) where+  ( BatteryInfo (..),+    BatteryState (..),+    BatteryTechnology (..),+    BatteryType (..),+    module System.Taffybar.Information.Battery,+  )+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.Except-import           Control.Monad.Trans.Reader-import           DBus-import           DBus.Client-import           DBus.Internal.Types (Serial(..))+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.Except+import Control.Monad.Trans.Reader+import DBus+import DBus.Client+import DBus.Internal.Types (Serial (..)) import qualified DBus.TH as DBus-import           Data.Int-import           Data.List-import           Data.Map ( Map )+import Data.Int+import Data.List+import Data.Map (Map) import qualified Data.Map as M-import           Data.Maybe-import           Data.Text ( Text )-import           Data.Word-import           System.Log.Logger-import           System.Taffybar.Context-import           System.Taffybar.DBus.Client.Params-import           System.Taffybar.DBus.Client.UPower-import           System.Taffybar.DBus.Client.UPowerDevice-import           System.Taffybar.Util+import Data.Maybe+import Data.Text (Text)+import Data.Word+import System.Log.Logger+import System.Taffybar.Context+import System.Taffybar.DBus.Client.Params+import System.Taffybar.DBus.Client.UPower+import System.Taffybar.DBus.Client.UPowerDevice+import System.Taffybar.Util +-- | Logger namespace for battery modules. batteryLogPath :: String batteryLogPath = "System.Taffybar.Information.Battery" -batteryLog-  :: MonadIO m-  => Priority -> String -> m ()+-- | Log a message to the battery logger.+batteryLog ::+  (MonadIO m) =>+  Priority -> String -> m () batteryLog priority = liftIO . logM batteryLogPath priority -batteryLogF-  :: (MonadIO m, Show t)-  => Priority -> String -> t -> m ()+-- | Formatted logging helper for the battery logger.+batteryLogF ::+  (MonadIO m, Show t) =>+  Priority -> String -> t -> m () batteryLogF = logPrintF batteryLogPath  -- | The DBus path prefix where UPower enumerates its objects.@@ -85,19 +92,21 @@ readDictIntegral dict key dflt = fromMaybe (fromIntegral dflt) $ do   v <- M.lookup key dict   case variantType v of-    TypeWord8   -> return $ fromIntegral (f v :: Word8)-    TypeWord16  -> return $ fromIntegral (f v :: Word16)-    TypeWord32  -> return $ fromIntegral (f v :: Word32)-    TypeWord64  -> return $ fromIntegral (f v :: Word64)-    TypeInt16   -> return $ fromIntegral (f v :: Int16)-    TypeInt32   -> return $ fromIntegral (f v :: Int32)-    TypeInt64   -> return $ fromIntegral (f v :: Int64)-    _           -> Nothing+    TypeWord8 -> return $ fromIntegral (f v :: Word8)+    TypeWord16 -> return $ fromIntegral (f v :: Word16)+    TypeWord32 -> return $ fromIntegral (f v :: Word32)+    TypeWord64 -> return $ fromIntegral (f v :: Word64)+    TypeInt16 -> return $ fromIntegral (f v :: Int16)+    TypeInt32 -> return $ fromIntegral (f v :: Int32)+    TypeInt64 -> return $ fromIntegral (f v :: Int64)+    _ -> Nothing   where     f :: (Num a, IsVariant a) => Variant -> a     f = fromMaybe (fromIntegral dflt) . fromVariant  -- XXX: Remove this once it is exposed in haskell-dbus++-- | Placeholder 'MethodError' used when required reply payload is missing. dummyMethodError :: MethodError dummyMethodError = methodError (Serial 1) $ errorName_ "org.ClientTypeMismatch" @@ -105,49 +114,58 @@ -- If some fields are not actually present, they may have bogus values -- here.  Don't bet anything critical on it. getBatteryInfo :: ObjectPath -> TaffyIO (Either MethodError BatteryInfo)-getBatteryInfo battPath = asks systemDBusClient >>= \client -> lift $ runExceptT $ do-  reply <- ExceptT $ getAllProperties client $-           (methodCall battPath uPowerDeviceInterfaceName "FakeMethod")-           { methodCallDestination = Just uPowerBusName }-  dict <- ExceptT $ return $ maybeToEither dummyMethodError $-         listToMaybe (methodReturnBody reply) >>= fromVariant-  return $ infoMapToBatteryInfo dict+getBatteryInfo battPath =+  asks systemDBusClient >>= \client -> lift $ runExceptT $ do+    reply <-+      ExceptT $+        getAllProperties client $+          (methodCall battPath uPowerDeviceInterfaceName "FakeMethod")+            { methodCallDestination = Just uPowerBusName+            }+    dict <-+      ExceptT $+        return $+          maybeToEither dummyMethodError $+            listToMaybe (methodReturnBody reply) >>= fromVariant+    return $ infoMapToBatteryInfo dict +-- | Decode a UPower property map into a 'BatteryInfo' record. infoMapToBatteryInfo :: Map Text Variant -> BatteryInfo infoMapToBatteryInfo dict =-    BatteryInfo-      { batteryNativePath = readDict dict "NativePath" ""-      , batteryVendor = readDict dict "Vendor" ""-      , batteryModel = readDict dict "Model" ""-      , batterySerial = readDict dict "Serial" ""-      , batteryType = toEnum $ fromIntegral $ readDictIntegral dict "Type" 0-      , batteryPowerSupply = readDict dict "PowerSupply" False-      , batteryHasHistory = readDict dict "HasHistory" False-      , batteryHasStatistics = readDict dict "HasStatistics" False-      , batteryOnline = readDict dict "Online" False-      , batteryEnergy = readDict dict "Energy" 0.0-      , batteryEnergyEmpty = readDict dict "EnergyEmpty" 0.0-      , batteryEnergyFull = readDict dict "EnergyFull" 0.0-      , batteryEnergyFullDesign = readDict dict "EnergyFullDesign" 0.0-      , batteryEnergyRate = readDict dict "EnergyRate" 0.0-      , batteryVoltage = readDict dict "Voltage" 0.0-      , batteryTimeToEmpty = readDict dict "TimeToEmpty" 0-      , batteryTimeToFull = readDict dict "TimeToFull" 0-      , batteryPercentage = readDict dict "Percentage" 0.0-      , batteryIsPresent = readDict dict "IsPresent" False-      , batteryState = toEnum $ readDictIntegral dict "State" 0-      , batteryIsRechargeable = readDict dict "IsRechargable" True-      , batteryCapacity = readDict dict "Capacity" 0.0-      , batteryTechnology =-          toEnum $ fromIntegral $ readDictIntegral dict "Technology" 0-      , batteryUpdateTime = readDict dict "UpdateTime" 0-      , batteryLuminosity = readDict dict "Luminosity" 0.0-      , batteryTemperature = readDict dict "Temperature" 0.0-      , batteryWarningLevel = readDict dict "WarningLevel" 0-      , batteryBatteryLevel = readDict dict "BatteryLevel" 0-      , batteryIconName = readDict dict "IconName" ""-      }+  BatteryInfo+    { batteryNativePath = readDict dict "NativePath" "",+      batteryVendor = readDict dict "Vendor" "",+      batteryModel = readDict dict "Model" "",+      batterySerial = readDict dict "Serial" "",+      batteryType = toEnum $ fromIntegral $ readDictIntegral dict "Type" 0,+      batteryPowerSupply = readDict dict "PowerSupply" False,+      batteryHasHistory = readDict dict "HasHistory" False,+      batteryHasStatistics = readDict dict "HasStatistics" False,+      batteryOnline = readDict dict "Online" False,+      batteryEnergy = readDict dict "Energy" 0.0,+      batteryEnergyEmpty = readDict dict "EnergyEmpty" 0.0,+      batteryEnergyFull = readDict dict "EnergyFull" 0.0,+      batteryEnergyFullDesign = readDict dict "EnergyFullDesign" 0.0,+      batteryEnergyRate = readDict dict "EnergyRate" 0.0,+      batteryVoltage = readDict dict "Voltage" 0.0,+      batteryTimeToEmpty = readDict dict "TimeToEmpty" 0,+      batteryTimeToFull = readDict dict "TimeToFull" 0,+      batteryPercentage = readDict dict "Percentage" 0.0,+      batteryIsPresent = readDict dict "IsPresent" False,+      batteryState = toEnum $ readDictIntegral dict "State" 0,+      batteryIsRechargeable = readDict dict "IsRechargable" True,+      batteryCapacity = readDict dict "Capacity" 0.0,+      batteryTechnology =+        toEnum $ fromIntegral $ readDictIntegral dict "Technology" 0,+      batteryUpdateTime = readDict dict "UpdateTime" 0,+      batteryLuminosity = readDict dict "Luminosity" 0.0,+      batteryTemperature = readDict dict "Temperature" 0.0,+      batteryWarningLevel = readDict dict "WarningLevel" 0,+      batteryBatteryLevel = readDict dict "BatteryLevel" 0,+      batteryIconName = readDict dict "IconName" ""+    } +-- | Enumerate UPower object paths that represent batteries. getBatteryPaths :: TaffyIO (Either MethodError [ObjectPath]) getBatteryPaths = do   client <- asks systemDBusClient@@ -155,65 +173,80 @@     paths <- ExceptT $ enumerateDevices client     return $ filter isBattery paths -newtype DisplayBatteryChanVar =-  DisplayBatteryChanVar (TChan BatteryInfo, MVar BatteryInfo)+-- | Shared display-battery update channel and latest-value cache.+newtype DisplayBatteryChanVar+  = DisplayBatteryChanVar (TChan BatteryInfo, MVar BatteryInfo) +-- | Read the latest display battery snapshot. getDisplayBatteryInfo :: TaffyIO BatteryInfo getDisplayBatteryInfo = do   DisplayBatteryChanVar (_, theVar) <- getDisplayBatteryChanVar   lift $ readMVar theVar +-- | Default set of UPower properties that trigger display-battery refreshes. defaultMonitorDisplayBatteryProperties :: [String]-defaultMonitorDisplayBatteryProperties = [ "IconName", "State", "Percentage" ]+defaultMonitorDisplayBatteryProperties = ["IconName", "State", "Percentage"]  -- | Start the monitoring of the display battery, and setup the associated -- channel and mvar for the current state. setupDisplayBatteryChanVar :: [String] -> TaffyIO DisplayBatteryChanVar-setupDisplayBatteryChanVar properties = getStateDefault $-  DisplayBatteryChanVar <$> monitorDisplayBattery properties+setupDisplayBatteryChanVar properties =+  getStateDefault $+    DisplayBatteryChanVar <$> monitorDisplayBattery properties +-- | Get (or initialize) the shared display-battery channel+state holder. getDisplayBatteryChanVar :: TaffyIO DisplayBatteryChanVar getDisplayBatteryChanVar =   setupDisplayBatteryChanVar defaultMonitorDisplayBatteryProperties +-- | Get the broadcast channel for display-battery updates. getDisplayBatteryChan :: TaffyIO (TChan BatteryInfo) getDisplayBatteryChan = do   DisplayBatteryChanVar (chan, _) <- getDisplayBatteryChanVar   return chan -updateBatteryInfo-  :: TChan BatteryInfo-  -> MVar BatteryInfo-  -> ObjectPath-  -> TaffyIO ()+-- | Refresh battery info for a path and publish it to the shared state.+updateBatteryInfo ::+  TChan BatteryInfo ->+  MVar BatteryInfo ->+  ObjectPath ->+  TaffyIO () updateBatteryInfo chan var path =   getBatteryInfo path >>= lift . either warnOfFailure doWrites   where     doWrites info =-        batteryLogF DEBUG "Writing info %s" info >>-        swapMVar var info >> void (atomically $ writeTChan chan info)+      batteryLogF DEBUG "Writing info %s" info+        >> swapMVar var info+        >> void (atomically $ writeTChan chan info)     warnOfFailure = batteryLogF WARNING "Failed to update battery info %s" -registerForAnyUPowerPropertiesChanged-  :: (Signal -> String -> Map String Variant -> [String] -> IO ())-  -> ReaderT Context IO SignalHandler+-- | Register for any UPower device property changes.+registerForAnyUPowerPropertiesChanged ::+  (Signal -> String -> Map String Variant -> [String] -> IO ()) ->+  ReaderT Context IO SignalHandler registerForAnyUPowerPropertiesChanged = registerForUPowerPropertyChanges [] -registerForUPowerPropertyChanges-  :: [String]-  -> (Signal -> String -> Map String Variant -> [String] -> IO ())-  -> ReaderT Context IO SignalHandler+-- | Register for UPower device property changes, optionally filtering by+-- property names.+registerForUPowerPropertyChanges ::+  [String] ->+  (Signal -> String -> Map String Variant -> [String] -> IO ()) ->+  ReaderT Context IO SignalHandler registerForUPowerPropertyChanges properties signalHandler = do   client <- asks systemDBusClient-  lift $ DBus.registerForPropertiesChanged+  lift $+    DBus.registerForPropertiesChanged       client-      matchAny { matchInterface = Just uPowerDeviceInterfaceName-               , matchPathNamespace = Just uPowerDevicesPath }+      matchAny+        { matchInterface = Just uPowerDeviceInterfaceName,+          matchPathNamespace = Just uPowerDevicesPath+        }       handleIfPropertyMatches-  where handleIfPropertyMatches rawSignal n propertiesMap l =-          let propertyPresent prop = M.member prop propertiesMap-          in when (any propertyPresent properties || null properties) $-             signalHandler rawSignal n propertiesMap l+  where+    handleIfPropertyMatches rawSignal n propertiesMap l =+      let propertyPresent prop = M.member prop propertiesMap+       in when (any propertyPresent properties || null properties) $+            signalHandler rawSignal n propertiesMap l  -- | Monitor the DisplayDevice for changes, writing a new "BatteryInfo" object -- to returned "MVar" and "Chan" objects@@ -227,10 +260,12 @@   taffyFork $ do     ctx <- ask     let warnOfFailedGetDevice err =-          batteryLogF WARNING "Failure getting DisplayBattery: %s" err >>-          return "/org/freedesktop/UPower/devices/DisplayDevice"-    displayPath <- lift $ getDisplayDevice client >>=-                   either warnOfFailedGetDevice return+          batteryLogF WARNING "Failure getting DisplayBattery: %s" err+            >> return "/org/freedesktop/UPower/devices/DisplayDevice"+    displayPath <-+      lift $+        getDisplayDevice client+          >>= either warnOfFailedGetDevice return     let doUpdate = updateBatteryInfo chan infoVar displayPath         signalCallback _ _ changedProps _ =           do@@ -246,13 +281,16 @@ -- something is updated and the update actually being visible. See -- https://github.com/taffybar/taffybar/issues/330 for more details. refreshBatteriesOnPropChange :: TaffyIO ()-refreshBatteriesOnPropChange = ask >>= \ctx ->-  let updateIfRealChange _ _ changedProps _ =-        flip runReaderT ctx $-             when (any ((`notElem` ["UpdateTime", "Voltage"]) . fst) $-                       M.toList changedProps) $-                  lift (threadDelay 1000000) >> refreshAllBatteries-  in void $ registerForAnyUPowerPropertiesChanged updateIfRealChange+refreshBatteriesOnPropChange =+  ask >>= \ctx ->+    let updateIfRealChange _ _ changedProps _ =+          flip runReaderT ctx+            $ when+              ( any ((`notElem` ["UpdateTime", "Voltage"]) . fst) $+                  M.toList changedProps+              )+            $ lift (threadDelay 1000000) >> refreshAllBatteries+     in void $ registerForAnyUPowerPropertiesChanged updateIfRealChange  -- | Request a refresh of all UPower batteries. This is only needed if UPower's -- refresh mechanism is not working properly.@@ -266,8 +304,9 @@   -- NB. The Refresh() method is only available if the UPower daemon   -- was started in debug mode. So ignore any errors about the method   -- not being implemented.-  let logRefreshError e = unless (methodErrorName e == errorUnknownMethod) $-        batteryLogF ERROR "Failed to refresh battery: %s" e+  let logRefreshError e =+        unless (methodErrorName e == errorUnknownMethod) $+          batteryLogF ERROR "Failed to refresh battery: %s" e       logGetPathsError = batteryLogF ERROR "Failed to get battery paths %s"    void $ either logGetPathsError (mapM_ $ either logRefreshError return) eerror
src/System/Taffybar/Information/Bluetooth.hs view
@@ -1,5 +1,9 @@ {-# LANGUAGE OverloadedStrings #-}+ -----------------------------------------------------------------------------++-----------------------------------------------------------------------------+ -- | -- Module      : System.Taffybar.Information.Bluetooth -- Copyright   : (c) Ivan A. Malison@@ -17,28 +21,31 @@ -- 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(..)+    BluetoothInfo (..),+    BluetoothDevice (..),+    BluetoothController (..),+    BluetoothStatus (..),+     -- * Information Access-  , getBluetoothInfo-  , getBluetoothInfoChan-  , getBluetoothInfoState+    getBluetoothInfo,+    getBluetoothInfoChan,+    getBluetoothInfoState,+     -- * Connection-  , connectBluez-  ) where+    connectBluez,+  )+where -import Control.Concurrent (forkIO, threadDelay)+import Control.Concurrent (forkIO) import Control.Concurrent.MVar import Control.Concurrent.STM.TChan import Control.Exception (SomeException, finally, try)-import Control.Monad (forever)+import Control.Monad (forever, void) import Control.Monad.IO.Class (MonadIO, liftIO) import Control.Monad.STM (atomically)+import Control.Monad.Trans.Reader (asks) import DBus import DBus.Client import Data.List (sortOn)@@ -48,43 +55,46 @@ import Data.Text (Text) import qualified Data.Text as T import Data.Word (Word8)-import System.Log.Logger (Priority(..))+import System.Log.Logger (Priority (..)) import System.Taffybar.Context (TaffyIO, getStateDefault, systemDBusClient)+import System.Taffybar.Information.Wakeup (getWakeupChannelForDelay) 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)+  { 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)+  { 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)+  { bluetoothController :: Maybe BluetoothController,+    bluetoothConnectedDevices :: [BluetoothDevice],+    bluetoothAllDevices :: [BluetoothDevice],+    bluetoothStatus :: BluetoothStatus+  }+  deriving (Eq, Show)  -- | High-level Bluetooth status. data BluetoothStatus@@ -123,8 +133,8 @@ battery1InterfaceName = "org.bluez.Battery1"  -- | Newtype wrapper for the channel/mvar pair to enable getStateDefault.-newtype BluetoothInfoChanVar =-  BluetoothInfoChanVar (TChan BluetoothInfo, MVar BluetoothInfo)+newtype BluetoothInfoChanVar+  = BluetoothInfoChanVar (TChan BluetoothInfo, MVar BluetoothInfo)  -- | Get a broadcast channel for Bluetooth info updates. --@@ -146,27 +156,34 @@ getBluetoothInfoChanVar =   getStateDefault $ do     client <- asks systemDBusClient+    retryWakeupChan <- getWakeupChannelForDelay (5 :: Double)+    blockWakeupChan <- getWakeupChannelForDelay (1000 :: Double)+    retryOurWakeupChan <- liftIO $ atomically $ dupTChan retryWakeupChan+    blockOurWakeupChan <- liftIO $ atomically $ dupTChan blockWakeupChan     liftIO $ do       chan <- newBroadcastTChanIO       var <- newMVar defaultBluetoothInfo-      _ <- forkIO $ monitorBluetoothInfo client chan var+      _ <- forkIO $ monitorBluetoothInfo client retryOurWakeupChan blockOurWakeupChan chan var       pure $ BluetoothInfoChanVar (chan, var)  defaultBluetoothInfo :: BluetoothInfo-defaultBluetoothInfo = BluetoothInfo-  { bluetoothController = Nothing-  , bluetoothConnectedDevices = []-  , bluetoothAllDevices = []-  , bluetoothStatus = BluetoothNoController-  }+defaultBluetoothInfo =+  BluetoothInfo+    { bluetoothController = Nothing,+      bluetoothConnectedDevices = [],+      bluetoothAllDevices = [],+      bluetoothStatus = BluetoothNoController+    }  -- | Monitor Bluetooth information changes. monitorBluetoothInfo ::   Client ->+  TChan a ->+  TChan b ->   TChan BluetoothInfo ->   MVar BluetoothInfo ->   IO ()-monitorBluetoothInfo client chan var = do+monitorBluetoothInfo client retryWakeupChan blockWakeupChan chan var = do   refreshLock <- newMVar ()   let writeInfo info = do         _ <- swapMVar var info@@ -184,26 +201,29 @@        -- Match rule for BlueZ property changes       propertiesChangedMatcher :: MatchRule-      propertiesChangedMatcher = matchAny-        { matchSender = Just bluezBusName-        , matchInterface = Just propertiesInterfaceName-        , matchMember = Just "PropertiesChanged"-        }+      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"-        }+      interfacesAddedMatcher =+        matchAny+          { matchSender = Just bluezBusName,+            matchInterface = Just objectManagerInterfaceName,+            matchMember = Just "InterfacesAdded"+          }        interfacesRemovedMatcher :: MatchRule-      interfacesRemovedMatcher = matchAny-        { matchSender = Just bluezBusName-        , matchInterface = Just objectManagerInterfaceName-        , matchMember = Just "InterfacesRemoved"-        }+      interfacesRemovedMatcher =+        matchAny+          { matchSender = Just bluezBusName,+            matchInterface = Just objectManagerInterfaceName,+            matchMember = Just "InterfacesRemoved"+          }        loop = do         -- Initial refresh@@ -230,10 +250,10 @@           Right _ -> pure ()          -- Wait before retrying-        threadDelay 5000000+        void $ atomically $ readTChan retryWakeupChan         loop -      blockForever = forever $ threadDelay 1000000000+      blockForever = forever $ void $ atomically $ readTChan blockWakeupChan    loop @@ -256,12 +276,13 @@               | not (controllerPowered c) -> BluetoothOff               | not (null connectedDevices) -> BluetoothConnected               | otherwise -> BluetoothOn-      return BluetoothInfo-        { bluetoothController = controller-        , bluetoothConnectedDevices = connectedDevices-        , bluetoothAllDevices = devices-        , bluetoothStatus = status-        }+      return+        BluetoothInfo+          { bluetoothController = controller,+            bluetoothConnectedDevices = connectedDevices,+            bluetoothAllDevices = devices,+            bluetoothStatus = status+          }  -- | Get Bluetooth info using the system DBus client. getBluetoothInfo :: Client -> IO BluetoothInfo@@ -278,14 +299,18 @@ -- | 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 }+  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"+      Nothing ->+        Left $+          methodError (methodReturnSerial ret) $+            errorName_ "org.taffybar.InvalidResponse"       Just objects -> Right objects  -- | Parse controllers from managed objects.@@ -296,17 +321,18 @@     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+      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-        }+      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]@@ -316,19 +342,20 @@     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+      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-        }+      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/CPU.hs view
@@ -1,35 +1,18 @@-module System.Taffybar.Information.CPU ( cpuLoad ) where--import Control.Concurrent ( threadDelay )-import System.IO ( IOMode(ReadMode), openFile, hGetLine, hClose )+{-# LANGUAGE NamedFieldPuns #-} -procData :: IO [Double]-procData = do-  h <- openFile "/proc/stat" ReadMode-  firstLine <- hGetLine h-  length firstLine `seq` return ()-  hClose h-  return (procParser firstLine)+-- | Read short-window CPU utilization samples from @/proc/stat@.+module System.Taffybar.Information.CPU+  {-# DEPRECATED "Legacy CPU module. Use System.Taffybar.Information.CPU2.getCPULoadChan (preferred) or sampleCPULoad/CPULoad." #-}+  (cpuLoad)+where -procParser :: String -> [Double]-procParser = map read . drop 1 . words+import System.Taffybar.Information.CPU2 (CPULoad (..), sampleCPULoad) -truncVal :: Double -> Double-truncVal v-  | isNaN v || v < 0.0 = 0.0-  | otherwise = v+{-# DEPRECATED cpuLoad "Legacy API. Use System.Taffybar.Information.CPU2.getCPULoadChan (preferred) or sampleCPULoad." #-} --- | Return a pair with (user time, system time, total time) (read--- from /proc/stat).  The function waits for 50 ms between samples.+-- | Return a triple with (user time, system time, total time), sampled from+-- /proc/stat over 50ms. cpuLoad :: IO (Double, Double, Double) cpuLoad = do-  a <- procData-  threadDelay 50000-  b <- procData-  let dif = zipWith (-) b a-      tot = sum dif-      pct = map (/ tot) dif-      user = sum $ take 2 pct-      system = pct !! 2-      t = user + system-  return (truncVal user, truncVal system, truncVal t)+  CPULoad {cpuUserLoad, cpuSystemLoad, cpuTotalLoad} <- sampleCPULoad 0.05 "cpu"+  return (cpuUserLoad, cpuSystemLoad, cpuTotalLoad)
src/System/Taffybar/Information/CPU2.hs view
@@ -1,5 +1,9 @@ {-# LANGUAGE TupleSections #-}+ -----------------------------------------------------------------------------++-----------------------------------------------------------------------------+ -- | -- Module      : System.Taffybar.Information.CPU2 -- Copyright   : (c) José A. Romero L.@@ -14,12 +18,13 @@ -- "System.Taffybar.Information.StreamInfo" module. -- And also provides information about the temperature of cores. -- (Now supports only physical cpu).---------------------------------------------------------------------------------- module System.Taffybar.Information.CPU2 where +import Control.Concurrent (forkIO, threadDelay)+import Control.Concurrent.STM.TChan import Control.Monad+import Control.Monad.STM (atomically)+import Data.IORef import Data.List import Data.Maybe import Safe@@ -27,14 +32,25 @@ import System.FilePath import System.Taffybar.Information.StreamInfo +-- | Relative CPU load values, expressed as ratios in [0,1].+data CPULoad = CPULoad+  { cpuUserLoad :: Double,+    cpuSystemLoad :: Double,+    cpuTotalLoad :: Double+  }+  deriving (Eq, Show)+ -- | Returns a list of 5 to 7 elements containing all the values available for -- the given core (or all of them aggregated, if "cpu" is passed).+{-# DEPRECATED getCPUInfo "Legacy low-level API. Use getCPULoadChan (preferred) or sampleCPULoad." #-} getCPUInfo :: String -> IO [Int] getCPUInfo = getParsedInfo "/proc/stat" parse +-- | Parse @/proc/stat@ contents into CPU-name/sample tuples. parse :: String -> [(String, [Int])] parse = mapMaybe (tuplize . words) . filter (\x -> take 3 x == "cpu") . lines +-- | Convert tokenized @/proc/stat@ lines into a typed CPU sample entry. tuplize :: [String] -> Maybe (String, [Int]) tuplize s = do   cpu <- s `atMay` 0@@ -43,31 +59,79 @@ -- | Returns a two-element list containing relative system and user times -- calculated using two almost simultaneous samples of the @\/proc\/stat@ file -- for the given core (or all of them aggregated, if \"cpu\" is passed).+{-# DEPRECATED getCPULoad "Legacy polling API. Use getCPULoadChan (preferred) or sampleCPULoad." #-} getCPULoad :: String -> IO [Double] getCPULoad cpu = do   load <- getLoad 0.05 $ getCPUInfo cpu   case load of-    l0:l1:l2:_ -> return [ l0 + l1, l2 ]+    l0 : l1 : l2 : _ -> return [l0 + l1, l2]     _ -> return [] +-- | Sample CPU usage for a given core over the provided interval (seconds).+sampleCPULoad :: Double -> String -> IO CPULoad+sampleCPULoad interval cpu = toCPULoad <$> getLoad interval (getCPUInfo cpu)++-- | Build a broadcast channel that is fed by a polling thread.+--+-- Each channel has its own polling thread; if multiple widgets should share a+-- data source, create once and reuse the returned channel.+getCPULoadChan :: String -> Double -> IO (TChan CPULoad)+getCPULoadChan cpu interval = do+  chan <- newBroadcastTChanIO+  initial <- getCPUInfo cpu+  sample <- newIORef initial+  let delayMicroseconds = max 1 (floor $ interval * 1000000)+  _ <- forkIO $ forever $ do+    load <- toCPULoad <$> getAccLoad sample (getCPUInfo cpu)+    atomically $ writeTChan chan load+    threadDelay delayMicroseconds+  return chan++toCPULoad :: [Double] -> CPULoad+toCPULoad load =+  case load of+    l0 : l1 : l2 : _ ->+      CPULoad+        { cpuUserLoad = l0 + l1,+          cpuSystemLoad = l2,+          cpuTotalLoad = l0 + l1 + l2+        }+    _ ->+      CPULoad+        { cpuUserLoad = 0,+          cpuSystemLoad = 0,+          cpuTotalLoad = 0+        }+ -- | Get the directory in which core temperature files are kept. getCPUTemperatureDirectory :: IO FilePath getCPUTemperatureDirectory =-  (baseDir </>) . fromMaybe "hwmon0" .-  find (isPrefixOf "hwmon")-  <$> listDirectory baseDir-  where baseDir =-          "/"  </> "sys" </> "bus" </> "platform" </>-          "devices" </> "coretemp.0" </> "hwmon"+  (baseDir </>)+    . fromMaybe "hwmon0"+    . find (isPrefixOf "hwmon")+    <$> listDirectory baseDir+  where+    baseDir =+      "/"+        </> "sys"+        </> "bus"+        </> "platform"+        </> "devices"+        </> "coretemp.0"+        </> "hwmon" +-- | Read one core-temperature file from sysfs and convert milli-degrees to+-- degrees Celsius. readCPUTempFile :: FilePath -> IO Double readCPUTempFile cpuTempFilePath = (/ 1000) . read <$> readFile cpuTempFilePath +-- | List core-temperature input files in a hwmon directory. getAllTemperatureFiles :: FilePath -> IO [FilePath] getAllTemperatureFiles temperaturesDirectory =-  filter (liftM2 (&&) (isPrefixOf "temp") (isSuffixOf "input")) <$>-         listDirectory temperaturesDirectory+  filter (liftM2 (&&) (isPrefixOf "temp") (isSuffixOf "input"))+    <$> listDirectory temperaturesDirectory +-- | Read all available CPU core temperatures from sysfs. getCPUTemperatures :: IO [(String, Double)] getCPUTemperatures = do   dir <- getCPUTemperatureDirectory
src/System/Taffybar/Information/Chrome.hs view
@@ -1,93 +1,107 @@ {-# LANGUAGE OverloadedStrings #-}++-- | Track Chrome tab favicon updates and map them to X11 windows. module System.Taffybar.Information.Chrome where -import           Control.Concurrent-import           Control.Concurrent.STM.TChan-import           Control.Monad-import           Control.Monad.IO.Class-import           Control.Monad.STM (atomically)-import           Control.Monad.Trans.Class+import Control.Concurrent+import Control.Concurrent.STM.TChan+import Control.Monad+import Control.Monad.IO.Class+import Control.Monad.STM (atomically)+import Control.Monad.Trans.Class import qualified Data.ByteString as BS import qualified Data.ByteString.Lazy as LBS import qualified Data.Map as M-import           Data.Maybe+import Data.Maybe import qualified GI.GLib as Gdk import qualified GI.GdkPixbuf as Gdk-import           System.Log.Logger-import           System.Taffybar.Context-import           System.Taffybar.Information.EWMHDesktopInfo-import           System.Taffybar.Information.SafeX11-import           Text.Read hiding (lift)-import           Text.Regex-import           Web.Scotty+import System.Log.Logger+import System.Taffybar.Context+import System.Taffybar.Information.EWMHDesktopInfo+import System.Taffybar.Information.SafeX11+import Text.Read hiding (lift)+import Text.Regex+import Web.Scotty +-- | Module logger. logIO :: System.Log.Logger.Priority -> String -> IO () logIO = logM "System.Taffybar.Information.Chrome" +-- | Favicon image data associated with a Chrome tab id. data ChromeTabImageData = ChromeTabImageData-  { tabImageData :: Gdk.Pixbuf-  , tabImageDataId :: Int+  { tabImageData :: Gdk.Pixbuf,+    tabImageDataId :: Int   } -newtype ChromeTabImageDataState =-  ChromeTabImageDataState-  (MVar (M.Map Int ChromeTabImageData), TChan ChromeTabImageData)+-- | Shared favicon table and broadcast update channel.+newtype ChromeTabImageDataState+  = ChromeTabImageDataState+      (MVar (M.Map Int ChromeTabImageData), TChan ChromeTabImageData) +-- | Get or initialize Chrome favicon state. getChromeTabImageDataState :: TaffyIO ChromeTabImageDataState getChromeTabImageDataState = do   ChromeFaviconServerPort port <- fromMaybe (ChromeFaviconServerPort 5000) <$> getState   getStateDefault (listenForChromeFaviconUpdates port) +-- | Get the broadcast channel for favicon updates. getChromeTabImageDataChannel :: TaffyIO (TChan ChromeTabImageData) getChromeTabImageDataChannel = do   ChromeTabImageDataState (_, chan) <- getChromeTabImageDataState   return chan +-- | Get the mutable favicon table keyed by tab id. getChromeTabImageDataTable :: TaffyIO (MVar (M.Map Int ChromeTabImageData)) getChromeTabImageDataTable = do   ChromeTabImageDataState (table, _) <- getChromeTabImageDataState   return table +-- | TCP port used by the local Chrome favicon update server. newtype ChromeFaviconServerPort = ChromeFaviconServerPort Int +-- | Start an HTTP listener that receives favicon updates from browser helpers. listenForChromeFaviconUpdates :: Int -> TaffyIO ChromeTabImageDataState listenForChromeFaviconUpdates port = do   infoVar <- lift $ newMVar M.empty   inChan <- liftIO newBroadcastTChanIO   outChan <- liftIO . atomically $ dupTChan inChan-  _ <- lift $ forkIO $ scotty port $-    post "/setTabImageData/:tabID" $ do-      tabID <- queryParam "tabID"-      imageData <- LBS.toStrict <$> body-      when (BS.length imageData > 0) $ lift $ do-        loader <- Gdk.pixbufLoaderNew-        Gdk.pixbufLoaderWriteBytes loader =<< Gdk.bytesNew (Just imageData)-        Gdk.pixbufLoaderClose loader-        let updateChannelAndMVar pixbuf =-              let chromeTabImageData =-                    ChromeTabImageData-                    { tabImageData = pixbuf-                    , tabImageDataId = tabID-                    }-              in-                modifyMVar_ infoVar $ \currentMap ->-                  do-                    _ <- atomically $ writeTChan inChan chromeTabImageData-                    return $ M.insert tabID chromeTabImageData currentMap-        Gdk.pixbufLoaderGetPixbuf loader >>= maybe (return ()) updateChannelAndMVar+  _ <- lift $+    forkIO $+      scotty port $+        post "/setTabImageData/:tabID" $ do+          tabID <- queryParam "tabID"+          imageData <- LBS.toStrict <$> body+          when (BS.length imageData > 0) $ lift $ do+            loader <- Gdk.pixbufLoaderNew+            Gdk.pixbufLoaderWriteBytes loader =<< Gdk.bytesNew (Just imageData)+            Gdk.pixbufLoaderClose loader+            let updateChannelAndMVar pixbuf =+                  let chromeTabImageData =+                        ChromeTabImageData+                          { tabImageData = pixbuf,+                            tabImageDataId = tabID+                          }+                   in modifyMVar_ infoVar $ \currentMap ->+                        do+                          _ <- atomically $ writeTChan inChan chromeTabImageData+                          return $ M.insert tabID chromeTabImageData currentMap+            Gdk.pixbufLoaderGetPixbuf loader >>= maybe (return ()) updateChannelAndMVar   return $ ChromeTabImageDataState (infoVar, outChan) +-- | Mapping from X11 window ids to parsed Chrome tab ids. newtype X11WindowToChromeTabId = X11WindowToChromeTabId (MVar (M.Map X11Window Int)) +-- | Get or initialize the X11-window to tab-id mapping. getX11WindowToChromeTabId :: TaffyIO X11WindowToChromeTabId getX11WindowToChromeTabId =   getStateDefault $ X11WindowToChromeTabId <$> maintainX11WindowToChromeTabId +-- | Maintain and update the X11-window to tab-id mapping from title changes. maintainX11WindowToChromeTabId :: TaffyIO (MVar (M.Map X11Window Int)) maintainX11WindowToChromeTabId = do   startTabMap <- updateTabMap M.empty   tabMapVar <- lift $ newMVar startTabMap-  let handleEvent PropertyEvent { ev_window = window } =+  let handleEvent PropertyEvent {ev_window = window} =         do           title <- runX11Def "" $ getWindowTitle window           lift $ modifyMVar_ tabMapVar $ \currentMap -> do@@ -98,17 +112,21 @@   _ <- subscribeToPropertyEvents [ewmhWMName] handleEvent   return tabMapVar +-- | Regex for tab-id markers embedded in window titles. tabIDRegex :: Regex tabIDRegex = mkRegexWithOpts "[|]%([0-9]*)%[|]" True True +-- | Extract a tab id from a window title, if present. getTabIdFromTitle :: String -> Maybe Int getTabIdFromTitle title =   matchRegex tabIDRegex title >>= listToMaybe >>= readMaybe +-- | Insert or update a window->tab mapping based on a title string. addTabIdEntry :: M.Map X11Window Int -> (X11Window, String) -> M.Map X11Window Int addTabIdEntry theMap (win, title) =-          maybe theMap ((flip $ M.insert win) theMap) $ getTabIdFromTitle title+  maybe theMap ((flip $ M.insert win) theMap) $ getTabIdFromTitle title +-- | Rebuild the window->tab map by scanning all current X11 windows. updateTabMap :: M.Map X11Window Int -> TaffyIO (M.Map X11Window Int) updateTabMap tabMap =   runX11Def tabMap $ do
src/System/Taffybar/Information/Crypto.hs view
@@ -1,8 +1,12 @@-{-# LANGUAGE KindSignatures #-} {-# LANGUAGE DataKinds #-}-{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE KindSignatures #-} {-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE ScopedTypeVariables #-}+ -----------------------------------------------------------------------------++-----------------------------------------------------------------------------+ -- | -- Module      : System.Taffybar.Information.Crypto -- Copyright   : (c) Ivan A. Malison@@ -14,75 +18,96 @@ -- -- This module provides utility functions for retrieving data about crypto -- assets.------------------------------------------------------------------------------ module System.Taffybar.Information.Crypto where -import           Control.Concurrent-import           Control.Concurrent.STM.TChan-import           Control.Exception.Enclosed (catchAny)-import           Control.Monad-import           Control.Monad.IO.Class-import           Control.Monad.STM (atomically)-import           Data.Aeson-import           Data.Aeson.Types (parseMaybe)+import Control.Concurrent+import Control.Concurrent.STM.TChan+import Control.Exception.Enclosed (catchAny)+import Control.Monad+import Control.Monad.IO.Class+import Control.Monad.STM (atomically)+import Data.Aeson import qualified Data.Aeson.Key as Key+import Data.Aeson.Types (parseMaybe) import qualified Data.ByteString.Lazy as LBS import qualified Data.ByteString.UTF8 as BS import qualified Data.Map as M-import           Data.Maybe-import           Data.Proxy-import           Data.Text (Text)+import Data.Maybe+import Data.Proxy+import Data.Text (Text) import qualified Data.Text as T-import           GHC.TypeLits-import           Network.HTTP.Simple hiding (Proxy)-import           System.Log.Logger-import           System.Taffybar.Context-import           System.Taffybar.Util-import           Text.Printf+import GHC.TypeLits+import Network.HTTP.Simple hiding (Proxy)+import System.Log.Logger+import System.Taffybar.Context+import System.Taffybar.Util+import Text.Printf -getSymbolToCoinGeckoId :: MonadIO m => m (M.Map Text Text)+-- | Build a map from lowercase symbol to CoinGecko coin identifier.+getSymbolToCoinGeckoId :: (MonadIO m) => m (M.Map Text Text) getSymbolToCoinGeckoId = do-    let uri = "https://api.coingecko.com/api/v3/coins/list?include_platform=false"-        request = parseRequest_ uri-    bodyText <- liftIO $ catchAny (getResponseBody <$> httpLBS request) $ \e -> do-                           liftIO $ logM "System.Taffybar.Information.Crypto" WARNING $-                                  printf "Error fetching coins list from coin gecko %s" $ show e-                           return ""-    let coinInfos :: [CoinGeckoInfo]-        coinInfos = fromMaybe [] $ decode bodyText+  let uri = "https://api.coingecko.com/api/v3/coins/list?include_platform=false"+      request = parseRequest_ uri+  bodyText <- liftIO $ catchAny (getResponseBody <$> httpLBS request) $ \e -> do+    liftIO $+      logM "System.Taffybar.Information.Crypto" WARNING $+        printf "Error fetching coins list from coin gecko %s" $+          show e+    return ""+  let coinInfos :: [CoinGeckoInfo]+      coinInfos = fromMaybe [] $ decode bodyText -    return $ M.fromList $ map (\CoinGeckoInfo { identifier = theId, symbol = theSymbol } ->-                        (theSymbol, theId)) coinInfos+  return $+    M.fromList $+      map+        ( \CoinGeckoInfo {identifier = theId, symbol = theSymbol} ->+            (theSymbol, theId)+        )+        coinInfos +-- | Cached symbol-to-CoinGecko-id map. newtype SymbolToCoinGeckoId = SymbolToCoinGeckoId (M.Map Text Text) -newtype CryptoPriceInfo = CryptoPriceInfo { lastPrice :: Double }+-- | Last observed price value.+newtype CryptoPriceInfo = CryptoPriceInfo {lastPrice :: Double} -newtype CryptoPriceChannel (a :: Symbol) =-  CryptoPriceChannel (TChan CryptoPriceInfo, MVar CryptoPriceInfo)+-- | Broadcast channel and latest-value cache for a typed symbol pair.+newtype CryptoPriceChannel (a :: Symbol)+  = CryptoPriceChannel (TChan CryptoPriceInfo, MVar CryptoPriceInfo) -getCryptoPriceChannel :: KnownSymbol a => TaffyIO (CryptoPriceChannel a)+-- | Get (or initialize) the shared price channel for a symbol pair type.+getCryptoPriceChannel :: (KnownSymbol a) => TaffyIO (CryptoPriceChannel a) getCryptoPriceChannel = do   -- XXX: This is a gross hack that is needed to avoid deadlock   symbolToId <- getStateDefault $ SymbolToCoinGeckoId <$> getSymbolToCoinGeckoId   getStateDefault $ buildCryptoPriceChannel (60.0 :: Double) symbolToId -data CoinGeckoInfo =-  CoinGeckoInfo { identifier :: Text, symbol :: Text }+-- | Minimal record returned by CoinGecko coin-list endpoints.+data CoinGeckoInfo+  = CoinGeckoInfo {identifier :: Text, symbol :: Text}   deriving (Show)  instance FromJSON CoinGeckoInfo where   parseJSON = withObject "CoinGeckoInfo" (\v -> CoinGeckoInfo <$> v .: "id" <*> v .: "symbol") -logCrypto :: MonadIO m => Priority -> String -> m ()+-- | Log helper for crypto information code.+logCrypto :: (MonadIO m) => Priority -> String -> m () logCrypto p = liftIO . logM "System.Taffybar.Information.Crypto" p -resolveSymbolPair :: KnownSymbol a => Proxy a -> SymbolToCoinGeckoId -> Either String (Text, Text)+maxCryptoBackoffForDelay :: Double -> Double+maxCryptoBackoffForDelay delay = delay * 16++nextCryptoBackoff :: Double -> Double -> (Double, Double)+nextCryptoBackoff maxBackoff current =+  (min (current * 2) maxBackoff, current)++-- | Resolve a type-level symbol pair like @BTC-USD@ into a CoinGecko id and+-- quote currency.+resolveSymbolPair :: (KnownSymbol a) => Proxy a -> SymbolToCoinGeckoId -> Either String (Text, Text) resolveSymbolPair sym symbolToId = do   (symbolName, inCurrency) <- parseSymbolPair (symbolVal sym)   cgIdentifier <- lookupSymbolCoinGeckoId symbolToId symbolName   pure (cgIdentifier, inCurrency)-   where     parseSymbolPair :: String -> Either String (Text, Text)     parseSymbolPair symbolPair = case T.splitOn "-" (T.toLower $ T.pack symbolPair) of@@ -90,14 +115,17 @@       _ -> Left $ printf "Type parameter \"%s\" does not match the form \"ASSET-CURRENCY\"" symbolPair      lookupSymbolCoinGeckoId :: SymbolToCoinGeckoId -> Text -> Either String Text-    lookupSymbolCoinGeckoId (SymbolToCoinGeckoId m) symbolName = maybeToEither-      (printf "Symbol \"%s\" not found in coin gecko list" (T.unpack symbolName))-      (M.lookup symbolName m)+    lookupSymbolCoinGeckoId (SymbolToCoinGeckoId m) symbolName =+      maybeToEither+        (printf "Symbol \"%s\" not found in coin gecko list" (T.unpack symbolName))+        (M.lookup symbolName m) +-- | Create a background polling channel for a symbol pair with retry backoff. buildCryptoPriceChannel ::-  forall a. KnownSymbol a => Double -> SymbolToCoinGeckoId -> TaffyIO (CryptoPriceChannel a)+  forall a. (KnownSymbol a) => Double -> SymbolToCoinGeckoId -> TaffyIO (CryptoPriceChannel a) buildCryptoPriceChannel delay symbolToId = do   let initialBackoff = delay+      maxBackoff = maxCryptoBackoffForDelay delay   chan <- liftIO newBroadcastTChanIO   var <- liftIO $ newMVar $ CryptoPriceInfo 0.0   backoffVar <- liftIO $ newMVar initialBackoff@@ -111,27 +139,40 @@   case resolveSymbolPair (Proxy :: Proxy a) symbolToId of     Left err -> logCrypto WARNING err     Right (cgIdentifier, inCurrency) ->-      void $ foreverWithVariableDelay $-           catchAny (liftIO $ getLatestPrice cgIdentifier inCurrency >>=-                            maybe (return ()) (doWrites . CryptoPriceInfo) >> return delay) $ \e -> do-                                     logCrypto WARNING $ printf "Error when fetching crypto price: %s" (show e)-                                     modifyMVar backoffVar $ \current ->-                                       return (min (current * 2) delay, current)+      void+        $ foreverWithVariableDelay+        $ catchAny+          ( liftIO $+              getLatestPrice cgIdentifier inCurrency+                >>= maybe (return ()) (doWrites . CryptoPriceInfo)+                >> return delay+          )+        $ \e -> do+          logCrypto WARNING $ printf "Error when fetching crypto price: %s" (show e)+          modifyMVar backoffVar $ \current ->+            return $ nextCryptoBackoff maxBackoff current    return $ CryptoPriceChannel (chan, var) -getLatestPrice :: MonadIO m => Text -> Text -> m (Maybe Double)+-- | Fetch the latest price for one CoinGecko id in a target currency.+getLatestPrice :: (MonadIO m) => Text -> Text -> m (Maybe Double) getLatestPrice tokenId inCurrency = do-  let uri = printf "https://api.coingecko.com/api/v3/simple/price?ids=%s&vs_currencies=%s"-            tokenId inCurrency+  let uri =+        printf+          "https://api.coingecko.com/api/v3/simple/price?ids=%s&vs_currencies=%s"+          tokenId+          inCurrency       request = parseRequest_ uri   bodyText <- getResponseBody <$> httpLBS request   return $ decode bodyText >>= parseMaybe ((.: Key.fromText tokenId) >=> (.: Key.fromText inCurrency)) -getCryptoMeta :: MonadIO m => String -> String -> m LBS.ByteString+-- | Fetch metadata for a symbol from CoinMarketCap's API.+getCryptoMeta :: (MonadIO m) => String -> String -> m LBS.ByteString getCryptoMeta cmcAPIKey symbolName = do   let headers = [("X-CMC_PRO_API_KEY", BS.fromString cmcAPIKey)] :: RequestHeaders-      uri = printf "https://pro-api.coinmarketcap.com/v1/cryptocurrency/info?symbol=%s"-            symbolName+      uri =+        printf+          "https://pro-api.coinmarketcap.com/v1/cryptocurrency/info?symbol=%s"+          symbolName       request = setRequestHeaders headers $ parseRequest_ uri   getResponseBody <$> httpLBS request
src/System/Taffybar/Information/DiskIO.hs view
@@ -1,4 +1,7 @@ -----------------------------------------------------------------------------++-----------------------------------------------------------------------------+ -- | -- Module      : System.Taffybar.Information.DiskIO -- Copyright   : (c) José A. Romero L.@@ -11,13 +14,11 @@ -- Provides information about read/write operations in a given disk or -- partition, obtained from parsing the @\/proc\/diskstats@ file with some -- of the facilities included in the "System.Taffybar.Information.StreamInfo" module.--------------------------------------------------------------------------------module System.Taffybar.Information.DiskIO ( getDiskTransfer ) where+module System.Taffybar.Information.DiskIO (getDiskTransfer) where -import Data.Maybe ( mapMaybe )-import Safe ( atMay, headMay, readDef )-import System.Taffybar.Information.StreamInfo ( getParsedInfo, getTransfer )+import Data.Maybe (mapMaybe)+import Safe (atMay, headMay, readDef)+import System.Taffybar.Information.StreamInfo (getParsedInfo, getTransfer)  -- | Returns a two-element list containing the speed of transfer for read and -- write operations performed in the given disk\/partition (e.g. \"sda\",@@ -39,4 +40,3 @@   used <- s `atMay` 3   capacity <- s `atMay` 7   return (device, [readDef (-1) used, readDef (-1) capacity])-
src/System/Taffybar/Information/DiskUsage.hs view
@@ -1,4 +1,7 @@ -----------------------------------------------------------------------------++-----------------------------------------------------------------------------+ -- | -- Module      : System.Taffybar.Information.DiskUsage -- Copyright   : (c) Ivan A. Malison@@ -19,71 +22,74 @@ -- 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+  ( 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 (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.DiskSpace (diskAvail, diskFree, diskTotal, getDiskUsage)+import System.Log.Logger (Priority (..)) import System.Taffybar.Context (TaffyIO, getStateDefault)+import System.Taffybar.Information.Wakeup (taffyForeverWithDelay) import System.Taffybar.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)+  { -- | Total space in bytes.+    diskInfoTotal :: !Integer,+    -- | Free space in bytes (includes reserved blocks).+    diskInfoFree :: !Integer,+    -- | Space available to unprivileged users, in bytes.+    diskInfoAvailable :: !Integer,+    -- | Used space in bytes (@total - free@).+    diskInfoUsed :: !Integer,+    -- | Percentage of total space that is used.+    diskInfoUsedPercent :: !Double,+    -- | Percentage of total space available to unprivileged users.+    diskInfoFreePercent :: !Double+  }+  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+      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-    }+      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)+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.@@ -99,17 +105,20 @@   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")+setupDiskUsageChanVar interval path = getStateDefault $ do+  chan <- liftIO newBroadcastTChanIO+  info <- liftIO $ getDiskUsageInfo path+  var <- liftIO $ newMVar info+  void $+    taffyForeverWithDelay interval $+      liftIO $+        catchAny+          ( do+              newInfo <- getDiskUsageInfo path+              void $ swapMVar var newInfo+              atomically $ writeTChan chan newInfo+          )+          (logPrintF logName WARNING "DiskUsage poll failed: %s")   pure $ DiskUsageChanVar (chan, var)  logName :: String
src/System/Taffybar/Information/EWMHDesktopInfo.hs view
@@ -1,4 +1,7 @@ -----------------------------------------------------------------------------++-----------------------------------------------------------------------------+ -- | -- Module      : System.Taffybar.Information.EWMHDesktopInfo -- Copyright   : (c) José A. Romero L.@@ -16,50 +19,48 @@ -- > import XMonad.Hooks.EwmhDesktops (ewmh) -- > -- > main = xmonad $ ewmh $ ...---------------------------------------------------------------------------------- module System.Taffybar.Information.EWMHDesktopInfo-  ( EWMHIcon(..)-  , EWMHIconData-  , WorkspaceId(..)-  , X11Window-  , allEWMHProperties-  , ewmhActiveWindow-  , ewmhClientList-  , ewmhClientListStacking-  , ewmhCurrentDesktop-  , ewmhDesktopNames-  , ewmhNumberOfDesktops-  , ewmhStateHidden-  , ewmhWMClass-  , ewmhWMDesktop-  , ewmhWMIcon-  , ewmhWMName-  , ewmhWMName2-  , ewmhWMState-  , ewmhWMStateHidden-  , focusWindow-  , getActiveWindow-  , getCurrentWorkspace-  , getVisibleWorkspaces-  , getWindowClass-  , getWindowIconsData-  , getWindowMinimized-  , getWindowState-  , getWindowStateProperty-  , getWindowTitle-  , getWindows-  , getWindowsStacking-  , getWorkspace-  , getWorkspaceNames-  , isWindowUrgent-  , parseWindowClasses-  , switchOneWorkspace-  , switchToWorkspace-  , withX11Context-  , withEWMHIcons-  ) where+  ( EWMHIcon (..),+    EWMHIconData,+    WorkspaceId (..),+    X11Window,+    allEWMHProperties,+    ewmhActiveWindow,+    ewmhClientList,+    ewmhClientListStacking,+    ewmhCurrentDesktop,+    ewmhDesktopNames,+    ewmhNumberOfDesktops,+    ewmhStateHidden,+    ewmhWMClass,+    ewmhWMDesktop,+    ewmhWMIcon,+    ewmhWMName,+    ewmhWMName2,+    ewmhWMState,+    ewmhWMStateHidden,+    focusWindow,+    getActiveWindow,+    getCurrentWorkspace,+    getVisibleWorkspaces,+    getWindowClass,+    getWindowIconsData,+    getWindowMinimized,+    getWindowState,+    getWindowStateProperty,+    getWindowTitle,+    getWindows,+    getWindowsStacking,+    getWorkspace,+    getWorkspaceNames,+    isWindowUrgent,+    parseWindowClasses,+    switchOneWorkspace,+    switchToWorkspace,+    withX11Context,+    withEWMHIcons,+  )+where  import Control.Monad ((>=>)) import Control.Monad.IO.Class@@ -77,9 +78,10 @@ import System.Taffybar.Information.SafeX11 import System.Taffybar.Information.X11DesktopInfo -logHere :: MonadIO m => Priority -> String -> m ()+logHere :: (MonadIO m) => Priority -> String -> m () logHere p = liftIO . logM "System.Taffybar.Information.EWMHDesktopInfo" p +-- | Workspace index (starting at 0). newtype WorkspaceId = WorkspaceId Int deriving (Show, Read, Ord, Eq)  -- A super annoying detail of the XGetWindowProperty interface is that: "If the@@ -93,52 +95,98 @@  type EWMHProperty = String -ewmhActiveWindow, ewmhClientList, ewmhClientListStacking, ewmhCurrentDesktop, ewmhDesktopNames, ewmhNumberOfDesktops, ewmhStateHidden, ewmhWMDesktop, ewmhWMStateHidden, ewmhWMClass, ewmhWMState, ewmhWMIcon, ewmhWMName, ewmhWMName2 :: EWMHProperty+-- | EWMH property name for active window id.+ewmhActiveWindow :: EWMHProperty ewmhActiveWindow = "_NET_ACTIVE_WINDOW"++-- | EWMH property name for client list in mapping order.+ewmhClientList :: EWMHProperty ewmhClientList = "_NET_CLIENT_LIST"++-- | EWMH property name for client list in stacking order.+ewmhClientListStacking :: EWMHProperty ewmhClientListStacking = "_NET_CLIENT_LIST_STACKING"++-- | EWMH property name for current desktop index.+ewmhCurrentDesktop :: EWMHProperty ewmhCurrentDesktop = "_NET_CURRENT_DESKTOP"++-- | EWMH property name for desktop names.+ewmhDesktopNames :: EWMHProperty ewmhDesktopNames = "_NET_DESKTOP_NAMES"++-- | EWMH property name for number of desktops.+ewmhNumberOfDesktops :: EWMHProperty ewmhNumberOfDesktops = "_NET_NUMBER_OF_DESKTOPS"++-- | EWMH atom name for hidden window state.+ewmhStateHidden :: EWMHProperty ewmhStateHidden = "_NET_WM_STATE_HIDDEN"++-- | ICCCM property name for window class.+ewmhWMClass :: EWMHProperty ewmhWMClass = "WM_CLASS"++-- | EWMH property name for window desktop assignment.+ewmhWMDesktop :: EWMHProperty ewmhWMDesktop = "_NET_WM_DESKTOP"++-- | EWMH property name for window icon data.+ewmhWMIcon :: EWMHProperty ewmhWMIcon = "_NET_WM_ICON"++-- | EWMH property name for UTF-8 window title.+ewmhWMName :: EWMHProperty ewmhWMName = "_NET_WM_NAME"++-- | Fallback ICCCM property name for window title.+ewmhWMName2 :: EWMHProperty ewmhWMName2 = "WM_NAME"++-- | EWMH property name for window state list.+ewmhWMState :: EWMHProperty ewmhWMState = "_NET_WM_STATE"++-- | EWMH atom string for hidden window state entry.+ewmhWMStateHidden :: EWMHProperty ewmhWMStateHidden = "_NET_WM_STATE_HIDDEN" +-- | List of EWMH property names commonly observed by workspace/window widgets. allEWMHProperties :: [EWMHProperty] allEWMHProperties =-  [ ewmhActiveWindow-  , ewmhClientList-  , ewmhClientListStacking-  , ewmhCurrentDesktop-  , ewmhDesktopNames-  , ewmhNumberOfDesktops-  , ewmhStateHidden-  , ewmhWMClass-  , ewmhWMDesktop-  , ewmhWMIcon-  , ewmhWMName-  , ewmhWMName2-  , ewmhWMState-  , ewmhWMStateHidden+  [ ewmhActiveWindow,+    ewmhClientList,+    ewmhClientListStacking,+    ewmhCurrentDesktop,+    ewmhDesktopNames,+    ewmhNumberOfDesktops,+    ewmhStateHidden,+    ewmhWMClass,+    ewmhWMDesktop,+    ewmhWMIcon,+    ewmhWMName,+    ewmhWMName2,+    ewmhWMState,+    ewmhWMStateHidden   ] +-- | Raw EWMH icon data buffer and element count. type EWMHIconData = (ForeignPtr PixelsWordType, Int) +-- | Parsed EWMH icon entry. data EWMHIcon = EWMHIcon-  { ewmhWidth :: Int-  , ewmhHeight :: Int-  , ewmhPixelsARGB :: Ptr PixelsWordType-  } deriving (Show, Eq)+  { ewmhWidth :: Int,+    ewmhHeight :: Int,+    ewmhPixelsARGB :: Ptr PixelsWordType+  }+  deriving (Show, Eq) +-- | Check whether a particular EWMH window-state atom is present. getWindowStateProperty :: String -> X11Window -> X11Property Bool getWindowStateProperty property window =   not . null <$> getWindowState window [property] +-- | Read and decode the EWMH window state list, filtered to requested names. getWindowState :: X11Window -> [String] -> X11Property [String] getWindowState window request = do   let getAsLong s = fromIntegral <$> getAtom s@@ -172,7 +220,8 @@ -- available. getWorkspaceNames :: X11Property [(WorkspaceId, String)] getWorkspaceNames = go <$> readAsListOfString Nothing ewmhDesktopNames-  where go = zip [WorkspaceId i | i <- [0..]]+  where+    go = zip [WorkspaceId i | i <- [0 ..]]  -- | Ask the window manager to switch to the workspace with the given -- index, starting from 0.@@ -190,13 +239,13 @@ -- | Check for corner case and switch one workspace up getPrev :: WorkspaceId -> Int -> WorkspaceId getPrev (WorkspaceId idx) end-  | idx > 0 = WorkspaceId $ idx-1+  | idx > 0 = WorkspaceId $ idx - 1   | otherwise = WorkspaceId end  -- | Check for corner case and switch one workspace down getNext :: WorkspaceId -> Int -> WorkspaceId getNext (WorkspaceId idx) end-  | idx < end = WorkspaceId $ idx+1+  | idx < end = WorkspaceId $ idx + 1   | otherwise = WorkspaceId 0  -- | Get the title of the given X11 window.@@ -206,12 +255,13 @@   prop <- readAsString w ewmhWMName   case prop of     "" -> readAsString w ewmhWMName2-    _  -> return prop+    _ -> return prop  -- | Get the class of the given X11 window. getWindowClass :: X11Window -> X11Property String getWindowClass window = readAsString (Just window) ewmhWMClass +-- | Split a raw @WM_CLASS@ string into non-empty class components. parseWindowClasses :: String -> [String] parseWindowClasses = filter (not . null) . splitOn "\NUL" @@ -248,14 +298,14 @@       newArr = advancePtr pixelsPtr thisSize       thisIcon =         EWMHIcon-        { ewmhWidth = iwidth-        , ewmhHeight = iheight-        , ewmhPixelsARGB = pixelsPtr-        }+          { ewmhWidth = iwidth,+            ewmhHeight = iheight,+            ewmhPixelsARGB = pixelsPtr+          }       getRes newSize         | newSize < 0 =-          logHere ERROR "Attempt to recurse on negative value in parseIcons"-                    >> return []+            logHere ERROR "Attempt to recurse on negative value in parseIcons"+              >> return []         | otherwise = (thisIcon :) <$> parseIcons newSize newArr   getRes $ totalSize - fromIntegral (thisSize + 2)
src/System/Taffybar/Information/Hyprland.hs view
@@ -1,6 +1,9 @@ {-# LANGUAGE OverloadedStrings #-}  -----------------------------------------------------------------------------++-----------------------------------------------------------------------------+ -- | -- Module      : System.Taffybar.Information.Hyprland -- Copyright   : (c) Ivan A. Malison@@ -16,93 +19,92 @@ -- -- 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+    HyprlandClient,+    HyprlandClientConfig (..),+    defaultHyprlandClientConfig,+    newHyprlandClient,+    reloadHyprlandClient,+    HyprlandClientEnv (..),+    getHyprlandClientEnv,      -- * Hyprland Monad-  , HyprlandT-  , runHyprlandT-  , askHyprlandClient-  , runHyprlandCommandRawM-  , runHyprlandCommandJsonM+    HyprlandT,+    runHyprlandT,+    askHyprlandClient,+    runHyprlandCommandRawM,+    runHyprlandCommandJsonM,      -- * Shared Event Channel-  , HyprlandEventChan(..)-  , subscribeHyprlandEvents-  , buildHyprlandEventChan+    HyprlandEventChan (..),+    subscribeHyprlandEvents,+    buildHyprlandEventChan,      -- * Commands-  , HyprlandCommand(..)-  , hyprCommand-  , hyprCommandJson-  , hyprlandCommandToSocketCommand-  , runHyprlandCommandRaw-  , runHyprlandCommandJson+    HyprlandCommand (..),+    hyprCommand,+    hyprCommandJson,+    hyprlandCommandToSocketCommand,+    runHyprlandCommandRaw,+    runHyprlandCommandJson,      -- * Sockets-  , HyprlandSocket(..)-  , hyprlandSocketName-  , hyprlandSocketPaths-  , openHyprlandSocket-  , openHyprlandEventSocket-  , withHyprlandEventSocket+    HyprlandSocket (..),+    hyprlandSocketName,+    hyprlandSocketPaths,+    openHyprlandSocket,+    openHyprlandEventSocket,+    withHyprlandEventSocket,      -- * Monitor queries-  , getFocusedMonitorPosition+    getFocusedMonitorPosition,      -- * Errors-  , HyprlandError(..)-  ) where+    HyprlandError (..),+  )+where -import           Control.Concurrent (forkIO, threadDelay)-import           Control.Concurrent.STM.TChan-  ( TChan-  , dupTChan-  , newBroadcastTChanIO-  , writeTChan+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', withObject, (.:))+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', withObject, (.:)) import qualified Data.ByteString as BS import qualified Data.ByteString.Char8 as BS8 import qualified Data.ByteString.Lazy as BL-import           Data.List (sortOn)-import           Data.Ord (Down(..))+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.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)+import System.Log.Logger (Priority (..), logM)+import System.Posix.Files (getFileStatus, isSocket, modificationTime)+import System.Posix.Types (EpochTime)+import System.Taffybar.Util (runCommand)+import Text.Printf (printf) +-- | Errors that can occur while talking to Hyprland. data HyprlandError   = HyprlandEnvMissing String   | HyprlandSocketUnavailable HyprlandSocket [FilePath]@@ -112,27 +114,35 @@   | HyprlandCommandBuildFailed String   deriving (Show, Eq) +-- | Configuration for creating and using a 'HyprlandClient'. 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)+  { -- | Try the Hyprland command/event sockets when possible.+    useSocket :: Bool,+    -- | If the socket path is unavailable, fall back to invoking @hyprctl@.+    fallbackToHyprctl :: Bool,+    hyprctlPath :: FilePath+  }+  deriving (Show, Eq) +-- | Default 'HyprlandClientConfig'.+--+-- Uses sockets when available and falls back to @hyprctl@. defaultHyprlandClientConfig :: HyprlandClientConfig defaultHyprlandClientConfig =   HyprlandClientConfig-    { useSocket = True-    , fallbackToHyprctl = True-    , hyprctlPath = "hyprctl"+    { useSocket = True,+      fallbackToHyprctl = True,+      hyprctlPath = "hyprctl"     } +-- | Environment-derived values used for socket path resolution. data HyprlandClientEnv = HyprlandClientEnv-  { instanceSignature :: String-  , runtimeDir :: Maybe FilePath-  } deriving (Show, Eq)+  { instanceSignature :: String,+    runtimeDir :: Maybe FilePath+  }+  deriving (Show, Eq) +-- | Read Hyprland-specific values from the process environment. getHyprlandClientEnv :: IO (Either HyprlandError HyprlandClientEnv) getHyprlandClientEnv = do   mSig <- lookupEnv "HYPRLAND_INSTANCE_SIGNATURE"@@ -141,15 +151,19 @@       return $ Left $ HyprlandEnvMissing "HYPRLAND_INSTANCE_SIGNATURE"     Just sig -> do       mRuntime <- lookupEnv "XDG_RUNTIME_DIR"-      return $ Right $ HyprlandClientEnv-        { instanceSignature = sig-        , runtimeDir = mRuntime-        }+      return $+        Right $+          HyprlandClientEnv+            { instanceSignature = sig,+              runtimeDir = mRuntime+            } +-- | Runtime client state used by command and event helpers. data HyprlandClient = HyprlandClient-  { clientConfig :: HyprlandClientConfig-  , clientEnv :: Maybe HyprlandClientEnv-  } deriving (Show, Eq)+  { clientConfig :: HyprlandClientConfig,+    clientEnv :: Maybe HyprlandClientEnv+  }+  deriving (Show, Eq)  -- | Construct a 'HyprlandClient' by reading environment variables. --@@ -160,7 +174,7 @@ newHyprlandClient cfg = do   envResult <- getHyprlandClientEnv   let env = either (const Nothing) Just envResult-  pure $ HyprlandClient { clientConfig = cfg, clientEnv = env }+  pure $ HyprlandClient {clientConfig = cfg, clientEnv = env}  -- | Reload the environment-derived portions of a 'HyprlandClient'. reloadHyprlandClient :: HyprlandClient -> IO HyprlandClient@@ -169,50 +183,59 @@ -- | A reader transformer that carries a 'HyprlandClient'. type HyprlandT m a = ReaderT HyprlandClient m a +-- | Run a 'HyprlandT' computation with the provided client. runHyprlandT :: HyprlandClient -> HyprlandT m a -> m a runHyprlandT = flip runReaderT -askHyprlandClient :: Monad m => HyprlandT m HyprlandClient+-- | Get the current 'HyprlandClient' from 'HyprlandT'.+askHyprlandClient :: (Monad m) => HyprlandT m HyprlandClient askHyprlandClient = ask +-- | Run a command in 'HyprlandT' and return the raw bytes response. runHyprlandCommandRawM :: (MonadIO m) => HyprlandCommand -> HyprlandT m (Either HyprlandError BS.ByteString) runHyprlandCommandRawM cmd = do   client <- ask   liftIO $ runHyprlandCommandRaw client cmd +-- | Run a command in 'HyprlandT' and decode the response as JSON. runHyprlandCommandJsonM :: (MonadIO m, FromJSON a) => HyprlandCommand -> HyprlandT m (Either HyprlandError a) runHyprlandCommandJsonM cmd = do   client <- ask   liftIO $ runHyprlandCommandJson client cmd +-- | Which Hyprland socket should be used for a request. data HyprlandSocket   = HyprlandCommandSocket   | HyprlandEventSocket   deriving (Show, Eq) +-- | Socket file basename for a given 'HyprlandSocket' kind. hyprlandSocketName :: HyprlandSocket -> FilePath hyprlandSocketName HyprlandCommandSocket = ".socket.sock" hyprlandSocketName HyprlandEventSocket = ".socket2.sock" +-- | Candidate socket paths for a client and socket type. hyprlandSocketPaths :: HyprlandClient -> HyprlandSocket -> [FilePath]-hyprlandSocketPaths HyprlandClient { clientEnv = Nothing } _ = []+hyprlandSocketPaths HyprlandClient {clientEnv = Nothing} _ = [] hyprlandSocketPaths   HyprlandClient     { clientEnv =-        Just HyprlandClientEnv-          { instanceSignature = sig-          , runtimeDir = mRuntimeDir-          }+        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]+    let name = hyprlandSocketName sock+        runtimePaths =+          case mRuntimeDir of+            Nothing -> []+            Just rd -> [rd ++ "/hypr/" ++ sig ++ "/" ++ name]+        tmpPath = "/tmp/hypr/" ++ sig ++ "/" ++ name+     in runtimePaths ++ [tmpPath] +-- | Open a Hyprland unix socket, trying known and discovered locations. openHyprlandSocket :: HyprlandClient -> HyprlandSocket -> IO (Either HyprlandError NS.Socket) openHyprlandSocket client sock = do   -- Prefer the instance signature from the process environment first. If that@@ -234,7 +257,7 @@   where     connectFirst :: [FilePath] -> IO (Maybe NS.Socket)     connectFirst [] = pure Nothing-    connectFirst (path:rest) = do+    connectFirst (path : rest) = do       result <- connectToSocket path       case result of         Left _ -> connectFirst rest@@ -244,8 +267,8 @@ discoverHyprlandSocketPaths _client sock = do   mRuntime <- lookupEnv "XDG_RUNTIME_DIR"   let bases =-        maybe [] (\rd -> [rd </> "hypr"]) mRuntime ++-        ["/tmp/hypr"]+        maybe [] (\rd -> [rd </> "hypr"]) mRuntime+          ++ ["/tmp/hypr"]   let name = hyprlandSocketName sock   pathsWithTimes <- fmap concat $ forM bases $ \base -> do     baseExists <- doesDirectoryExist base@@ -265,23 +288,26 @@  socketPathMTime :: FilePath -> IO (Maybe EpochTime) socketPathMTime path =-  (do+  ( do       st <- getFileStatus path       if isSocket st         then pure $ Just $ modificationTime st         else pure Nothing-    ) `catchAny` \_ -> 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+  ( do       NS.connect sock (NS.SockAddrUnix path)       return $ Right sock-    ) `catchAny` \e -> do+    )+    `catchAny` \e -> do       void $ NS.close sock `catchAny` \_ -> pure ()       return $ Left $ HyprlandSocketException path (show e) +-- | Open the Hyprland event socket and return it as a line-buffered 'Handle'. openHyprlandEventSocket :: HyprlandClient -> IO (Either HyprlandError Handle) openHyprlandEventSocket client = do   sockResult <- openHyprlandSocket client HyprlandEventSocket@@ -292,30 +318,34 @@       hSetBuffering handle LineBuffering       return (Right handle) +-- | Bracket-style helper for safely using the Hyprland event socket 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+      ( do           result <- action handle           hClose handle           return (Right result)-        ) `catchAny` \e -> do+      )+        `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)+newtype HyprlandEventChan+  = HyprlandEventChan (TChan T.Text) +-- | Subscribe to a per-reader cursor for a shared Hyprland event channel. subscribeHyprlandEvents :: HyprlandEventChan -> IO (TChan T.Text) subscribeHyprlandEvents (HyprlandEventChan chan) =   atomically $ dupTChan chan +-- | Create and maintain a shared Hyprland event broadcast channel. buildHyprlandEventChan :: HyprlandClient -> IO HyprlandEventChan buildHyprlandEventChan client = do   chan <- newBroadcastTChanIO@@ -347,9 +377,9 @@  -- | Minimal monitor info parsed from @hyprctl monitors -j@. data HyprMonitorInfo = HyprMonitorInfo-  { hmX :: Int-  , hmY :: Int-  , hmFocused :: Bool+  { hmX :: Int,+    hmY :: Int,+    hmFocused :: Bool   }  instance FromJSON HyprMonitorInfo where@@ -367,22 +397,27 @@     Left _ -> return Nothing     Right monitors ->       case filter hmFocused monitors of-        (m:_) -> return $ Just (hmX m, hmY m)+        (m : _) -> return $ Just (hmX m, hmY m)         [] -> return Nothing +-- | Structured representation of a Hyprland command invocation. data HyprlandCommand = HyprlandCommand-  { commandArgs :: [String]-  , commandJson :: Bool-  } deriving (Show, Eq)+  { commandArgs :: [String],+    commandJson :: Bool+  }+  deriving (Show, Eq) +-- | Construct a non-JSON command. hyprCommand :: [String] -> HyprlandCommand-hyprCommand args = HyprlandCommand { commandArgs = args, commandJson = False }+hyprCommand args = HyprlandCommand {commandArgs = args, commandJson = False} +-- | Construct a command whose output should be JSON. hyprCommandJson :: [String] -> HyprlandCommand-hyprCommandJson args = HyprlandCommand { commandArgs = args, commandJson = True }+hyprCommandJson args = HyprlandCommand {commandArgs = args, commandJson = True} +-- | Encode a 'HyprlandCommand' into the bytes expected by the command socket. hyprlandCommandToSocketCommand :: HyprlandCommand -> Either HyprlandError BS.ByteString-hyprlandCommandToSocketCommand HyprlandCommand { commandArgs = args, commandJson = isJson }+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@@ -396,27 +431,29 @@   client@HyprlandClient     { clientConfig =         HyprlandClientConfig-          { useSocket = useSock-          , fallbackToHyprctl = fallback-          , hyprctlPath = hyprctl+          { 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)+    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@@ -424,7 +461,7 @@   case sockResult of     Left err -> pure (Left err)     Right sock ->-      (do+      ( do           cmdBytes <- case hyprlandCommandToSocketCommand cmd of             Left e -> NS.close sock >> pure (Left e)             Right b -> pure (Right b)@@ -436,16 +473,17 @@               resp <- recvAll sock               NS.close sock               pure (Right resp)-        ) `catchAny` \e -> do+      )+        `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+runHyprlandCommandHyprctl client hyprctl HyprlandCommand {commandArgs = args, commandJson = isJson} = do   mSig <- pickHyprlandInstanceSignature client   let flags =-        ["-j" | isJson] ++-        maybe [] (\sig -> ["-i", sig]) mSig+        ["-j" | isJson]+          ++ maybe [] (\sig -> ["-i", sig]) mSig   result <- runCommand hyprctl (flags ++ args)   pure $ case result of     Left err -> Left err@@ -454,12 +492,13 @@ pickHyprlandInstanceSignature :: HyprlandClient -> IO (Maybe String) pickHyprlandInstanceSignature client =   case clientEnv client of-    Just HyprlandClientEnv { instanceSignature = sig } -> do+    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+      envAlive <-+        anyM canConnectSocket $+          hyprlandSocketPaths client HyprlandCommandSocket       if envAlive         then pure (Just sig)         else discover@@ -477,12 +516,12 @@       -- Use the newest discovered command socket.       paths <- discoverHyprlandSocketPaths client HyprlandCommandSocket       pure $ case paths of-        p:_ -> Just $ takeFileName $ takeDirectory p+        p : _ -> Just $ takeFileName $ takeDirectory p         [] -> Nothing -anyM :: Monad m => (a -> m Bool) -> [a] -> m Bool+anyM :: (Monad m) => (a -> m Bool) -> [a] -> m Bool anyM _ [] = pure False-anyM p (x:xs) = do+anyM p (x : xs) = do   b <- p x   if b then pure True else anyM p xs @@ -493,9 +532,10 @@       chunk <- NSB.recv sock 4096       if BS.null chunk         then return (BS.concat (reverse acc))-        else go (chunk:acc)+        else go (chunk : acc) -runHyprlandCommandJson :: FromJSON a => HyprlandClient -> HyprlandCommand -> IO (Either HyprlandError a)+-- | Run a command and decode the response body as JSON.+runHyprlandCommandJson :: (FromJSON a) => HyprlandClient -> HyprlandCommand -> IO (Either HyprlandError a) runHyprlandCommandJson client cmd = do   raw <- runHyprlandCommandRaw client cmd   pure $ case raw of
+ src/System/Taffybar/Information/Hyprland/API.hs view
@@ -0,0 +1,129 @@+{-# LANGUAGE OverloadedStrings #-}++-----------------------------------------------------------------------------++-----------------------------------------------------------------------------++-- |+-- Module      : System.Taffybar.Information.Hyprland.API+-- Copyright   : (c) Ivan A. Malison+-- License     : BSD3-style (see LICENSE)+--+-- Maintainer  : Ivan A. Malison+-- Stability   : unstable+-- Portability : unportable+--+-- Typed, validated Hyprland operations built on top of+-- "System.Taffybar.Information.Hyprland".+--+-- This module is intended for widget use: it exposes typed query functions for+-- the common @hyprctl -j@ endpoints and a small set of typed dispatch commands.+module System.Taffybar.Information.Hyprland.API+  ( -- * Queries+    getHyprlandClients,+    getHyprlandWorkspaces,+    getHyprlandMonitors,+    getHyprlandActiveWorkspace,+    getHyprlandActiveWindow,++    -- * Dispatch+    HyprlandWorkspaceTarget,+    mkHyprlandWorkspaceTarget,+    hyprlandWorkspaceTargetText,+    HyprlandAddress,+    mkHyprlandAddress,+    hyprlandAddressText,+    HyprlandDispatch (..),+    dispatchHyprland,+  )+where++import Data.Aeson (FromJSON)+import qualified Data.ByteString as BS+import Data.Char (isSpace)+import Data.Text (Text)+import qualified Data.Text as T+import System.Taffybar.Information.Hyprland+  ( HyprlandClient,+    HyprlandError (..),+    hyprCommand,+    hyprCommandJson,+    runHyprlandCommandJson,+    runHyprlandCommandRaw,+  )+import System.Taffybar.Information.Hyprland.Types+  ( HyprlandActiveWindowInfo,+    HyprlandActiveWorkspaceInfo,+    HyprlandClientInfo,+    HyprlandMonitorInfo,+    HyprlandWorkspaceInfo,+  )++runJson :: (FromJSON a) => HyprlandClient -> [String] -> IO (Either HyprlandError a)+runJson client args = runHyprlandCommandJson client (hyprCommandJson args)++getHyprlandClients :: HyprlandClient -> IO (Either HyprlandError [HyprlandClientInfo])+getHyprlandClients client = runJson client ["clients"]++getHyprlandWorkspaces :: HyprlandClient -> IO (Either HyprlandError [HyprlandWorkspaceInfo])+getHyprlandWorkspaces client = runJson client ["workspaces"]++getHyprlandMonitors :: HyprlandClient -> IO (Either HyprlandError [HyprlandMonitorInfo])+getHyprlandMonitors client = runJson client ["monitors"]++getHyprlandActiveWorkspace :: HyprlandClient -> IO (Either HyprlandError HyprlandActiveWorkspaceInfo)+getHyprlandActiveWorkspace client = runJson client ["activeworkspace"]++getHyprlandActiveWindow :: HyprlandClient -> IO (Either HyprlandError HyprlandActiveWindowInfo)+getHyprlandActiveWindow client = runJson client ["activewindow"]++newtype HyprlandWorkspaceTarget = HyprlandWorkspaceTarget Text+  deriving (Show, Eq)++hyprlandWorkspaceTargetText :: HyprlandWorkspaceTarget -> Text+hyprlandWorkspaceTargetText (HyprlandWorkspaceTarget t) = t++-- | Construct a workspace target validated enough to avoid socket argument splitting.+--+-- Note: This is stricter than @hyprctl@ (which can accept arguments with+-- whitespace), because the Hyprland command socket is a single string and we+-- currently build it with 'unwords'.+mkHyprlandWorkspaceTarget :: Text -> Either HyprlandError HyprlandWorkspaceTarget+mkHyprlandWorkspaceTarget t+  | T.null t = Left $ HyprlandCommandBuildFailed "Hyprland workspace target must not be empty"+  | T.any isSpace t = Left $ HyprlandCommandBuildFailed "Hyprland workspace target must not contain whitespace"+  | otherwise = Right $ HyprlandWorkspaceTarget t++newtype HyprlandAddress = HyprlandAddress Text+  deriving (Show, Eq)++hyprlandAddressText :: HyprlandAddress -> Text+hyprlandAddressText (HyprlandAddress t) = t++-- | Construct an address validated enough to prevent obvious argument splitting.+--+-- Hyprland currently represents window addresses like @0x123abc@, but we avoid+-- hard-coding that shape to reduce breakage if Hyprland changes formatting.+mkHyprlandAddress :: Text -> Either HyprlandError HyprlandAddress+mkHyprlandAddress t+  | T.null t = Left $ HyprlandCommandBuildFailed "Hyprland address must not be empty"+  | T.any isSpace t = Left $ HyprlandCommandBuildFailed "Hyprland address must not contain whitespace"+  | otherwise = Right $ HyprlandAddress t++data HyprlandDispatch+  = -- | @hyprctl dispatch workspace <name-or-id>@+    DispatchWorkspace HyprlandWorkspaceTarget+  | -- | @hyprctl dispatch focuswindow address:<addr>@+    DispatchFocusWindowAddress HyprlandAddress+  deriving (Show, Eq)++dispatchHyprland :: HyprlandClient -> HyprlandDispatch -> IO (Either HyprlandError BS.ByteString)+dispatchHyprland client action =+  runHyprlandCommandRaw client (hyprCommand (dispatchToArgs action))++dispatchToArgs :: HyprlandDispatch -> [String]+dispatchToArgs action =+  case action of+    DispatchWorkspace ws -> ["dispatch", "workspace", T.unpack (hyprlandWorkspaceTargetText ws)]+    DispatchFocusWindowAddress addr ->+      ["dispatch", "focuswindow", "address:" <> T.unpack (hyprlandAddressText addr)]
+ src/System/Taffybar/Information/Hyprland/Types.hs view
@@ -0,0 +1,160 @@+{-# LANGUAGE OverloadedStrings #-}++-----------------------------------------------------------------------------++-----------------------------------------------------------------------------++-- |+-- Module      : System.Taffybar.Information.Hyprland.Types+-- Copyright   : (c) Ivan A. Malison+-- License     : BSD3-style (see LICENSE)+--+-- Maintainer  : Ivan A. Malison+-- Stability   : unstable+-- Portability : unportable+--+-- Typed representations of JSON structures returned by @hyprctl -j@.+--+-- These are intended to be used by widgets so they do not need to deal with+-- raw JSON parsing and partial field lookups.+module System.Taffybar.Information.Hyprland.Types+  ( HyprlandWorkspaceRef (..),+    HyprlandWorkspaceInfo (..),+    HyprlandMonitorInfo (..),+    HyprlandClientInfo (..),+    HyprlandActiveWorkspaceInfo (..),+    HyprlandActiveWindowInfo (..),+  )+where++import Control.Applicative ((<|>))+import Data.Aeson (FromJSON (..), withObject, (.!=), (.:), (.:?))+import Data.Aeson.Types (Parser)+import Data.Text (Text)++parseOptionalAt :: Maybe [Int] -> Parser (Maybe (Int, Int))+parseOptionalAt mAt =+  case mAt of+    Nothing -> pure Nothing+    Just [x, y] -> pure $ Just (x, y)+    Just _ -> fail "Expected \"at\" to be a 2-element array"++data HyprlandWorkspaceRef = HyprlandWorkspaceRef+  { hyprWorkspaceRefId :: Int,+    hyprWorkspaceRefName :: Text+  }+  deriving (Show, Eq)++instance FromJSON HyprlandWorkspaceRef where+  parseJSON = withObject "HyprlandWorkspaceRef" $ \v ->+    HyprlandWorkspaceRef+      <$> v .: "id"+      <*> v .: "name"++-- | Entry from @hyprctl -j workspaces@.+data HyprlandWorkspaceInfo = HyprlandWorkspaceInfo+  { hyprWorkspaceId :: Int,+    hyprWorkspaceName :: Text,+    hyprWorkspaceMonitor :: Maybe Text,+    hyprWorkspaceWindows :: Maybe Int+  }+  deriving (Show, Eq)++instance FromJSON HyprlandWorkspaceInfo where+  parseJSON = withObject "HyprlandWorkspaceInfo" $ \v ->+    HyprlandWorkspaceInfo+      <$> v .: "id"+      <*> v .: "name"+      <*> v .:? "monitor"+      <*> v .:? "windows"++-- | Entry from @hyprctl -j monitors@.+data HyprlandMonitorInfo = HyprlandMonitorInfo+  { hyprMonitorName :: Maybe Text,+    hyprMonitorId :: Maybe Int,+    hyprMonitorFocused :: Bool,+    hyprMonitorX :: Maybe Int,+    hyprMonitorY :: Maybe Int,+    hyprMonitorWidth :: Maybe Int,+    hyprMonitorHeight :: Maybe Int,+    hyprMonitorActiveWorkspace :: Maybe HyprlandWorkspaceRef+  }+  deriving (Show, Eq)++instance FromJSON HyprlandMonitorInfo where+  parseJSON = withObject "HyprlandMonitorInfo" $ \v ->+    HyprlandMonitorInfo+      <$> v .:? "name"+      <*> v .:? "id"+      <*> v .:? "focused" .!= False+      <*> v .:? "x"+      <*> v .:? "y"+      <*> v .:? "width"+      <*> v .:? "height"+      <*> v .:? "activeWorkspace"++-- | Entry from @hyprctl -j clients@.+data HyprlandClientInfo = HyprlandClientInfo+  { hyprClientAddress :: Text,+    hyprClientTitle :: Text,+    hyprClientInitialTitle :: Maybe Text,+    hyprClientClass :: Maybe Text,+    hyprClientInitialClass :: Maybe Text,+    hyprClientWorkspace :: HyprlandWorkspaceRef,+    hyprClientFocused :: Bool,+    hyprClientHidden :: Bool,+    hyprClientMapped :: Bool,+    hyprClientUrgent :: Bool,+    hyprClientAt :: Maybe (Int, Int)+  }+  deriving (Show, Eq)++instance FromJSON HyprlandClientInfo where+  parseJSON = withObject "HyprlandClientInfo" $ \v -> do+    at <- parseOptionalAt =<< (v .:? "at")+    HyprlandClientInfo+      <$> v .: "address"+      <*> v .:? "title" .!= ""+      <*> v .:? "initialTitle"+      <*> v .:? "class"+      <*> v .:? "initialClass"+      <*> v .: "workspace"+      <*> v .:? "focused" .!= False+      <*> v .:? "hidden" .!= False+      <*> v .:? "mapped" .!= True+      <*> v .:? "urgent" .!= False+      <*> pure at++-- | Result from @hyprctl -j activeworkspace@.+--+-- Hyprland has used multiple field spellings for the layout; we normalize those+-- into 'hawLayout'.+data HyprlandActiveWorkspaceInfo = HyprlandActiveWorkspaceInfo+  { hyprActiveWorkspaceId :: Maybe Int,+    hyprActiveWorkspaceName :: Maybe Text,+    hyprActiveWorkspaceLayout :: Maybe Text+  }+  deriving (Show, Eq)++instance FromJSON HyprlandActiveWorkspaceInfo where+  parseJSON = withObject "HyprlandActiveWorkspaceInfo" $ \v -> do+    layout <- v .:? "layout" <|> v .:? "layoutName" <|> v .:? "layoutname"+    HyprlandActiveWorkspaceInfo+      <$> v .:? "id"+      <*> v .:? "name"+      <*> pure layout++-- | Result from @hyprctl -j activewindow@.+data HyprlandActiveWindowInfo = HyprlandActiveWindowInfo+  { hyprActiveWindowAddress :: Text,+    hyprActiveWindowTitle :: Maybe Text,+    hyprActiveWindowClass :: Maybe Text+  }+  deriving (Show, Eq)++instance FromJSON HyprlandActiveWindowInfo where+  parseJSON = withObject "HyprlandActiveWindowInfo" $ \v ->+    HyprlandActiveWindowInfo+      <$> v .:? "address" .!= ""+      <*> v .:? "title"+      <*> v .:? "class"
src/System/Taffybar/Information/Inhibitor.hs view
@@ -1,5 +1,9 @@ {-# LANGUAGE OverloadedStrings #-}+ -----------------------------------------------------------------------------++-----------------------------------------------------------------------------+ -- | -- Module      : System.Taffybar.Information.Inhibitor -- Copyright   : (c) Ivan A. Malison@@ -13,35 +17,37 @@ -- 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(..)+    InhibitType (..),+    InhibitorState (..),+    InhibitorContext (..),+     -- * Inhibitor Management-  , getInhibitorContext-  , getInhibitorState-  , toggleInhibitor-  , getInhibitorChan+    getInhibitorContext,+    getInhibitorState,+    toggleInhibitor,+    getInhibitorChan,+     -- * Utilities-  , inhibitTypeToString-  , inhibitTypesFromStrings-  ) where+    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 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+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@@ -56,22 +62,23 @@  -- | Current state of the inhibitor data InhibitorState = InhibitorState-  { inhibitorActive :: Bool-  , inhibitorTypes :: [InhibitType]-  } deriving (Eq, Show)+  { 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]+  { 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 :: (MonadIO m) => Priority -> String -> m () inhibitorLog priority = liftIO . logM inhibitorLogPath priority  -- | Convert an InhibitType to its string representation for DBus@@ -128,14 +135,18 @@       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)-                       ]-    }+  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@@ -148,12 +159,16 @@             return $ Right fd           Nothing -> do             inhibitorLog WARNING "Invalid fd type in response"-            return $ Left $ methodError (methodReturnSerial ret) $-              errorName_ "org.taffybar.InvalidResponse"+            return $+              Left $+                methodError (methodReturnSerial ret) $+                  errorName_ "org.taffybar.InvalidResponse"         _ -> do           inhibitorLog WARNING "Unexpected response format"-          return $ Left $ methodError (methodReturnSerial ret) $-            errorName_ "org.taffybar.InvalidResponse"+          return $+            Left $+              methodError (methodReturnSerial ret) $+                errorName_ "org.taffybar.InvalidResponse"  -- | Release an inhibitor by closing its file descriptor releaseInhibitor :: Fd -> IO ()@@ -166,17 +181,21 @@ getInhibitorContext types = getStateDefault $ do   inhibitorLog DEBUG "Initializing InhibitorContext"   chan <- liftIO newBroadcastTChanIO-  stateVar <- liftIO $ newMVar InhibitorState-    { inhibitorActive = False-    , inhibitorTypes = types-    }+  stateVar <-+    liftIO $+      newMVar+        InhibitorState+          { inhibitorActive = False,+            inhibitorTypes = types+          }   fdVar <- liftIO $ newMVar Nothing-  return InhibitorContext-    { inhibitorChan = chan-    , inhibitorStateVar = stateVar-    , inhibitorFdVar = fdVar-    , inhibitorConfig = types-    }+  return+    InhibitorContext+      { inhibitorChan = chan,+        inhibitorStateVar = stateVar,+        inhibitorFdVar = fdVar,+        inhibitorConfig = types+      }  -- | Get the current inhibitor state getInhibitorState :: [InhibitType] -> TaffyIO InhibitorState@@ -200,10 +219,11 @@       Just fd -> do         -- Currently active, release it         releaseInhibitor fd-        let newState = InhibitorState-              { inhibitorActive = False-              , inhibitorTypes = types-              }+        let newState =+              InhibitorState+                { inhibitorActive = False,+                  inhibitorTypes = types+                }         _ <- swapMVar (inhibitorStateVar ctx) newState         atomically $ writeTChan (inhibitorChan ctx) newState         inhibitorLog DEBUG "Inhibitor deactivated"@@ -213,10 +233,11 @@         result <- acquireInhibitor client types         case result of           Right fd -> do-            let newState = InhibitorState-                  { inhibitorActive = True-                  , inhibitorTypes = types-                  }+            let newState =+                  InhibitorState+                    { inhibitorActive = True,+                      inhibitorTypes = types+                    }             _ <- swapMVar (inhibitorStateVar ctx) newState             atomically $ writeTChan (inhibitorChan ctx) newState             inhibitorLog DEBUG "Inhibitor activated"
src/System/Taffybar/Information/KeyboardState.hs view
@@ -1,6 +1,9 @@ {-# LANGUAGE OverloadedStrings #-}  --------------------------------------------------------------------------------++--------------------------------------------------------------------------------+ -- | -- Module      : System.Taffybar.Information.KeyboardState -- Copyright   : (c) Ivan Malison@@ -12,28 +15,27 @@ -- -- 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+  ( KeyboardState (..),+    getKeyboardState,+    defaultKeyboardState,+    findLedPath,+    defaultLedBasePath,+  )+where -import Control.Exception (catch, SomeException)+import Control.Exception (SomeException, catch) import Data.List (find)-import System.Directory (listDirectory, doesFileExist)+import System.Directory (doesFileExist, listDirectory) import System.FilePath ((</>))  -- | Represents the state of keyboard lock keys. data KeyboardState = KeyboardState-  { capsLock :: Bool-  , numLock :: Bool-  , scrollLock :: Bool-  } deriving (Eq, Show)+  { capsLock :: Bool,+    numLock :: Bool,+    scrollLock :: Bool+  }+  deriving (Eq, Show)  -- | Default keyboard state with all locks off. defaultKeyboardState :: KeyboardState@@ -92,8 +94,9 @@   numState <- maybe (return False) readLedState numPath   scrollState <- maybe (return False) readLedState scrollPath -  return KeyboardState-    { capsLock = capsState-    , numLock = numState-    , scrollLock = scrollState-    }+  return+    KeyboardState+      { capsLock = capsState,+        numLock = numState,+        scrollLock = scrollState+      }
src/System/Taffybar/Information/MPRIS2.hs view
@@ -1,6 +1,10 @@-{-# LANGUAGE NoMonoLocalBinds #-} {-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE NoMonoLocalBinds #-}+ -----------------------------------------------------------------------------++-----------------------------------------------------------------------------+ -- | -- Module      : System.Taffybar.Information.MPRIS2 -- Copyright   : (c) Ivan A. Malison@@ -10,62 +14,99 @@ -- Stability   : unstable -- Portability : unportable ---------------------------------------------------------------------------------+-- Query and decode MPRIS2 metadata from DBus media-player services. module System.Taffybar.Information.MPRIS2 where -import           Control.Applicative-import           Control.Monad.IO.Class-import           Control.Monad.Trans.Class-import           Control.Monad.Trans.Except-import           Control.Monad.Trans.Maybe+import Control.Applicative+import Control.Monad.IO.Class+import Control.Monad.Trans.Class+import Control.Monad.Trans.Except+import Control.Monad.Trans.Maybe import qualified DBus import qualified DBus.Client as DBus import qualified DBus.Internal.Types as DBus import qualified DBus.TH as DBus-import           Data.Coerce-import           Data.List+import Data.Coerce+import Data.List import qualified Data.Map as M-import           Data.Maybe-import           System.Log.Logger-import           System.Taffybar.DBus.Client.MPRIS2-import           Text.Printf+import Data.Maybe+import System.Log.Logger+import System.Taffybar.DBus.Client.MPRIS2+import Text.Printf +-- | Normalized now-playing metadata for a single MPRIS2 player. data NowPlaying = NowPlaying-  { npTitle :: String-  , npArtists :: [String]-  , npStatus :: String-  , npBusName :: DBus.BusName-  } deriving (Show, Eq)+  { npTitle :: String,+    npArtists :: [String],+    npStatus :: String,+    npBusName :: DBus.BusName,+    npCanGoPrevious :: Bool,+    npCanPlay :: Bool,+    npCanPause :: Bool,+    npCanGoNext :: Bool+  }+  deriving (Show, Eq) +-- | Convert an 'Either' into a 'Maybe' while logging failures. eitherToMaybeWithLog :: (MonadIO m, Show a1) => Either a1 a2 -> m (Maybe a2) eitherToMaybeWithLog (Right v) = return $ Just v eitherToMaybeWithLog (Left e) = liftIO $ do   logM "System.Taffybar.Information.MPRIS2" WARNING $-       printf "Got error: %s" $ show e+    printf "Got error: %s" $+      show e   return Nothing -getNowPlayingInfo :: MonadIO m => DBus.Client -> m [NowPlaying]+-- | Query all active MPRIS2 players and return their now-playing metadata.+getNowPlayingInfo :: (MonadIO m) => DBus.Client -> m [NowPlaying] getNowPlayingInfo client =-  fmap (fromMaybe []) $ eitherToMaybeWithLog =<< liftIO (runExceptT $ do-    allBusNames <- ExceptT $ DBus.listNames client-    let mediaPlayerBusNames =-          filter (isPrefixOf "org.mpris.MediaPlayer2.") allBusNames-        getSongData _busName = runMaybeT $-          do-            let busName = coerce _busName-            metadataMap <--              MaybeT $ getMetadata client busName >>= eitherToMaybeWithLog-            (title, artists) <- MaybeT $ return $ getSongInfo metadataMap-            status <- MaybeT $ getPlaybackStatus client busName >>=-                               eitherToMaybeWithLog-            return NowPlaying { npTitle = title-                              , npArtists = artists-                              , npStatus = status-                              , npBusName = busName-                              }-    lift $ catMaybes <$> mapM getSongData mediaPlayerBusNames)+  fmap (fromMaybe []) $+    eitherToMaybeWithLog+      =<< liftIO+        ( runExceptT $ do+            allBusNames <- ExceptT $ DBus.listNames client+            let mediaPlayerBusNames =+                  filter (isPrefixOf "org.mpris.MediaPlayer2.") allBusNames+                getSongData _busName = runMaybeT $+                  do+                    let busName = coerce _busName+                    metadataMap <-+                      MaybeT $ getMetadata client busName >>= eitherToMaybeWithLog+                    (title, artists) <- MaybeT $ return $ getSongInfo metadataMap+                    status <-+                      MaybeT $+                        getPlaybackStatus client busName+                          >>= eitherToMaybeWithLog+                    canGoPrevious <-+                      lift $+                        fromMaybe False+                          <$> (getCanGoPrevious client busName >>= eitherToMaybeWithLog)+                    canPlay <-+                      lift $+                        fromMaybe False+                          <$> (getCanPlay client busName >>= eitherToMaybeWithLog)+                    canPause <-+                      lift $+                        fromMaybe False+                          <$> (getCanPause client busName >>= eitherToMaybeWithLog)+                    canGoNext <-+                      lift $+                        fromMaybe False+                          <$> (getCanGoNext client busName >>= eitherToMaybeWithLog)+                    return+                      NowPlaying+                        { npTitle = title,+                          npArtists = artists,+                          npStatus = status,+                          npBusName = busName,+                          npCanGoPrevious = canGoPrevious,+                          npCanPlay = canPlay,+                          npCanPause = canPause,+                          npCanGoNext = canGoNext+                        }+            lift $ catMaybes <$> mapM getSongData mediaPlayerBusNames+        ) +-- | Extract title and artist list from an MPRIS metadata map. getSongInfo :: M.Map String DBus.Variant -> Maybe (String, [String]) getSongInfo songData = do   let lookupVariant k = M.lookup k songData >>= DBus.fromVariant
src/System/Taffybar/Information/Memory.hs view
@@ -1,57 +1,71 @@-module System.Taffybar.Information.Memory (-  MemoryInfo(..),-  parseMeminfo-  ) where+-- | Parse memory usage data from Linux @/proc/meminfo@ and expose a derived+-- summary record used by memory widgets.+module System.Taffybar.Information.Memory+  ( MemoryInfo (..),+    parseMeminfo,+  )+where  toMB :: String -> Double toMB size = (read size :: Double) / 1024 +safeRatio :: Double -> Double -> Double+safeRatio+  _+  0 = 0+safeRatio numerator denominator = numerator / denominator++-- | Snapshot of parsed memory and swap values from @/proc/meminfo@. data MemoryInfo = MemoryInfo-  { memoryTotal :: Double-  , memoryFree :: Double-  , memoryBuffer :: Double-  , memoryCache :: Double-  , memorySwapTotal :: Double-  , memorySwapFree :: Double-  , memorySwapUsed :: Double -- swapTotal - swapFree-  , memorySwapUsedRatio :: Double -- swapUsed / swapTotal-  , memoryAvailable :: Double -- An estimate of how much memory is available-  , memoryRest :: Double -- free + buffer + cache-  , memoryUsed :: Double -- total - rest-  , memoryUsedRatio :: Double -- used / total+  { memoryTotal :: Double,+    memoryFree :: Double,+    memoryBuffer :: Double,+    memoryCache :: Double,+    memorySwapTotal :: Double,+    memorySwapFree :: Double,+    memorySwapUsed :: Double, -- swapTotal - swapFree+    memorySwapUsedRatio :: Double, -- swapUsed / swapTotal+    memoryAvailable :: Double, -- An estimate of how much memory is available+    memoryRest :: Double, -- free + buffer + cache+    memoryUsed :: Double, -- total - rest+    memoryUsedRatio :: Double -- used / total   }  emptyMemoryInfo :: MemoryInfo emptyMemoryInfo = MemoryInfo 0 0 0 0 0 0 0 0 0 0 0 0  parseLines :: [String] -> MemoryInfo -> MemoryInfo-parseLines (line:rest) memInfo = parseLines rest newMemInfo-  where newMemInfo = case words line of-                       (label:size:_) ->-                         case label of-                           "MemTotal:"     -> memInfo { memoryTotal = toMB size }-                           "MemFree:"      -> memInfo { memoryFree = toMB size }-                           "MemAvailable:" -> memInfo { memoryAvailable = toMB size }-                           "Buffers:"      -> memInfo { memoryBuffer = toMB size }-                           "Cached:"       -> memInfo { memoryCache = toMB size }-                           "SwapTotal:"    -> memInfo { memorySwapTotal = toMB size }-                           "SwapFree:"     -> memInfo { memorySwapFree = toMB size }-                           _               -> memInfo-                       _ -> memInfo+parseLines (line : rest) memInfo = parseLines rest newMemInfo+  where+    newMemInfo = case words line of+      (label : size : _) ->+        case label of+          "MemTotal:" -> memInfo {memoryTotal = toMB size}+          "MemFree:" -> memInfo {memoryFree = toMB size}+          "MemAvailable:" -> memInfo {memoryAvailable = toMB size}+          "Buffers:" -> memInfo {memoryBuffer = toMB size}+          "Cached:" -> memInfo {memoryCache = toMB size}+          "SwapTotal:" -> memInfo {memorySwapTotal = toMB size}+          "SwapFree:" -> memInfo {memorySwapFree = toMB size}+          _ -> memInfo+      _ -> memInfo parseLines _ memInfo = memInfo +-- | Read @/proc/meminfo@ and return memory/swap totals and usage ratios in MiB. parseMeminfo :: IO MemoryInfo parseMeminfo = do   s <- readFile "/proc/meminfo"   let m = parseLines (lines s) emptyMemoryInfo       rest = memoryFree m + memoryBuffer m + memoryCache m       used = memoryTotal m - rest-      usedRatio = used / memoryTotal m+      usedRatio = safeRatio used (memoryTotal m)       swapUsed = memorySwapTotal m - memorySwapFree m-      swapUsedRatio = swapUsed / memorySwapTotal m-  return m { memoryRest = rest-           , memoryUsed = used-           , memoryUsedRatio = usedRatio-           , memorySwapUsed = swapUsed-           , memorySwapUsedRatio = swapUsedRatio-           }+      swapUsedRatio = safeRatio swapUsed (memorySwapTotal m)+  return+    m+      { memoryRest = rest,+        memoryUsed = used,+        memoryUsedRatio = usedRatio,+        memorySwapUsed = swapUsed,+        memorySwapUsedRatio = swapUsedRatio+      }
src/System/Taffybar/Information/Network.hs view
@@ -1,4 +1,7 @@ -----------------------------------------------------------------------------++-----------------------------------------------------------------------------+ -- | -- Module      : System.Taffybar.Information.Network -- Copyright   : (c) José A. Romero L.@@ -11,23 +14,22 @@ -- Provides information about network traffic over selected interfaces, -- obtained from parsing the @\/proc\/net\/dev@ file using some of the -- facilities provided by the "System.Taffybar.Information.StreamInfo" module.---------------------------------------------------------------------------------- module System.Taffybar.Information.Network where  import qualified Control.Concurrent.MVar as MV-import           Control.Exception (catch, SomeException)-import           Control.Monad-import           Control.Monad.IO.Class-import           Control.Monad.Trans.Maybe (MaybeT(..))-import           Data.Maybe ( mapMaybe )-import           Data.Time.Clock-import           Data.Time.Clock.System-import           Safe ( atMay, initSafe, readDef )-import           System.Taffybar.Information.StreamInfo ( getParsedInfo )-import           System.Taffybar.Util+import Control.Exception (SomeException, catch)+import Control.Monad+import Control.Monad.IO.Class+import Control.Monad.Trans.Maybe (MaybeT (..))+import Data.Maybe (mapMaybe)+import Data.Time.Clock+import Data.Time.Clock.System+import Safe (atMay, initSafe, readDef)+import System.Taffybar.Context (TaffyIO)+import System.Taffybar.Information.StreamInfo (getParsedInfo)+import System.Taffybar.Information.Wakeup (taffyForeverWithDelay) +-- | Source file for Linux per-interface byte counters. networkInfoFile :: FilePath networkInfoFile = "/proc/net/dev" @@ -39,14 +41,19 @@   isInterfaceUp iface   handleFailure $ getParsedInfo networkInfoFile parseDevNet' iface +-- | Parse @/proc/net/dev@ into a simplified map of+-- @(interface, [receivedBytes, transmittedBytes])@. parseDevNet' :: String -> [(String, [Int])] parseDevNet' input =   map makeList $ parseDevNet input-  where makeList (a, (u, d)) = (a, [u, d])+  where+    makeList (a, (u, d)) = (a, [u, d]) +-- | Parse @/proc/net/dev@ into @(interface, (receivedBytes, transmittedBytes))@. parseDevNet :: String -> [(String, (Int, Int))] parseDevNet = mapMaybe (getDeviceUpDown . words) . drop 2 . lines +-- | Parse one tokenized @/proc/net/dev@ line. getDeviceUpDown :: [String] -> Maybe (String, (Int, Int)) getDeviceUpDown s = do   dev <- initSafe <$> s `atMay` 0@@ -57,6 +64,8 @@     out = length s - 8  -- Nothing if interface does not exist or is down++-- | Check whether a network interface exists and reports as up. isInterfaceUp :: String -> MaybeT IO () isInterfaceUp iface = do   state <- handleFailure $ readFile $ "/sys/class/net/" ++ iface ++ "/operstate"@@ -64,77 +73,90 @@     'u' : _ -> return ()     _ -> mzero +-- | Convert IO exceptions into @Nothing@ for polling helpers. handleFailure :: IO a -> MaybeT IO a handleFailure action = MaybeT $ catch (Just <$> action) eToNothing   where     eToNothing :: SomeException -> IO (Maybe a)     eToNothing _ = pure Nothing +-- | Collect per-interface byte-counter samples with timestamps. getDeviceSamples :: IO (Maybe [TxSample]) getDeviceSamples = runMaybeT $ handleFailure $ do   contents <- readFile networkInfoFile   length contents `seq` return ()   time <- liftIO getSystemTime   let mkSample (device, (up, down)) =-          TxSample { sampleUp = up-                   , sampleDown = down-                   , sampleTime = time-                   , sampleDevice = device-                   }+        TxSample+          { sampleUp = up,+            sampleDown = down,+            sampleTime = time,+            sampleDevice = device+          }   return $ map mkSample $ parseDevNet contents +-- | Raw network sample for a single interface at a point in time. data TxSample = TxSample-  { sampleUp :: Int-  , sampleDown :: Int-  , sampleTime :: SystemTime-  , sampleDevice :: String-  } deriving (Show, Eq)+  { sampleUp :: Int,+    sampleDown :: Int,+    sampleTime :: SystemTime,+    sampleDevice :: String+  }+  deriving (Show, Eq) -monitorNetworkInterfaces-  :: RealFrac a1-  => a1 -> ([(String, (Rational, Rational))] -> IO ()) -> IO ()-monitorNetworkInterfaces interval onUpdate = void $ do-  samplesVar <- MV.newMVar []+-- | Periodically monitor interface speeds and call a callback with+-- per-interface download/upload rates in bytes per second.+monitorNetworkInterfaces ::+  (RealFrac a1) =>+  a1 -> ([(String, (Rational, Rational))] -> IO ()) -> TaffyIO ()+monitorNetworkInterfaces interval onUpdate = do+  samplesVar <- liftIO $ MV.newMVar []   let sampleToSpeeds (device, (s1, s2)) = (device, getSpeed s1 s2)       doOnUpdate samples = do         let speedInfo = map sampleToSpeeds samples         onUpdate speedInfo         return samples       doUpdate = MV.modifyMVar_ samplesVar (updateSamples >=> doOnUpdate)-  foreverWithDelay interval doUpdate+  void $ taffyForeverWithDelay interval (liftIO doUpdate) +-- | Update sample history by pairing newest and previous samples per interface. updateSamples ::   [(String, (TxSample, TxSample))] ->   IO [(String, (TxSample, TxSample))] updateSamples currentSamples = do-  let getLast sample@TxSample { sampleDevice = device } =+  let getLast sample@TxSample {sampleDevice = device} =         maybe sample fst $ lookup device currentSamples-      getSamplePair sample@TxSample { sampleDevice = device } =+      getSamplePair sample@TxSample {sampleDevice = device} =         let lastSample = getLast sample-        in lastSample `seq` (device, (sample, lastSample))+         in lastSample `seq` (device, (sample, lastSample))   maybe currentSamples (map getSamplePair) <$> getDeviceSamples +-- | Compute download/upload speeds from two samples. getSpeed :: TxSample -> TxSample -> (Rational, Rational)-getSpeed TxSample { sampleUp = thisUp-                  , sampleDown = thisDown-                  , sampleTime = thisTime-                  }-         TxSample { sampleUp = lastUp-                  , sampleDown = lastDown-                  , sampleTime = lastTime-                  } =-        let intervalDiffTime =-              diffUTCTime-              (systemToUTCTime thisTime)-              (systemToUTCTime lastTime)-            intervalRatio =-              if intervalDiffTime == 0-              then 0-              else toRational $ 1 / intervalDiffTime-        in ( fromIntegral (thisDown - lastDown) * intervalRatio-           , fromIntegral (thisUp - lastUp) * intervalRatio-           )+getSpeed+  TxSample+    { sampleUp = thisUp,+      sampleDown = thisDown,+      sampleTime = thisTime+    }+  TxSample+    { sampleUp = lastUp,+      sampleDown = lastDown,+      sampleTime = lastTime+    } =+    let intervalDiffTime =+          diffUTCTime+            (systemToUTCTime thisTime)+            (systemToUTCTime lastTime)+        intervalRatio =+          if intervalDiffTime == 0+            then 0+            else toRational $ 1 / intervalDiffTime+     in ( fromIntegral (thisDown - lastDown) * intervalRatio,+          fromIntegral (thisUp - lastUp) * intervalRatio+        ) +-- | Sum download/upload speeds across interfaces. sumSpeeds :: [(Rational, Rational)] -> (Rational, Rational) sumSpeeds = foldr1 sumOne   where
src/System/Taffybar/Information/NetworkManager.hs view
@@ -1,5 +1,9 @@ {-# LANGUAGE OverloadedStrings #-}+ -----------------------------------------------------------------------------++-----------------------------------------------------------------------------+ -- | -- Module      : System.Taffybar.Information.NetworkManager -- Copyright   : (c) Ivan A. Malison@@ -11,49 +15,50 @@ -- -- 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+  ( 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 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 Data.List (minimumBy)+import Data.Map (Map) import qualified Data.Map as M-import           Data.Maybe (fromMaybe, listToMaybe)-import           Data.Text (Text)+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)+import Data.Word (Word8)+import System.Log.Logger+import System.Taffybar.Context+import System.Taffybar.DBus.Client.Params+import System.Taffybar.Util (logPrintF, maybeToEither) +-- | High-level WiFi connectivity state from NetworkManager. data WifiState   = WifiDisabled   | WifiDisconnected@@ -61,19 +66,23 @@   | WifiUnknown   deriving (Eq, Show) +-- | Snapshot of WiFi-specific connection information. data WifiInfo = WifiInfo-  { wifiState :: WifiState-  , wifiSsid :: Maybe Text-  , wifiStrength :: Maybe Int-  , wifiConnectionId :: Maybe Text-  } deriving (Eq, Show)+  { wifiState :: WifiState,+    wifiSsid :: Maybe Text,+    wifiStrength :: Maybe Int,+    wifiConnectionId :: Maybe Text+  }+  deriving (Eq, Show) +-- | High-level non-device-specific network connectivity state. data NetworkState   = NetworkConnected   | NetworkDisconnected   | NetworkUnknown   deriving (Eq, Show) +-- | Active network transport type. data NetworkType   = NetworkWifi   | NetworkWired@@ -81,14 +90,16 @@   | NetworkOther Text   deriving (Eq, Show) +-- | Snapshot of the current active network connection. data NetworkInfo = NetworkInfo-  { networkState :: NetworkState-  , networkType :: Maybe NetworkType-  , networkSsid :: Maybe Text-  , networkStrength :: Maybe Int-  , networkConnectionId :: Maybe Text-  , networkWirelessEnabled :: Maybe Bool-  } deriving (Eq, Show)+  { 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"@@ -102,37 +113,39 @@ wifiUnknownInfo :: WifiInfo wifiUnknownInfo =   WifiInfo-    { wifiState = WifiUnknown-    , wifiSsid = Nothing-    , wifiStrength = Nothing-    , wifiConnectionId = Nothing+    { wifiState = WifiUnknown,+      wifiSsid = Nothing,+      wifiStrength = Nothing,+      wifiConnectionId = Nothing     }  wifiDisabledInfo :: WifiInfo wifiDisabledInfo =   WifiInfo-    { wifiState = WifiDisabled-    , wifiSsid = Nothing-    , wifiStrength = Nothing-    , wifiConnectionId = Nothing+    { wifiState = WifiDisabled,+      wifiSsid = Nothing,+      wifiStrength = Nothing,+      wifiConnectionId = Nothing     }  wifiDisconnectedInfo :: WifiInfo wifiDisconnectedInfo =   WifiInfo-    { wifiState = WifiDisconnected-    , wifiSsid = Nothing-    , wifiStrength = Nothing-    , wifiConnectionId = Nothing+    { wifiState = WifiDisconnected,+      wifiSsid = Nothing,+      wifiStrength = Nothing,+      wifiConnectionId = Nothing     }  newtype WifiInfoChanVar = WifiInfoChanVar (TChan WifiInfo, MVar WifiInfo) +-- | Read the latest cached 'WifiInfo' value. getWifiInfoState :: TaffyIO WifiInfo getWifiInfoState = do   WifiInfoChanVar (_, theVar) <- getWifiInfoChanVar   lift $ readMVar theVar +-- | Get a broadcast channel of WiFi info updates. getWifiInfoChan :: TaffyIO (TChan WifiInfo) getWifiInfoChan = do   WifiInfoChanVar (chan, _) <- getWifiInfoChanVar@@ -157,46 +170,52 @@     updateInfo   return (chan, infoVar) -registerForNetworkManagerPropertiesChanged-  :: (Signal -> String -> Map String Variant -> [String] -> IO ())-  -> ReaderT Context IO SignalHandler+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+  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 ::+  (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+  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 ::+  (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+  lift $+    DBus.registerForPropertiesChanged+      client+      matchAny+        { matchInterface = Just nmAccessPointInterfaceName,+          matchPathNamespace = Just nmAccessPointPathNamespace+        }+      signalHandler -updateWifiInfo-  :: TChan WifiInfo-  -> MVar WifiInfo-  -> TaffyIO ()+updateWifiInfo ::+  TChan WifiInfo ->+  MVar WifiInfo ->+  TaffyIO () updateWifiInfo chan var = do   info <- getWifiInfo   lift $ do@@ -207,24 +226,31 @@ dummyMethodError :: MethodError dummyMethodError = methodError (Serial 1) $ errorName_ "org.ClientTypeMismatch" -readDictMaybe :: IsVariant a => Map Text Variant -> Text -> Maybe a+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 ->+  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+  reply <-+    ExceptT $+      getAllProperties client $+        (methodCall path iface "FakeMethod")+          { methodCallDestination = Just nmBusName+          }+  ExceptT $+    return $+      maybeToEither dummyMethodError $+        listToMaybe (methodReturnBody reply) >>= fromVariant +-- | Query WiFi information using taffybar's shared DBus client. getWifiInfo :: TaffyIO WifiInfo getWifiInfo = asks systemDBusClient >>= liftIO . getWifiInfoFromClient +-- | Query WiFi information from the provided NetworkManager DBus client. getWifiInfoFromClient :: Client -> IO WifiInfo getWifiInfoFromClient client = do   nmPropsResult <- getProperties client nmObjectPath nmInterfaceName@@ -239,8 +265,9 @@       case wirelessEnabled of         Just False -> return wifiDisabledInfo         Just True -> case activeConnections of-          Just paths -> fromMaybe wifiDisconnectedInfo <$>-                        findActiveWifi client paths+          Just paths ->+            fromMaybe wifiDisconnectedInfo+              <$> findActiveWifi client paths           Nothing -> do             logM wifiLogPath WARNING "NetworkManager missing ActiveConnections"             return wifiUnknownInfo@@ -250,7 +277,7 @@  findActiveWifi :: Client -> [ObjectPath] -> IO (Maybe WifiInfo) findActiveWifi _ [] = return Nothing-findActiveWifi client (path:rest) = do+findActiveWifi client (path : rest) = do   connPropsResult <- getProperties client path nmActiveConnectionInterfaceName   case connPropsResult of     Left err -> do@@ -265,20 +292,23 @@               specificObject =                 readDictMaybe connProps "SpecificObject" :: Maybe ObjectPath           (ssid, strength) <- getAccessPointInfo client specificObject-          return $ Just WifiInfo-            { wifiState = WifiConnected-            , wifiSsid = ssid-            , wifiStrength = strength-            , wifiConnectionId = connId-            }+          return $+            Just+              WifiInfo+                { wifiState = WifiConnected,+                  wifiSsid = ssid,+                  wifiStrength = strength,+                  wifiConnectionId = connId+                } -getAccessPointInfo-  :: Client-  -> Maybe ObjectPath-  -> IO (Maybe Text, Maybe Int)+getAccessPointInfo ::+  Client ->+  Maybe ObjectPath ->+  IO (Maybe Text, Maybe Int) getAccessPointInfo _ Nothing = return (Nothing, Nothing)-getAccessPointInfo _ (Just path) | path == nullObjectPath =-  return (Nothing, Nothing)+getAccessPointInfo _ (Just path)+  | path == nullObjectPath =+      return (Nothing, Nothing) getAccessPointInfo client (Just path) = do   apPropsResult <- getProperties client path nmAccessPointInterfaceName   case apPropsResult of@@ -289,8 +319,8 @@       let ssidBytes = readDictMaybe apProps "Ssid" :: Maybe [Word8]           strength = readDictMaybe apProps "Strength" :: Maybe Word8       return-        ( ssidBytes >>= decodeSsid-        , fromIntegral <$> strength+        ( ssidBytes >>= decodeSsid,+          fromIntegral <$> strength         )  decodeSsid :: [Word8] -> Maybe Text@@ -305,19 +335,21 @@ networkUnknownInfo :: NetworkInfo networkUnknownInfo =   NetworkInfo-    { networkState = NetworkUnknown-    , networkType = Nothing-    , networkSsid = Nothing-    , networkStrength = Nothing-    , networkConnectionId = Nothing-    , networkWirelessEnabled = Nothing+    { networkState = NetworkUnknown,+      networkType = Nothing,+      networkSsid = Nothing,+      networkStrength = Nothing,+      networkConnectionId = Nothing,+      networkWirelessEnabled = Nothing     } +-- | Read the latest cached 'NetworkInfo' value. getNetworkInfoState :: TaffyIO NetworkInfo getNetworkInfoState = do   NetworkInfoChanVar (_, theVar) <- getNetworkInfoChanVar   lift $ readMVar theVar +-- | Get a broadcast channel of network info updates. getNetworkInfoChan :: TaffyIO (TChan NetworkInfo) getNetworkInfoChan = do   NetworkInfoChanVar (chan, _) <- getNetworkInfoChanVar@@ -341,26 +373,29 @@     updateInfo   return (chan, infoVar) -updateNetworkInfo-  :: TChan NetworkInfo-  -> MVar NetworkInfo-  -> TaffyIO ()+updateNetworkInfo ::+  TChan NetworkInfo ->+  MVar NetworkInfo ->+  TaffyIO () updateNetworkInfo chan var = do   info <- getNetworkInfo   lift $ do     _ <- swapMVar var info     atomically $ writeTChan chan info +-- | Query network information using taffybar's shared DBus client. getNetworkInfo :: TaffyIO NetworkInfo getNetworkInfo = asks systemDBusClient >>= liftIO . getNetworkInfoFromClient  data ActiveConnectionInfo = ActiveConnectionInfo-  { activeConnectionPath :: ObjectPath-  , activeConnectionType :: Text-  , activeConnectionId :: Maybe Text-  , activeConnectionSpecificObject :: Maybe ObjectPath-  } deriving (Eq, Show)+  { activeConnectionPath :: ObjectPath,+    activeConnectionType :: Text,+    activeConnectionId :: Maybe Text,+    activeConnectionSpecificObject :: Maybe ObjectPath+  }+  deriving (Eq, Show) +-- | Query network information from the provided NetworkManager DBus client. getNetworkInfoFromClient :: Client -> IO NetworkInfo getNetworkInfoFromClient client = do   nmPropsResult <- getProperties client nmObjectPath nmInterfaceName@@ -378,23 +413,25 @@        case best of         Nothing ->-          return networkUnknownInfo-            { networkState = NetworkDisconnected-            , networkWirelessEnabled = wirelessEnabled-            }+          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-            }+          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@@ -402,38 +439,39 @@   case connPropsResult of     Left err -> do       wifiLogF DEBUG "Failed to read active connection %s" err-      return ActiveConnectionInfo-        { activeConnectionPath = path-        , activeConnectionType = ""-        , activeConnectionId = Nothing-        , activeConnectionSpecificObject = Nothing-        }+      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-        }+      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+  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
src/System/Taffybar/Information/PowerProfiles.hs view
@@ -1,5 +1,9 @@ {-# LANGUAGE OverloadedStrings #-}+ -----------------------------------------------------------------------------++-----------------------------------------------------------------------------+ -- | -- Module      : System.Taffybar.Information.PowerProfiles -- Copyright   : (c) Ivan A. Malison@@ -11,38 +15,38 @@ -- -- 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+  ( 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 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 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)+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@@ -53,10 +57,11 @@  -- | Information about the current power profile state. data PowerProfileInfo = PowerProfileInfo-  { currentProfile :: PowerProfile-  , availableProfiles :: [PowerProfile]-  , performanceDegraded :: Maybe Text-  } deriving (Eq, Show)+  { currentProfile :: PowerProfile,+    availableProfiles :: [PowerProfile],+    performanceDegraded :: Maybe Text+  }+  deriving (Eq, Show)  -- | The DBus bus name for power-profiles-daemon. powerProfilesBusName :: BusName@@ -91,28 +96,34 @@  -- | Default info when power-profiles-daemon is unavailable. unknownProfileInfo :: PowerProfileInfo-unknownProfileInfo = PowerProfileInfo-  { currentProfile = Balanced-  , availableProfiles = []-  , performanceDegraded = Nothing-  }+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 :: (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 ->+  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+  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@@ -140,20 +151,24 @@           availableProfs = maybe [] (mapMaybe parseProfile) profilesArray           currentProf = fromMaybe Balanced (activeProfileStr >>= stringToPowerProfile) -      return PowerProfileInfo-        { currentProfile = currentProf-        , availableProfiles = availableProfs-        , performanceDegraded = if degraded == Just "" then Nothing else degraded-        }+      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)+  result <-+    setProperty+      client+      (methodCall powerProfilesObjectPath powerProfilesInterfaceName "ActiveProfile")+        { methodCallDestination = Just powerProfilesBusName+        }+      (toVariant profileStr)   return $ case result of     Left err -> Left err     Right _ -> Right ()@@ -168,12 +183,12 @@         PowerSaver -> Balanced         Balanced -> Performance         Performance -> PowerSaver-  in setProfile client nextProfile+   in setProfile client nextProfile  -- State management for monitoring -newtype PowerProfileInfoChanVar =-  PowerProfileInfoChanVar (TChan PowerProfileInfo, MVar PowerProfileInfo)+newtype PowerProfileInfoChanVar+  = PowerProfileInfoChanVar (TChan PowerProfileInfo, MVar PowerProfileInfo)  -- | Get the current power profile info state. getPowerProfileInfoState :: TaffyIO PowerProfileInfo@@ -203,22 +218,24 @@     updateInfo   return (chan, infoVar) -registerForPowerProfilesPropertiesChanged-  :: (Signal -> String -> Map String Variant -> [String] -> IO ())-  -> ReaderT Context IO SignalHandler+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+  lift $+    DBus.registerForPropertiesChanged+      client+      matchAny+        { matchInterface = Just powerProfilesInterfaceName,+          matchPath = Just powerProfilesObjectPath+        }+      signalHandler -updatePowerProfileInfo-  :: TChan PowerProfileInfo-  -> MVar PowerProfileInfo-  -> TaffyIO ()+updatePowerProfileInfo ::+  TChan PowerProfileInfo ->+  MVar PowerProfileInfo ->+  TaffyIO () updatePowerProfileInfo chan var = do   info <- getPowerProfileInfo   lift $ do
src/System/Taffybar/Information/Privacy.hs view
@@ -4,6 +4,9 @@ {-# LANGUAGE ScopedTypeVariables #-}  -----------------------------------------------------------------------------++-----------------------------------------------------------------------------+ -- | -- Module      : System.Taffybar.Information.Privacy -- Copyright   : (c) Ivan A. Malison@@ -16,87 +19,99 @@ -- 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(..)+    PrivacyInfo (..),+    PrivacyNode (..),+    NodeType (..),+     -- * Query functions-  , getPrivacyInfo+    getPrivacyInfo,+     -- * Channel-based monitoring-  , getPrivacyInfoChan-  , getPrivacyInfoState+    getPrivacyInfoChan,+    getPrivacyInfoState,+     -- * Configuration-  , PrivacyConfig(..)-  , defaultPrivacyConfig-  ) where+    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 (void) import Control.Monad.IO.Class (liftIO) import Control.Monad.STM (atomically) import Data.Aeson-  ( FromJSON(..)-  , (.:)-  , (.:?)-  , withObject+  ( 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.Default (Default (..)) import Data.List (nubBy) import Data.Maybe (fromMaybe, mapMaybe) import Data.Text (Text) import qualified Data.Text as T+import qualified Data.Text.Encoding as TE import GHC.Generics (Generic)-import System.Log.Logger (Priority(..))+import System.Log.Logger (Priority (..)) import System.Taffybar.Context (TaffyIO, getStateDefault)+import System.Taffybar.Information.Wakeup (taffyForeverWithDelay) 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+  = -- | Microphone / audio capture+    AudioInput+  | -- | Audio playback (less privacy-sensitive, but useful)+    AudioOutput+  | -- | Camera / screen capture+    VideoInput   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)+  { 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)+  }+  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)+  { -- | Polling interval in seconds+    privacyPollingInterval :: Double,+    -- | Path to pw-dump command+    privacyPwDumpPath :: FilePath,+    -- | Whether to ignore monitor streams+    privacyIgnoreMonitors :: Bool,+    -- | Whether to ignore audio output streams+    privacyIgnoreAudioOutput :: Bool+  }+  deriving (Eq, Show, Generic)  -- | Default privacy configuration. defaultPrivacyConfig :: PrivacyConfig-defaultPrivacyConfig = PrivacyConfig-  { privacyPollingInterval = 2.0-  , privacyPwDumpPath = "pw-dump"-  , privacyIgnoreMonitors = True-  , privacyIgnoreAudioOutput = True-  }+defaultPrivacyConfig =+  PrivacyConfig+    { privacyPollingInterval = 2.0,+      privacyPwDumpPath = "pw-dump",+      privacyIgnoreMonitors = True,+      privacyIgnoreAudioOutput = True+    }  instance Default PrivacyConfig where   def = defaultPrivacyConfig@@ -104,51 +119,57 @@ privacyLogPath :: String privacyLogPath = "System.Taffybar.Information.Privacy" -privacyLogF :: Show t => Priority -> String -> t -> IO ()+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)+  { pwId :: Int,+    pwType :: Text,+    pwInfo :: Maybe PwInfo+  }+  deriving (Eq, Show, Generic)  data PwInfo = PwInfo-  { pwState :: Maybe Text-  , pwProps :: Maybe PwProps-  } deriving (Eq, Show, Generic)+  { 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)+  { 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"+  parseJSON = withObject "PwObject" $ \v ->+    PwObject+      <$> v .: "id"+      <*> v .: "type"+      <*> v .:? "info"  instance FromJSON PwInfo where-  parseJSON = withObject "PwInfo" $ \v -> PwInfo-    <$> v .:? "state"-    <*> v .:? "props"+  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"+  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@@ -193,29 +214,32 @@           nType <- classToNodeType mediaClass            -- Get application name (try multiple sources)-          let name = fromMaybe "Unknown" $-                propAppName props-                  <|> propPortalAppId props-                  <|> propNodeName props-                  <|> propMediaName props+          let name =+                fromMaybe "Unknown" $+                  propAppName props+                    <|> propPortalAppId props+                    <|> propNodeName props+                    <|> propMediaName props                -- Get icon name-              icon = propAppIconName props-                       <|> propPortalAppId props-                       <|> propAppName props+              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-            }+          Just+            PrivacyNode+              { nodeType = nType,+                appName = name,+                appIcon = icon,+                nodeName = nName,+                isMonitor = monitor+              }   where     (<|>) :: Maybe a -> Maybe a -> Maybe a     (<|>) ma mb = case ma of@@ -243,8 +267,9 @@       | otherwise = True  -- | State for the privacy info channel.-newtype PrivacyInfoChanVar = PrivacyInfoChanVar-  (TChan PrivacyInfo, MVar PrivacyInfo)+newtype PrivacyInfoChanVar+  = PrivacyInfoChanVar+      (TChan PrivacyInfo, MVar PrivacyInfo)  -- | Get a broadcast channel for privacy info updates. --@@ -264,35 +289,22 @@ getPrivacyInfoChanVar :: PrivacyConfig -> TaffyIO PrivacyInfoChanVar getPrivacyInfoChanVar config =   getStateDefault $ do-    liftIO $ do-      chan <- newBroadcastTChanIO-      var <- newMVar (PrivacyInfo [])-      _ <- forkIO $ monitorPrivacyInfo config chan var-      pure $ PrivacyInfoChanVar (chan, var)+    chan <- liftIO newBroadcastTChanIO+    var <- liftIO $ newMVar (PrivacyInfo [])+    let intervalSeconds :: Double+        intervalSeconds = max 0.1 (privacyPollingInterval config)+    liftIO $ refreshPrivacyInfo config chan var+    void $ taffyForeverWithDelay intervalSeconds (liftIO $ refreshPrivacyInfo config chan var)+    pure $ PrivacyInfoChanVar (chan, var) -monitorPrivacyInfo ::+refreshPrivacyInfo ::   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+refreshPrivacyInfo config chan var = do+  info <- catch (getPrivacyInfo config) $ \(e :: SomeException) -> do+    privacyLogF WARNING "Privacy info refresh failed: %s" e+    return $ PrivacyInfo []+  _ <- swapMVar var info+  atomically $ writeTChan chan info
src/System/Taffybar/Information/PulseAudio.hs view
@@ -41,7 +41,7 @@ where  import Control.Applicative ((<|>))-import Control.Concurrent (forkIO, threadDelay)+import Control.Concurrent (forkIO) import Control.Concurrent.MVar import Control.Concurrent.STM.TChan import Control.Exception (SomeException, finally, throwIO, try)@@ -74,6 +74,7 @@     paServerLookupInterfaceName,     paServerLookupObjectPath,   )+import System.Taffybar.Information.Wakeup (getWakeupChannelForDelay) import System.Taffybar.Util (logPrintF, maybeToEither)  -- | PulseAudio information for the default (or provided) sink.@@ -128,34 +129,40 @@ -- 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 :: 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 :: 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 :: forall a. (KnownSymbol a) => TaffyIO (PulseAudioInfoChanVar a) getPulseAudioInfoChanVarFor =   getStateDefault $ do     let sinkSpec = symbolVal (Proxy @a)+    retryWakeupChan <- getWakeupChannelForDelay (5 :: Double)+    blockWakeupChan <- getWakeupChannelForDelay (1000 :: Double)+    retryOurWakeupChan <- liftIO $ atomically $ dupTChan retryWakeupChan+    blockOurWakeupChan <- liftIO $ atomically $ dupTChan blockWakeupChan     liftIO $ do       chan <- newBroadcastTChanIO       var <- newMVar Nothing-      _ <- forkIO $ monitorPulseAudioInfo sinkSpec chan var+      _ <- forkIO $ monitorPulseAudioInfo sinkSpec retryOurWakeupChan blockOurWakeupChan chan var       pure $ PulseAudioInfoChanVar (chan, var)  monitorPulseAudioInfo ::   String ->+  TChan a ->+  TChan b ->   TChan (Maybe PulseAudioInfo) ->   MVar (Maybe PulseAudioInfo) ->   IO ()-monitorPulseAudioInfo sinkSpec chan var = do+monitorPulseAudioInfo sinkSpec retryWakeupChan blockWakeupChan chan var = do   refreshLock <- newMVar ()   let writeInfo info = do         _ <- swapMVar var info@@ -203,8 +210,8 @@       listenForSignal client signalName objects = do         let callMsg =               (methodCall paCorePath paCoreInterfaceName "ListenForSignal")-                { methodCallDestination = Nothing-                , methodCallBody = [toVariant signalName, toVariant objects]+                { methodCallDestination = Nothing,+                  methodCallBody = [toVariant signalName, toVariant objects]                 }         reply <- call client callMsg         case reply of@@ -241,17 +248,17 @@       deviceSignalMatcher :: MemberName -> MatchRule       deviceSignalMatcher memberName =         matchAny-          { matchPathNamespace = Just paCoreObjectPath-          , matchInterface = Just paDeviceInterfaceName-          , matchMember = Just memberName+          { matchPathNamespace = Just paCoreObjectPath,+            matchInterface = Just paDeviceInterfaceName,+            matchMember = Just memberName           }        coreSignalMatcher :: MemberName -> MatchRule       coreSignalMatcher memberName =         matchAny-          { matchPath = Just paCoreObjectPath-          , matchInterface = Just paCoreInterfaceName-          , matchMember = Just memberName+          { matchPath = Just paCoreObjectPath,+            matchInterface = Just paCoreInterfaceName,+            matchMember = Just memberName           }        loop = do@@ -260,7 +267,7 @@           Nothing -> do             writeInfo Nothing             -- No polling; just retry connection periodically.-            threadDelay 5000000+            void $ atomically $ readTChan retryWakeupChan             loop           Just client -> do             let runWithClient = do@@ -326,8 +333,7 @@        -- Avoid BlockedIndefinitelyOnMVar exceptions from the "empty mvar trick".       blockForever =-        forever $ threadDelay 1000000000 -- ~1000s; interruptible by async exceptions.-+        forever $ void $ atomically $ readTChan blockWakeupChan -- ~1000s; interruptible by async exceptions.   loop  -- | Query volume and mute state for the provided sink name.@@ -337,6 +343,8 @@   result <- withPulseAudio (`getPulseAudioInfoFromClient` sinkSpec)   return $ join result +-- | Query volume/mute info for a sink using an existing PulseAudio DBus+-- client. getPulseAudioInfoFromClient :: Client -> String -> IO (Maybe PulseAudioInfo) getPulseAudioInfoFromClient client sinkSpec = do   sinkPath <- resolveSinkPath client sinkSpec@@ -392,6 +400,7 @@ nullObjectPath :: ObjectPath nullObjectPath = objectPath_ "/" +-- | Connect to the PulseAudio DBus server (if available). connectPulseAudio :: IO (Maybe Client) connectPulseAudio = do   addressString <- getPulseAudioAddress
src/System/Taffybar/Information/SafeX11.hs view
@@ -1,8 +1,16 @@-{-# LANGUAGE MultiParamTypeClasses, StandaloneDeriving, FlexibleInstances,-  InterruptibleFFI, ExistentialQuantification, DeriveDataTypeable #-}+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE ExistentialQuantification #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE InterruptibleFFI #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE StandaloneDeriving #-} {-# OPTIONS_GHC -Wno-orphans #-}+{-# OPTIONS_HADDOCK hide #-}  -----------------------------------------------------------------------------++-----------------------------------------------------------------------------+ -- | -- Module      : System.Taffybar.Information.SafeX11 -- Copyright   : (c) Ivan A. Malison@@ -11,35 +19,39 @@ -- Maintainer  : Ivan A. Malison -- Stability   : unstable -- Portability : unportable------------------------------------------------------------------------------ module System.Taffybar.Information.SafeX11-  ( module Graphics.X11.Xlib-  , module Graphics.X11.Xlib.Extras-  , getWMHints-  , getWindowProperty8-  , getWindowProperty16-  , getWindowProperty32-  , postX11RequestSyncDef-  , rawGetWindowPropertyBytes-  , safeGetGeometry+  ( module Graphics.X11.Xlib,+    module Graphics.X11.Xlib.Extras,+    getWMHints,+    getWindowProperty8,+    getWindowProperty16,+    getWindowProperty32,+    postX11RequestSyncDef,+    rawGetWindowPropertyBytes,+    safeGetGeometry,   )-  where+where  import Control.Concurrent import Control.Exception import Control.Monad import Control.Monad.Trans.Class-import Control.Monad.Trans.Maybe (MaybeT(..))+import Control.Monad.Trans.Maybe (MaybeT (..)) import Data.Either.Combinators import Data.Typeable import Foreign hiding (void) import Foreign.C.Types import GHC.ForeignPtr import Graphics.X11.Xlib-import Graphics.X11.Xlib.Extras-       hiding (rawGetWindowProperty, getWindowProperty8,-               getWindowProperty16, getWindowProperty32,-               xGetWMHints, getWMHints, refreshKeyboardMapping)+import Graphics.X11.Xlib.Extras hiding+  ( getWMHints,+    getWindowProperty16,+    getWindowProperty32,+    getWindowProperty8,+    rawGetWindowProperty,+    refreshKeyboardMapping,+    xGetWMHints,+  ) import System.IO.Unsafe import System.Log.Logger import System.Timeout@@ -49,46 +61,48 @@ logHere = logM "System.Taffybar.Information.SafeX11"  foreign import ccall safe "XlibExtras.h XGetWMHints"-    safeXGetWMHints :: Display -> Window -> IO (Ptr WMHints)+  safeXGetWMHints :: Display -> Window -> IO (Ptr WMHints)  foreign import ccall interruptible "XlibExtras.h XGetWindowProperty"-               safeXGetWindowProperty ::-               Display ->-                 Window ->-                   Atom ->-                     CLong ->-                       CLong ->-                         Bool ->-                           Atom ->-                             Ptr Atom ->-                               Ptr CInt ->-                                 Ptr CULong ->-                                   Ptr CULong ->-                                     Ptr (Ptr CUChar) -> IO Status+  safeXGetWindowProperty ::+    Display ->+    Window ->+    Atom ->+    CLong ->+    CLong ->+    Bool ->+    Atom ->+    Ptr Atom ->+    Ptr CInt ->+    Ptr CULong ->+    Ptr CULong ->+    Ptr (Ptr CUChar) ->+    IO Status -rawGetWindowPropertyBytes-  :: Storable a-  => Int -> Display -> Atom -> Window -> IO (Maybe (ForeignPtr a, Int))+rawGetWindowPropertyBytes ::+  (Storable a) =>+  Int -> Display -> Atom -> Window -> IO (Maybe (ForeignPtr a, Int)) rawGetWindowPropertyBytes bits d atom w =   alloca $ \actual_type_return ->     alloca $ \actual_format_return ->       alloca $ \nitems_return ->         alloca $ \bytes_after_return ->           alloca $ \prop_return -> do-            ret <- postX11RequestSync $-              safeXGetWindowProperty-                d-                w-                atom-                0-                0xFFFFFFFF-                False-                anyPropertyType-                actual_type_return-                actual_format_return-                nitems_return-                bytes_after_return-                prop_return+            ret <-+              postX11RequestSync $+                safeXGetWindowProperty+                  d+                  w+                  atom+                  0+                  0xFFFFFFFF+                  False+                  anyPropertyType+                  actual_type_return+                  actual_format_return+                  nitems_return+                  bytes_after_return+                  prop_return             if fromRight (-1) ret /= 0               then return Nothing               else do@@ -101,16 +115,16 @@       | actual_format == 0 = return Nothing -- Property not found       | actual_format /= bits = xFree prop_ptr >> return Nothing       | otherwise = do-        ptr <- newConcForeignPtr (castPtr prop_ptr) (void $ xFree prop_ptr)-        return $ Just (ptr, nitems)+          ptr <- newConcForeignPtr (castPtr prop_ptr) (void $ xFree prop_ptr)+          return $ Just (ptr, nitems)  data SafeX11Exception = SafeX11Exception deriving (Show, Eq, Typeable)  instance Exception SafeX11Exception  data IORequest = forall a. IORequest-  { ioAction :: IO a-  , ioResponse :: Chan (Either SafeX11Exception a)+  { ioAction :: IO a,+    ioResponse :: Chan (Either SafeX11Exception a)   }  {-# NOINLINE requestQueue #-}@@ -123,21 +137,23 @@  withErrorHandler :: XErrorHandler -> IO a -> IO a withErrorHandler new_handler action = do-    handler <- mkXErrorHandler (\d e -> new_handler d e >> return 0)-    original <- _xSetErrorHandler handler-    res <- action-    _ <- _xSetErrorHandler original-    return res+  handler <- mkXErrorHandler (\d e -> new_handler d e >> return 0)+  original <- _xSetErrorHandler handler+  res <- action+  _ <- _xSetErrorHandler original+  return res  deriving instance Show ErrorEvent  startHandlingX11Requests :: IO () startHandlingX11Requests =   withErrorHandler handleError handleX11Requests-  where handleError _ xerrptr = do-          ee <- getErrorEvent xerrptr-          logHere WARNING $-                  printf "Handling X11 error with error handler: %s" $ show ee+  where+    handleError _ xerrptr = do+      ee <- getErrorEvent xerrptr+      logHere WARNING $+        printf "Handling X11 error with error handler: %s" $+          show ee  handleX11Requests :: IO () handleX11Requests = do@@ -146,10 +162,12 @@   res <-     catch       (maybe (Left SafeX11Exception) Right <$> timeout 500000 action)-      (\e -> do-         logHere WARNING $ printf "Handling X11 error with catch: %s" $-                 show (e :: IOException)-         return $ Left SafeX11Exception)+      ( \e -> do+          logHere WARNING $+            printf "Handling X11 error with catch: %s" $+              show (e :: IOException)+          return $ Left SafeX11Exception+      )   writeChan responseChannel res   handleX11Requests   return ()@@ -172,8 +190,8 @@   fromRight def <$> postX11RequestSync action  rawGetWindowProperty ::-  Storable a-  => Int -> Display -> Atom -> Window -> IO (Maybe [a])+  (Storable a) =>+  Int -> Display -> Atom -> Window -> IO (Maybe [a]) rawGetWindowProperty bits d atom w =   runMaybeT $ do     (ptr, count) <- MaybeT $ rawGetWindowPropertyBytes bits d atom w@@ -190,39 +208,51 @@  getWMHints :: Display -> Window -> IO WMHints getWMHints dpy w = do-    p <- safeXGetWMHints dpy w-    if p == nullPtr-        then return $ WMHints 0 False 0 0 0 0 0 0 0-        else do x <- peek p; _ <- xFree p; return x+  p <- safeXGetWMHints dpy w+  if p == nullPtr+    then return $ WMHints 0 False 0 0 0 0 0 0 0+    else do x <- peek p; _ <- xFree p; return x -safeGetGeometry :: Display -> Drawable ->-        IO (Window, Position, Position, Dimension, Dimension, Dimension, CInt)+safeGetGeometry ::+  Display ->+  Drawable ->+  IO (Window, Position, Position, Dimension, Dimension, Dimension, CInt) safeGetGeometry display d =-        outParameters7 (throwIfZero "getGeometry") $-                xGetGeometry display d+  outParameters7 (throwIfZero "getGeometry") $+    xGetGeometry display d -outParameters7 :: (Storable a, Storable b, Storable c, Storable d, Storable e, Storable f, Storable g) =>-        (IO r -> IO ()) -> (Ptr a -> Ptr b -> Ptr c -> Ptr d -> Ptr e -> Ptr f -> Ptr g -> IO r) ->-        IO (a,b,c,d,e,f,g)+outParameters7 ::+  (Storable a, Storable b, Storable c, Storable d, Storable e, Storable f, Storable g) =>+  (IO r -> IO ()) ->+  (Ptr a -> Ptr b -> Ptr c -> Ptr d -> Ptr e -> Ptr f -> Ptr g -> IO r) ->+  IO (a, b, c, d, e, f, g) outParameters7 check fn =-        alloca $ \ a_return ->-        alloca $ \ b_return ->-        alloca $ \ c_return ->-        alloca $ \ d_return ->-        alloca $ \ e_return ->-        alloca $ \ f_return ->-        alloca $ \ g_return -> do-        check (fn a_return b_return c_return d_return e_return f_return g_return)-        a <- peek a_return-        b <- peek b_return-        c <- peek c_return-        d <- peek d_return-        e <- peek e_return-        f <- peek f_return-        g <- peek g_return-        return (a,b,c,d,e,f,g)+  alloca $ \a_return ->+    alloca $ \b_return ->+      alloca $ \c_return ->+        alloca $ \d_return ->+          alloca $ \e_return ->+            alloca $ \f_return ->+              alloca $ \g_return -> do+                check (fn a_return b_return c_return d_return e_return f_return g_return)+                a <- peek a_return+                b <- peek b_return+                c <- peek c_return+                d <- peek d_return+                e <- peek e_return+                f <- peek f_return+                g <- peek g_return+                return (a, b, c, d, e, f, g)  foreign import ccall safe "HsXlib.h XGetGeometry"-        xGetGeometry :: Display -> Drawable ->-                Ptr Window -> Ptr Position -> Ptr Position -> Ptr Dimension ->-                Ptr Dimension -> Ptr Dimension -> Ptr CInt -> IO Status+  xGetGeometry ::+    Display ->+    Drawable ->+    Ptr Window ->+    Ptr Position ->+    Ptr Position ->+    Ptr Dimension ->+    Ptr Dimension ->+    Ptr Dimension ->+    Ptr CInt ->+    IO Status
src/System/Taffybar/Information/ScreenLock.hs view
@@ -1,4 +1,7 @@ -----------------------------------------------------------------------------++-----------------------------------------------------------------------------+ -- | -- Module      : System.Taffybar.Information.ScreenLock -- Copyright   : (c) Ivan A. Malison@@ -11,28 +14,28 @@ -- This module provides screen lock functionality as a thin wrapper around -- "System.Taffybar.Information.Inhibitor". It re-exports the inhibitor -- management functions and adds a 'lockScreen' action that spawns hyprlock.------------------------------------------------------------------------------ module System.Taffybar.Information.ScreenLock   ( -- * Re-exports from Inhibitor-    getInhibitorChan-  , getInhibitorState-  , toggleInhibitor+    getInhibitorChan,+    getInhibitorState,+    toggleInhibitor,+     -- * Screen Lock-  , lockScreen-  ) where+    lockScreen,+  )+where  import Control.Monad (void) import Control.Monad.IO.Class import System.Process (spawnCommand)- import System.Taffybar.Information.Inhibitor-  ( getInhibitorChan-  , getInhibitorState-  , toggleInhibitor+  ( getInhibitorChan,+    getInhibitorState,+    toggleInhibitor,   )  -- | Lock the screen by spawning hyprlock. Output is redirected to -- @\/dev\/null@ to avoid flooding taffybar's log with hyprlock's -- verbose Wayland messages.-lockScreen :: MonadIO m => m ()+lockScreen :: (MonadIO m) => m () lockScreen = liftIO $ void $ spawnCommand "hyprlock >/dev/null 2>&1"
src/System/Taffybar/Information/StreamInfo.hs view
@@ -1,4 +1,7 @@ --------------------------------------------------------------------------------++--------------------------------------------------------------------------------+ -- | -- Module      : System.Taffybar.Information.StreamInfo -- Copyright   : (c) José A. Romero L.@@ -12,28 +15,26 @@ -- POSIX systems. Provides methods for applying a custom parsing function to the -- contents of the file and to calculate differentials across one or more values -- provided via the file.------------------------------------------------------------------------------------- module System.Taffybar.Information.StreamInfo-    ( getParsedInfo-    , getLoad-    , getAccLoad-    , getTransfer-    ) where+  ( getParsedInfo,+    getLoad,+    getAccLoad,+    getTransfer,+  )+where -import Control.Concurrent ( threadDelay )+import Control.Concurrent (threadDelay) import Data.IORef-import Data.Maybe ( fromMaybe )+import Data.Maybe (fromMaybe)  -- | Apply the given parser function to the file under the given path to produce -- a lookup map, then use the given selector as key to extract from it the -- desired value. getParsedInfo :: FilePath -> (String -> [(String, [a])]) -> String -> IO [a] getParsedInfo path parser selector = do-    file <- readFile path-    length file `seq` return ()-    return (fromMaybe [] $ lookup selector $ parser file)+  file <- readFile path+  length file `seq` return ()+  return (fromMaybe [] $ lookup selector $ parser file)  truncVal :: (RealFloat a) => a -> a truncVal v@@ -44,33 +45,34 @@ -- elements against their sum. toRatioList :: (Integral a, RealFloat b) => [a] -> [b] toRatioList deltas = map truncVal ratios-    where total = fromIntegral $ sum deltas-          ratios = map ((/total) . fromIntegral) deltas+  where+    total = fromIntegral $ sum deltas+    ratios = map ((/ total) . fromIntegral) deltas  -- | Execute the given action twice with the given delay in-between and return -- the difference between the two samples. probe :: (Num a, RealFrac b) => IO [a] -> b -> IO [a] probe action delay = do-    a <- action-    threadDelay $ round (delay * 1e6)-    b <- action-    return $ zipWith (-) b a+  a <- action+  threadDelay $ round (delay * 1e6)+  b <- action+  return $ zipWith (-) b a  -- | Execute the given action once and return the difference between the -- obtained sample and the one contained in the given IORef. accProbe :: (Num a) => IO [a] -> IORef [a] -> IO [a] accProbe action sample = do-    a <- readIORef sample-    b <- action-    writeIORef sample b-    return $ zipWith (-) b a+  a <- readIORef sample+  b <- action+  writeIORef sample b+  return $ zipWith (-) b a  -- | Probe the given action and, interpreting the result as a variation in time, -- return the speed of change of its values. getTransfer :: (Integral a, RealFloat b) => b -> IO [a] -> IO [b] getTransfer interval action = do-    deltas <- probe action interval-    return $ map (truncVal . (/interval) . fromIntegral) deltas+  deltas <- probe action interval+  return $ map (truncVal . (/ interval) . fromIntegral) deltas  -- | Probe the given action and return the relative variation of each of the -- obtained values against the whole, where the whole is calculated as the sum
src/System/Taffybar/Information/Systemd.hs view
@@ -1,5 +1,9 @@ {-# LANGUAGE OverloadedStrings #-}+ -----------------------------------------------------------------------------++-----------------------------------------------------------------------------+ -- | -- Module      : System.Taffybar.Information.Systemd -- Copyright   : (c) Ivan A. Malison@@ -12,64 +16,79 @@ -- 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+  ( 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 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 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+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+  = -- | All units are running properly+    SystemdRunning+  | -- | Some units have failed+    SystemdDegraded+  | -- | System is starting up+    SystemdStarting+  | -- | System is shutting down+    SystemdStopping+  | -- | System is in maintenance mode+    SystemdMaintenance+  | -- | System is initializing+    SystemdInitializing+  | -- | Unknown state+    SystemdOther Text+  | -- | systemd is not available on this bus+    SystemdUnavailable   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)+  { -- | State of system systemd+    systemState :: SystemdState,+    -- | State of user systemd+    userState :: SystemdState,+    -- | Number of failed system units+    systemFailedCount :: Int,+    -- | Number of failed user units+    userFailedCount :: Int,+    -- | Total failed units (system + user)+    totalFailedCount :: Int+  }+  deriving (Eq, Show)  -- | Default info when systemd is unknown/unavailable. systemdUnknownInfo :: SystemdInfo-systemdUnknownInfo = SystemdInfo-  { systemState = SystemdUnavailable-  , userState = SystemdUnavailable-  , systemFailedCount = 0-  , userFailedCount = 0-  , totalFailedCount = 0-  }+systemdUnknownInfo =+  SystemdInfo+    { systemState = SystemdUnavailable,+      userState = SystemdUnavailable,+      systemFailedCount = 0,+      userFailedCount = 0,+      totalFailedCount = 0+    }  systemdLogPath :: String systemdLogPath = "System.Taffybar.Information.Systemd"@@ -88,13 +107,13 @@ parseSystemdState :: Text -> SystemdState parseSystemdState txt =   case T.toLower txt of-    "running"      -> SystemdRunning-    "degraded"     -> SystemdDegraded-    "starting"     -> SystemdStarting-    "stopping"     -> SystemdStopping-    "maintenance"  -> SystemdMaintenance+    "running" -> SystemdRunning+    "degraded" -> SystemdDegraded+    "starting" -> SystemdStarting+    "stopping" -> SystemdStopping+    "maintenance" -> SystemdMaintenance     "initializing" -> SystemdInitializing-    _              -> SystemdOther txt+    _ -> SystemdOther txt  -- | Newtype wrapper for the channel/var pair stored in Context. newtype SystemdInfoChanVar = SystemdInfoChanVar (TChan SystemdInfo, MVar SystemdInfo)@@ -143,20 +162,26 @@         signalCallback _ _ _ _ = runReaderT debouncedUpdate ctx      -- Register for PropertiesChanged on system bus-    _ <- lift $ DBus.registerForPropertiesChanged-      systemClient-      matchAny { matchInterface = Just systemdManagerInterface-               , matchPath = Just systemdObjectPath-               }-      signalCallback+    _ <-+      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+    _ <-+      lift $+        DBus.registerForPropertiesChanged+          sessionClient+          matchAny+            { matchInterface = Just systemdManagerInterface,+              matchPath = Just systemdObjectPath+            }+          signalCallback      -- Initial update     doUpdate@@ -164,12 +189,12 @@   return (chan, infoVar)  -- | Update the systemd info by querying both buses.-updateSystemdInfo-  :: TChan SystemdInfo-  -> MVar SystemdInfo-  -> Client-  -> Client-  -> TaffyIO ()+updateSystemdInfo ::+  TChan SystemdInfo ->+  MVar SystemdInfo ->+  Client ->+  Client ->+  TaffyIO () updateSystemdInfo chan var systemClient sessionClient = do   info <- liftIO $ getSystemdInfoFromClients systemClient sessionClient   liftIO $ do@@ -188,13 +213,14 @@ 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-    }+  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)@@ -206,9 +232,11 @@         "Failed to get " ++ busType ++ " systemd state: " ++ show err       return (SystemdUnavailable, 0)     Right stateVariant -> do-      let state = maybe (SystemdOther "unknown")-                        parseSystemdState-                        (fromVariant stateVariant :: Maybe Text)+      let state =+            maybe+              (SystemdOther "unknown")+              parseSystemdState+              (fromVariant stateVariant :: Maybe Text)       -- Only query failed count if degraded       if state == SystemdDegraded         then do@@ -226,21 +254,31 @@ -- | 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]-    }+  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")+          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
@@ -1,4 +1,7 @@ --------------------------------------------------------------------------------++--------------------------------------------------------------------------------+ -- | -- Module      : System.Taffybar.Information.Temperature -- Copyright   : (c) Ivan Malison@@ -10,21 +13,19 @@ -- -- 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+  ( TemperatureInfo (..),+    ThermalSensor (..),+    TemperatureUnit (..),+    discoverSensors,+    readSensorTemperature,+    readAllTemperatures,+    readTemperaturesFrom,+    convertTemperature,+  )+where -import Control.Exception (try, SomeException)+import Control.Exception (SomeException, try) import Control.Monad (forM) import Data.List (sortOn) import Data.Maybe (catMaybes, fromMaybe)@@ -38,16 +39,23 @@  -- | 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)+  { -- | Human-readable sensor name+    sensorName :: String,+    -- | Path to the temperature file+    sensorPath :: FilePath,+    -- | Zone or hwmon identifier+    sensorZone :: String+  }+  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)+  { -- | Temperature in Celsius+    tempCelsius :: Double,+    -- | The sensor this reading is from+    tempSensor :: ThermalSensor+  }+  deriving (Show, Eq)  -- | Convert temperature from Celsius to another unit convertTemperature :: TemperatureUnit -> Double -> Double@@ -80,11 +88,13 @@         if tempExists           then do             sensorType <- readFileSafe typePath-            return $ Just ThermalSensor-              { sensorName = fromMaybe zone sensorType-              , sensorPath = tempPath-              , sensorZone = zone-              }+            return $+              Just+                ThermalSensor+                  { sensorName = fromMaybe zone sensorType,+                    sensorPath = tempPath,+                    sensorZone = zone+                  }           else return Nothing       return $ catMaybes sensors   where@@ -116,11 +126,12 @@                 (Just l, _) -> l                 (_, Just n) -> n ++ "_temp" ++ sensorId                 _ -> hwmon ++ "_temp" ++ sensorId-          return ThermalSensor-            { sensorName = name-            , sensorPath = tempPath-            , sensorZone = hwmon-            }+          return+            ThermalSensor+              { sensorName = name,+                sensorPath = tempPath,+                sensorZone = hwmon+              }       return $ concat sensorLists   where     isPrefixOf prefix str = take (length prefix) str == prefix@@ -128,12 +139,12 @@     isSuffixOf suffix str =       let suffixLen = length suffix           strLen = length str-      in strLen >= suffixLen && drop (strLen - suffixLen) str == suffix+       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+      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)@@ -159,10 +170,13 @@     Right content ->       case readMaybe (strip content) :: Maybe Integer of         Nothing -> return Nothing-        Just milliDegrees -> return $ Just TemperatureInfo-          { tempCelsius = fromIntegral milliDegrees / 1000.0-          , tempSensor = sensor-          }+        Just milliDegrees ->+          return $+            Just+              TemperatureInfo+                { tempCelsius = fromIntegral milliDegrees / 1000.0,+                  tempSensor = sensor+                }   where     strip = dropWhile (== ' ') . reverse . dropWhile (== '\n') . reverse . dropWhile (== ' ')
src/System/Taffybar/Information/Udev.hs view
@@ -8,21 +8,24 @@ --    'GHC.Conc.threadWaitRead'. -- 3. Drain pending udev events via 'udev_monitor_receive_device'. module System.Taffybar.Information.Udev-  ( UdevBacklightMonitor-  , openBacklightMonitor-  , closeBacklightMonitor-  , backlightMonitorFd-  , drainBacklightMonitor-  ) where+  ( UdevBacklightMonitor,+    openBacklightMonitor,+    closeBacklightMonitor,+    backlightMonitorFd,+    drainBacklightMonitor,+  )+where -import Control.Monad (void, when) import Control.Exception (bracketOnError, throwIO)+import Control.Monad (void, when) import Foreign hiding (void) import Foreign.C-import System.Posix.Types (Fd(..))+import System.Posix.Types (Fd (..))  data Udev+ data UdevMonitor+ data UdevDevice  foreign import ccall unsafe "udev_new"@@ -38,11 +41,11 @@   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+  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@@ -57,9 +60,9 @@   c_udev_device_unref :: Ptr UdevDevice -> IO (Ptr UdevDevice)  data UdevBacklightMonitor = UdevBacklightMonitor-  { monitorUdev :: Ptr Udev-  , monitorHandle :: Ptr UdevMonitor-  , monitorFd :: Fd+  { monitorUdev :: Ptr Udev,+    monitorHandle :: Ptr UdevMonitor,+    monitorFd :: Fd   }  openBacklightMonitor :: IO UdevBacklightMonitor@@ -78,11 +81,12 @@         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-          }+        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)
+ src/System/Taffybar/Information/Wakeup.hs view
@@ -0,0 +1,159 @@+{-# LANGUAGE AllowAmbiguousTypes #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE KindSignatures #-}+{-# LANGUAGE MultiWayIf #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeApplications #-}++-- |+-- Module      : System.Taffybar.Information.Wakeup+-- Copyright   : (c) Ivan A. Malison+-- License     : BSD3-style (see LICENSE)+--+-- Maintainer  : Ivan A. Malison+-- Stability   : unstable+-- Portability : unportable+--+-- Shared coordinated wakeup channels keyed by polling interval.+--+-- This module provides a single scheduler thread that wakes registered+-- intervals from a shared monotonic timeline. Intervals that evenly divide each+-- other naturally align to the same schedule (e.g. 10s wakeups occur on every+-- other 5s boundary). The wall-clock phase is chosen from the Unix epoch, which+-- means wakeups are top-of-second aligned and minute-start aligned whenever the+-- interval permits.+module System.Taffybar.Information.Wakeup+  ( WakeupEvent (..),+    WakeupSchedulerEvent (..),+    WakeupChannel (..),+    taffyForeverWithDelay,+    getWakeupChannelNanoseconds,+    getWakeupChannelSeconds,+    getWakeupChannelForDelay,+    getWakeupChannel,+    getWakeupSchedulerEvents,+    getRegisteredWakeupIntervalsNanoseconds,+    intervalSecondsToNanoseconds,+    nextWallAlignedWakeupNs,+    nextAlignedWakeupNs,+    intervalDueAtStepNs,+  )+where++import Control.Concurrent (ThreadId, forkIO)+import Control.Concurrent.STM (atomically)+import Control.Concurrent.STM.TChan (TChan, dupTChan, readTChan)+import Control.Exception.Enclosed (catchAny)+import Control.Monad (forever, void)+import Control.Monad.IO.Class (liftIO)+import Control.Monad.Trans.Reader (ask, asks, runReaderT)+import Data.Proxy (Proxy (..))+import Data.Word (Word64)+import GHC.TypeNats (KnownNat, Nat, natVal)+import System.Log.Logger (Priority (..), logM)+import System.Taffybar.Context (Context, TaffyIO, wakeupManager)+import System.Taffybar.Information.Wakeup.Manager+  ( WakeupEvent (..),+    WakeupManager,+    WakeupSchedulerEvent (..),+    intervalDueAtStepNs,+    intervalSecondsToNanoseconds,+    nextAlignedWakeupNs,+    nextWallAlignedWakeupNs,+    registerWakeupInterval,+    secondsToNanoseconds,+    subscribeWakeupSchedulerEvents,+  )+import qualified System.Taffybar.Information.Wakeup.Manager as WakeupManager+import Text.Printf (printf)++-- | Type-tagged wakeup channel for @TypeApplications@-based lookup.+newtype WakeupChannel (seconds :: Nat)+  = WakeupChannel {unWakeupChannel :: TChan WakeupEvent}++-- | Execute a 'TaffyIO' action on a shared synchronized wakeup schedule.+--+-- This is the preferred context-aware replacement for+-- 'System.Taffybar.Util.foreverWithDelay'.+taffyForeverWithDelay :: (RealFrac d) => d -> TaffyIO () -> TaffyIO ThreadId+taffyForeverWithDelay delay action = do+  wakeupChan <- getWakeupChannelForDelay delay+  ourWakeupChan <- liftIO $ atomically $ dupTChan wakeupChan+  context <- ask+  liftIO $+    forkIO $+      forever $ do+        safeAction context+        void $ atomically $ readTChan ourWakeupChan+  where+    safeAction :: Context -> IO ()+    safeAction context =+      catchAny+        (runReaderT action context)+        (logM logPath WARNING . printf "Error in taffyForeverWithDelay %s" . show)++-- | Return the shared wakeup channel for an interval in nanoseconds.+getWakeupChannelNanoseconds :: Word64 -> TaffyIO (TChan WakeupEvent)+getWakeupChannelNanoseconds intervalNs = do+  manager <- getWakeupManager+  liftIO $ registerWakeupInterval manager intervalNs++-- | Subscribe to aggregated scheduler wakeup events.+getWakeupSchedulerEvents :: TaffyIO (TChan WakeupSchedulerEvent)+getWakeupSchedulerEvents = do+  manager <- getWakeupManager+  liftIO $ subscribeWakeupSchedulerEvents manager++-- | Return all currently registered wakeup intervals (nanoseconds).+getRegisteredWakeupIntervalsNanoseconds :: TaffyIO [Word64]+getRegisteredWakeupIntervalsNanoseconds = do+  manager <- getWakeupManager+  liftIO $ WakeupManager.getRegisteredWakeupIntervalsNanoseconds manager++-- | Return the shared wakeup channel for @seconds@.+getWakeupChannelSeconds :: Int -> TaffyIO (TChan WakeupEvent)+getWakeupChannelSeconds seconds =+  case secondsToNanoseconds seconds of+    Left err -> fail err+    Right intervalNs -> getWakeupChannelNanoseconds intervalNs++-- | Return the shared wakeup channel for an interval expressed in seconds.+getWakeupChannelForDelay :: (RealFrac d) => d -> TaffyIO (TChan WakeupEvent)+getWakeupChannelForDelay seconds =+  case intervalSecondsToNanoseconds seconds of+    Left err -> fail err+    Right intervalNs -> getWakeupChannelNanoseconds intervalNs++-- | Type-driven variant of 'getWakeupChannelSeconds'.+--+-- Example:+--+-- @+-- wake5 <- getWakeupChannel @5+-- wake10 <- getWakeupChannel @10+-- @+getWakeupChannel ::+  forall seconds.+  (KnownNat seconds) =>+  TaffyIO (TChan WakeupEvent)+getWakeupChannel = do+  seconds <- intervalSecondsFromType @seconds+  getWakeupChannelSeconds seconds++getWakeupManager :: TaffyIO WakeupManager+getWakeupManager = asks wakeupManager++intervalSecondsFromType :: forall seconds m. (KnownNat seconds, MonadFail m) => m Int+intervalSecondsFromType =+  let secondsInteger = toInteger (natVal (Proxy :: Proxy seconds))+      maxIntInteger = toInteger (maxBound :: Int)+   in if+        | secondsInteger <= 0 ->+            fail "Wakeup interval must be greater than 0 seconds"+        | secondsInteger > maxIntInteger ->+            fail "Wakeup interval does not fit into an Int"+        | otherwise ->+            return (fromInteger secondsInteger)++logPath :: String+logPath = "System.Taffybar.Information.Wakeup"
+ src/System/Taffybar/Information/Wakeup/Manager.hs view
@@ -0,0 +1,319 @@+-- |+-- Module      : System.Taffybar.Information.Wakeup.Manager+-- Copyright   : (c) Ivan A. Malison+-- License     : BSD3-style (see LICENSE)+--+-- Maintainer  : Ivan A. Malison+-- Stability   : unstable+-- Portability : unportable+--+-- Internal shared wakeup manager implementation.+module System.Taffybar.Information.Wakeup.Manager+  ( WakeupEvent (..),+    WakeupSchedulerEvent (..),+    WakeupManager,+    newWakeupManager,+    registerWakeupInterval,+    subscribeWakeupSchedulerEvents,+    getRegisteredWakeupIntervalsNanoseconds,+    secondsToNanoseconds,+    intervalSecondsToNanoseconds,+    nextWallAlignedWakeupNs,+    nextAlignedWakeupNs,+    intervalDueAtStepNs,+  )+where++import Control.Concurrent (forkIO, threadDelay)+import Control.Concurrent.STM+  ( STM,+    TVar,+    atomically,+    check,+    newTVarIO,+    orElse,+    readTVar,+    registerDelay,+    writeTVar,+  )+import Control.Concurrent.STM.TChan+  ( TChan,+    dupTChan,+    newBroadcastTChan,+    newBroadcastTChanIO,+    newTChanIO,+    readTChan,+    tryReadTChan,+    writeTChan,+  )+import Control.Exception.Enclosed (catchAny)+import qualified Data.Map.Strict as M+import Data.Maybe (mapMaybe)+import Data.Time.Clock.POSIX (getPOSIXTime)+import Data.Word (Word64)+import GHC.Clock (getMonotonicTimeNSec)+import System.Log.Logger (Priority (..), logM)+import Text.Printf (printf)++-- | A wakeup event emitted for a registered interval.+data WakeupEvent = WakeupEvent+  { wakeupIntervalNanoseconds :: !Word64,+    -- | Monotonic counter for this interval. If the scheduler was delayed,+    -- this counter can advance by more than one between events.+    wakeupTickCount :: !Word64+  }+  deriving (Eq, Show)++-- | A scheduler event containing all interval wakeups published together.+data WakeupSchedulerEvent = WakeupSchedulerEvent+  { wakeupEventTimeNanoseconds :: !Word64,+    wakeupDueEvents :: ![WakeupEvent]+  }+  deriving (Eq, Show)++-- Internal scheduler state for one interval.+data IntervalRegistration = IntervalRegistration+  { intervalNanoseconds :: !Word64,+    intervalChannel :: TChan WakeupEvent,+    intervalNextDueNs :: !Word64,+    intervalTickCount :: !Word64+  }++-- Shared wakeup manager state.+data WakeupManager = WakeupManager+  { -- Approximate wall clock as @monotonic + wakeupRealtimeOffsetNs@.+    wakeupRealtimeOffsetNs :: !Integer,+    wakeupIntervals :: TVar (M.Map Word64 IntervalRegistration),+    wakeupRescheduleChan :: TChan (),+    wakeupDebugChan :: TChan WakeupSchedulerEvent+  }++newWakeupManager :: IO WakeupManager+newWakeupManager = do+  realtimeOffsetNs <- getRealtimeOffsetNs+  intervalsVar <- newTVarIO M.empty+  rescheduleChan <- newTChanIO+  debugChan <- newBroadcastTChanIO+  let manager =+        WakeupManager+          { wakeupRealtimeOffsetNs = realtimeOffsetNs,+            wakeupIntervals = intervalsVar,+            wakeupRescheduleChan = rescheduleChan,+            wakeupDebugChan = debugChan+          }+  _ <- forkIO (runWakeupScheduler manager)+  pure manager++registerWakeupInterval :: WakeupManager -> Word64 -> IO (TChan WakeupEvent)+registerWakeupInterval manager intervalNs =+  case validateIntervalNanoseconds intervalNs of+    Left err -> ioError (userError err)+    Right validIntervalNs -> do+      now <- getMonotonicTimeNSec+      atomically $ do+        registrations <- readTVar (wakeupIntervals manager)+        case M.lookup validIntervalNs registrations of+          Just registration -> pure (intervalChannel registration)+          Nothing -> do+            channel <- newBroadcastTChan+            let registration =+                  IntervalRegistration+                    { intervalNanoseconds = validIntervalNs,+                      intervalChannel = channel,+                      intervalNextDueNs =+                        nextWallAlignedWakeupNs+                          (wakeupRealtimeOffsetNs manager)+                          validIntervalNs+                          now,+                      intervalTickCount = 0+                    }+            writeTVar+              (wakeupIntervals manager)+              (M.insert validIntervalNs registration registrations)+            -- Ensure the scheduler recomputes immediately, so newly added short+            -- intervals are not blocked behind an older long sleep.+            writeTChan (wakeupRescheduleChan manager) ()+            pure channel++subscribeWakeupSchedulerEvents :: WakeupManager -> IO (TChan WakeupSchedulerEvent)+subscribeWakeupSchedulerEvents manager =+  atomically $ dupTChan (wakeupDebugChan manager)++getRegisteredWakeupIntervalsNanoseconds :: WakeupManager -> IO [Word64]+getRegisteredWakeupIntervalsNanoseconds manager =+  atomically $ M.keys <$> readTVar (wakeupIntervals manager)++runWakeupScheduler :: WakeupManager -> IO ()+runWakeupScheduler manager =+  schedulerLoop `catchAny` onSchedulerException+  where+    schedulerLoop = do+      maybeNextDue <- atomically $ nextDueNs <$> readTVar (wakeupIntervals manager)+      case maybeNextDue of+        Nothing -> atomically (readTChan (wakeupRescheduleChan manager) >> drainRescheduleChan (wakeupRescheduleChan manager))+        Just nextDue -> do+          now <- getMonotonicTimeNSec+          if nextDue <= now+            then publishDueIntervals manager now+            else waitForRescheduleOrTimeout manager (nextDue - now)+      schedulerLoop++    onSchedulerException e = do+      logM logPath WARNING $ printf "Wakeup scheduler crashed and will be restarted: %s" (show e)+      threadDelay 1000000+      runWakeupScheduler manager++waitForRescheduleOrTimeout :: WakeupManager -> Word64 -> IO ()+waitForRescheduleOrTimeout manager delayNs = do+  timeoutVar <- registerDelay (toRegisterDelayMicros delayNs)+  atomically $+    (readTChan (wakeupRescheduleChan manager) >> drainRescheduleChan (wakeupRescheduleChan manager))+      `orElse` (readTVar timeoutVar >>= check)++publishDueIntervals :: WakeupManager -> Word64 -> IO ()+publishDueIntervals manager nowNs =+  atomically $ do+    registrations <- readTVar (wakeupIntervals manager)+    updatedWithEvents <- mapM (advanceIntervalIfDue nowNs) registrations+    let updated = fst <$> updatedWithEvents+        dueEvents = mapMaybe snd (M.elems updatedWithEvents)+    writeTVar (wakeupIntervals manager) updated+    if null dueEvents+      then pure ()+      else+        writeTChan+          (wakeupDebugChan manager)+          WakeupSchedulerEvent+            { wakeupEventTimeNanoseconds = nowNs,+              wakeupDueEvents = dueEvents+            }++advanceIntervalIfDue :: Word64 -> IntervalRegistration -> STM (IntervalRegistration, Maybe WakeupEvent)+advanceIntervalIfDue nowNs registration+  | intervalNextDueNs registration > nowNs = pure (registration, Nothing)+  | otherwise = do+      let intervalsElapsed =+            ((nowNs - intervalNextDueNs registration) `div` intervalNanoseconds registration) + 1+          nextDueNs' =+            fromInteger $+              toInteger (intervalNextDueNs registration)+                + toInteger intervalsElapsed * toInteger (intervalNanoseconds registration)+          tickCount = intervalTickCount registration + intervalsElapsed+          wakeupEvent =+            WakeupEvent+              { wakeupIntervalNanoseconds = intervalNanoseconds registration,+                wakeupTickCount = tickCount+              }+      writeTChan+        (intervalChannel registration)+        wakeupEvent+      pure+        ( registration+            { intervalNextDueNs = nextDueNs',+              intervalTickCount = tickCount+            },+          Just wakeupEvent+        )++nextDueNs :: M.Map Word64 IntervalRegistration -> Maybe Word64+nextDueNs registrations+  | M.null registrations = Nothing+  | otherwise = Just $ minimum $ intervalNextDueNs <$> M.elems registrations++secondsToNanoseconds :: Int -> Either String Word64+secondsToNanoseconds seconds+  | seconds <= 0 = Left "Wakeup interval must be greater than 0 seconds"+  | secondsInteger > maxWord64Integer =+      Left "Wakeup interval is too large"+  | otherwise =+      Right (fromInteger secondsInteger)+  where+    secondsInteger = toInteger seconds * 1000000000+    maxWord64Integer = toInteger (maxBound :: Word64)++-- | Convert an interval in seconds to nanoseconds.+intervalSecondsToNanoseconds :: (RealFrac d) => d -> Either String Word64+intervalSecondsToNanoseconds seconds+  | secondsRational <= 0 = Left "Wakeup interval must be greater than 0 seconds"+  | intervalNanosecondsInteger <= 0 = Left "Wakeup interval rounded to zero nanoseconds"+  | intervalNanosecondsInteger > maxWord64Integer = Left "Wakeup interval is too large"+  | otherwise = Right (fromInteger intervalNanosecondsInteger)+  where+    secondsRational = toRational seconds+    intervalNanosecondsInteger = round (secondsRational * 1000000000)+    maxWord64Integer = toInteger (maxBound :: Word64)++validateIntervalNanoseconds :: Word64 -> Either String Word64+validateIntervalNanoseconds intervalNs+  | intervalNs == 0 = Left "Wakeup interval must be greater than 0 nanoseconds"+  | otherwise = Right intervalNs++-- | Convert a delay in nanoseconds into a value suitable for+-- 'Control.Concurrent.STM.registerDelay'.+toRegisterDelayMicros :: Word64 -> Int+toRegisterDelayMicros nanoseconds =+  fromInteger (min maxIntInteger micros)+  where+    micros = (toInteger nanoseconds + 999) `div` 1000+    maxIntInteger = toInteger (maxBound :: Int)++drainRescheduleChan :: TChan () -> STM ()+drainRescheduleChan chan = do+  maybeEvent <- tryReadTChan chan+  case maybeEvent of+    Nothing -> pure ()+    Just () -> drainRescheduleChan chan++getRealtimeOffsetNs :: IO Integer+getRealtimeOffsetNs = do+  monotonicBefore <- getMonotonicTimeNSec+  wallNow <- getPOSIXTimeNanoseconds+  monotonicAfter <- getMonotonicTimeNSec+  let monotonicMidpoint =+        (toInteger monotonicBefore + toInteger monotonicAfter) `div` 2+  pure $ wallNow - monotonicMidpoint++getPOSIXTimeNanoseconds :: IO Integer+getPOSIXTimeNanoseconds = do+  -- POSIX time has picosecond precision; convert to nanoseconds.+  posix <- getPOSIXTime+  let picoseconds :: Integer+      picoseconds = round (posix * 1000000000000)+  pure (picoseconds `div` 1000)++-- | Return the next due monotonic timestamp strictly after @nowNs@ for the+-- given @intervalNs@, aligned to wall-clock interval boundaries.+--+-- The wall clock is approximated as @monotonic + realtimeOffsetNs@.+nextWallAlignedWakeupNs :: Integer -> Word64 -> Word64 -> Word64+nextWallAlignedWakeupNs realtimeOffsetNs intervalNs nowNs =+  fromInteger (toInteger nowNs + delta)+  where+    wallNowNs = toInteger nowNs + realtimeOffsetNs+    intervalInteger = toInteger intervalNs+    remainder = wallNowNs `mod` intervalInteger+    delta+      | remainder == 0 = intervalInteger+      | otherwise = intervalInteger - remainder++-- | Return the @step@-th due timestamp for @intervalNs@ from @anchorNs@.+--+-- Steps are 1-indexed (step 1 is the first due time at @anchor + interval@).+intervalDueAtStepNs :: Word64 -> Word64 -> Word64 -> Word64+intervalDueAtStepNs anchorNs intervalNs step =+  fromInteger $+    toInteger anchorNs+      + toInteger intervalNs * toInteger step++-- | Return the next due timestamp strictly after @nowNs@ for the given+-- @intervalNs@ from @anchorNs@.+nextAlignedWakeupNs :: Word64 -> Word64 -> Word64 -> Word64+nextAlignedWakeupNs anchorNs intervalNs nowNs =+  intervalDueAtStepNs anchorNs intervalNs (stepsElapsed + 1)+  where+    stepsElapsed+      | nowNs <= anchorNs = 0+      | otherwise = (nowNs - anchorNs) `div` intervalNs++logPath :: String+logPath = "System.Taffybar.Information.Wakeup"
src/System/Taffybar/Information/WirePlumber.hs view
@@ -36,11 +36,10 @@   ) 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 (void) import Control.Monad.IO.Class (MonadIO, liftIO) import Control.Monad.STM (atomically) import Data.List (isInfixOf)@@ -50,6 +49,7 @@ import GHC.TypeLits (KnownSymbol, SomeSymbol (..), Symbol, someSymbolVal, symbolVal) import System.Log.Logger (Priority (..)) import System.Taffybar.Context (TaffyIO, getStateDefault)+import System.Taffybar.Information.Wakeup (taffyForeverWithDelay) import System.Taffybar.Util (logPrintF, runCommand) import Text.Read (readMaybe) @@ -101,45 +101,49 @@  -- | 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 :: 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 :: 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 :: 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)+    chan <- liftIO newBroadcastTChanIO+    var <- liftIO $ newMVar Nothing+    liftIO $ refreshWirePlumberInfo nodeSpec chan var+    let pollIntervalSeconds :: Double+        pollIntervalSeconds = fromIntegral pollIntervalMicros / 1000000+    void $+      taffyForeverWithDelay pollIntervalSeconds $+        liftIO $+          refreshWirePlumberInfo nodeSpec chan var+    pure $ WirePlumberInfoChanVar (chan, var)  -- | Polling interval in microseconds (1 second). pollIntervalMicros :: Int pollIntervalMicros = 1_000_000 -monitorWirePlumberInfo ::+refreshWirePlumberInfo ::   String ->   TChan (Maybe WirePlumberInfo) ->   MVar (Maybe WirePlumberInfo) ->   IO ()-monitorWirePlumberInfo nodeSpec chan var = forever $ do+refreshWirePlumberInfo nodeSpec chan var = do   result <- try $ getWirePlumberInfo nodeSpec   let info = case result of         Left (_ :: SomeException) -> Nothing         Right i -> i   _ <- swapMVar var info   atomically $ writeTChan chan info-  threadDelay pollIntervalMicros  -- | Query volume and mute state for the provided node spec. --
src/System/Taffybar/Information/Wlsunset.hs view
@@ -1,4 +1,7 @@ -----------------------------------------------------------------------------++-----------------------------------------------------------------------------+ -- | -- Module      : System.Taffybar.Information.Wlsunset -- Copyright   : (c) Ivan A. Malison@@ -10,78 +13,101 @@ -- -- This module provides process-level management of @wlsunset@, a -- Wayland day\/night gamma adjustor. It polls for the running state of--- the process and tracks mode cycling (auto → forced-warm → forced-cool--- → auto) via @SIGUSR1@.------------------------------------------------------------------------------+-- the process and tracks mode cycling (auto → forced high temp →+-- forced low temp → auto) via @SIGUSR1@. module System.Taffybar.Information.Wlsunset   ( -- * Types-    WlsunsetMode(..)-  , WlsunsetState(..)-  , WlsunsetConfig(..)+    WlsunsetMode (..),+    WlsunsetState (..),+    WlsunsetConfig (..),+     -- * State access-  , getWlsunsetChan-  , getWlsunsetState+    getWlsunsetChan,+    getWlsunsetState,+     -- * Actions-  , cycleWlsunsetMode-  , startWlsunset-  , stopWlsunset-  , toggleWlsunset-  ) where+    cycleWlsunsetMode,+    startWlsunset,+    stopWlsunset,+    toggleWlsunset,+    restartWlsunsetWithTemps,+  )+where -import           Control.Concurrent (threadDelay)-import           Control.Concurrent.MVar-import           Control.Concurrent.STM.TChan-import           Control.Exception.Enclosed (catchAny)-import           Control.Monad (void, when)-import           Control.Monad.IO.Class-import           Control.Monad.STM (atomically)-import           Control.Monad.Trans.Class-import           Data.Default (Default(..))-import           System.Log.Logger-import           System.Posix.Signals (signalProcess, sigUSR1)-import           System.Posix.Types (CPid(..))-import           System.Process (readProcess, spawnCommand)-import           System.Taffybar.Context-import           System.Taffybar.Util (logPrintF)-import           Text.Read (readMaybe)+import Control.Concurrent.MVar+import Control.Concurrent.STM.TChan+import Control.Exception.Enclosed (catchAny)+import Control.Monad (void, when)+import Control.Monad.IO.Class+import Control.Monad.STM (atomically)+import Control.Monad.Trans.Class+import Data.Default (Default (..))+import Data.List (isPrefixOf)+import System.Log.Logger+import System.Posix.Signals (sigUSR1, signalProcess)+import System.Posix.Types (CPid (..))+import System.Process (readProcess, spawnCommand)+import System.Taffybar.Context+import System.Taffybar.Information.Wakeup (getWakeupChannelSeconds)+import System.Taffybar.Util (logPrintF)+import Text.Read (readMaybe)  -- | The three operating modes that wlsunset cycles through when it--- receives @SIGUSR1@.+-- receives @SIGUSR1@.  The cycle order matches wlsunset's internal+-- ring: Auto → ForcedHighTemp → ForcedLowTemp → Auto. data WlsunsetMode-  = WlsunsetAuto        -- ^ Normal day/night schedule-  | WlsunsetForcedWarm  -- ^ Forced warm (night) temperature-  | WlsunsetForcedCool  -- ^ Forced cool (day) temperature+  = -- | Normal day/night schedule+    WlsunsetAuto+  | -- | Forced high (day) temperature — no color shift+    WlsunsetForcedHighTemp+  | -- | Forced low (night) temperature — warm/reddish colors+    WlsunsetForcedLowTemp   deriving (Eq, Show, Ord, Enum, Bounded)  -- | Observable state of the wlsunset process. data WlsunsetState = WlsunsetState-  { wlsunsetRunning :: Bool-  , wlsunsetMode    :: WlsunsetMode-  } deriving (Eq, Show)+  { wlsunsetRunning :: Bool,+    wlsunsetMode :: WlsunsetMode,+    -- | The effective high temperature wlsunset is running with.+    wlsunsetEffectiveHighTemp :: Int,+    -- | The effective low temperature wlsunset is running with.+    wlsunsetEffectiveLowTemp :: Int+  }+  deriving (Eq, Show)  -- | Configuration for the wlsunset monitor. data WlsunsetConfig = WlsunsetConfig   { -- | Full shell command used to start wlsunset (e.g.     -- @\"wlsunset -l 38.9 -L -77.0\"@).-    wlsunsetCommand        :: String+    wlsunsetCommand :: String,+    -- | High (day) temperature in Kelvin. Used for display only.+    -- Should match the @-T@ flag passed to wlsunset (default 6500).+    wlsunsetHighTemp :: Int,+    -- | Low (night) temperature in Kelvin. Used for display only.+    -- Should match the @-t@ flag passed to wlsunset (default 4000).+    wlsunsetLowTemp :: Int,     -- | How often (in seconds) to poll for process status.-  , wlsunsetPollIntervalSec :: Int-  } deriving (Eq, Show)+    wlsunsetPollIntervalSec :: Int+  }+  deriving (Eq, Show)  instance Default WlsunsetConfig where-  def = WlsunsetConfig-    { wlsunsetCommand         = "wlsunset"-    , wlsunsetPollIntervalSec = 2-    }+  def =+    WlsunsetConfig+      { wlsunsetCommand = "wlsunset",+        wlsunsetHighTemp = 6500,+        wlsunsetLowTemp = 4000,+        wlsunsetPollIntervalSec = 2+      }  -- | Internal state bundle stored in 'contextState' via 'getStateDefault'.-newtype WlsunsetChanVar =-  WlsunsetChanVar (TChan WlsunsetState, MVar WlsunsetState, WlsunsetConfig)+newtype WlsunsetChanVar+  = WlsunsetChanVar (TChan WlsunsetState, MVar WlsunsetState, WlsunsetConfig)  wlsunsetLogPath :: String wlsunsetLogPath = "System.Taffybar.Information.Wlsunset" -wlsunsetLog :: MonadIO m => Priority -> String -> m ()+wlsunsetLog :: (MonadIO m) => Priority -> String -> m () wlsunsetLog priority = liftIO . logM wlsunsetLogPath priority  wlsunsetLogF :: (MonadIO m, Show t) => Priority -> String -> t -> m ()@@ -100,7 +126,7 @@   where     parsePids = map (CPid . fromIntegral) . concatMap toList . lines     toList s = case (readMaybe s :: Maybe Int) of-      Just n  -> [n]+      Just n -> [n]       Nothing -> []  -- | Send @SIGUSR1@ to a wlsunset process to cycle its mode.@@ -128,20 +154,26 @@   lift $ readMVar var  -- | Start the polling loop that monitors wlsunset.-monitorWlsunset-  :: WlsunsetConfig-  -> TaffyIO (TChan WlsunsetState, MVar WlsunsetState, WlsunsetConfig)+monitorWlsunset ::+  WlsunsetConfig ->+  TaffyIO (TChan WlsunsetState, MVar WlsunsetState, WlsunsetConfig) monitorWlsunset cfg = do-  let initialState = WlsunsetState { wlsunsetRunning = False-                                   , wlsunsetMode    = WlsunsetAuto-                                   }+  let initialState =+        WlsunsetState+          { wlsunsetRunning = False,+            wlsunsetMode = WlsunsetAuto,+            wlsunsetEffectiveHighTemp = wlsunsetHighTemp cfg,+            wlsunsetEffectiveLowTemp = wlsunsetLowTemp cfg+          }   stateVar <- liftIO $ newMVar initialState-  chan     <- liftIO newBroadcastTChanIO+  chan <- liftIO newBroadcastTChanIO+  wakeupChan <- getWakeupChannelSeconds (max 1 (wlsunsetPollIntervalSec cfg))+  ourWakeupChan <- liftIO $ atomically $ dupTChan wakeupChan   taffyFork $ do     wlsunsetLog DEBUG "Starting wlsunset polling loop"     let loop = do           liftIO $ pollWlsunset chan stateVar-          liftIO $ threadDelay (wlsunsetPollIntervalSec cfg * 1000000)+          liftIO $ void $ atomically $ readTChan ourWakeupChan           loop     loop   return (chan, stateVar, cfg)@@ -157,11 +189,13 @@         -- When the process freshly appears, reset mode to Auto.         newMode           | not wasRunning && isRunning = WlsunsetAuto-          | not isRunning              = WlsunsetAuto-          | otherwise                  = wlsunsetMode old-        new = WlsunsetState { wlsunsetRunning = isRunning-                             , wlsunsetMode    = newMode-                             }+          | not isRunning = WlsunsetAuto+          | otherwise = wlsunsetMode old+        new =+          old+            { wlsunsetRunning = isRunning,+              wlsunsetMode = newMode+            }     when (new /= old) $ do       wlsunsetLogF DEBUG "Wlsunset state changed: %s" new       atomically $ writeTChan chan new@@ -172,7 +206,7 @@ -- ---------------------------------------------------------------------------  -- | Cycle wlsunset mode by sending @SIGUSR1@ to the process.--- The mode cycles: Auto → ForcedWarm → ForcedCool → Auto.+-- The mode cycles: Auto → ForcedHighTemp → ForcedLowTemp → Auto. cycleWlsunsetMode :: WlsunsetConfig -> TaffyIO () cycleWlsunsetMode cfg = do   WlsunsetChanVar (chan, var, _) <- getWlsunsetChanVar cfg@@ -180,14 +214,14 @@     pids <- pgrepWlsunset     case pids of       [] -> wlsunsetLog DEBUG "cycleWlsunsetMode: wlsunset not running"-      _  -> do+      _ -> do         mapM_ sendUSR1 pids         modifyMVar_ var $ \old -> do           let newMode = case wlsunsetMode old of-                WlsunsetAuto       -> WlsunsetForcedWarm-                WlsunsetForcedWarm -> WlsunsetForcedCool-                WlsunsetForcedCool -> WlsunsetAuto-              new = old { wlsunsetMode = newMode }+                WlsunsetAuto -> WlsunsetForcedHighTemp+                WlsunsetForcedHighTemp -> WlsunsetForcedLowTemp+                WlsunsetForcedLowTemp -> WlsunsetAuto+              new = old {wlsunsetMode = newMode}           wlsunsetLogF DEBUG "Cycled wlsunset mode: %s" newMode           atomically $ writeTChan chan new           return new@@ -204,7 +238,7 @@   pids <- pgrepWlsunset   case pids of     [] -> wlsunsetLog DEBUG "stopWlsunset: wlsunset not running"-    _  -> do+    _ -> do       wlsunsetLog DEBUG "Stopping wlsunset (SIGTERM)"       mapM_ (signalProcess 15) pids @@ -215,3 +249,50 @@   if wlsunsetRunning st     then stopWlsunset cfg     else startWlsunset cfg++-- | Restart wlsunset with specific low and high temperatures.+-- Kills the running instance, updates the effective temperatures in state,+-- and spawns a new instance with @-t lowTemp -T highTemp@.+restartWlsunsetWithTemps :: WlsunsetConfig -> Int -> Int -> TaffyIO ()+restartWlsunsetWithTemps cfg lowTemp highTemp = do+  WlsunsetChanVar (chan, var, _) <- getWlsunsetChanVar cfg+  liftIO $ do+    pids <- pgrepWlsunset+    mapM_ (signalProcess 15) pids+    let cmd = buildCommandWithTemps (wlsunsetCommand cfg) lowTemp highTemp+    wlsunsetLog DEBUG $ "Restarting wlsunset: " ++ cmd+    void $ spawnCommand cmd+    modifyMVar_ var $ \old -> do+      let new =+            old+              { wlsunsetMode = WlsunsetAuto,+                wlsunsetEffectiveHighTemp = highTemp,+                wlsunsetEffectiveLowTemp = lowTemp+              }+      atomically $ writeTChan chan new+      return new++-- ---------------------------------------------------------------------------+-- Command building+-- ---------------------------------------------------------------------------++-- | Build a wlsunset command with specific temperature flags.+-- Strips any existing @-t@\/@-T@ flags from the base command and appends+-- new ones.+buildCommandWithTemps :: String -> Int -> Int -> String+buildCommandWithTemps baseCmd lowTemp highTemp =+  unwords (stripTempArgs (words baseCmd))+    ++ " -t "+    ++ show lowTemp+    ++ " -T "+    ++ show highTemp++-- | Strip @-t \<val\>@ and @-T \<val\>@ arguments from a word list.+stripTempArgs :: [String] -> [String]+stripTempArgs [] = []+stripTempArgs ("-t" : _ : rest) = stripTempArgs rest+stripTempArgs ("-T" : _ : rest) = stripTempArgs rest+stripTempArgs (x : rest)+  | "-t" `isPrefixOf` x && length x > 2 = stripTempArgs rest+  | "-T" `isPrefixOf` x && length x > 2 = stripTempArgs rest+  | otherwise = x : stripTempArgs rest
+ src/System/Taffybar/Information/Workspaces/EWMH.hs view
@@ -0,0 +1,324 @@+{-# LANGUAGE OverloadedStrings #-}++-----------------------------------------------------------------------------++-----------------------------------------------------------------------------++-- |+-- Module      : System.Taffybar.Information.Workspaces.EWMH+-- Copyright   : (c) Ivan A. Malison+-- License     : BSD3-style (see LICENSE)+--+-- Maintainer  : Ivan A. Malison+-- Stability   : unstable+-- Portability : unportable+--+-- Shared EWMH/X11 workspace-state provider using broadcast channels + state MVar.+module System.Taffybar.Information.Workspaces.EWMH+  ( EWMHWorkspaceProviderConfig (..),+    defaultEWMHWorkspaceProviderConfig,+    defaultEWMHWorkspaceState,+    getEWMHWorkspaceStateAndEventChansAndVar,+    getEWMHWorkspaceStateAndEventChansAndVarWith,+    getEWMHWorkspaceEventChan,+    getEWMHWorkspaceEventChanWith,+    getEWMHWorkspaceStateChanAndVar,+    getEWMHWorkspaceStateChanAndVarWith,+    getEWMHWorkspaceStateChan,+    getEWMHWorkspaceStateChanWith,+    getEWMHWorkspaceState,+    getEWMHWorkspaceStateWith,+  )+where++import Control.Concurrent.MVar+import Control.Concurrent.STM.TChan+import Control.Exception.Enclosed (catchAny)+import Control.Monad (filterM, foldM, void)+import Control.Monad.IO.Class (MonadIO (..))+import Control.Monad.STM (atomically)+import Control.Monad.Trans.Reader (ask, runReaderT)+import Control.RateLimit (RateLimit (PerInvocation), generateRateLimitedFunction)+import Data.Char (toLower)+import Data.List (isPrefixOf, (\\))+import qualified Data.MultiMap as MM+import qualified Data.Text as T+import Data.Time.Units (Microsecond, fromMicroseconds)+import System.Log.Logger (Priority (..), logM)+import System.Taffybar.Context+  ( TaffyIO,+    getStateDefault,+    runX11,+    subscribeToPropertyEvents,+    taffyFork,+  )+import System.Taffybar.Information.EWMHDesktopInfo+  ( WorkspaceId (WorkspaceId),+    allEWMHProperties,+    ewmhWMIcon,+    getActiveWindow,+    getVisibleWorkspaces,+    getWindowClass,+    getWindowMinimized,+    getWindowTitle,+    getWindows,+    getWorkspace,+    getWorkspaceNames,+    isWindowUrgent,+    parseWindowClasses,+  )+import System.Taffybar.Information.SafeX11 (safeGetGeometry)+import System.Taffybar.Information.Workspaces.Model+import System.Taffybar.Information.X11DesktopInfo (X11Property, X11Window, getDisplay)++data EWMHWorkspaceProviderConfig = EWMHWorkspaceProviderConfig+  { workspaceSnapshotGetter :: TaffyIO (Bool, [WorkspaceInfo]),+    workspaceUpdateEvents :: [String],+    workspaceUpdateRateLimitMicroseconds :: Integer+  }++defaultEWMHWorkspaceProviderConfig :: EWMHWorkspaceProviderConfig+defaultEWMHWorkspaceProviderConfig =+  EWMHWorkspaceProviderConfig+    { workspaceSnapshotGetter = buildEWMHWorkspaceSnapshot,+      workspaceUpdateEvents = allEWMHProperties \\ [ewmhWMIcon],+      workspaceUpdateRateLimitMicroseconds = 100000+    }++defaultEWMHWorkspaceState :: WorkspaceSnapshot+defaultEWMHWorkspaceState =+  WorkspaceSnapshot+    { snapshotBackend = WorkspaceBackendEWMH,+      snapshotRevision = 0,+      snapshotWindowDataComplete = False,+      snapshotWorkspaces = []+    }++newtype EWMHWorkspaceStateChanVar+  = EWMHWorkspaceStateChanVar+      (TChan WorkspaceSnapshot, TChan WorkspaceEventBatch, MVar WorkspaceSnapshot)++wLog :: (MonadIO m) => Priority -> String -> m ()+wLog level message =+  liftIO $ logM "System.Taffybar.Information.Workspaces.EWMH" level message++getEWMHWorkspaceStateAndEventChansAndVar ::+  TaffyIO (TChan WorkspaceSnapshot, TChan WorkspaceEventBatch, MVar WorkspaceSnapshot)+getEWMHWorkspaceStateAndEventChansAndVar =+  getEWMHWorkspaceStateAndEventChansAndVarWith defaultEWMHWorkspaceProviderConfig++getEWMHWorkspaceStateAndEventChansAndVarWith ::+  EWMHWorkspaceProviderConfig ->+  TaffyIO (TChan WorkspaceSnapshot, TChan WorkspaceEventBatch, MVar WorkspaceSnapshot)+getEWMHWorkspaceStateAndEventChansAndVarWith cfg = do+  EWMHWorkspaceStateChanVar chansAndVar <- getStateDefault $ buildEWMHWorkspaceStateChanVar cfg+  return chansAndVar++getEWMHWorkspaceEventChan :: TaffyIO (TChan WorkspaceEventBatch)+getEWMHWorkspaceEventChan =+  getEWMHWorkspaceEventChanWith defaultEWMHWorkspaceProviderConfig++getEWMHWorkspaceEventChanWith ::+  EWMHWorkspaceProviderConfig ->+  TaffyIO (TChan WorkspaceEventBatch)+getEWMHWorkspaceEventChanWith cfg = do+  (_, eventChan, _) <- getEWMHWorkspaceStateAndEventChansAndVarWith cfg+  return eventChan++getEWMHWorkspaceStateChanAndVar ::+  TaffyIO (TChan WorkspaceSnapshot, MVar WorkspaceSnapshot)+getEWMHWorkspaceStateChanAndVar =+  getEWMHWorkspaceStateChanAndVarWith defaultEWMHWorkspaceProviderConfig++getEWMHWorkspaceStateChanAndVarWith ::+  EWMHWorkspaceProviderConfig ->+  TaffyIO (TChan WorkspaceSnapshot, MVar WorkspaceSnapshot)+getEWMHWorkspaceStateChanAndVarWith cfg = do+  (stateChan, _, stateVar) <- getEWMHWorkspaceStateAndEventChansAndVarWith cfg+  return (stateChan, stateVar)++getEWMHWorkspaceStateChan :: TaffyIO (TChan WorkspaceSnapshot)+getEWMHWorkspaceStateChan =+  getEWMHWorkspaceStateChanWith defaultEWMHWorkspaceProviderConfig++getEWMHWorkspaceStateChanWith ::+  EWMHWorkspaceProviderConfig ->+  TaffyIO (TChan WorkspaceSnapshot)+getEWMHWorkspaceStateChanWith cfg =+  fst <$> getEWMHWorkspaceStateChanAndVarWith cfg++getEWMHWorkspaceState :: TaffyIO WorkspaceSnapshot+getEWMHWorkspaceState =+  getEWMHWorkspaceStateWith defaultEWMHWorkspaceProviderConfig++getEWMHWorkspaceStateWith ::+  EWMHWorkspaceProviderConfig ->+  TaffyIO WorkspaceSnapshot+getEWMHWorkspaceStateWith cfg = do+  (_, var) <- getEWMHWorkspaceStateChanAndVarWith cfg+  liftIO $ readMVar var++buildEWMHWorkspaceStateChanVar ::+  EWMHWorkspaceProviderConfig ->+  TaffyIO EWMHWorkspaceStateChanVar+buildEWMHWorkspaceStateChanVar cfg = do+  stateChan <- liftIO newBroadcastTChanIO+  eventChan <- liftIO newBroadcastTChanIO+  stateVar <- liftIO $ newMVar defaultEWMHWorkspaceState+  taffyFork $ ewmhWorkspaceStateLoop cfg stateChan eventChan stateVar+  return $ EWMHWorkspaceStateChanVar (stateChan, eventChan, stateVar)++ewmhWorkspaceStateLoop ::+  EWMHWorkspaceProviderConfig ->+  TChan WorkspaceSnapshot ->+  TChan WorkspaceEventBatch ->+  MVar WorkspaceSnapshot ->+  TaffyIO ()+ewmhWorkspaceStateLoop cfg stateChan eventChan stateVar = do+  refreshEWMHWorkspaceState cfg stateChan eventChan stateVar+  setupEWMHWorkspaceSubscription cfg stateChan eventChan stateVar+    `catchAny` \err ->+      wLog WARNING $ "Failed to subscribe to EWMH workspace events: " <> show err++setupEWMHWorkspaceSubscription ::+  EWMHWorkspaceProviderConfig ->+  TChan WorkspaceSnapshot ->+  TChan WorkspaceEventBatch ->+  MVar WorkspaceSnapshot ->+  TaffyIO ()+setupEWMHWorkspaceSubscription cfg stateChan eventChan stateVar = do+  ctx <- ask+  let rate = fromMicroseconds (workspaceUpdateRateLimitMicroseconds cfg) :: Microsecond+      combineRequests _ b = Just (b, const ((), ()))+      refreshForEvent _ =+        runReaderT+          (refreshEWMHWorkspaceState cfg stateChan eventChan stateVar)+          ctx+  rateLimitedRefresh <-+    liftIO $+      generateRateLimitedFunction+        (PerInvocation rate)+        refreshForEvent+        combineRequests+  _ <-+    subscribeToPropertyEvents+      (workspaceUpdateEvents cfg)+      (liftIO . void . rateLimitedRefresh)+  return ()++refreshEWMHWorkspaceState ::+  EWMHWorkspaceProviderConfig ->+  TChan WorkspaceSnapshot ->+  TChan WorkspaceEventBatch ->+  MVar WorkspaceSnapshot ->+  TaffyIO ()+refreshEWMHWorkspaceState cfg stateChan eventChan stateVar = do+  previous <- liftIO $ readMVar stateVar+  (complete, workspaces) <-+    workspaceSnapshotGetter cfg+      `catchAny` \err -> do+        wLog WARNING $ "EWMH workspace snapshot update failed: " <> show err+        return (False, snapshotWorkspaces previous)+  let nextRevision = snapshotRevision previous + 1+      next =+        WorkspaceSnapshot+          { snapshotBackend = WorkspaceBackendEWMH,+            snapshotRevision = nextRevision,+            snapshotWindowDataComplete = complete,+            snapshotWorkspaces = workspaces+          }+      eventBatch =+        WorkspaceEventBatch+          { eventBatchBackend = WorkspaceBackendEWMH,+            eventBatchRevision = nextRevision,+            eventBatchWindowDataComplete = complete,+            eventBatchEvents = diffWorkspaceSnapshots previous next+          }+  liftIO $ do+    _ <- swapMVar stateVar next+    atomically $ do+      writeTChan stateChan next+      writeTChan eventChan eventBatch++buildEWMHWorkspaceSnapshot :: TaffyIO (Bool, [WorkspaceInfo])+buildEWMHWorkspaceSnapshot = do+  workspaces <- runX11 collectEWMHWorkspaceSnapshot+  return (True, workspaces)++collectEWMHWorkspaceSnapshot :: X11Property [WorkspaceInfo]+collectEWMHWorkspaceSnapshot = do+  names <- getWorkspaceNames+  windows <- getWindows+  workspaceToWindows <- getWorkspaceToWindows windows+  urgentWindows <- filterM isWindowUrgent windows+  activeWindow <- getActiveWindow+  visibleWorkspaces <- getVisibleWorkspaces+  let activeWorkspace = case visibleWorkspaces of+        [] -> Nothing+        ws : _ -> Just ws+      nonFocusedVisibleWorkspaces = case visibleWorkspaces of+        [] -> []+        _ : rest -> rest+      toWorkspaceInfo (WorkspaceId idx, name) = do+        let workspaceKey = WorkspaceId idx+            wsWindowIds = MM.lookup workspaceKey workspaceToWindows+            wsViewState+              | Just workspaceKey == activeWorkspace = WorkspaceActive+              | workspaceKey `elem` nonFocusedVisibleWorkspaces = WorkspaceVisible+              | null wsWindowIds = WorkspaceEmpty+              | otherwise = WorkspaceHidden+        windowsInfo <- mapM (getWindowInfo activeWindow urgentWindows) wsWindowIds+        return+          WorkspaceInfo+            { workspaceIdentity =+                WorkspaceIdentity+                  { workspaceNumericId = Just idx,+                    workspaceName = T.pack name+                  },+              workspaceState = wsViewState,+              workspaceHasUrgentWindow = any windowUrgent windowsInfo,+              workspaceIsSpecial = isSpecialWorkspaceName name,+              workspaceWindows = windowsInfo+            }+  mapM toWorkspaceInfo names++isSpecialWorkspaceName :: String -> Bool+isSpecialWorkspaceName name =+  let lowered = map toLower name+   in lowered == "nsp" || "special:" `isPrefixOf` lowered++getWorkspaceToWindows ::+  [X11Window] ->+  X11Property (MM.MultiMap WorkspaceId X11Window)+getWorkspaceToWindows =+  foldM+    (\theMap window -> MM.insert <$> getWorkspace window <*> pure window <*> pure theMap)+    MM.empty++getWindowInfo ::+  Maybe X11Window ->+  [X11Window] ->+  X11Window ->+  X11Property WindowInfo+getWindowInfo activeWindow urgentWindows window = do+  wTitle <- getWindowTitle window+  wClass <- getWindowClass window+  wMinimized <- getWindowMinimized window+  wPosition <- getWindowPosition window+  return+    WindowInfo+      { windowIdentity = X11WindowIdentity (fromIntegral window),+        windowTitle = T.pack wTitle,+        windowClassHints = map T.pack $ parseWindowClasses wClass,+        windowPosition = wPosition,+        windowUrgent = window `elem` urgentWindows,+        windowActive = Just window == activeWindow,+        windowMinimized = wMinimized+      }++getWindowPosition :: X11Window -> X11Property (Maybe (Int, Int))+getWindowPosition window = do+  display <- getDisplay+  liftIO $+    ((\(_, x, y, _, _, _, _) -> Just (fromIntegral x, fromIntegral y)) <$> safeGetGeometry display window)+      `catchAny` const (return Nothing)
+ src/System/Taffybar/Information/Workspaces/Hyprland.hs view
@@ -0,0 +1,341 @@+{-# LANGUAGE OverloadedStrings #-}++-----------------------------------------------------------------------------++-----------------------------------------------------------------------------++-- |+-- Module      : System.Taffybar.Information.Workspaces.Hyprland+-- Copyright   : (c) Ivan A. Malison+-- License     : BSD3-style (see LICENSE)+--+-- Maintainer  : Ivan A. Malison+-- Stability   : unstable+-- Portability : unportable+--+-- Shared Hyprland workspace-state provider using a broadcast channel + state MVar.+module System.Taffybar.Information.Workspaces.Hyprland+  ( HyprlandWorkspaceProviderConfig (..),+    defaultHyprlandWorkspaceProviderConfig,+    defaultHyprlandWorkspaceState,+    isRelevantHyprlandWorkspaceEvent,+    getHyprlandWorkspaceStateAndEventChansAndVar,+    getHyprlandWorkspaceStateAndEventChansAndVarWith,+    getHyprlandWorkspaceEventChan,+    getHyprlandWorkspaceEventChanWith,+    getHyprlandWorkspaceStateChanAndVar,+    getHyprlandWorkspaceStateChanAndVarWith,+    getHyprlandWorkspaceStateChan,+    getHyprlandWorkspaceStateChanWith,+    getHyprlandWorkspaceState,+    getHyprlandWorkspaceStateWith,+  )+where++import Control.Applicative ((<|>))+import Control.Concurrent.MVar+import Control.Concurrent.STM.TChan+import Control.Exception.Enclosed (catchAny)+import Control.Monad (forever, when)+import Control.Monad.IO.Class (MonadIO (..))+import Control.Monad.STM (atomically)+import Data.Either (isRight)+import qualified Data.Foldable as F+import Data.List (sortOn)+import qualified Data.Map.Strict as M+import Data.Maybe (catMaybes, fromMaybe, listToMaybe)+import qualified Data.Text as T+import System.Log.Logger (Priority (..), logM)+import System.Taffybar.Context (TaffyIO, getStateDefault, taffyFork)+import System.Taffybar.Hyprland (getHyprlandClient, getHyprlandEventChan)+import qualified System.Taffybar.Information.Hyprland as Hypr+import qualified System.Taffybar.Information.Hyprland.API as HyprAPI+import qualified System.Taffybar.Information.Hyprland.Types as HyprTypes+import System.Taffybar.Information.Workspaces.Model++data HyprlandWorkspaceProviderConfig = HyprlandWorkspaceProviderConfig+  { workspaceSnapshotGetter :: TaffyIO (Bool, [WorkspaceInfo]),+    workspaceEventFilter :: T.Text -> Bool+  }++defaultHyprlandWorkspaceProviderConfig :: HyprlandWorkspaceProviderConfig+defaultHyprlandWorkspaceProviderConfig =+  HyprlandWorkspaceProviderConfig+    { workspaceSnapshotGetter = buildHyprlandWorkspaceSnapshot,+      workspaceEventFilter = isRelevantHyprlandWorkspaceEvent+    }++defaultHyprlandWorkspaceState :: WorkspaceSnapshot+defaultHyprlandWorkspaceState =+  WorkspaceSnapshot+    { snapshotBackend = WorkspaceBackendHyprland,+      snapshotRevision = 0,+      snapshotWindowDataComplete = False,+      snapshotWorkspaces = []+    }++newtype HyprlandWorkspaceStateChanVar+  = HyprlandWorkspaceStateChanVar+      (TChan WorkspaceSnapshot, TChan WorkspaceEventBatch, MVar WorkspaceSnapshot)++wLog :: (MonadIO m) => Priority -> String -> m ()+wLog level msg = liftIO $ logM "System.Taffybar.Information.Workspaces.Hyprland" level msg++-- | Parse Hyprland event-socket lines and determine whether workspace state+-- should be refreshed.+isRelevantHyprlandWorkspaceEvent :: T.Text -> Bool+isRelevantHyprlandWorkspaceEvent line =+  let eventName = T.takeWhile (/= '>') line+   in eventName+        `elem` [ "workspace",+                 "workspacev2",+                 "focusedmon",+                 "activewindow",+                 "activewindowv2",+                 "openwindow",+                 "closewindow",+                 "movewindow",+                 "movewindowv2",+                 "moveworkspace",+                 "renameworkspace",+                 "createworkspace",+                 "destroyworkspace",+                 "monitoradded",+                 "monitorremoved",+                 "taffybar-hyprland-connected"+               ]++getHyprlandWorkspaceStateAndEventChansAndVar ::+  TaffyIO (TChan WorkspaceSnapshot, TChan WorkspaceEventBatch, MVar WorkspaceSnapshot)+getHyprlandWorkspaceStateAndEventChansAndVar =+  getHyprlandWorkspaceStateAndEventChansAndVarWith defaultHyprlandWorkspaceProviderConfig++getHyprlandWorkspaceStateAndEventChansAndVarWith ::+  HyprlandWorkspaceProviderConfig ->+  TaffyIO (TChan WorkspaceSnapshot, TChan WorkspaceEventBatch, MVar WorkspaceSnapshot)+getHyprlandWorkspaceStateAndEventChansAndVarWith cfg = do+  HyprlandWorkspaceStateChanVar chansAndVar <- getStateDefault $ buildHyprlandWorkspaceStateChanVar cfg+  return chansAndVar++getHyprlandWorkspaceEventChan :: TaffyIO (TChan WorkspaceEventBatch)+getHyprlandWorkspaceEventChan =+  getHyprlandWorkspaceEventChanWith defaultHyprlandWorkspaceProviderConfig++getHyprlandWorkspaceEventChanWith ::+  HyprlandWorkspaceProviderConfig ->+  TaffyIO (TChan WorkspaceEventBatch)+getHyprlandWorkspaceEventChanWith cfg = do+  (_, eventChan, _) <- getHyprlandWorkspaceStateAndEventChansAndVarWith cfg+  return eventChan++getHyprlandWorkspaceStateChanAndVar ::+  TaffyIO (TChan WorkspaceSnapshot, MVar WorkspaceSnapshot)+getHyprlandWorkspaceStateChanAndVar =+  getHyprlandWorkspaceStateChanAndVarWith defaultHyprlandWorkspaceProviderConfig++-- | Obtain the shared Hyprland workspace state channel and state MVar.+--+-- Note: like other 'getStateDefault' based providers, the first caller wins:+-- if this provider has already been initialized, later calls with a different+-- config return the existing provider state.+getHyprlandWorkspaceStateChanAndVarWith ::+  HyprlandWorkspaceProviderConfig ->+  TaffyIO (TChan WorkspaceSnapshot, MVar WorkspaceSnapshot)+getHyprlandWorkspaceStateChanAndVarWith cfg = do+  (stateChan, _, stateVar) <- getHyprlandWorkspaceStateAndEventChansAndVarWith cfg+  return (stateChan, stateVar)++getHyprlandWorkspaceStateChan :: TaffyIO (TChan WorkspaceSnapshot)+getHyprlandWorkspaceStateChan =+  getHyprlandWorkspaceStateChanWith defaultHyprlandWorkspaceProviderConfig++getHyprlandWorkspaceStateChanWith ::+  HyprlandWorkspaceProviderConfig ->+  TaffyIO (TChan WorkspaceSnapshot)+getHyprlandWorkspaceStateChanWith cfg =+  fst <$> getHyprlandWorkspaceStateChanAndVarWith cfg++getHyprlandWorkspaceState :: TaffyIO WorkspaceSnapshot+getHyprlandWorkspaceState =+  getHyprlandWorkspaceStateWith defaultHyprlandWorkspaceProviderConfig++getHyprlandWorkspaceStateWith ::+  HyprlandWorkspaceProviderConfig ->+  TaffyIO WorkspaceSnapshot+getHyprlandWorkspaceStateWith cfg = do+  (_, var) <- getHyprlandWorkspaceStateChanAndVarWith cfg+  liftIO $ readMVar var++buildHyprlandWorkspaceStateChanVar ::+  HyprlandWorkspaceProviderConfig ->+  TaffyIO HyprlandWorkspaceStateChanVar+buildHyprlandWorkspaceStateChanVar cfg = do+  stateChan <- liftIO newBroadcastTChanIO+  eventChan <- liftIO newBroadcastTChanIO+  var <- liftIO $ newMVar defaultHyprlandWorkspaceState+  taffyFork $ hyprlandWorkspaceStateLoop cfg stateChan eventChan var+  return $ HyprlandWorkspaceStateChanVar (stateChan, eventChan, var)++hyprlandWorkspaceStateLoop ::+  HyprlandWorkspaceProviderConfig ->+  TChan WorkspaceSnapshot ->+  TChan WorkspaceEventBatch ->+  MVar WorkspaceSnapshot ->+  TaffyIO ()+hyprlandWorkspaceStateLoop cfg stateChan workspaceEventChan var = do+  refreshHyprlandWorkspaceState cfg stateChan workspaceEventChan var+  hyprlandEventChan <- getHyprlandEventChan+  events <- liftIO $ Hypr.subscribeHyprlandEvents hyprlandEventChan+  forever $ do+    line <- liftIO $ atomically $ readTChan events+    when (workspaceEventFilter cfg line) $+      refreshHyprlandWorkspaceState cfg stateChan workspaceEventChan var++refreshHyprlandWorkspaceState ::+  HyprlandWorkspaceProviderConfig ->+  TChan WorkspaceSnapshot ->+  TChan WorkspaceEventBatch ->+  MVar WorkspaceSnapshot ->+  TaffyIO ()+refreshHyprlandWorkspaceState cfg stateChan workspaceEventChan var = do+  previous <- liftIO $ readMVar var+  (complete, workspaces) <-+    workspaceSnapshotGetter cfg+      `catchAny` \err -> do+        wLog WARNING $ "Hyprland workspace snapshot update failed: " <> show err+        return (False, snapshotWorkspaces previous)+  let next =+        WorkspaceSnapshot+          { snapshotBackend = WorkspaceBackendHyprland,+            snapshotRevision = snapshotRevision previous + 1,+            snapshotWindowDataComplete = complete,+            snapshotWorkspaces = workspaces+          }+      eventBatch =+        WorkspaceEventBatch+          { eventBatchBackend = snapshotBackend next,+            eventBatchRevision = snapshotRevision next,+            eventBatchWindowDataComplete = snapshotWindowDataComplete next,+            eventBatchEvents = diffWorkspaceSnapshots previous next+          }+  liftIO $ do+    _ <- swapMVar var next+    atomically $ do+      writeTChan stateChan next+      writeTChan workspaceEventChan eventBatch++buildHyprlandWorkspaceSnapshot :: TaffyIO (Bool, [WorkspaceInfo])+buildHyprlandWorkspaceSnapshot = do+  client <- getHyprlandClient+  workspacesResult <- liftIO $ HyprAPI.getHyprlandWorkspaces client+  clientsResult <- liftIO $ HyprAPI.getHyprlandClients client+  monitorsResult <- liftIO $ HyprAPI.getHyprlandMonitors client+  activeWorkspaceResult <- liftIO $ HyprAPI.getHyprlandActiveWorkspace client+  activeWindowResult <- liftIO $ HyprAPI.getHyprlandActiveWindow client++  workspaces <- case workspacesResult of+    Left err -> wLog WARNING ("hyprctl workspaces failed: " <> show err) >> return []+    Right ws -> return ws++  clients <- case clientsResult of+    Left err -> wLog WARNING ("hyprctl clients failed: " <> show err) >> return []+    Right cs -> return cs++  monitors <- case monitorsResult of+    Left err -> wLog WARNING ("hyprctl monitors failed: " <> show err) >> return []+    Right ms -> return ms++  activeWorkspaceId <- case activeWorkspaceResult of+    Left err -> wLog WARNING ("hyprctl activeworkspace failed: " <> show err) >> return Nothing+    Right ws -> return $ HyprTypes.hyprActiveWorkspaceId ws++  activeWindowAddress <- case activeWindowResult of+    Left err -> wLog WARNING ("hyprctl activewindow failed: " <> show err) >> return Nothing+    Right win ->+      let address = HyprTypes.hyprActiveWindowAddress win+       in return $ if T.null address then Nothing else Just address++  let windowsByWorkspace = collectWorkspaceWindows activeWindowAddress clients+      sortedWorkspaces = sortOn HyprTypes.hyprWorkspaceId workspaces+      visibleWorkspaceIds =+        [ HyprTypes.hyprWorkspaceRefId wsRef+        | monitor <- monitors,+          Just wsRef <- [HyprTypes.hyprMonitorActiveWorkspace monitor]+        ]+      focusedWorkspaceId =+        listToMaybe+          [ HyprTypes.hyprWorkspaceRefId wsRef+          | monitor <- monitors,+            HyprTypes.hyprMonitorFocused monitor,+            Just wsRef <- [HyprTypes.hyprMonitorActiveWorkspace monitor]+          ]+      activeWorkspaceId' = focusedWorkspaceId <|> activeWorkspaceId+      clientsOk = isRight clientsResult+      toWorkspace wsInfo =+        let wsId = HyprTypes.hyprWorkspaceId wsInfo+            wsName = HyprTypes.hyprWorkspaceName wsInfo+            wsWindows = M.findWithDefault [] wsId windowsByWorkspace+            hasWindows =+              not (null wsWindows)+                || fromMaybe 0 (HyprTypes.hyprWorkspaceWindows wsInfo) > 0+            wsState+              | Just wsId == activeWorkspaceId' = WorkspaceActive+              | wsId `elem` visibleWorkspaceIds = WorkspaceVisible+              | not hasWindows && clientsOk = WorkspaceEmpty+              | otherwise = WorkspaceHidden+         in WorkspaceInfo+              { workspaceIdentity =+                  WorkspaceIdentity+                    { workspaceNumericId = Just wsId,+                      workspaceName = wsName+                    },+                workspaceState = wsState,+                workspaceHasUrgentWindow = any windowUrgent wsWindows,+                workspaceIsSpecial = isSpecialWorkspace wsId wsName,+                workspaceWindows = wsWindows+              }+  return (clientsOk, map toWorkspace sortedWorkspaces)++isSpecialWorkspace :: Int -> T.Text -> Bool+isSpecialWorkspace wsId wsName =+  let lowered = T.toLower wsName+   in wsId < 0 || T.isPrefixOf "special" lowered++collectWorkspaceWindows ::+  Maybe T.Text ->+  [HyprTypes.HyprlandClientInfo] ->+  M.Map Int [WindowInfo]+collectWorkspaceWindows activeWindowAddress =+  F.foldl' (addWindow activeWindowAddress) M.empty+  where+    addWindow activeAddr windowsMap client =+      let wsId = HyprTypes.hyprWorkspaceRefId $ HyprTypes.hyprClientWorkspace client+          windowData = windowFromClient activeAddr client+       in M.insertWith (++) wsId [windowData] windowsMap++windowFromClient :: Maybe T.Text -> HyprTypes.HyprlandClientInfo -> WindowInfo+windowFromClient activeAddr client =+  let rawTitle = HyprTypes.hyprClientTitle client+      title =+        if T.null rawTitle+          then fromMaybe "" (HyprTypes.hyprClientInitialTitle client)+          else rawTitle+      active =+        HyprTypes.hyprClientFocused client+          || Just (HyprTypes.hyprClientAddress client) == activeAddr+      minimized =+        HyprTypes.hyprClientHidden client+          || not (HyprTypes.hyprClientMapped client)+   in WindowInfo+        { windowIdentity = HyprlandWindowIdentity (HyprTypes.hyprClientAddress client),+          windowTitle = title,+          windowClassHints =+            catMaybes+              [ HyprTypes.hyprClientClass client,+                HyprTypes.hyprClientInitialClass client+              ],+          windowPosition = HyprTypes.hyprClientAt client,+          windowUrgent = HyprTypes.hyprClientUrgent client,+          windowActive = active,+          windowMinimized = minimized+        }
+ src/System/Taffybar/Information/Workspaces/Model.hs view
@@ -0,0 +1,173 @@+-----------------------------------------------------------------------------++-----------------------------------------------------------------------------++-- |+-- Module      : System.Taffybar.Information.Workspaces.Model+-- Copyright   : (c) Ivan A. Malison+-- License     : BSD3-style (see LICENSE)+--+-- Maintainer  : Ivan A. Malison+-- Stability   : unstable+-- Portability : unportable+--+-- Backend-agnostic workspace/window model shared by workspace-related widgets.+module System.Taffybar.Information.Workspaces.Model+  ( WorkspaceBackend (..),+    WorkspaceSnapshot (..),+    WorkspaceEventBatch (..),+    WorkspaceEvent (..),+    WindowEvent (..),+    diffWorkspaceSnapshots,+    WorkspaceViewState (..),+    WorkspaceIdentity (..),+    WorkspaceInfo (..),+    WindowIdentity (..),+    WindowInfo (..),+  )+where++import qualified Data.Map.Strict as M+import Data.Text (Text)+import Data.Word (Word64)++data WorkspaceBackend+  = WorkspaceBackendEWMH+  | WorkspaceBackendHyprland+  deriving (Eq, Show)++-- | Snapshot of workspace state produced by a backend provider.+data WorkspaceSnapshot = WorkspaceSnapshot+  { snapshotBackend :: WorkspaceBackend,+    snapshotRevision :: Word64,+    -- | Whether window-level data was complete in this snapshot.+    snapshotWindowDataComplete :: Bool,+    snapshotWorkspaces :: [WorkspaceInfo]+  }+  deriving (Eq, Show)++-- | Delta events corresponding to a snapshot revision.+--+-- Consumers that want incremental updates can subscribe to these events,+-- while snapshot consumers keep using 'WorkspaceSnapshot'.+data WorkspaceEventBatch = WorkspaceEventBatch+  { eventBatchBackend :: WorkspaceBackend,+    eventBatchRevision :: Word64,+    eventBatchWindowDataComplete :: Bool,+    eventBatchEvents :: [WorkspaceEvent]+  }+  deriving (Eq, Show)++data WorkspaceEvent+  = WorkspaceOrderChanged [WorkspaceIdentity]+  | WorkspaceAdded WorkspaceInfo+  | WorkspaceRemoved WorkspaceIdentity+  | WorkspaceChanged WorkspaceInfo+  | WorkspaceWindowsChanged WorkspaceIdentity [WindowEvent]+  deriving (Eq, Show)++data WindowEvent+  = WindowAdded WindowInfo+  | WindowRemoved WindowIdentity+  | WindowChanged WindowInfo+  deriving (Eq, Show)++-- | Visibility/occupancy state that controls workspace presentation.+data WorkspaceViewState+  = WorkspaceActive+  | WorkspaceVisible+  | WorkspaceHidden+  | WorkspaceEmpty+  deriving (Eq, Show)++-- | Backend-neutral workspace identity.+data WorkspaceIdentity = WorkspaceIdentity+  { workspaceNumericId :: Maybe Int,+    workspaceName :: Text+  }+  deriving (Eq, Ord, Show)++-- | Backend-neutral workspace information.+data WorkspaceInfo = WorkspaceInfo+  { workspaceIdentity :: WorkspaceIdentity,+    workspaceState :: WorkspaceViewState,+    workspaceHasUrgentWindow :: Bool,+    workspaceIsSpecial :: Bool,+    workspaceWindows :: [WindowInfo]+  }+  deriving (Eq, Show)++data WindowIdentity+  = X11WindowIdentity Word64+  | HyprlandWindowIdentity Text+  deriving (Eq, Ord, Show)++-- | Backend-neutral window information.+data WindowInfo = WindowInfo+  { windowIdentity :: WindowIdentity,+    windowTitle :: Text,+    -- | Ordered class/app-id hints used for icon lookup.+    windowClassHints :: [Text],+    -- | Top-left position in global coordinates when available.+    windowPosition :: Maybe (Int, Int),+    windowUrgent :: Bool,+    windowActive :: Bool,+    windowMinimized :: Bool+  }+  deriving (Eq, Show)++-- | Produce incremental events that describe the change from an old snapshot to+-- a new one.+diffWorkspaceSnapshots :: WorkspaceSnapshot -> WorkspaceSnapshot -> [WorkspaceEvent]+diffWorkspaceSnapshots previous next =+  orderEvent ++ removedEvents ++ addedEvents ++ changedEvents+  where+    oldWorkspaces = snapshotWorkspaces previous+    newWorkspaces = snapshotWorkspaces next+    oldOrder = map workspaceIdentity oldWorkspaces+    newOrder = map workspaceIdentity newWorkspaces+    orderEvent =+      [WorkspaceOrderChanged newOrder | oldOrder /= newOrder]+    oldMap = M.fromList [(workspaceIdentity ws, ws) | ws <- oldWorkspaces]+    newMap = M.fromList [(workspaceIdentity ws, ws) | ws <- newWorkspaces]+    removedEvents =+      [WorkspaceRemoved wsId | wsId <- M.keys oldMap, M.notMember wsId newMap]+    addedEvents =+      [WorkspaceAdded ws | (wsId, ws) <- M.toList newMap, M.notMember wsId oldMap]+    changedEvents =+      concatMap mkChangedEvents sharedIds+    sharedIds = M.keys $ M.intersection oldMap newMap+    mkChangedEvents wsId =+      case (M.lookup wsId oldMap, M.lookup wsId newMap) of+        (Just oldWs, Just newWs) ->+          let oldWithoutWindows = oldWs {workspaceWindows = []}+              newWithoutWindows = newWs {workspaceWindows = []}+              metadataEvents =+                [WorkspaceChanged newWs | oldWithoutWindows /= newWithoutWindows]+              windowEvents = diffWorkspaceWindows oldWs newWs+              windowsChangedEvents =+                [ WorkspaceWindowsChanged wsId windowEvents+                | not (null windowEvents)+                ]+           in metadataEvents ++ windowsChangedEvents+        _ -> []++diffWorkspaceWindows :: WorkspaceInfo -> WorkspaceInfo -> [WindowEvent]+diffWorkspaceWindows oldWs newWs =+  removedEvents ++ addedEvents ++ changedEvents+  where+    oldWindows = workspaceWindows oldWs+    newWindows = workspaceWindows newWs+    oldMap = M.fromList [(windowIdentity w, w) | w <- oldWindows]+    newMap = M.fromList [(windowIdentity w, w) | w <- newWindows]+    removedEvents =+      [WindowRemoved wId | wId <- M.keys oldMap, M.notMember wId newMap]+    addedEvents =+      [WindowAdded w | (wId, w) <- M.toList newMap, M.notMember wId oldMap]+    changedEvents =+      [ WindowChanged newW+      | wId <- M.keys $ M.intersection oldMap newMap,+        Just oldW <- [M.lookup wId oldMap],+        Just newW <- [M.lookup wId newMap],+        oldW /= newW+      ]
src/System/Taffybar/Information/X11DesktopInfo.hs view
@@ -3,6 +3,9 @@ {-# LANGUAGE RecordWildCards #-}  -----------------------------------------------------------------------------++-----------------------------------------------------------------------------+ -- | -- Module      : System.Taffybar.Information.X11DesktopInfo -- Copyright   : (c) José A. Romero L.@@ -20,48 +23,46 @@ -- > import XMonad.Hooks.TaffybarPagerHints (pagerHints) -- > -- > main = xmonad $ ewmh $ pagerHints $ ...---------------------------------------------------------------------------------- module System.Taffybar.Information.X11DesktopInfo   ( -- * Context-    X11Context-  , DisplayName(..)-  , getX11Context-  , withX11Context+    X11Context,+    DisplayName (..),+    getX11Context,+    withX11Context, -  -- * Properties-  , X11Property-  , X11PropertyT+    -- * Properties+    X11Property,+    X11PropertyT, -  -- ** Event loop-  , eventLoop+    -- ** Event loop+    eventLoop, -  -- ** Context getters-  , getDisplay-  , getAtom+    -- ** Context getters+    getDisplay,+    getAtom, -  -- ** Basic properties of windows-  , X11Window-  , PropertyFetcher-  , fetch-  , readAsInt-  , readAsListOfInt-  , readAsListOfString-  , readAsListOfWindow-  , readAsString+    -- ** Basic properties of windows+    X11Window,+    PropertyFetcher,+    fetch,+    readAsInt,+    readAsListOfInt,+    readAsListOfString,+    readAsListOfWindow,+    readAsString, -  -- ** Getters-  , isWindowUrgent-  , getPrimaryOutputNumber-  , getVisibleTags+    -- ** Getters+    isWindowUrgent,+    getPrimaryOutputNumber,+    getVisibleTags, -  -- ** Operations-  , doLowerWindow-  , postX11RequestSyncProp-  , sendCommandEvent-  , sendWindowEvent-  ) where+    -- ** Operations+    doLowerWindow,+    postX11RequestSyncProp,+    sendCommandEvent,+    sendWindowEvent,+  )+where  import Codec.Binary.UTF8.String as UTF8 import qualified Control.Concurrent.MVar as MV@@ -70,29 +71,30 @@ import Control.Monad.Trans.Class import Control.Monad.Trans.Reader import Data.Bits (testBit, (.|.))-import Data.Default (Default(..))+import Data.Default (Default (..)) import Data.List (elemIndex) import Data.List.Split (endBy) import Data.Maybe (fromMaybe, listToMaybe) import GHC.Generics (Generic)-import Graphics.X11.Xrandr (XRRScreenResources(..), XRROutputInfo(..), xrrGetOutputInfo, xrrGetScreenResources, xrrGetOutputPrimary)+import Graphics.X11.Xrandr (XRROutputInfo (..), XRRScreenResources (..), xrrGetOutputInfo, xrrGetOutputPrimary, xrrGetScreenResources) import System.Taffybar.Information.SafeX11 hiding (displayName)  -- | Represents a connection to an X11 display. -- Use 'getX11Context' to construct one of these. data X11Context = X11Context-  { ctxDisplayName :: DisplayName-  , ctxDisplay :: Display-  , ctxRoot :: Window-  , ctxAtomCache :: MV.MVar [(String, Atom)]+  { ctxDisplayName :: DisplayName,+    ctxDisplay :: Display,+    ctxRoot :: Window,+    ctxAtomCache :: MV.MVar [(String, Atom)]   }  -- | Specifies an X11 display to connect to.-data DisplayName = DefaultDisplay-                   -- ^ Use the @DISPLAY@ environment variable.-                 | DisplayName String-                   -- ^ Of the form @hostname:number.screen_number@-                 deriving (Show, Read, Eq, Ord, Generic)+data DisplayName+  = -- | Use the @DISPLAY@ environment variable.+    DefaultDisplay+  | -- | Of the form @hostname:number.screen_number@+    DisplayName String+  deriving (Show, Read, Eq, Ord, Generic)  instance Default DisplayName where   def = DefaultDisplay@@ -104,9 +106,14 @@  -- | A 'ReaderT' with 'X11Context'. type X11PropertyT m a = ReaderT X11Context m a+ -- | 'IO' actions with access to an 'X11Context'. type X11Property a = X11PropertyT IO a++-- | X11 window identifier. type X11Window = Window++-- | Low-level property fetcher for a given window and atom. type PropertyFetcher a = Display -> Atom -> X11Window -> IO (Maybe [a])  -- | Makes a connection to the default X11 display using@@ -124,53 +131,72 @@ getDisplay :: X11Property Display getDisplay = ctxDisplay <$> ask -doRead :: Integral a => b -> ([a] -> b)-       -> PropertyFetcher a-       -> Maybe X11Window-       -> String-       -> X11Property b+doRead ::+  (Integral a) =>+  b ->+  ([a] -> b) ->+  PropertyFetcher a ->+  Maybe X11Window ->+  String ->+  X11Property b doRead b transform windowPropFn window name =   maybe b transform <$> fetch windowPropFn window name  -- | Retrieve the property of the given window (or the root window, if Nothing) -- with the given name as a value of type Int. If that property hasn't been set, -- then return -1.-readAsInt :: Maybe X11Window -- ^ window to read from. Nothing means the root window.-          -> String -- ^ name of the property to retrieve-          -> X11Property Int+readAsInt ::+  -- | window to read from. Nothing means the root window.+  Maybe X11Window ->+  -- | name of the property to retrieve+  String ->+  X11Property Int readAsInt = doRead (-1) (maybe (-1) fromIntegral . listToMaybe) getWindowProperty32  -- | Retrieve the property of the given window (or the root window, if Nothing) -- with the given name as a list of Ints. If that property hasn't been set, then -- return an empty list.-readAsListOfInt :: Maybe X11Window -- ^ window to read from. Nothing means the root window.-                -> String          -- ^ name of the property to retrieve-                -> X11Property [Int]+readAsListOfInt ::+  -- | window to read from. Nothing means the root window.+  Maybe X11Window ->+  -- | name of the property to retrieve+  String ->+  X11Property [Int] readAsListOfInt = doRead [] (map fromIntegral) getWindowProperty32  -- | Retrieve the property of the given window (or the root window, if Nothing) -- with the given name as a String. If the property hasn't been set, then return -- an empty string.-readAsString :: Maybe X11Window -- ^ window to read from. Nothing means the root window.-             -> String          -- ^ name of the property to retrieve-             -> X11Property String+readAsString ::+  -- | window to read from. Nothing means the root window.+  Maybe X11Window ->+  -- | name of the property to retrieve+  String ->+  X11Property String readAsString = doRead "" (UTF8.decode . map fromIntegral) getWindowProperty8  -- | Retrieve the property of the given window (or the root window, if Nothing) -- with the given name as a list of Strings. If the property hasn't been set, -- then return an empty list.-readAsListOfString :: Maybe X11Window -- ^ window to read from. Nothing means the root window.-                   -> String          -- ^ name of the property to retrieve-                   -> X11Property [String]+readAsListOfString ::+  -- | window to read from. Nothing means the root window.+  Maybe X11Window ->+  -- | name of the property to retrieve+  String ->+  X11Property [String] readAsListOfString = doRead [] parse getWindowProperty8-  where parse = endBy "\0" . UTF8.decode . map fromIntegral+  where+    parse = endBy "\0" . UTF8.decode . map fromIntegral  -- | Retrieve the property of the given window (or the root window, if Nothing) -- with the given name as a list of X11 Window IDs. If the property hasn't been -- set, then return an empty list.-readAsListOfWindow :: Maybe X11Window -- ^ window to read from. Nothing means the root window.-                   -> String          -- ^ name of the property to retrieve-                   -> X11Property [X11Window]+readAsListOfWindow ::+  -- | window to read from. Nothing means the root window.+  Maybe X11Window ->+  -- | name of the property to retrieve+  String ->+  X11Property [X11Window] readAsListOfWindow = doRead [] (map fromIntegral) getWindowProperty32  -- | Determine whether the \"urgent\" flag is set in the WM_HINTS of the given@@ -198,7 +224,7 @@       updateCache currentCache =         do           atom <- internAtom d s False-          return ((s, atom):currentCache, atom)+          return ((s, atom) : currentCache, atom)   maybe updateCacheAction return a  -- | Spawn a new thread and listen inside it to all incoming events, invoking@@ -213,7 +239,7 @@     allocaXEvent $ \e -> forever $ do       event <- nextEvent d e >> getEvent e       case event of-        MapNotifyEvent { ev_window = window } ->+        MapNotifyEvent {ev_window = window} ->           selectInput d window propertyChangeMask         _ -> return ()       dispatch event@@ -239,17 +265,21 @@   d <- openDisplay $ fromDisplayName ctxDisplayName   ctxRoot <- rootWindow d $ defaultScreen d   ctxAtomCache <- MV.newMVar []-  return $ X11Context{ctxDisplay=d,..}+  return $ X11Context {ctxDisplay = d, ..}  -- | Apply the given function to the given window in order to obtain the X11 -- property with the given name, or Nothing if no such property can be read.-fetch :: (Integral a)-      => PropertyFetcher a -- ^ Function to use to retrieve the property.-      -> Maybe X11Window   -- ^ Window to read from. Nothing means the root Window.-      -> String            -- ^ Name of the property to retrieve.-      -> X11Property (Maybe [a])+fetch ::+  (Integral a) =>+  -- | Function to use to retrieve the property.+  PropertyFetcher a ->+  -- | Window to read from. Nothing means the root Window.+  Maybe X11Window ->+  -- | Name of the property to retrieve.+  String ->+  X11Property (Maybe [a]) fetch fetcher window name = do-  X11Context{..} <- ask+  X11Context {..} <- ask   atom <- getAtom name   liftIO $ fetcher ctxDisplay atom (fromMaybe ctxRoot window) @@ -261,12 +291,16 @@  -- | Emit an event of type @ClientMessage@ that can be listened to and consumed -- by XMonad event hooks.-sendCustomEvent :: Atom -- ^ Command-                -> Atom -- ^ Argument-                -> Maybe X11Window -- ^ 'Just' a window, or 'Nothing' for the root window-                -> X11Property ()+sendCustomEvent ::+  -- | Command+  Atom ->+  -- | Argument+  Atom ->+  -- | 'Just' a window, or 'Nothing' for the root window+  Maybe X11Window ->+  X11Property () sendCustomEvent cmd arg win = do-  X11Context{..} <- ask+  X11Context {..} <- ask   let win' = fromMaybe ctxRoot win   liftIO $ allocaXEvent $ \e -> do     setEventType e clientMessage@@ -293,7 +327,7 @@ -- | Return all the active RANDR outputs. getActiveOutputs :: X11Property [RROutput] getActiveOutputs = do-  X11Context{..} <- ask+  X11Context {..} <- ask   liftIO (xrrGetScreenResources ctxDisplay ctxRoot) >>= \case     Just sres -> filterM (isActiveOutput sres) (xrr_sr_outputs sres)     Nothing -> return []@@ -301,7 +335,7 @@ -- | Get the index of the primary monitor as set and ordered by Xrandr. getPrimaryOutputNumber :: X11Property (Maybe Int) getPrimaryOutputNumber = do-  X11Context{..} <- ask+  X11Context {..} <- ask   primary <- liftIO $ xrrGetOutputPrimary ctxDisplay ctxRoot   outputs <- getActiveOutputs   return $ primary `elemIndex` outputs
src/System/Taffybar/Information/XDG/Protocol.hs view
@@ -1,4 +1,10 @@ -----------------------------------------------------------------------------++---- specification, see+-- See also 'MenuWidget'.+--+-----------------------------------------------------------------------------+ -- | -- Module      : System.Taffybar.Information.XDG.Protocol -- Copyright   : 2017 Ulf Jasper@@ -11,55 +17,55 @@ -- Implementation of version 1.1 of the XDG "Desktop Menu -- Specification", see -- https://specifications.freedesktop.org/menu-spec/menu-spec-1.1.html----- specification, see--- See also 'MenuWidget'.--------------------------------------------------------------------------------- module System.Taffybar.Information.XDG.Protocol-  ( XDGMenu(..)-  , DesktopEntryCondition(..)-  , getApplicationEntries-  , getDirectoryDirs-  , getPreferredLanguages-  , getXDGDesktop-  , getXDGMenuFilenames-  , matchesCondition-  , readXDGMenu-  ) where+  ( XDGMenu (..),+    DesktopEntryCondition (..),+    getApplicationEntries,+    getDirectoryDirs,+    getPreferredLanguages,+    getXDGDesktop,+    getXDGMenuFilenames,+    matchesCondition,+    readXDGMenu,+  )+where -import           Control.Applicative-import           Control.Monad-import           Control.Monad.Trans.Class-import           Control.Monad.Trans.Maybe-import           Data.Char (toLower)-import           Data.List-import           Data.Maybe+import Control.Applicative+import Control.Monad+import Control.Monad.Trans.Class+import Control.Monad.Trans.Maybe+import Data.Char (toLower)+import Data.List+import Data.Maybe import qualified Debug.Trace as D-import           GHC.IO.Encoding-import           Safe (headMay)-import           System.Directory-import           System.Environment-import           System.Environment.XDG.DesktopEntry-import           System.FilePath.Posix-import           System.Log.Logger-import           System.Posix.Files-import           System.Taffybar.Util-import           Text.XML.Light-import           Text.XML.Light.Helpers+import GHC.IO.Encoding+import Safe (headMay)+import System.Directory+import System.Environment+import System.Environment.XDG.DesktopEntry+import System.FilePath.Posix+import System.Log.Logger+import System.Posix.Files+import System.Taffybar.Util+import Text.XML.Light+import Text.XML.Light.Helpers  getXDGMenuPrefix :: IO (Maybe String) getXDGMenuPrefix = lookupEnv "XDG_MENU_PREFIX"  -- | Find filename(s) of the application menu(s).-getXDGMenuFilenames-  :: Maybe String -- ^ Overrides the value of the environment variable-                  -- XDG_MENU_PREFIX. Specifies the prefix for the menu (e.g.-                  -- 'Just "mate-"').-  -> IO [FilePath]+getXDGMenuFilenames ::+  -- | Overrides the value of the environment variable+  -- XDG_MENU_PREFIX. Specifies the prefix for the menu (e.g.+  -- 'Just "mate-"').+  Maybe String ->+  IO [FilePath] getXDGMenuFilenames mMenuPrefix = do   configDirs <--    liftA2 (:) (getXdgDirectory XdgConfig "")-             (getXdgDirectoryList XdgConfigDirs)+    liftA2+      (:)+      (getXdgDirectory XdgConfig "")+      (getXdgDirectoryList XdgConfigDirs)   maybePrefix <- (mMenuPrefix <|>) <$> getXDGMenuPrefix   let maybeAddDash t = if last t == '-' then t else t ++ "-"       dashedPrefix = maybe "" maybeAddDash maybePrefix@@ -67,38 +73,55 @@  -- | XDG Menu, cf. "Desktop Menu Specification". data XDGMenu = XDGMenu-  { xmAppDir :: Maybe String-  , xmDefaultAppDirs :: Bool -- Use $XDG_DATA_DIRS/applications-  , xmDirectoryDir :: Maybe String-  , xmDefaultDirectoryDirs :: Bool -- Use $XDG_DATA_DIRS/desktop-directories-  , xmLegacyDirs :: [String]-  , xmName :: String-  , xmDirectory :: String-  , xmOnlyUnallocated :: Bool-  , xmDeleted :: Bool-  , xmInclude :: Maybe DesktopEntryCondition-  , xmExclude :: Maybe DesktopEntryCondition-  , xmSubmenus :: [XDGMenu]-  , xmLayout :: [XDGLayoutItem]-  } deriving (Show)+  { xmAppDir :: Maybe String,+    xmDefaultAppDirs :: Bool, -- Use $XDG_DATA_DIRS/applications+    xmDirectoryDir :: Maybe String,+    xmDefaultDirectoryDirs :: Bool, -- Use $XDG_DATA_DIRS/desktop-directories+    xmLegacyDirs :: [String],+    xmName :: String,+    xmDirectory :: String,+    xmOnlyUnallocated :: Bool,+    xmDeleted :: Bool,+    xmInclude :: Maybe DesktopEntryCondition,+    xmExclude :: Maybe DesktopEntryCondition,+    xmSubmenus :: [XDGMenu],+    xmLayout :: [XDGLayoutItem]+  }+  deriving (Show) -data XDGLayoutItem =-  XliFile String | XliSeparator | XliMenu String | XliMerge String-  deriving(Show)+data XDGLayoutItem+  = XliFile String+  | XliSeparator+  | XliMenu String+  | XliMerge String+  deriving (Show)  -- | Return a list of all available desktop entries for a given xdg menu.-getApplicationEntries-  :: [String] -- ^ Preferred languages-  -> XDGMenu-  -> IO [DesktopEntry]+getApplicationEntries ::+  -- | Preferred languages+  [String] ->+  XDGMenu ->+  IO [DesktopEntry] getApplicationEntries langs xm = do-  defEntries <- if xmDefaultAppDirs xm-    then do dataDirs <- getXDGDataDirs-            concat <$> mapM (listDesktopEntries ".desktop" .-                                                  (</> "applications")) dataDirs-    else return []-  return $ sortBy (\de1 de2 -> compare (map toLower (deName langs de1))-                               (map toLower (deName langs de2))) defEntries+  defEntries <-+    if xmDefaultAppDirs xm+      then do+        dataDirs <- getXDGDataDirs+        concat+          <$> mapM+            ( listDesktopEntries ".desktop"+                . (</> "applications")+            )+            dataDirs+      else return []+  return $+    sortBy+      ( \de1 de2 ->+          compare+            (map toLower (deName langs de1))+            (map toLower (deName langs de2))+      )+      defEntries  -- | Parse menu. parseMenu :: Element -> Maybe XDGMenu@@ -110,8 +133,9 @@       name = fromMaybe "Name?" $ getChildData "Name" elt       dir = fromMaybe "Dir?" $ getChildData "Directory" elt       onlyUnallocated =-        case ( getChildData "OnlyUnallocated" elt-             , getChildData "NotOnlyUnallocated" elt) of+        case ( getChildData "OnlyUnallocated" elt,+               getChildData "NotOnlyUnallocated" elt+             ) of           (Nothing, Nothing) -> False -- ?!           (Nothing, Just _) -> False           (Just _, Nothing) -> True@@ -121,94 +145,108 @@       exclude = parseConditions "Exclude" elt       layout = parseLayout elt       subMenus = fromMaybe [] $ mapChildren "Menu" elt parseMenu-  in Just-       XDGMenu-       { xmAppDir = appDir-       , xmDefaultAppDirs = defaultAppDirs-       , xmDirectoryDir = directoryDir-       , xmDefaultDirectoryDirs = defaultDirectoryDirs-       , xmLegacyDirs = []-       , xmName = name-       , xmDirectory = dir-       , xmOnlyUnallocated = onlyUnallocated-       , xmDeleted = deleted-       , xmInclude = include-       , xmExclude = exclude-       , xmSubmenus = subMenus-       , xmLayout = layout -- FIXME-       }+   in Just+        XDGMenu+          { xmAppDir = appDir,+            xmDefaultAppDirs = defaultAppDirs,+            xmDirectoryDir = directoryDir,+            xmDefaultDirectoryDirs = defaultDirectoryDirs,+            xmLegacyDirs = [],+            xmName = name,+            xmDirectory = dir,+            xmOnlyUnallocated = onlyUnallocated,+            xmDeleted = deleted,+            xmInclude = include,+            xmExclude = exclude,+            xmSubmenus = subMenus,+            xmLayout = layout -- FIXME+          }  -- | Parse Desktop Entry conditions for Include/Exclude clauses. parseConditions :: String -> Element -> Maybe DesktopEntryCondition parseConditions key elt = case findChild (unqual key) elt of   Nothing -> Nothing   Just inc -> doParseConditions (elChildren inc)-  where doParseConditions :: [Element] -> Maybe DesktopEntryCondition-        doParseConditions []   = Nothing-        doParseConditions [e]  = parseSingleItem e-        doParseConditions elts = Just $ Or $ mapMaybe parseSingleItem elts+  where+    doParseConditions :: [Element] -> Maybe DesktopEntryCondition+    doParseConditions [] = Nothing+    doParseConditions [e] = parseSingleItem e+    doParseConditions elts = Just $ Or $ mapMaybe parseSingleItem elts -        parseSingleItem e = case qName (elName e) of-          "Category" -> Just $ Category $ strContent e-          "Filename" -> Just $ Filename $ strContent e-          "And"      -> Just $ And $ mapMaybe parseSingleItem-                          $ elChildren e-          "Or"       -> Just $ Or  $ mapMaybe parseSingleItem-                          $ elChildren e-          "Not"      -> Not <$> (parseSingleItem =<< listToMaybe (elChildren e))-          unknown    -> D.trace ("Unknown Condition item: " ++  unknown) Nothing+    parseSingleItem e = case qName (elName e) of+      "Category" -> Just $ Category $ strContent e+      "Filename" -> Just $ Filename $ strContent e+      "And" ->+        Just $+          And $+            mapMaybe parseSingleItem $+              elChildren e+      "Or" ->+        Just $+          Or $+            mapMaybe parseSingleItem $+              elChildren e+      "Not" -> Not <$> (parseSingleItem =<< listToMaybe (elChildren e))+      unknown -> D.trace ("Unknown Condition item: " ++ unknown) Nothing  -- | Combinable conditions for Include and Exclude statements.-data DesktopEntryCondition = Category String-                           | Filename String-                           | Not DesktopEntryCondition-                           | And [DesktopEntryCondition]-                           | Or [DesktopEntryCondition]-                           | All-                           | None+data DesktopEntryCondition+  = Category String+  | Filename String+  | Not DesktopEntryCondition+  | And [DesktopEntryCondition]+  | Or [DesktopEntryCondition]+  | All+  | None   deriving (Read, Show, Eq)  parseLayout :: Element -> [XDGLayoutItem] parseLayout elt = case findChild (unqual "Layout") elt of   Nothing -> []   Just lt -> mapMaybe parseLayoutItem (elChildren lt)-  where parseLayoutItem :: Element -> Maybe XDGLayoutItem-        parseLayoutItem e = case qName (elName e) of-          "Separator" -> Just XliSeparator-          "Filename"  -> Just $ XliFile $ strContent e-          unknown     -> D.trace ("Unknown layout item: " ++ unknown) Nothing+  where+    parseLayoutItem :: Element -> Maybe XDGLayoutItem+    parseLayoutItem e = case qName (elName e) of+      "Separator" -> Just XliSeparator+      "Filename" -> Just $ XliFile $ strContent e+      unknown -> D.trace ("Unknown layout item: " ++ unknown) Nothing  -- | Determine whether a desktop entry fulfils a condition. matchesCondition :: DesktopEntry -> DesktopEntryCondition -> Bool matchesCondition de (Category cat) = deHasCategory de cat-matchesCondition de (Filename fn)  = fn == deFilename de-matchesCondition de (Not cond)     = not $ matchesCondition de cond-matchesCondition de (And conds)    = all (matchesCondition de) conds-matchesCondition de (Or conds)     = any (matchesCondition de) conds-matchesCondition _  All            = True-matchesCondition _  None           = False+matchesCondition de (Filename fn) = fn == deFilename de+matchesCondition de (Not cond) = not $ matchesCondition de cond+matchesCondition de (And conds) = all (matchesCondition de) conds+matchesCondition de (Or conds) = any (matchesCondition de) conds+matchesCondition _ All = True+matchesCondition _ None = False  -- | Determine locale language settings getPreferredLanguages :: IO [String] getPreferredLanguages = do   mLcMessages <- lookupEnv "LC_MESSAGES"   lang <- case mLcMessages of-               Nothing -> lookupEnv "LANG" -- FIXME?-               Just lm -> return (Just lm)+    Nothing -> lookupEnv "LANG" -- FIXME?+    Just lm -> return (Just lm)   case lang of     Nothing -> return []-    Just l -> return $-      let woEncoding      = takeWhile (/= '.') l-          (language, _cm) = span (/= '_') woEncoding-          (country, _m)   = span (/= '@') (drop 1 _cm)-          modifier        = drop 1 _m-                       in dgl language country modifier-    where dgl "" "" "" = []-          dgl l  "" "" = [l]-          dgl l  c  "" = [l ++ "_" ++ c, l]-          dgl l  "" m  = [l ++ "@" ++ m, l]-          dgl l  c  m  = [l ++ "_" ++ c ++ "@" ++ m, l ++ "_" ++ c,-                          l ++ "@" ++ m]+    Just l ->+      return $+        let woEncoding = takeWhile (/= '.') l+            (language, _cm) = span (/= '_') woEncoding+            (country, _m) = span (/= '@') (drop 1 _cm)+            modifier = drop 1 _m+         in dgl language country modifier+  where+    dgl "" "" "" = []+    dgl l "" "" = [l]+    dgl l c "" = [l ++ "_" ++ c, l]+    dgl l "" m = [l ++ "@" ++ m, l]+    dgl l c m =+      [ l ++ "_" ++ c ++ "@" ++ m,+        l ++ "_" ++ c,+        l ++ "@" ++ m+      ]  -- | Determine current Desktop getXDGDesktop :: IO String@@ -232,15 +270,18 @@ -- | Load and assemble the XDG menu from a specific file, if it exists. maybeMenu :: FilePath -> IO (Maybe (XDGMenu, [DesktopEntry])) maybeMenu filename =-  ifM (doesFileExist filename)-      (do+  ifM+    (doesFileExist filename)+    ( do         contents <- readFile filename         langs <- getPreferredLanguages         runMaybeT $ do           m <- MaybeT $ return $ parseXMLDoc contents >>= parseMenu           des <- lift $ getApplicationEntries langs m-          return (m, des))-       (do-         logM "System.Taffybar.Information.XDG.Protocol" WARNING $-                "Menu file '" ++ filename ++ "' does not exist!"-         return Nothing)+          return (m, des)+    )+    ( do+        logM "System.Taffybar.Information.XDG.Protocol" WARNING $+          "Menu file '" ++ filename ++ "' does not exist!"+        return Nothing+    )
src/System/Taffybar/LogFormatter.hs view
@@ -1,4 +1,7 @@ -----------------------------------------------------------------------------++-----------------------------------------------------------------------------+ -- | -- Module      : System.Taffybar.LogFormatter -- Copyright   : (c) Ivan A. Malison@@ -7,19 +10,22 @@ -- Maintainer  : Ivan A. Malison -- Stability   : unstable -- Portability : unportable------------------------------------------------------------------------------+--+-- ANSI-colored log formatting helpers for taffybar logging output. module System.Taffybar.LogFormatter where  import System.Console.ANSI+import System.IO import System.Log.Formatter import System.Log.Handler.Simple import System.Log.Logger import Text.Printf-import System.IO +-- | Build an ANSI foreground color escape sequence. setColor :: Color -> String setColor color = setSGRCode [SetColor Foreground Vivid color] +-- | Choose a color for a log priority. priorityToColor :: Priority -> Color priorityToColor CRITICAL = Red priorityToColor ALERT = Red@@ -30,20 +36,28 @@ priorityToColor INFO = Blue priorityToColor DEBUG = Green +-- | ANSI reset sequence. reset :: String reset = setSGRCode [Reset] +-- | Wrap text in ANSI color escapes and reset formatting afterward. colorize :: Color -> String -> String colorize color txt = setColor color <> txt <> reset +-- | Formatter used for taffybar logs. taffyLogFormatter :: LogFormatter a taffyLogFormatter _ (level, msg) name =   return $ printf "%s %s - %s" colorizedPriority colorizedName msg-    where priorityColor = priorityToColor level-          colorizedPriority = colorize priorityColor-                              ("[" <> show level <> "]")-          colorizedName = colorize Green name+  where+    priorityColor = priorityToColor level+    colorizedPriority =+      colorize+        priorityColor+        ("[" <> show level <> "]")+    colorizedName = colorize Green name +-- | Default stderr log handler configured with 'taffyLogFormatter'. taffyLogHandler :: IO (GenericHandler Handle) taffyLogHandler = setFormatter <$> streamHandler stderr DEBUG-  where setFormatter h = h { formatter = taffyLogFormatter }+  where+    setFormatter h = h {formatter = taffyLogFormatter}
src/System/Taffybar/LogLevels.hs view
@@ -1,5 +1,9 @@ {-# LANGUAGE OverloadedStrings #-}+ -----------------------------------------------------------------------------++-----------------------------------------------------------------------------+ -- | -- Module      : System.Taffybar.LogLevels -- Copyright   : (c) Ivan A. Malison@@ -22,22 +26,21 @@ -- -- Valid log levels are: @DEBUG@, @INFO@, @NOTICE@, @WARNING@, @ERROR@, -- @CRITICAL@, @ALERT@, @EMERGENCY@.------------------------------------------------------------------------------- module System.Taffybar.LogLevels-  ( loadLogLevelsFromFile-  , defaultLogLevelsPath-  ) where+  ( loadLogLevelsFromFile,+    defaultLogLevelsPath,+  )+where -import           Control.Monad (forM_, when)-import           Data.Aeson (Value(..))+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+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@.@@ -88,12 +91,12 @@  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+  "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+  _ -> Nothing
src/System/Taffybar/SimpleConfig.hs view
@@ -1,4 +1,10 @@+{-# LANGUAGE PatternSynonyms #-}+{-# LANGUAGE ViewPatterns #-}+ -----------------------------------------------------------------------------++-----------------------------------------------------------------------------+ -- | -- Module      : System.Taffybar.SimpleConfig -- Copyright   : (c) Ivan A. Malison@@ -10,35 +16,55 @@ -- -- This module defines a simpler, but less flexible config system than the one -- offered in "System.Taffybar.Context".------------------------------------------------------------------------------ module System.Taffybar.SimpleConfig-  ( SimpleTaffyConfig(..)-  , Position(..)-  , defaultSimpleTaffyConfig-  , simpleDyreTaffybar-  , simpleTaffybar-  , toTaffyConfig-  , toTaffybarConfig-  , useAllMonitors-  , usePrimaryMonitor-  , StrutSize(..)-  ) where+  ( SimpleTaffyConfig (..),+    BarLevelConfig (..),+    Position (..),+    defaultSimpleTaffyConfig,+    simpleDyreTaffybar,+    simpleTaffybar,+    toTaffyConfig,+    toTaffybarConfig,+    useAllMonitors,+    usePrimaryMonitor,+    StrutSize,+    pattern ExactSize,+    pattern ScreenRatio,+  )+where  import qualified Control.Concurrent.MVar as MV-import           Control.Monad-import           Control.Monad.Trans.Class-import           Data.Default (Default(..))-import           Data.List-import           Data.Maybe-import           Data.Unique+import Control.Monad+import Control.Monad.Trans.Class+import Data.Default (Default (..))+import Data.List+import Data.Maybe+import Data.Unique+import GI.Gdk import qualified GI.Gtk as Gtk-import           GI.Gdk-import           Graphics.UI.GIGtkStrut-import           System.Taffybar-import qualified System.Taffybar.Context as BC (BarConfig(..), TaffybarConfig(..))-import           System.Taffybar.Context hiding (TaffybarConfig(..), BarConfig(..))-import           System.Taffybar.Util+import Graphics.UI.GIGtkStrut hiding (ExactSize, ScreenRatio, StrutSize)+import qualified Graphics.UI.GIGtkStrut as GIGtkStrut+import System.Taffybar+import System.Taffybar.Context hiding (BarConfig (..), TaffybarConfig (..))+import qualified System.Taffybar.Context as BC (BarConfig (..), TaffybarConfig (..))+import System.Taffybar.Util +-- | Size of a bar strut reservation. This is an alias for+-- 'Graphics.UI.GIGtkStrut.StrutSize'.+type StrutSize = GIGtkStrut.StrutSize++-- | Reserve an exact number of pixels.+pattern ExactSize :: Int -> StrutSize+pattern ExactSize size <- GIGtkStrut.ExactSize (fromIntegral -> size)+  where+    ExactSize size = GIGtkStrut.ExactSize (fromIntegral size)++-- | Reserve a fraction of the monitor dimension as a strut size.+pattern ScreenRatio :: Rational -> StrutSize+pattern ScreenRatio ratio = GIGtkStrut.ScreenRatio ratio++{-# COMPLETE ExactSize, ScreenRatio #-}+ -- | An ADT representing the edge of the monitor along which taffybar should be -- displayed. data Position = Top | Bottom@@ -48,45 +74,49 @@ -- 'TaffybarConfig'. Unless you have a good reason to use taffybar's more -- advanced interface, you should stick to using this one. data SimpleTaffyConfig = SimpleTaffyConfig-  {-  -- | The monitor number to put the bar on (default: 'usePrimaryMonitor')-    monitorsAction :: TaffyIO [Int]-  -- | Number of pixels to reserve for the bar (default: 30)-  , barHeight :: StrutSize-  -- | Number of additional pixels to reserve for the bar strut (default: 0)-  , barPadding :: Int-  -- | The position of the bar on the screen (default: 'Top')-  , barPosition :: Position-  -- | The number of pixels between widgets (default: 5)-  , widgetSpacing :: Int-  -- | Widget constructors whose outputs are placed at the beginning of the bar-  , startWidgets :: [TaffyIO Gtk.Widget]-  -- | Widget constructors whose outputs are placed in the center of the bar-  , centerWidgets :: [TaffyIO Gtk.Widget]-  -- | Widget constructors whose outputs are placed at the end of the bar-  , endWidgets :: [TaffyIO Gtk.Widget]-  -- | List of paths to CSS stylesheets that should be loaded at startup.-  , cssPaths :: [FilePath]-  -- | Hook to run at taffybar startup.-  , startupHook :: TaffyIO ()+  { -- | The monitor number to put the bar on (default: 'usePrimaryMonitor')+    monitorsAction :: TaffyIO [Int],+    -- | Number of pixels to reserve for the bar (default: 30)+    barHeight :: StrutSize,+    -- | Number of additional pixels to reserve for the bar strut (default: 0)+    barPadding :: Int,+    -- | The position of the bar on the screen (default: 'Top')+    barPosition :: Position,+    -- | The number of pixels between widgets (default: 5)+    widgetSpacing :: Int,+    -- | Widget constructors whose outputs are placed at the beginning of the bar+    startWidgets :: [TaffyIO Gtk.Widget],+    -- | Widget constructors whose outputs are placed in the center of the bar+    centerWidgets :: [TaffyIO Gtk.Widget],+    -- | Widget constructors whose outputs are placed at the end of the bar+    endWidgets :: [TaffyIO Gtk.Widget],+    -- | Optional level-based widget configuration. If this field is set,+    -- 'startWidgets', 'centerWidgets' and 'endWidgets' are ignored.+    barLevels :: Maybe [BarLevelConfig],+    -- | List of paths to CSS stylesheets that should be loaded at startup.+    cssPaths :: [FilePath],+    -- | Hook to run at taffybar startup.+    startupHook :: TaffyIO ()   }  -- | Sensible defaults for most of the fields of 'SimpleTaffyConfig'. You'll -- need to specify the widgets you want in the bar with 'startWidgets', -- 'centerWidgets' and 'endWidgets'. defaultSimpleTaffyConfig :: SimpleTaffyConfig-defaultSimpleTaffyConfig = SimpleTaffyConfig-  { monitorsAction = useAllMonitors-  , barHeight = ScreenRatio $ 1 / 27-  , barPadding = 0-  , barPosition = Top-  , widgetSpacing = 5-  , startWidgets = []-  , centerWidgets = []-  , endWidgets = []-  , cssPaths = []-  , startupHook = return ()-  }+defaultSimpleTaffyConfig =+  SimpleTaffyConfig+    { monitorsAction = useAllMonitors,+      barHeight = ScreenRatio $ 1 / 27,+      barPadding = 0,+      barPosition = Top,+      widgetSpacing = 5,+      startWidgets = [],+      centerWidgets = [],+      endWidgets = [],+      barLevels = Nothing,+      cssPaths = [],+      startupHook = return ()+    }  instance Default SimpleTaffyConfig where   def = defaultSimpleTaffyConfig@@ -94,21 +124,24 @@ -- | Convert a 'SimpleTaffyConfig' into a 'StrutConfig' that can be used with -- gtk-strut. toStrutConfig :: SimpleTaffyConfig -> Int -> StrutConfig-toStrutConfig SimpleTaffyConfig { barHeight = height-                                , barPadding = padding-                                , barPosition = pos-                                } monitor =-  defaultStrutConfig-  { strutHeight = height-  , strutYPadding = fromIntegral padding-  , strutXPadding = fromIntegral padding-  , strutAlignment = Center-  , strutMonitor = Just $ fromIntegral monitor-  , strutPosition =-      case pos of-        Top -> TopPos-        Bottom -> BottomPos-  }+toStrutConfig+  SimpleTaffyConfig+    { barHeight = height,+      barPadding = padding,+      barPosition = pos+    }+  monitor =+    defaultStrutConfig+      { strutHeight = height,+        strutYPadding = fromIntegral padding,+        strutXPadding = fromIntegral padding,+        strutAlignment = Center,+        strutMonitor = Just $ fromIntegral monitor,+        strutPosition =+          case pos of+            Top -> TopPos+            Bottom -> BottomPos+      }  toBarConfig :: SimpleTaffyConfig -> Int -> IO BC.BarConfig toBarConfig config monitor = do@@ -116,17 +149,20 @@   barId <- newUnique   return     BC.BarConfig-    { BC.strutConfig = strutConfig-    , BC.widgetSpacing = fromIntegral $ widgetSpacing config-    , BC.startWidgets = startWidgets config-    , BC.centerWidgets = centerWidgets config-    , BC.endWidgets = endWidgets config-    , BC.barId = barId-    }+      { BC.strutConfig = strutConfig,+        BC.widgetSpacing = fromIntegral $ widgetSpacing config,+        BC.startWidgets = startWidgets config,+        BC.centerWidgets = centerWidgets config,+        BC.endWidgets = endWidgets config,+        BC.barLevels = barLevels config,+        BC.barId = barId+      }  newtype SimpleBarConfigs = SimpleBarConfigs (MV.MVar [(Int, BC.BarConfig)])  {-# DEPRECATED toTaffyConfig "Use toTaffybarConfig instead" #-}++-- | Deprecated alias for 'toTaffybarConfig'. toTaffyConfig :: SimpleTaffyConfig -> BC.TaffybarConfig toTaffyConfig = toTaffybarConfig @@ -134,10 +170,10 @@ -- with 'startTaffybar' or 'dyreTaffybar'. toTaffybarConfig :: SimpleTaffyConfig -> BC.TaffybarConfig toTaffybarConfig conf =-    def-    { BC.getBarConfigsParam = configGetter-    , BC.cssPaths = cssPaths conf-    , BC.startupHook = startupHook conf+  def+    { BC.getBarConfigsParam = configGetter,+      BC.cssPaths = cssPaths conf,+      BC.startupHook = startupHook conf     }   where     configGetter = do@@ -149,10 +185,9 @@             (monitorNumber, lookup monitorNumber barConfigs)            lookupAndUpdate barConfigs = do-             let (alreadyPresent, toCreate) =                   partition (isJust . snd) $-                  map (lookupWithIndex barConfigs) monitorNumbers+                    map (lookupWithIndex barConfigs) monitorNumbers                 alreadyPresentConfigs = mapMaybe snd alreadyPresent              newlyCreated <-@@ -172,15 +207,19 @@  getMonitorCount :: IO Int getMonitorCount =-  fromIntegral <$> (screenGetDefault >>= maybe (return 0)-                    (screenGetDisplay >=> displayGetNMonitors))+  fromIntegral+    <$> ( screenGetDefault+            >>= maybe+              (return 0)+              (screenGetDisplay >=> displayGetNMonitors)+        )  -- | Supply this value for 'monitorsAction' to display the taffybar window on -- all monitors. useAllMonitors :: TaffyIO [Int] useAllMonitors = lift $ do   count <- getMonitorCount-  return [0..count-1]+  return [0 .. count - 1]  -- | Supply this value for 'monitorsAction' to display the taffybar window only -- on the primary monitor.@@ -192,7 +231,7 @@     Just display -> do       maybePrimary <- displayGetPrimaryMonitor display       monitorCount <- displayGetNMonitors display-      monitors <- catMaybes <$> mapM (displayGetMonitor display) [0..(monitorCount-1)]+      monitors <- catMaybes <$> mapM (displayGetMonitor display) [0 .. (monitorCount - 1)]       let primaryIndex = case maybePrimary of             Nothing -> 0             Just primary -> fromMaybe 0 (elemIndex primary monitors)
src/System/Taffybar/Support/PagerHints.hs view
@@ -1,4 +1,7 @@ -----------------------------------------------------------------------------++-----------------------------------------------------------------------------+ -- | -- Module      : System.Taffybar.Support.PagerHints -- Copyright   : (c) José A. Romero L.@@ -27,15 +30,13 @@ -- -- The second one should be considered read-only, and is set every time -- XMonad calls its log hooks.---------------------------------------------------------------------------------- module System.Taffybar.Support.PagerHints-  {-# DEPRECATED "Use XMonad.Hooks.TaffybarPagerHints instead" #-} (-  -- * Usage-  -- $usage-  pagerHints-  ) where+  {-# DEPRECATED "Use XMonad.Hooks.TaffybarPagerHints instead" #-}+  ( -- * Usage+    -- $usage+    pagerHints,+  )+where  import Codec.Binary.UTF8.String (encode) import Control.Monad@@ -64,9 +65,13 @@ -- | Add support for the \"Current Layout\" and \"Visible Workspaces\" custom -- hints to the given config. pagerHints :: XConfig a -> XConfig a-pagerHints c = c { handleEventHook = handleEventHook c +++ pagerHintsEventHook-           , logHook = logHook c +++ pagerHintsLogHook }-  where x +++ y = x `mappend` y+pagerHints c =+  c+    { handleEventHook = handleEventHook c +++ pagerHintsEventHook,+      logHook = logHook c +++ pagerHintsLogHook+    }+  where+    x +++ y = x `mappend` y  -- | Update the current values of both custom hints. pagerHintsLogHook :: X ()@@ -88,29 +93,31 @@ -- | Set the value of the \"Visible Workspaces\" hint to the one given. setVisibleWorkspaces :: [String] -> X () setVisibleWorkspaces vis = withDisplay $ \dpy -> do-  r  <- asks theRoot-  a  <- xVisibleProp-  c  <- getAtom "UTF8_STRING"-  let vis' = map fromIntegral $ concatMap ((++[0]) . encode) vis+  r <- asks theRoot+  a <- xVisibleProp+  c <- getAtom "UTF8_STRING"+  let vis' = map fromIntegral $ concatMap ((++ [0]) . encode) vis   io $ changeProperty8 dpy r a c propModeReplace vis'  -- | Handle all \"Current Layout\" events received from pager widgets, and -- set the current layout accordingly. pagerHintsEventHook :: Event -> X All-pagerHintsEventHook ClientMessageEvent {-    ev_message_type = mt,-    ev_data = d-  } = withWindowSet $ \_ -> do-  a <- xLayoutProp-  when (mt == a) $ sendLayoutMessage d-  return (All True)+pagerHintsEventHook+  ClientMessageEvent+    { ev_message_type = mt,+      ev_data = d+    } = withWindowSet $ \_ -> do+    a <- xLayoutProp+    when (mt == a) $ sendLayoutMessage d+    return (All True) pagerHintsEventHook _ = return (All True)  -- | Request a change in the current layout by sending an internal message -- to XMonad. sendLayoutMessage :: [CInt] -> X () sendLayoutMessage evData = case evData of-  []   -> return ()-  x:_  -> if x < 0-            then sendMessage FirstLayout-            else sendMessage NextLayout+  [] -> return ()+  x : _ ->+    if x < 0+      then sendMessage FirstLayout+      else sendMessage NextLayout
src/System/Taffybar/Util.hs view
@@ -1,6 +1,10 @@-{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE CPP #-}+{-# LANGUAGE OverloadedStrings #-}+ -----------------------------------------------------------------------------++-----------------------------------------------------------------------------+ -- | -- Module      : System.Taffybar.Util -- Copyright   : (c) Ivan A. Malison@@ -9,121 +13,148 @@ -- Maintainer  : Ivan A. Malison -- Stability   : unstable -- Portability : unportable------------------------------------------------------------------------------+module System.Taffybar.Util+  ( -- * Configuration+    taffyStateDir, -module System.Taffybar.Util (-  -- * Configuration-    taffyStateDir-  -- * GTK concurrency-  , module Gtk-  -- * GLib-  , catchGErrorsAsLeft-  -- * Logging-  , logPrintF-  -- * Text-  , truncateString-  , truncateText-  -- * Resources-  , downloadURIToPath-  , getPixbufFromFilePath-  , safePixbufNewFromFile-  -- * Logic Combinators-  , (<||>)-  , (<|||>)-  , forkM-  , ifM-  , anyM-  , maybeTCombine-  , maybeToEither-  -- * Control-  , foreverWithVariableDelay-  , foreverWithDelay-  -- * Process control-  , runCommand-  , onSigINT-  , maybeHandleSigHUP-  , handlePosixSignal-  -- * Resource management-  , rebracket-  , rebracket_-  -- * Deprecated-  , logPrintFDebug-  , liftReader-  , liftActionTaker-  , (??)-  , runCommandFromPath-  ) where+    -- * GTK concurrency+    module Gtk, -import           Conduit-import           Control.Applicative-import           Control.Arrow ((&&&))-import           Control.Concurrent (ThreadId, forkIO, threadDelay)+    -- * GLib+    catchGErrorsAsLeft,++    -- * Logging+    logPrintF,++    -- * Text+    truncateString,+    truncateText,++    -- * Resources+    downloadURIToPath,+    getPixbufFromFilePath,+    safePixbufNewFromFile,++    -- * Logic Combinators+    (<||>),+    (<|||>),+    forkM,+    ifM,+    anyM,+    maybeTCombine,+    maybeToEither,++    -- * Control+    VariableDelayConfig (..),+    defaultVariableDelayConfig,+    foreverWithVariableDelayWithConfig,+    foreverWithVariableDelay,+    foreverWithDelay,++    -- * Process control+    runCommand,+    onSigINT,+    maybeHandleSigHUP,+    handlePosixSignal,++    -- * Resource management+    rebracket,+    rebracket_,++    -- * Deprecated+    logPrintFDebug,+    liftReader,+    liftActionTaker,+    (??),+    runCommandFromPath,+  )+where++import Conduit+import Control.Applicative+import Control.Arrow ((&&&))+import Control.Concurrent (ThreadId, forkIO, threadDelay) import qualified Control.Concurrent.MVar as MV-import           Control.Exception.Base-import           Control.Monad-import           Control.Monad.Trans.Maybe-import           Control.Monad.Trans.Reader-import           Data.Either.Combinators-import           Data.GI.Base.GError-import           Control.Exception.Enclosed (catchAny)-import           Data.GI.Gtk.Threading as Gtk (postGUIASync, postGUISync)-import           Data.GI.Gtk.Threading (postGUIASyncWithPriority)-import           Data.Maybe-import           Data.IORef (newIORef, readIORef, writeIORef)+import Control.Exception.Base+import Control.Exception.Enclosed (catchAny)+import Control.Monad+import Control.Monad.Trans.Maybe+import Control.Monad.Trans.Reader+import Data.Either.Combinators+import Data.GI.Base.GError+import Data.GI.Gtk.Threading (postGUIASyncWithPriority)+import Data.GI.Gtk.Threading as Gtk (postGUIASync, postGUISync)+import Data.IORef (newIORef, readIORef, writeIORef)+import Data.Maybe import qualified Data.Text as T-import           Data.Tuple.Sequence-import qualified GI.GdkPixbuf.Objects.Pixbuf as Gdk+import qualified Data.Time.Clock as Clock+import Data.Tuple.Sequence import qualified GI.GLib.Constants as G-import           Network.HTTP.Simple-import           System.Directory-import           System.Environment.XDG.BaseDir-import           System.Exit (ExitCode (..), exitWith)-import           System.FilePath.Posix-import           System.IO (hIsTerminalDevice, stdout, stderr)-import           System.Log.Logger-import           System.Posix.Signals (Signal, Handler(..), installHandler, sigHUP, sigINT)+import qualified GI.GdkPixbuf.Objects.Pixbuf as Gdk+import Network.HTTP.Simple+import System.Directory+import System.Environment.XDG.BaseDir+import System.Exit (ExitCode (..), exitWith)+import System.FilePath.Posix+import System.IO (hIsTerminalDevice, stderr, stdout)+import System.Log.Logger+import System.Posix.Signals (Handler (..), Signal, installHandler, sigHUP, sigINT) import qualified System.Process as P-import           Text.Printf-+import Text.Printf +-- | Per-user state directory for taffybar runtime/cache data. taffyStateDir :: IO FilePath taffyStateDir = getUserDataDir "taffybar"  {-# DEPRECATED liftReader "Use Control.Monad.Trans.Reader.mapReaderT instead" #-}-liftReader :: Monad m => (m1 a -> m b) -> ReaderT r m1 a -> ReaderT r m b++-- | Deprecated alias for 'mapReaderT'.+liftReader :: (Monad m) => (m1 a -> m b) -> ReaderT r m1 a -> ReaderT r m b liftReader = mapReaderT -logPrintF-  :: (MonadIO m, Show t)-  => String -> Priority -> String -> t -> m ()+-- | Log a formatted value using 'printf' into a specific logger path.+logPrintF ::+  (MonadIO m, Show t) =>+  String -> Priority -> String -> t -> m () logPrintF logPath priority format toPrint =   liftIO $ logM logPath priority $ printf format $ show toPrint  {-# DEPRECATED logPrintFDebug "Use logPrintF instead" #-}++-- | Deprecated debug-level convenience wrapper around 'logPrintF'. logPrintFDebug :: (MonadIO m, Show t) => String -> String -> t -> m () logPrintFDebug path = logPrintF path DEBUG  infixl 4 ??-(??) :: Functor f => f (a -> b) -> a -> f b++-- | Apply a pure argument to a functor-wrapped function.+(??) :: (Functor f) => f (a -> b) -> a -> f b fab ?? a = fmap ($ a) fab {-# INLINE (??) #-} {-# DEPRECATED (??) "Use @f <*> pure a@ instead" #-} -ifM :: Monad m => m Bool -> m a -> m a -> m a+-- | Monadic conditional.+ifM :: (Monad m) => m Bool -> m a -> m a -> m a ifM cond whenTrue whenFalse =   cond >>= (\bool -> if bool then whenTrue else whenFalse) -forkM :: Monad m => (c -> m a) -> (c -> m b) -> c -> m (a, b)+-- | Evaluate two monadic computations from the same input and return both+-- results.+forkM :: (Monad m) => (c -> m a) -> (c -> m b) -> c -> m (a, b) forkM a b = sequenceT . (a &&& b) +-- | Convert a 'Maybe' into an 'Either' with a provided left value. maybeToEither :: b -> Maybe a -> Either b a maybeToEither = flip maybe Right . Left +-- | Truncate a string to at most @n@ characters, appending an ellipsis when+-- truncation occurs. truncateString :: Int -> String -> String truncateString n incoming   | length incoming <= n = incoming   | otherwise = take n incoming ++ "…" +-- | Text variant of 'truncateString'. truncateText :: Int -> T.Text -> T.Text truncateText n incoming   | T.length incoming <= n = incoming@@ -133,17 +164,19 @@ -- -- If the command filename does not contain a slash, then the @PATH@ -- environment variable is searched for the executable.-runCommand :: MonadIO m => FilePath -> [String] -> m (Either String String)+runCommand :: (MonadIO m) => FilePath -> [String] -> m (Either String String) runCommand cmd args = liftIO $ do   (ecode, out, err) <- P.readProcessWithExitCode cmd args ""   logM "System.Taffybar.Util" INFO $-       printf "Running command %s with args %s" (show cmd) (show args)+    printf "Running command %s with args %s" (show cmd) (show args)   return $ case ecode of     ExitSuccess -> Right out     ExitFailure exitCode -> Left $ printf "Exit code %s: %s " (show exitCode) err  {-# DEPRECATED runCommandFromPath "Use runCommand instead" #-}-runCommandFromPath :: MonadIO m => FilePath -> [String] -> m (Either String String)++-- | Deprecated alias for 'runCommand'.+runCommandFromPath :: (MonadIO m) => FilePath -> [String] -> m (Either String String) runCommandFromPath = runCommand  -- | A variant of 'bracket' which allows for reloading.@@ -178,61 +211,116 @@ -- automatically allocate the resource before running the enclosed -- action. rebracket_ :: IO (IO ()) -> (IO () -> IO a) -> IO a-rebracket_ alloc action = rebracket ((, ()) <$> alloc) $+rebracket_ alloc action = rebracket ((,()) <$> alloc) $   \reload -> reload >> action reload  -- | Execute the provided IO action at the provided interval. foreverWithDelay :: (MonadIO m, RealFrac d) => d -> IO () -> m ThreadId foreverWithDelay delay action =   foreverWithVariableDelay $ safeAction >> return delay-  where safeAction =-          catchAny action $ \e ->-            logPrintF "System.Taffybar.Util" WARNING "Error in foreverWithDelay %s" e+  where+    safeAction =+      catchAny action $ \e ->+        logPrintF "System.Taffybar.Util" WARNING "Error in foreverWithDelay %s" e+{-# DEPRECATED foreverWithDelay "Use System.Taffybar.Information.Wakeup.taffyForeverWithDelay for context-aware synchronized wakeups" #-}  -- | Execute the provided IO action, and use the value it returns to decide how -- long to wait until executing it again. The value returned by the action is -- interpreted as a number of seconds.+newtype VariableDelayConfig d = VariableDelayConfig+  { -- | Maximum sleep chunk used while waiting between polls.+    --+    -- If 'Nothing', waits use a single 'threadDelay' for the entire delay.+    -- If present, waits are chunked using wall-clock time, which helps polling+    -- loops recover promptly after suspend/resume.+    variableDelayMaxWaitChunk :: Maybe d+  }+  deriving (Eq, Ord, Show)++defaultVariableDelayConfig :: VariableDelayConfig d+defaultVariableDelayConfig =+  VariableDelayConfig+    { variableDelayMaxWaitChunk = Nothing+    }+ foreverWithVariableDelay :: (MonadIO m, RealFrac d) => IO d -> m ThreadId-foreverWithVariableDelay action = liftIO $ forkIO $ action >>= delayThenAction-  where delayThenAction delay =-          threadDelay (floor $ delay * 1000000) >> action >>= delayThenAction+foreverWithVariableDelay = foreverWithVariableDelayWithConfig defaultVariableDelayConfig -liftActionTaker-  :: (Monad m)-  => ((a -> m a) -> m b) -> (a -> ReaderT c m a) -> ReaderT c m b+foreverWithVariableDelayWithConfig ::+  (MonadIO m, RealFrac d) => VariableDelayConfig d -> IO d -> m ThreadId+foreverWithVariableDelayWithConfig config action = liftIO $ forkIO $ action >>= delayThenAction+  where+    delayThenAction delay = do+      waitDelay delay+      action >>= delayThenAction++    waitDelay delay+      | delay <= 0 = pure ()+      | otherwise =+          case variableDelayMaxWaitChunk config of+            Just waitChunk | waitChunk > 0 -> do+              start <- Clock.getCurrentTime+              let waitChunkMicros =+                    max 1 $+                      floor+                        (realToFrac waitChunk * 1000000 :: Double)+              waitUntil waitChunkMicros $ Clock.addUTCTime (realToFrac delay) start+            _ -> threadDelay (floor $ delay * 1000000)++    waitUntil waitChunkMicros target = do+      now <- Clock.getCurrentTime+      let remainingMicros =+            floor+              (realToFrac (Clock.diffUTCTime target now) * 1000000 :: Double)+          sleepMicros = min waitChunkMicros remainingMicros+      when (sleepMicros > 0) $ threadDelay sleepMicros >> waitUntil waitChunkMicros target++-- | Lift an action-taker combinator into a 'ReaderT' context.+liftActionTaker ::+  (Monad m) =>+  ((a -> m a) -> m b) -> (a -> ReaderT c m a) -> ReaderT c m b liftActionTaker actionTaker action = do   ctx <- ask   lift $ actionTaker $ flip runReaderT ctx . action -maybeTCombine-  :: Monad m-  => m (Maybe a) -> m (Maybe a) -> m (Maybe a)+-- | Combine two @Maybe@-producing actions, preferring the first successful one.+maybeTCombine ::+  (Monad m) =>+  m (Maybe a) -> m (Maybe a) -> m (Maybe a) maybeTCombine a b = runMaybeT $ MaybeT a <|> MaybeT b  infixl 3 <||>++-- | Pointwise 'maybeTCombine' for unary functions. (<||>) ::-  Monad m =>+  (Monad m) =>   (t -> m (Maybe a)) -> (t -> m (Maybe a)) -> t -> m (Maybe a) a <||> b = combineOptions-  where combineOptions v = maybeTCombine (a v) (b v)+  where+    combineOptions v = maybeTCombine (a v) (b v)  infixl 3 <|||>-(<|||>)-  :: Monad m-  => (t -> t1 -> m (Maybe a))-  -> (t -> t1 -> m (Maybe a))-  -> t-  -> t1-  -> m (Maybe a)++-- | Pointwise 'maybeTCombine' for binary functions.+(<|||>) ::+  (Monad m) =>+  (t -> t1 -> m (Maybe a)) ->+  (t -> t1 -> m (Maybe a)) ->+  t ->+  t1 ->+  m (Maybe a) a <|||> b = combineOptions-  where combineOptions v v1 = maybeTCombine (a v v1) (b v v1)+  where+    combineOptions v v1 = maybeTCombine (a v v1) (b v v1) +-- | Catch GLib errors as 'Left', otherwise return 'Right'. catchGErrorsAsLeft :: IO a -> IO (Either GError a) catchGErrorsAsLeft action = catch (Right <$> action) (return . Left)  catchGErrorsAsNothing :: IO a -> IO (Maybe a) catchGErrorsAsNothing = fmap rightToMaybe . catchGErrorsAsLeft +-- | Safely load a pixbuf from file, returning 'Nothing' on GDK errors. safePixbufNewFromFile :: FilePath -> IO (Maybe Gdk.Pixbuf) safePixbufNewFromFile =   handleResult . catchGErrorsAsNothing . Gdk.pixbufNewFromFile@@ -243,27 +331,31 @@     handleResult = id #endif +-- | Load a pixbuf from file and emit a warning log on failure. getPixbufFromFilePath :: FilePath -> IO (Maybe Gdk.Pixbuf) getPixbufFromFilePath filepath = do   result <- safePixbufNewFromFile filepath   when (isNothing result) $-       logM "System.Taffybar.WindowIcon" WARNING $-            printf "Failed to load icon from filepath %s" filepath+    logM "System.Taffybar.WindowIcon" WARNING $+      printf "Failed to load icon from filepath %s" filepath   return result +-- | Download a URI response body directly to a local file path. downloadURIToPath :: Request -> FilePath -> IO () downloadURIToPath uri filepath =-  createDirectoryIfMissing True directory >>-  runConduitRes (httpSource uri getResponseBody .| sinkFile filepath)-  where (directory, _) = splitFileName filepath+  createDirectoryIfMissing True directory+    >> runConduitRes (httpSource uri getResponseBody .| sinkFile filepath)+  where+    (directory, _) = splitFileName filepath +-- | Monadic 'any'. anyM :: (Monad m) => (a -> m Bool) -> [a] -> m Bool anyM _ [] = return False-anyM p (x:xs) = do+anyM p (x : xs) = do   q <- p x   if q-  then return True-  else anyM p xs+    then return True+    else anyM p xs  -- | Installs a useful posix signal handler for 'sigINT' (i.e. Ctrl-C) -- for cases when the 'Control.Exception.UserInterrupt' exception gets@@ -276,10 +368,12 @@ -- -- If the signal handler was invoked, the program will exit with -- status 130 after the main loop action returns.-onSigINT-  :: IO a -- ^ The main loop 'IO' action-  -> IO () -- ^ Callback for @SIGINT@-  -> IO a+onSigINT ::+  -- | The main loop 'IO' action+  IO a ->+  -- | Callback for @SIGINT@+  IO () ->+  IO a onSigINT action callback = do   exitStatus <- newIORef Nothing @@ -301,7 +395,8 @@ -- program, which is the correct thing to do. maybeHandleSigHUP :: IO () -> IO a -> IO a maybeHandleSigHUP callback action =-  ifM (anyM hIsTerminalDevice [stdout, stderr])+  ifM+    (anyM hIsTerminalDevice [stdout, stderr])     action     (handlePosixSignal sigHUP callback action)
src/System/Taffybar/Widget.hs view
@@ -1,6 +1,17 @@+{- ORMOLU_DISABLE -} {-# LANGUAGE CPP #-} {-# LANGUAGE DuplicateRecordFields #-} +-- |+-- Module      : System.Taffybar.Widget+-- Copyright   : (c) Ivan A. Malison+-- License     : BSD3-style (see LICENSE)+--+-- Maintainer  : Ivan A. Malison+-- Stability   : unstable+-- Portability : unportable+--+-- Convenience re-export module for commonly used widgets. module System.Taffybar.Widget   ( module System.Taffybar.Widget.Util   -- * "System.Taffybar.Widget.PulseAudio"@@ -41,6 +52,9 @@   -- * "System.Taffybar.Widget.FreedesktopNotifications"   , module System.Taffybar.Widget.FreedesktopNotifications +  -- * "System.Taffybar.Widget.ImageCommandButton"+  , module System.Taffybar.Widget.ImageCommandButton+   -- * "System.Taffybar.Widget.Inhibitor"   , module System.Taffybar.Widget.Inhibitor @@ -61,6 +75,7 @@    -- * "System.Taffybar.Widget.SNITray"   , module System.Taffybar.Widget.SNITray+  , module System.Taffybar.Widget.SNITray.PrioritizedCollapsible    -- * "System.Taffybar.Widget.SimpleClock"   , module System.Taffybar.Widget.SimpleClock@@ -68,6 +83,9 @@   -- * "System.Taffybar.Widget.SimpleCommandButton"   , module System.Taffybar.Widget.SimpleCommandButton +  -- * "System.Taffybar.Widget.WakeupDebug"+  , module System.Taffybar.Widget.WakeupDebug+   -- * "System.Taffybar.Widget.Text.CPUMonitor"   , module System.Taffybar.Widget.Text.CPUMonitor @@ -83,6 +101,12 @@   -- * "System.Taffybar.Widget.Windows"   , module System.Taffybar.Widget.Windows +  -- * "System.Taffybar.Widget.ChannelWorkspaces"+  , ChannelWorkspacesConfig+  , defaultChannelWorkspacesConfig+  , defaultChannelEWMHWorkspacesConfig+  , channelWorkspacesNew+   -- * "System.Taffybar.Widget.HyprlandWorkspaces"   , HyprlandWorkspacesConfig(..)   , defaultHyprlandWorkspacesConfig@@ -116,6 +140,8 @@   , module System.Taffybar.Widget.XDGMenu.MenuWidget   ) where +import qualified GI.Gtk as Gtk+import System.Taffybar.Context (TaffyIO) import System.Taffybar.Widget.Battery import System.Taffybar.Widget.BatteryDonut import System.Taffybar.Widget.BatteryTextIcon@@ -128,6 +154,7 @@ import System.Taffybar.Widget.DiskUsage import System.Taffybar.Widget.FSMonitor import System.Taffybar.Widget.FreedesktopNotifications+import System.Taffybar.Widget.ImageCommandButton import System.Taffybar.Widget.Inhibitor import System.Taffybar.Widget.Layout import System.Taffybar.Widget.MPRIS2@@ -135,8 +162,10 @@ import System.Taffybar.Widget.NetworkManager import System.Taffybar.Widget.PowerProfiles import System.Taffybar.Widget.SNITray+import System.Taffybar.Widget.SNITray.PrioritizedCollapsible import System.Taffybar.Widget.SimpleClock import System.Taffybar.Widget.SimpleCommandButton+import System.Taffybar.Widget.WakeupDebug import System.Taffybar.Widget.Text.CPUMonitor import System.Taffybar.Widget.Text.MemoryMonitor import System.Taffybar.Widget.Text.NetworkMonitor@@ -145,17 +174,22 @@ import System.Taffybar.Widget.Backlight import System.Taffybar.Widget.Weather import System.Taffybar.Widget.Windows-import System.Taffybar.Widget.HyprlandWorkspaces+import System.Taffybar.Widget.Workspaces.Hyprland hiding   ( HyprlandWorkspacesConfig(..)   , defaultHyprlandWorkspacesConfig+  , hyprlandBuildButtonController+  , hyprlandBuildContentsController+  , hyprlandBuildCustomOverlayController+  , hyprlandBuildIconController+  , hyprlandBuildLabelController+  , hyprlandBuildLabelOverlayController   , hyprlandWorkspacesNew-  , HyprlandWorkspace(..)-  , HyprlandWindow(..)-  , HyprlandWindowIconPixbufGetter-  , HyprlandWorkspaceWidgetController(..)-  , HyprlandWWC(..)-  , HyprlandControllerConstructor-  , HyprlandParentControllerConstructor+  , defaultHyprlandWidgetBuilder+  )+import System.Taffybar.Widget.Workspaces.Hyprland.Compat+  ( HyprlandWorkspacesConfig(..)+  , defaultHyprlandWorkspacesConfig+  , hyprlandWorkspacesNew   , hyprlandBuildLabelController   , hyprlandBuildIconController   , hyprlandBuildContentsController@@ -163,13 +197,17 @@   , hyprlandBuildCustomOverlayController   , hyprlandBuildButtonController   , defaultHyprlandWidgetBuilder-  , defaultHyprlandGetWindowIconPixbuf-  , getHyprlandWorkspaces-  , hyprlandSwitchToWorkspace-  , getActiveWindowAddress-  , runHyprctlJson-  , HyprlandClient(..)-  , windowFromClient   ) import System.Taffybar.Widget.Workspaces import System.Taffybar.Widget.XDGMenu.MenuWidget++type ChannelWorkspacesConfig = WorkspacesConfig++defaultChannelWorkspacesConfig :: ChannelWorkspacesConfig+defaultChannelWorkspacesConfig = defaultWorkspacesConfig++defaultChannelEWMHWorkspacesConfig :: ChannelWorkspacesConfig+defaultChannelEWMHWorkspacesConfig = defaultEWMHWorkspacesConfig++channelWorkspacesNew :: ChannelWorkspacesConfig -> TaffyIO Gtk.Widget+channelWorkspacesNew = workspacesNew
+ src/System/Taffybar/Widget/ASUS.hs view
@@ -0,0 +1,217 @@+{-# LANGUAGE OverloadedStrings #-}++-----------------------------------------------------------------------------++-----------------------------------------------------------------------------++-- |+-- Module      : System.Taffybar.Widget.ASUS+-- Copyright   : (c) Ivan A. Malison+-- License     : BSD3-style (see LICENSE)+--+-- Maintainer  : Ivan A. Malison+-- Stability   : unstable+-- Portability : unportable+--+-- This module provides a widget for displaying and controlling the current+-- ASUS platform profile along with CPU frequency and temperature.+--+-- Displays: @\<icon\> \<freq\> \<temp\>@, e.g. @nf-icon 3.2GHz 72°C@.+-- Left-click opens a profile selection menu; right-click cycles profiles.+module System.Taffybar.Widget.ASUS+  ( ASUSWidgetConfig (..),+    defaultASUSWidgetConfig,+    asusWidgetNew,+    asusWidgetNewWithConfig,+  )+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.GLib as GLib+import qualified GI.Gdk as Gdk+import qualified GI.Gtk as Gtk+import System.Log.Logger+import System.Taffybar.Context+import System.Taffybar.Information.ASUS+import System.Taffybar.Util (logPrintF, postGUIASync)+import System.Taffybar.Widget.Generic.ChannelWidget+import Text.Printf (printf)++-- | Configuration for the ASUS widget.+data ASUSWidgetConfig = ASUSWidgetConfig+  { -- | Nerd font icon for quiet mode+    asusQuietIcon :: T.Text,+    -- | Nerd font icon for balanced mode+    asusBalancedIcon :: T.Text,+    -- | Nerd font icon for performance mode+    asusPerformanceIcon :: T.Text,+    -- | Show CPU frequency+    asusShowFreq :: Bool,+    -- | Show CPU temperature+    asusShowTemp :: Bool+  }+  deriving (Eq, Show)++-- | Default configuration.+-- Icons: nf-md-leaf (quiet), nf-md-scale_balance (balanced), nf-md-rocket_launch (performance)+defaultASUSWidgetConfig :: ASUSWidgetConfig+defaultASUSWidgetConfig =+  ASUSWidgetConfig+    { asusQuietIcon = T.pack "\xF06C9", -- nf-md-leaf+      asusBalancedIcon = T.pack "\xF0A7A", -- nf-md-scale_balance+      asusPerformanceIcon = T.pack "\xF0E4E", -- nf-md-rocket_launch+      asusShowFreq = True,+      asusShowTemp = True+    }++instance Default ASUSWidgetConfig where+  def = defaultASUSWidgetConfig++asusLogPath :: String+asusLogPath = "System.Taffybar.Widget.ASUS"++asusLogF :: (MonadIO m, Show t) => Priority -> String -> t -> m ()+asusLogF = logPrintF asusLogPath++-- | Create an ASUS widget with default configuration.+asusWidgetNew :: TaffyIO Gtk.Widget+asusWidgetNew = asusWidgetNewWithConfig defaultASUSWidgetConfig++-- | Create an ASUS widget with custom configuration.+asusWidgetNewWithConfig :: ASUSWidgetConfig -> TaffyIO Gtk.Widget+asusWidgetNewWithConfig config = do+  chan <- getASUSInfoChan+  ctx <- ask++  liftIO $ do+    label <- Gtk.labelNew Nothing+    ebox <- Gtk.eventBoxNew+    Gtk.containerAdd ebox label+    styleCtx <- Gtk.widgetGetStyleContext ebox+    Gtk.styleContextAddClass styleCtx "asus-profile"++    let updateWidget info = postGUIASync $ do+          let icon = getTextIcon config (asusProfile info)+              freqText =+                if asusShowFreq config+                  then T.pack $ printf " %.1fGHz" (asusCpuFreqGHz info)+                  else ""+              tempText =+                if asusShowTemp config+                  then T.pack $ printf " %.0f\x00B0C" (asusCpuTempC info)+                  else ""+              labelText = icon <> freqText <> tempText+          Gtk.labelSetText label labelText+          updateProfileClasses ebox info+          updateTooltip ebox info++    void $ Gtk.onWidgetRealize ebox $ do+      initialInfo <- runReaderT getASUSInfoState ctx+      updateWidget initialInfo++    setupClickHandler ctx ebox+    Gtk.widgetShowAll ebox+    Gtk.toWidget =<< channelWidgetNew ebox chan updateWidget++-- | Select the nerd font text icon for a given profile.+getTextIcon :: ASUSWidgetConfig -> ASUSPlatformProfile -> T.Text+getTextIcon config Quiet = asusQuietIcon config+getTextIcon config Balanced = asusBalancedIcon config+getTextIcon config Performance = asusPerformanceIcon config++-- | Update CSS classes based on the current profile.+updateProfileClasses :: (Gtk.IsWidget w) => w -> ASUSInfo -> IO ()+updateProfileClasses widget info = do+  let profile = asusProfile info+      allClasses = ["quiet", "balanced", "performance"] :: [T.Text]+      currentClass = case profile of+        Quiet -> "quiet"+        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 -> ASUSInfo -> IO ()+updateTooltip widget info = do+  let profile = asusProfileToString (asusProfile info)+      freqStr = T.pack $ printf "%.2f GHz" (asusCpuFreqGHz info)+      tempStr = T.pack $ printf "%.1f\x00B0C" (asusCpuTempC info)+      tooltipText =+        "Profile: "+          <> profile+          <> "\nCPU Freq: "+          <> freqStr+          <> "\nCPU Temp: "+          <> tempStr+  Gtk.widgetSetTooltipText widget (Just tooltipText)++-- | Set up click handler: left-click opens profile menu, right-click cycles.+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+      then return False+      else case button of+        1 -> do+          showProfileMenu ctx ebox+          return True+        3 -> do+          let client = systemDBusClient ctx+          result <- cycleASUSProfile client+          case result of+            Left err ->+              asusLogF WARNING "Failed to cycle ASUS profile: %s" (show err)+            Right () ->+              return ()+          return True+        _ -> return False++-- | Build and show a popup menu for selecting a profile.+showProfileMenu :: Context -> Gtk.EventBox -> IO ()+showProfileMenu ctx ebox = do+  currentEvent <- Gtk.getCurrentEvent+  currentInfo <- runReaderT getASUSInfoState ctx+  let currentProfile = asusProfile currentInfo++  menu <- Gtk.menuNew+  Gtk.menuAttachToWidget menu ebox Nothing++  let profiles =+        [ ("Quiet", Quiet),+          ("Balanced", Balanced),+          ("Performance", Performance)+        ]++  forM_ profiles $ \(labelText, profile) -> do+    let prefix =+          if profile == currentProfile+            then "\x2713 " :: T.Text+            else "   "+    item <- Gtk.menuItemNewWithLabel (prefix <> labelText)+    void $ Gtk.onMenuItemActivate item $ do+      let client = systemDBusClient ctx+      result <- setASUSProfile client profile+      case result of+        Left err ->+          asusLogF WARNING "Failed to set ASUS profile: %s" (show err)+        Right () ->+          return ()+    Gtk.menuShellAppend menu item++  void $+    Gtk.onWidgetHide menu $+      void $+        GLib.idleAdd GLib.PRIORITY_LOW $ do+          Gtk.widgetDestroy menu+          return False++  Gtk.widgetShowAll menu+  Gtk.menuPopupAtPointer menu currentEvent
src/System/Taffybar/Widget/Backlight.hs view
@@ -1,5 +1,9 @@ {-# LANGUAGE OverloadedStrings #-}------------------------------------------------------------------------------ ++-----------------------------------------------------------------------------++-----------------------------------------------------------------------------+ -- | -- Module      : System.Taffybar.Widget.Backlight -- Copyright   : (c) Ivan A. Malison@@ -11,93 +15,92 @@ -- -- 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+  ( 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 Data.Default (Default (..)) import qualified Data.Text as T-import qualified GI.Gdk.Structs.EventScroll as GdkEvent+import qualified GI.GLib as G import qualified GI.Gdk.Enums as Gdk+import qualified GI.Gdk.Structs.EventScroll as GdkEvent import qualified GI.Gtk as Gtk-import 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 System.Taffybar.Widget.Util (buildIconLabelBox, widgetSetClassGI) 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).+  { backlightPollingInterval :: Double,+    backlightDevice :: Maybe FilePath,+    backlightFormat :: String,+    backlightUnknownFormat :: String,+    backlightTooltipFormat :: Maybe String,+    backlightScrollStepPercent :: Maybe Int,+    backlightBrightnessctlPath :: FilePath,+    -- | Nerd font icon character (default U+F0EB, \xF0EB).+    backlightIcon :: T.Text   }  -- | 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"+    { 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 :: (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 :: (MonadIO m) => BacklightWidgetConfig -> m Gtk.Widget backlightIconNewWith config = liftIO $ do   label <- Gtk.labelNew (Just (backlightIcon config))+  _ <- widgetSetClassGI label "backlight-icon"   Gtk.widgetShowAll label   Gtk.toWidget label  -- | Create a combined icon+label backlight widget with default configuration.-backlightNew :: MonadIO m => m Gtk.Widget+backlightNew :: (MonadIO m) => m Gtk.Widget backlightNew = backlightNewWith defaultBacklightWidgetConfig  -- | Create a combined icon+label backlight widget.-backlightNewWith :: MonadIO m => BacklightWidgetConfig -> m Gtk.Widget+backlightNewWith :: (MonadIO m) => BacklightWidgetConfig -> m Gtk.Widget backlightNewWith config = liftIO $ do   iconWidget <- backlightIconNewWith config   labelWidget <- backlightLabelNewWith config-  buildIconLabelBox iconWidget labelWidget+  buildIconLabelBox iconWidget labelWidget >>= (`widgetSetClassGI` "backlight")  -- | Create a combined icon+label backlight widget (channel-driven). backlightNewChan :: TaffyIO Gtk.Widget@@ -108,18 +111,22 @@ backlightNewChanWith config = do   iconWidget <- liftIO $ backlightIconNewWith config   labelWidget <- backlightLabelNewChanWith config-  liftIO $ buildIconLabelBox iconWidget labelWidget+  liftIO $+    buildIconLabelBox iconWidget labelWidget+      >>= (`widgetSetClassGI` "backlight")  -- | Create a backlight widget with default configuration.-backlightLabelNew :: MonadIO m => m Gtk.Widget+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 :: (MonadIO m) => BacklightWidgetConfig -> m Gtk.Widget backlightLabelNewWith config = liftIO $ do-  widget <- pollingLabelNewWithTooltip-    (backlightPollingInterval config)-    (formatBacklightWidget config)+  widget <-+    pollingLabelNewWithTooltip+      (backlightPollingInterval config)+      (formatBacklightWidget config)+  _ <- widgetSetClassGI widget "backlight-label"    case backlightScrollStepPercent config of     Nothing -> return ()@@ -148,22 +155,23 @@ -- | 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)+  chan <-+    BL.getBacklightInfoChanWithInterval+      (backlightDevice config)+      (backlightPollingInterval config)   initialInfo <- BL.getBacklightInfoState (backlightDevice config)    liftIO $ do     label <- Gtk.labelNew Nothing+    _ <- widgetSetClassGI label "backlight-label" -    let-      updateLabel info = do-        (labelText, tooltipText) <- formatBacklightWidgetFromInfo config info-        postGUIASync $ do-          Gtk.labelSetMarkup label labelText-          Gtk.widgetSetTooltipMarkup label tooltipText+    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+        refreshNow = BL.getBacklightInfo (backlightDevice config) >>= updateLabel      void $ Gtk.onWidgetRealize label $ updateLabel initialInfo @@ -186,19 +194,20 @@         return ()      Gtk.widgetShowAll label-    Gtk.toWidget =<< channelWidgetNew label chan updateLabel+    (Gtk.toWidget =<< channelWidgetNew label chan updateLabel)+      >>= (`widgetSetClassGI` "backlight-label") -formatBacklightWidget-  :: BacklightWidgetConfig-  -> IO (T.Text, Maybe T.Text)+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 ::+  BacklightWidgetConfig ->+  Maybe BL.BacklightInfo ->+  IO (T.Text, Maybe T.Text) formatBacklightWidgetFromInfo config info =   case info of     Nothing -> return (T.pack $ backlightUnknownFormat config, Nothing)@@ -210,20 +219,19 @@  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+  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)+    [ ("brightness", brightness),+      ("max", maxBrightness),+      ("percent", percent),+      ("device", device)     ]  renderTemplate :: String -> [(String, String)] -> String@@ -237,11 +245,10 @@   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]+      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 =
src/System/Taffybar/Widget/Battery.hs view
@@ -1,6 +1,10 @@-{-# LANGUAGE OverloadedStrings   #-}+{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ScopedTypeVariables #-}+ -----------------------------------------------------------------------------++-----------------------------------------------------------------------------+ -- | -- Module      : System.Taffybar.Widget.Battery -- Copyright   : (c) Ivan A. Malison@@ -15,49 +19,51 @@ -- widget displayed (if using a multi-head configuration or multiple battery -- widgets), these widgets use the broadcast "TChan" based system for receiving -- updates defined in "System.Taffybar.Information.Battery".------------------------------------------------------------------------------ module System.Taffybar.Widget.Battery-  ( batteryIconNew-  , BatteryClassesConfig(..)-  , defaultBatteryClassesConfig-  , setBatteryStateClasses-  , textBatteryNew-  , textBatteryNewWithLabelAction-  ) where+  ( batteryIconNew,+    BatteryClassesConfig (..),+    defaultBatteryClassesConfig,+    setBatteryStateClasses,+    textBatteryNew,+    textBatteryNewWithLabelAction,+  )+where -import           Control.Monad-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 Control.Monad+import Control.Monad.IO.Class+import Control.Monad.Trans.Reader+import Data.Default (Default (..))+import Data.GI.Base.Overloading (IsDescendantOf)+import Data.IORef (newIORef, readIORef, writeIORef)+import Data.Int (Int64) 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.Generic.ChannelWidget-import           System.Taffybar.Widget.Generic.ScalingImage (scalingImage)-import           System.Taffybar.Widget.Util hiding (themeLoadFlags)-import           Text.Printf-import           Text.StringTemplate+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.Generic.ScalingImage (scalingImage)+import System.Taffybar.Widget.Util hiding (themeLoadFlags)+import Text.Printf+import Text.StringTemplate  -- | Just the battery info that will be used for display (this makes combining -- several easier). data BatteryWidgetInfo = BWI-  { seconds :: Maybe Int64-  , percent :: Int-  , status :: String-  } deriving (Eq, Show)+  { seconds :: Maybe Int64,+    percent :: Int,+    status :: String+  }+  deriving (Eq, Show)  -- | Format a duration expressed as seconds to hours and minutes formatDuration :: Maybe Int64 -> String formatDuration Nothing = ""-formatDuration (Just secs) = let minutes = secs `div` 60-                                 hours = minutes `div` 60-                                 minutes' = minutes `mod` 60-                             in printf "%02d:%02d" hours minutes'+formatDuration (Just secs) =+  let minutes = secs `div` 60+      hours = minutes `div` 60+      minutes' = minutes `mod` 60+   in printf "%02d:%02d" hours minutes'  getBatteryWidgetInfo :: BatteryInfo -> BatteryWidgetInfo getBatteryWidgetInfo info =@@ -75,17 +81,20 @@           BatteryStateCharging -> "Charging"           BatteryStateDischarging -> "Discharging"           _ -> "✔"-  in BWI {seconds = battTime, percent = battPctNum, status = battStatus}+   in BWI {seconds = battTime, percent = battPctNum, status = battStatus}  -- | Given (maybe summarized) battery info and format: provides the string to display formatBattInfo :: BatteryWidgetInfo -> String -> T.Text formatBattInfo info fmt =   let tpl = newSTMP fmt-      tpl' = setManyAttrib [ ("percentage", (show . percent) info)-                           , ("time", formatDuration (seconds info))-                           , ("status", status info)-                           ] tpl-  in render tpl'+      tpl' =+        setManyAttrib+          [ ("percentage", (show . percent) info),+            ("time", formatDuration (seconds info)),+            ("status", status info)+          ]+          tpl+   in render tpl'  -- | A simple textual battery widget. The displayed format is specified format -- string where $percentage$ is replaced with the percentage of battery@@ -93,48 +102,57 @@ -- charged/discharged. textBatteryNew :: String -> TaffyIO Widget textBatteryNew format = textBatteryNewWithLabelAction labelSetter-  where labelSetter label info = do-          setBatteryStateClasses def label info-          labelSetMarkup label $-                         formatBattInfo (getBatteryWidgetInfo info) format+  where+    labelSetter label info = do+      setBatteryStateClasses def label info+      labelSetMarkup label $+        formatBattInfo (getBatteryWidgetInfo info) format +-- | CSS-threshold configuration for battery level classes. data BatteryClassesConfig = BatteryClassesConfig-  { batteryHighThreshold :: Double-  , batteryLowThreshold :: Double-  , batteryCriticalThreshold :: Double+  { batteryHighThreshold :: Double,+    batteryLowThreshold :: Double,+    batteryCriticalThreshold :: Double   } +-- | Default thresholds for 'BatteryClassesConfig'. defaultBatteryClassesConfig :: BatteryClassesConfig defaultBatteryClassesConfig =   BatteryClassesConfig-  { batteryHighThreshold = 80-  , batteryLowThreshold = 20-  , batteryCriticalThreshold = 5-  }+    { batteryHighThreshold = 80,+      batteryLowThreshold = 20,+      batteryCriticalThreshold = 5+    }  instance Default BatteryClassesConfig where   def = defaultBatteryClassesConfig +-- | Add/remove CSS classes on a widget to reflect battery charging state and+-- level thresholds. setBatteryStateClasses ::   (IsDescendantOf Widget a, GObject a, MonadIO m) =>   BatteryClassesConfig -> a -> BatteryInfo -> m () setBatteryStateClasses config 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+    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   classIf "critical" $ percentage <= batteryCriticalThreshold config-  where percentage = batteryPercentage info-        classIf klass condition =-          if condition-          then addClassIfMissing klass widget-          else removeClassIfPresent klass widget+  where+    percentage = batteryPercentage info+    classIf klass condition =+      if condition+        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@@ -148,13 +166,15 @@     label <- labelNew Nothing     let updateWidget =           postGUIASync . flip runReaderT ctx . labelSetter label-    void $ onWidgetRealize label $-         runReaderT getDisplayBatteryInfo ctx >>= updateWidget+    void $+      onWidgetRealize label $+        runReaderT getDisplayBatteryInfo ctx >>= updateWidget     toWidget =<< channelWidgetNew label chan updateWidget  themeLoadFlags :: [IconLookupFlags] themeLoadFlags = [IconLookupFlagsGenericFallback, IconLookupFlagsUseBuiltin] +-- | Create an icon-only battery widget using the battery icon name from UPower. batteryIconNew :: TaffyIO Widget batteryIconNew = do   chan <- getDisplayBatteryChan@@ -165,8 +185,8 @@         iw <- readIORef imageWidgetRef         styleCtx <- widgetGetStyleContext iw         name <- T.pack . batteryIconName <$> runReaderT getDisplayBatteryInfo ctx-        iconThemeLookupIcon defaultTheme name size themeLoadFlags >>=-          traverse (\info -> fst <$> iconInfoLoadSymbolicForContext info styleCtx)+        iconThemeLookupIcon defaultTheme name size themeLoadFlags+          >>= traverse (\info -> fst <$> iconInfoLoadSymbolicForContext info styleCtx)   (imageWidget, updateImage) <- scalingImage setIconForSize OrientationHorizontal   liftIO $ do     writeIORef imageWidgetRef imageWidget
src/System/Taffybar/Widget/BatteryDonut.hs view
@@ -1,6 +1,10 @@ {-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE RecordWildCards   #-}+{-# LANGUAGE RecordWildCards #-}+ -----------------------------------------------------------------------------++-----------------------------------------------------------------------------+ -- | -- Module      : System.Taffybar.Widget.BatteryDonut -- Copyright   : (c) Ivan A. Malison@@ -12,92 +16,97 @@ -- -- 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+  ( 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 Control.Monad+import Control.Monad.IO.Class+import Control.Monad.Trans.Reader+import Data.Default (Default (..))+import Data.IORef+import Data.Int (Int32) 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 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.Battery (textBatteryNew)+import System.Taffybar.Widget.Generic.ChannelWidget+import System.Taffybar.Widget.Util+  ( addClassIfMissing,+    buildIconLabelBox,+    removeClassIfPresent,+    widgetSetClassGI,+  ) 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.+  { -- | Color when charge is high (default: green)+    donutHighColor :: (Double, Double, Double),+    -- | Color when charge is medium (default: yellow)+    donutMediumColor :: (Double, Double, Double),+    -- | Color when charge is low (default: orange)+    donutLowColor :: (Double, Double, Double),+    -- | Color when charge is critical (default: red)+    donutCriticalColor :: (Double, Double, Double),+    -- | Background ring color (default: dim gray)+    donutBackgroundColor :: (Double, Double, Double),+    -- | Percentage above which color is "high" (default: 60)+    donutHighThreshold :: Double,+    -- | Percentage above which color is "medium" (default: 30)+    donutMediumThreshold :: Double,+    -- | Percentage below which color is "critical" (default: 10)+    donutCriticalThreshold :: Double,+    -- | Requested widget size in pixels (default: 24)+    donutSize :: Int32,+    -- | Optional override color when charging (default: Nothing)+    donutChargingColor :: Maybe (Double, Double, Double),+    -- | 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$%"@)+    donutLabelFormat :: String   }  -- | 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$%"-  }+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 =+donutColorForLevel BatteryDonutConfig {..} pct state =   case (state, donutChargingColor) of     (BatteryStateCharging, Just color) -> color-    _ | pct >= donutHighThreshold     -> donutHighColor-      | pct >= donutMediumThreshold   -> donutMediumColor+    _+      | pct >= donutHighThreshold -> donutHighColor+      | pct >= donutMediumThreshold -> donutMediumColor       | pct >= donutCriticalThreshold -> donutLowColor-      | otherwise                     -> donutCriticalColor+      | otherwise -> donutCriticalColor  -- | Render the donut arc for the battery. renderDonut :: BatteryDonutConfig -> Double -> BatteryState -> Int -> Int -> C.Render ()@@ -132,24 +141,30 @@   (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+    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 "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+  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@@ -182,8 +197,9 @@           setDonutBatteryClasses cfg drawArea info           widgetQueueDraw drawArea -    void $ onWidgetRealize drawArea $-      runReaderT getDisplayBatteryInfo ctx >>= updateWidget+    void $+      onWidgetRealize drawArea $+        runReaderT getDisplayBatteryInfo ctx >>= updateWidget      toWidget =<< channelWidgetNew drawArea chan updateWidget
src/System/Taffybar/Widget/BatteryTextIcon.hs view
@@ -1,5 +1,9 @@ {-# LANGUAGE OverloadedStrings #-}+ -----------------------------------------------------------------------------++-----------------------------------------------------------------------------+ -- | -- Module      : System.Taffybar.Widget.BatteryTextIcon -- Copyright   : (c) Ivan A. Malison@@ -13,70 +17,71 @@ -- 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+  ( batteryTextIconNew,+    batteryTextIconNewWith,+    BatteryTextIconConfig (..),+    defaultBatteryTextIconConfig,+  )+where -import           Control.Monad-import           Control.Monad.IO.Class-import           Control.Monad.Trans.Reader-import           Data.Default (Default(..))+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)+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]+    batteryTextIconDischarging :: [T.Text],     -- | Glyphs to use when charging, ordered from empty (0%) to full (100%).     -- Must have at least one element.-  , batteryTextIconCharging :: [T.Text]+    batteryTextIconCharging :: [T.Text],     -- | Glyph to use when fully charged / on AC with no discharge.-  , batteryTextIconFull :: T.Text+    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-  }+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@@ -87,7 +92,7 @@ selectGlyph glyphs pct =   let n = length glyphs       idx = min (n - 1) $ floor (pct / 100.0 * fromIntegral n)-  in glyphs !! max 0 idx+   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@@ -114,11 +119,13 @@                   selectGlyph (batteryTextIconCharging config) pct                 BatteryStateDischarging ->                   selectGlyph (batteryTextIconDischarging config) pct-                _ | pct >= 99 -> batteryTextIconFull config+                _+                  | pct >= 99 -> batteryTextIconFull config                   | otherwise ->-                    selectGlyph (batteryTextIconDischarging config) pct+                      selectGlyph (batteryTextIconDischarging config) pct           labelSetLabel label glyph           setBatteryStateClasses def label info-    void $ onWidgetRealize label $-         runReaderT getDisplayBatteryInfo ctx >>= updateWidget+    void $+      onWidgetRealize label $+        runReaderT getDisplayBatteryInfo ctx >>= updateWidget     toWidget =<< channelWidgetNew label chan updateWidget
src/System/Taffybar/Widget/Bluetooth.hs view
@@ -1,5 +1,9 @@ {-# LANGUAGE OverloadedStrings #-}+ -----------------------------------------------------------------------------++-----------------------------------------------------------------------------+ -- | -- Module      : System.Taffybar.Widget.Bluetooth -- Copyright   : (c) Ivan A. Malison@@ -14,21 +18,21 @@ -- -- 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+  ( BluetoothWidgetConfig (..),+    defaultBluetoothWidgetConfig,+    bluetoothIconNew,+    bluetoothIconNewWith,+    bluetoothLabelNew,+    bluetoothLabelNewWith,+    bluetoothNew,+    bluetoothNewWith,+  )+where  import Control.Monad (void) import Control.Monad.IO.Class-import Data.Default (Default(..))+import Data.Default (Default (..)) import Data.List (intercalate) import qualified Data.Text as T import qualified GI.GLib as G@@ -42,45 +46,48 @@  -- | Configuration for the Bluetooth widget. data BluetoothWidgetConfig = BluetoothWidgetConfig-  { -- | Format string when Bluetooth is connected.+  { -- \$num_connections$, $controller_alias$++    -- | Format string when Bluetooth is connected.     -- Available variables: $status$, $device_alias$, $device_battery$,-    -- $num_connections$, $controller_alias$-    bluetoothFormatConnected :: String+    bluetoothFormatConnected :: String,     -- | Format string when Bluetooth is on but not connected.-  , bluetoothFormatOn :: String+    bluetoothFormatOn :: String,     -- | Format string when Bluetooth is off (powered down).-  , bluetoothFormatOff :: String+    bluetoothFormatOff :: String,     -- | Format string when no Bluetooth controller is found.-  , bluetoothFormatNoController :: String+    bluetoothFormatNoController :: String,     -- | Optional tooltip format.     -- Additional variable: $device_list$-  , bluetoothTooltipFormat :: Maybe String+    bluetoothTooltipFormat :: Maybe String,     -- | Format for each device in the tooltip device list.     -- Variables: $device_alias$, $device_battery$-  , bluetoothDeviceListFormat :: String+    bluetoothDeviceListFormat :: String,     -- | Icon to display when Bluetooth is connected.-  , bluetoothConnectedIcon :: T.Text+    bluetoothConnectedIcon :: T.Text,     -- | Icon to display when Bluetooth is on but not connected.-  , bluetoothOnIcon :: T.Text+    bluetoothOnIcon :: T.Text,     -- | Icon to display when Bluetooth is off (powered down).-  , bluetoothOffIcon :: T.Text+    bluetoothOffIcon :: T.Text,     -- | Icon to display when no Bluetooth controller is found.-  , bluetoothNoControllerIcon :: T.Text+    bluetoothNoControllerIcon :: T.Text   } +-- | Default Bluetooth widget configuration. 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"-  }+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@@ -193,7 +200,7 @@       -- Get the first connected device for primary display       primaryDevice = case bluetoothConnectedDevices info of         [] -> Nothing-        (d:_) -> Just d+        (d : _) -> Just d        deviceAliasText = maybe "" deviceAlias primaryDevice       deviceBatteryText = maybe "?" (maybe "?" show . deviceBatteryPercentage) primaryDevice@@ -201,12 +208,13 @@       controllerAliasText = maybe "none" controllerAlias (bluetoothController info)        -- Build device list for tooltip-      deviceListText = intercalate "\n" $-        map formatDeviceEntry (bluetoothConnectedDevices info)+      deviceListText =+        intercalate "\n" $+          map formatDeviceEntry (bluetoothConnectedDevices info)        formatDeviceEntry dev =         let battery = maybe "?" show (deviceBatteryPercentage dev)-        in deviceAlias dev ++ " (" ++ battery ++ "%)"+         in deviceAlias dev ++ " (" ++ battery ++ "%)"    status <- escapeText $ T.pack statusText   deviceAliasEsc <- escapeText $ T.pack deviceAliasText@@ -215,12 +223,12 @@   deviceListEsc <- escapeText $ T.pack deviceListText    return-    [ ("status", status)-    , ("device_alias", deviceAliasEsc)-    , ("device_battery", deviceBatteryEsc)-    , ("num_connections", show numConnections)-    , ("controller_alias", controllerAliasEsc)-    , ("device_list", deviceListEsc)+    [ ("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.
src/System/Taffybar/Widget/CPUMonitor.hs view
@@ -1,4 +1,9 @@+{-# LANGUAGE OverloadedStrings #-}+ --------------------------------------------------------------------------------++--------------------------------------------------------------------------------+ -- | -- Module      : System.Taffybar.Widget.CPUMonitor -- Copyright   : (c) José A. Romero L.@@ -8,36 +13,34 @@ -- Stability   : unstable -- Portability : unportable ----- Simple CPU monitor that uses a PollingGraph to visualize variations in the--- user and system CPU times in one selected core, or in all cores available.------------------------------------------------------------------------------------+-- Simple CPU monitor that uses a channel-driven graph to visualize variations+-- in the user and system CPU times in one selected core, or in all cores+-- available. module System.Taffybar.Widget.CPUMonitor where  import Control.Monad.IO.Class-import Data.IORef import qualified GI.Gtk-import System.Taffybar.Information.CPU2 (getCPUInfo)-import System.Taffybar.Information.StreamInfo (getAccLoad)-import System.Taffybar.Widget.Generic.PollingGraph+import System.Taffybar.Information.CPU2 (CPULoad (..), getCPULoadChan)+import System.Taffybar.Widget.Generic.ChannelGraph+import System.Taffybar.Widget.Generic.Graph+import System.Taffybar.Widget.Util (widgetSetClassGI) --- | Creates a new CPU monitor. This is a PollingGraph fed by regular calls to--- getCPUInfo, associated to an IORef used to remember the values yielded by the--- last call to this function.-cpuMonitorNew-  :: MonadIO m-  => GraphConfig -- ^ Configuration data for the Graph.-  -> Double -- ^ Polling period (in seconds).-  -> String -- ^ Name of the core to watch (e.g. \"cpu\", \"cpu0\").-  -> m GI.Gtk.Widget+-- | Creates a new CPU monitor. This is a channel-driven graph fed by CPU load+-- samples for one core (or all cores when "cpu" is selected).+cpuMonitorNew ::+  (MonadIO m) =>+  -- | Configuration data for the Graph.+  GraphConfig ->+  -- | Polling period (in seconds).+  Double ->+  -- | Name of the core to watch (e.g. \"cpu\", \"cpu0\").+  String ->+  m GI.Gtk.Widget cpuMonitorNew cfg interval cpu = liftIO $ do-    info <- getCPUInfo cpu-    sample <- newIORef info-    pollingGraphNew cfg interval $ probe sample cpu+  chan <- getCPULoadChan cpu interval+  channelGraphNew cfg chan toSample+    >>= (`widgetSetClassGI` "cpu-monitor") -probe :: IORef [Int] -> String -> IO [Double]-probe sample cpuName = do-    load <- getAccLoad sample $ getCPUInfo cpuName-    case load of-      l0:l1:l2:_ -> return [ l0 + l1, l2 ] -- user, system-      _ -> return []+toSample :: CPULoad -> IO [Double]+toSample CPULoad {cpuTotalLoad = totalLoad, cpuSystemLoad = systemLoad} =+  return [totalLoad, systemLoad]
+ src/System/Taffybar/Widget/ChannelWorkspaces.hs view
@@ -0,0 +1,42 @@+-----------------------------------------------------------------------------++-----------------------------------------------------------------------------++-- |+-- Module      : System.Taffybar.Widget.ChannelWorkspaces+-- Copyright   : (c) Ivan A. Malison+-- License     : BSD3-style (see LICENSE)+--+-- Maintainer  : Ivan A. Malison+-- Stability   : unstable+-- Portability : unportable+--+-- Transitional, prefixed exports for the channel-driven Workspaces widget.+--+-- The canonical API lives in "System.Taffybar.Widget.Workspaces"+-- (with names like 'workspacesNew'). This module provides prefixed aliases so+-- "System.Taffybar.Widget" can expose the new widget without colliding with+-- legacy workspace exports.+module System.Taffybar.Widget.ChannelWorkspaces+  {-# DEPRECATED "Use System.Taffybar.Widget.Workspaces instead." #-}+  ( ChannelWorkspacesConfig,+    defaultChannelWorkspacesConfig,+    defaultChannelEWMHWorkspacesConfig,+    channelWorkspacesNew,+  )+where++import qualified GI.Gtk as Gtk+import System.Taffybar.Context (TaffyIO)+import qualified System.Taffybar.Widget.Workspaces as Channel++type ChannelWorkspacesConfig = Channel.WorkspacesConfig++defaultChannelWorkspacesConfig :: ChannelWorkspacesConfig+defaultChannelWorkspacesConfig = Channel.defaultWorkspacesConfig++defaultChannelEWMHWorkspacesConfig :: ChannelWorkspacesConfig+defaultChannelEWMHWorkspacesConfig = Channel.defaultEWMHWorkspacesConfig++channelWorkspacesNew :: ChannelWorkspacesConfig -> TaffyIO Gtk.Widget+channelWorkspacesNew = Channel.workspacesNew
src/System/Taffybar/Widget/CommandRunner.hs view
@@ -1,5 +1,9 @@ {-# LANGUAGE OverloadedStrings #-}+ --------------------------------------------------------------------------------++--------------------------------------------------------------------------------+ -- | -- Module      : System.Taffybar.Widget.CommandRunner -- Copyright   : (c) Arseniy Seroka@@ -11,34 +15,42 @@ -- -- Simple function which runs user defined command and -- returns it's output in PollingLabel widget-----------------------------------------------------------------------------------module System.Taffybar.Widget.CommandRunner ( commandRunnerNew ) where+module System.Taffybar.Widget.CommandRunner (commandRunnerNew) where -import           Control.Monad.IO.Class-import qualified GI.Gtk-import           System.Log.Logger-import           System.Taffybar.Util-import           System.Taffybar.Widget.Generic.PollingLabel-import           Text.Printf+import Control.Monad.IO.Class import qualified Data.Text as T+import qualified GI.Gtk+import System.Log.Logger+import System.Taffybar.Util+import System.Taffybar.Widget.Generic.PollingLabel+import System.Taffybar.Widget.Util (widgetSetClassGI)+import Text.Printf  -- | Creates a new command runner widget. This is a 'PollingLabel' fed by -- regular calls to command given by argument. The results of calling this -- function are displayed as string.-commandRunnerNew-  :: MonadIO m-  => Double -- ^ Polling period (in seconds).-  -> String -- ^ Command to execute. Should be in $PATH or an absolute path-  -> [String] -- ^ Command argument. May be @[]@-  -> T.Text -- ^ If command fails this will be displayed.-  -> m GI.Gtk.Widget+commandRunnerNew ::+  (MonadIO m) =>+  -- | Polling period (in seconds).+  Double ->+  -- | Command to execute. Should be in $PATH or an absolute path+  String ->+  -- | Command argument. May be @[]@+  [String] ->+  -- | If command fails this will be displayed.+  T.Text ->+  m GI.Gtk.Widget commandRunnerNew interval cmd args defaultOutput =-  pollingLabelNew interval $ runCommandWithDefault cmd args defaultOutput+  pollingLabelNew interval (runCommandWithDefault cmd args defaultOutput)+    >>= (`widgetSetClassGI` "command-runner")  runCommandWithDefault :: FilePath -> [String] -> T.Text -> IO T.Text runCommandWithDefault cmd args def =   T.filter (/= '\n') <$> (runCommand cmd args >>= either logError (return . T.pack))-  where logError err =-          logM "System.Taffybar.Widget.CommandRunner" ERROR-               (printf "Got error in CommandRunner %s" err) >> return def+  where+    logError err =+      logM+        "System.Taffybar.Widget.CommandRunner"+        ERROR+        (printf "Got error in CommandRunner %s" err)+        >> return def
src/System/Taffybar/Widget/Crypto.hs view
@@ -1,9 +1,13 @@-{-# LANGUAGE TypeApplications #-}-{-# LANGUAGE DataKinds #-}-{-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE AllowAmbiguousTypes #-}+{-# LANGUAGE DataKinds #-} {-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeApplications #-}+ -----------------------------------------------------------------------------++-----------------------------------------------------------------------------+ -- | -- Module      : System.Taffybar.Widget.Crypto -- Copyright   : (c) Ivan A. Malison@@ -15,34 +19,34 @@ -- -- This module provides widgets for tracking the price of crypto currency -- assets.------------------------------------------------------------------------------ module System.Taffybar.Widget.Crypto where -import           Control.Concurrent-import           Control.Monad-import           Control.Monad.IO.Class-import           Control.Monad.Trans.Class-import           Control.Monad.Trans.Maybe-import           Control.Monad.Trans.Reader-import           Data.Aeson-import           Data.Aeson.Types+import Control.Concurrent+import Control.Monad+import Control.Monad.IO.Class+import Control.Monad.Trans.Class+import Control.Monad.Trans.Maybe+import Control.Monad.Trans.Reader+import Data.Aeson import qualified Data.Aeson.Key as Key+import Data.Aeson.Types import qualified Data.ByteString.Lazy as LBS-import           Data.Maybe-import           Data.Proxy+import Data.Maybe+import Data.Proxy import qualified Data.Text-import           GHC.TypeLits+import GHC.TypeLits import qualified GI.GdkPixbuf.Objects.Pixbuf as Gdk import qualified GI.Gtk as Gtk-import           Network.HTTP.Simple hiding (Proxy)-import           System.FilePath.Posix-import           System.Taffybar.Context-import           System.Taffybar.Information.Crypto hiding (symbol)-import           System.Taffybar.Util-import           System.Taffybar.Widget.Generic.ChannelWidget-import           System.Taffybar.Widget.Generic.ScalingImage (scalingImage)-import           System.Taffybar.WindowIcon-import           Text.Printf+import Network.HTTP.Simple hiding (Proxy)+import System.FilePath.Posix+import System.Taffybar.Context+import System.Taffybar.Information.Crypto hiding (symbol)+import System.Taffybar.Util+import System.Taffybar.Widget.Generic.ChannelWidget+import System.Taffybar.Widget.Generic.ScalingImage (scalingImage)+import System.Taffybar.Widget.Util (buildIconLabelBox, widgetSetClassGI)+import System.Taffybar.WindowIcon+import Text.Printf  -- | Extends 'cryptoPriceLabel' with an icon corresponding to the symbol of the -- purchase crypto that will appear to the left of the price label. See the@@ -53,26 +57,25 @@ -- symbol of the relevant token and the underlying currency in which its price -- should be expressed. See the docstring of 'cryptoPriceLabel' for details -- about the exact format that this string should take.-cryptoPriceLabelWithIcon :: forall a. KnownSymbol a => TaffyIO Gtk.Widget+cryptoPriceLabelWithIcon :: forall a. (KnownSymbol a) => TaffyIO Gtk.Widget cryptoPriceLabelWithIcon = do   label <- cryptoPriceLabel @a   let symbolPair = symbolVal (Proxy :: Proxy a)       symbol = takeWhile (/= '-') symbolPair-  hbox <- Gtk.boxNew Gtk.OrientationHorizontal 0    ctx <- ask   let refresh size =-        Just <$> runReaderT-        (fromMaybe <$> pixBufFromColor size 0 <*> getCryptoPixbuf symbol) ctx+        Just+          <$> runReaderT+            (fromMaybe <$> pixBufFromColor size 0 <*> getCryptoPixbuf symbol)+            ctx   (image, _) <- scalingImage refresh Gtk.OrientationHorizontal--  Gtk.containerAdd hbox image-  Gtk.containerAdd hbox label--  Gtk.widgetShowAll hbox--  Gtk.toWidget hbox+  _ <- widgetSetClassGI image "crypto-price-icon"+  _ <- widgetSetClassGI label "crypto-price-label"+  buildIconLabelBox image label+    >>= (`widgetSetClassGI` "crypto-price") +-- | Stored CoinMarketCap API key used for on-demand icon fetches. newtype CMCAPIKey = CMCAPIKey String  -- | Set the coinmarketcap.com api key that will be used for retrieving crypto@@ -92,22 +95,30 @@ -- associated with the asset that you want to track as follows: -- -- > cryptoPriceLabel @"BTC-USD"-cryptoPriceLabel :: forall a. KnownSymbol a => TaffyIO Gtk.Widget+cryptoPriceLabel :: forall a. (KnownSymbol a) => TaffyIO Gtk.Widget cryptoPriceLabel = getCryptoPriceChannel @a >>= cryptoPriceLabel' +-- | Build a crypto price label from an existing price channel. cryptoPriceLabel' :: CryptoPriceChannel a -> TaffyIO Gtk.Widget cryptoPriceLabel' (CryptoPriceChannel (chan, var)) = do   label <- Gtk.labelNew Nothing-  let updateWidget CryptoPriceInfo { lastPrice = cryptoPrice } =-        postGUIASync $ Gtk.labelSetMarkup label $-                     Data.Text.pack $ show cryptoPrice-  void $ Gtk.onWidgetRealize label $-       readMVar var >>= updateWidget-  Gtk.toWidget =<< channelWidgetNew label chan updateWidget+  _ <- widgetSetClassGI label "crypto-price-label"+  let updateWidget CryptoPriceInfo {lastPrice = cryptoPrice} =+        postGUIASync $+          Gtk.labelSetMarkup label $+            Data.Text.pack $+              show cryptoPrice+  void $+    Gtk.onWidgetRealize label $+      readMVar var >>= updateWidget+  (Gtk.toWidget =<< channelWidgetNew label chan updateWidget)+    >>= (`widgetSetClassGI` "crypto-price-label") +-- | Directory used to cache downloaded crypto icons. cryptoIconsDir :: IO FilePath cryptoIconsDir = (</> "crypto_icons") <$> taffyStateDir +-- | Cache path for a specific crypto symbol icon. pathForCryptoSymbol :: String -> IO FilePath pathForCryptoSymbol symbol =   (</> printf "%s.png" symbol) <$> cryptoIconsDir@@ -120,16 +131,20 @@ getCryptoPixbuf :: String -> TaffyIO (Maybe Gdk.Pixbuf) getCryptoPixbuf = getCryptoIconFromCache <||> getCryptoIconFromCMC -getCryptoIconFromCache :: MonadIO m => String -> m (Maybe Gdk.Pixbuf)-getCryptoIconFromCache symbol = liftIO $-  pathForCryptoSymbol symbol >>= safePixbufNewFromFile+-- | Try to load a cached icon for a symbol from disk.+getCryptoIconFromCache :: (MonadIO m) => String -> m (Maybe Gdk.Pixbuf)+getCryptoIconFromCache symbol =+  liftIO $+    pathForCryptoSymbol symbol >>= safePixbufNewFromFile +-- | Try to fetch an icon via CoinMarketCap using the configured API key. getCryptoIconFromCMC :: String -> TaffyIO (Maybe Gdk.Pixbuf) getCryptoIconFromCMC symbol =   runMaybeT $ do     CMCAPIKey cmcAPIKey <- MaybeT getState     MaybeT $ lift $ getCryptoIconFromCMC' cmcAPIKey symbol +-- | Fetch a symbol icon from CoinMarketCap metadata and cache it to disk. getCryptoIconFromCMC' :: String -> String -> IO (Maybe Gdk.Pixbuf) getCryptoIconFromCMC' cmcAPIKey symbol = do   jsonText <- getCryptoMeta cmcAPIKey symbol@@ -138,7 +153,9 @@   maybe (return ()) (`downloadURIToPath` path) uri   safePixbufNewFromFile path +-- | Extract the logo URI for a symbol from CoinMarketCap metadata JSON. getIconURIFromJSON :: String -> LBS.ByteString -> Maybe Data.Text.Text getIconURIFromJSON symbol jsonText =-  decode jsonText >>= parseMaybe-           ((.: "data") >=> (.: Key.fromString symbol) >=> (.: "logo"))+  decode jsonText+    >>= parseMaybe+      ((.: "data") >=> (.: Key.fromString symbol) >=> (.: "logo"))
src/System/Taffybar/Widget/DiskIOMonitor.hs view
@@ -1,4 +1,9 @@+{-# LANGUAGE OverloadedStrings #-}+ --------------------------------------------------------------------------------++--------------------------------------------------------------------------------+ -- | -- Module      : System.Taffybar.Widget.DiskIOMonitor -- Copyright   : (c) José A. Romero L.@@ -10,31 +15,32 @@ -- -- Simple Disk IO monitor that uses a PollingGraph to visualize the speed of -- read/write operations in one selected disk or partition.--------------------------------------------------------------------------------------module System.Taffybar.Widget.DiskIOMonitor ( dioMonitorNew ) where+module System.Taffybar.Widget.DiskIOMonitor (dioMonitorNew) where -import           Control.Monad.IO.Class import qualified GI.Gtk-import           System.Taffybar.Information.DiskIO ( getDiskTransfer )-import           System.Taffybar.Widget.Generic.PollingGraph ( GraphConfig, pollingGraphNew )+import System.Taffybar.Context (TaffyIO)+import System.Taffybar.Information.DiskIO (getDiskTransfer)+import System.Taffybar.Widget.Generic.PollingGraph (GraphConfig, pollingGraphNew)+import System.Taffybar.Widget.Util (widgetSetClassGI)  -- | Creates a new disk IO monitor widget. This is a 'PollingGraph' fed by -- regular calls to 'getDiskTransfer'. The results of calling this function -- are normalized to the maximum value of the obtained probe (either read or -- write transfer).-dioMonitorNew-  :: MonadIO m-  => GraphConfig -- ^ Configuration data for the Graph.-  -> Double -- ^ Polling period (in seconds).-  -> String -- ^ Name of the disk or partition to watch (e.g. \"sda\", \"sdb1\").-  -> m GI.Gtk.Widget-dioMonitorNew cfg pollSeconds =-  pollingGraphNew cfg pollSeconds . probeDisk+dioMonitorNew ::+  -- | Configuration data for the Graph.+  GraphConfig ->+  -- | Polling period (in seconds).+  Double ->+  -- | Name of the disk or partition to watch (e.g. \"sda\", \"sdb1\").+  String ->+  TaffyIO GI.Gtk.Widget+dioMonitorNew cfg pollSeconds disk = do+  widget <- pollingGraphNew cfg pollSeconds (probeDisk disk)+  widgetSetClassGI widget "disk-io-monitor"  probeDisk :: String -> IO [Double] probeDisk disk = do   transfer <- getDiskTransfer disk   let top = foldr max 1.0 transfer-  return $ map (/top) transfer+  return $ map (/ top) transfer
src/System/Taffybar/Widget/DiskUsage.hs view
@@ -1,5 +1,9 @@ {-# LANGUAGE OverloadedStrings #-}+ -----------------------------------------------------------------------------++-----------------------------------------------------------------------------+ -- | -- Module      : System.Taffybar.Widget.DiskUsage -- Copyright   : (c) Ivan A. Malison@@ -14,56 +18,60 @@ -- -- Template variables: @$total$@, @$used$@, @$free$@, @$available$@, -- @$usedPercent$@, @$freePercent$@, @$path$@.+-- @$free$@ and @$available$@ both report space available to unprivileged users+-- (the @Avail@ value from @df@). -- -- 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+  ( DiskUsageWidgetConfig (..),+    defaultDiskUsageWidgetConfig,+    diskUsageIconNew,+    diskUsageIconNewWith,+    diskUsageLabelNew,+    diskUsageLabelNewWith,+    diskUsageNew,+    diskUsageNewWith,+  )+where  import Control.Monad (void) import Control.Monad.IO.Class-import Data.Default (Default(..))+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 System.Taffybar.Widget.Util (buildIconLabelBox, widgetSetClassGI) import Text.Printf (printf) import Text.StringTemplate +-- | Configuration for disk usage widgets. 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, ).+  { -- | Filesystem path to monitor (default @\/@).+    diskUsagePath :: FilePath,+    -- | Polling interval in seconds (default 60).+    diskUsagePollInterval :: Double,+    -- | Label format string (default @\"$free$\"@).+    diskUsageFormat :: String,+    -- | Optional tooltip format string.+    diskUsageTooltipFormat :: Maybe String,+    -- | Nerd font icon character (default U+F0A0, ).+    diskUsageIcon :: T.Text   } +-- | Default disk usage widget configuration. defaultDiskUsageWidgetConfig :: DiskUsageWidgetConfig-defaultDiskUsageWidgetConfig = DiskUsageWidgetConfig-  { diskUsagePath         = "/"-  , diskUsagePollInterval = 60-  , diskUsageFormat       = "$free$"-  , diskUsageTooltipFormat =-      Just "$path$: $used$ / $total$ ($usedPercent$% used)"-  , diskUsageIcon = T.pack "\xF0A0" ---  }+defaultDiskUsageWidgetConfig =+  DiskUsageWidgetConfig+    { diskUsagePath = "/",+      diskUsagePollInterval = 60,+      diskUsageFormat = "$free$",+      diskUsageTooltipFormat =+        Just "$path$: $used$ / $total$ ($usedPercent$% used)",+      diskUsageIcon = T.pack "\xF0A0" --+    }  instance Default DiskUsageWidgetConfig where   def = defaultDiskUsageWidgetConfig@@ -75,13 +83,14 @@ -- | Create a disk usage label with the given configuration. diskUsageLabelNewWith :: DiskUsageWidgetConfig -> TaffyIO Gtk.Widget diskUsageLabelNewWith config = do-  let path     = diskUsagePath config+  let path = diskUsagePath config       interval = diskUsagePollInterval config-  chan        <- getDiskUsageInfoChan interval path+  chan <- getDiskUsageInfoChan interval path   initialInfo <- getDiskUsageInfoState interval path    liftIO $ do     label <- Gtk.labelNew Nothing+    _ <- widgetSetClassGI label "disk-usage-label"      let updateLabel info = postGUIASync $ do           let (labelText, tooltipText) = formatDiskUsage config info@@ -90,7 +99,8 @@      void $ Gtk.onWidgetRealize label $ updateLabel initialInfo     Gtk.widgetShowAll label-    Gtk.toWidget =<< channelWidgetNew label chan updateLabel+    (Gtk.toWidget =<< channelWidgetNew label chan updateLabel)+      >>= (`widgetSetClassGI` "disk-usage-label")  -- | Create a disk usage icon widget with default configuration. diskUsageIconNew :: TaffyIO Gtk.Widget@@ -100,6 +110,7 @@ diskUsageIconNewWith :: DiskUsageWidgetConfig -> TaffyIO Gtk.Widget diskUsageIconNewWith config = liftIO $ do   label <- Gtk.labelNew (Just (diskUsageIcon config))+  _ <- widgetSetClassGI label "disk-usage-icon"   Gtk.widgetShowAll label   Gtk.toWidget label @@ -112,7 +123,9 @@ diskUsageNewWith config = do   iconWidget <- diskUsageIconNewWith config   labelWidget <- diskUsageLabelNewWith config-  liftIO $ buildIconLabelBox iconWidget labelWidget+  liftIO $+    buildIconLabelBox iconWidget labelWidget+      >>= (`widgetSetClassGI` "disk-usage")  -- -------------------------------------------------------------------------- -- Formatting@@ -120,9 +133,9 @@ formatDiskUsage :: DiskUsageWidgetConfig -> DiskUsageInfo -> (T.Text, Maybe T.Text) formatDiskUsage config info =   let attrs = diskUsageAttrs (diskUsagePath config) info-      labelText   = renderTpl (diskUsageFormat config) attrs+      labelText = renderTpl (diskUsageFormat config) attrs       tooltipText = renderTpl <$> diskUsageTooltipFormat config <*> pure attrs-  in (labelText, tooltipText)+   in (labelText, tooltipText)  renderTpl :: String -> [(String, String)] -> T.Text renderTpl template attrs =@@ -130,23 +143,24 @@  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)+  [ ("total", formatBytes (diskInfoTotal info)),+    ("used", formatBytes (diskInfoUsed info)),+    -- Prefer user-available blocks for the primary "free" template variable.+    ("free", formatBytes (diskInfoAvailable 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+  | gb >= 1 = printf "%.1f GiB" gb+  | mb >= 1 = printf "%.0f MiB" mb+  | otherwise = printf "%.0f KiB" kb   where-    kb = fromIntegral bytes / 1024        :: Double+    kb = fromIntegral bytes / 1024 :: Double     mb = kb / 1024     gb = mb / 1024
src/System/Taffybar/Widget/FSMonitor.hs view
@@ -1,5 +1,9 @@ {-# LANGUAGE OverloadedStrings #-}+ -----------------------------------------------------------------------------++-----------------------------------------------------------------------------+ -- | -- Module      : System.Taffybar.Widget.FSMonitor -- Copyright   : (c) José A. Romero L.@@ -12,32 +16,33 @@ -- Simple text widget that monitors the current usage of selected disk -- partitions by regularly parsing the output of the df command in Linux -- systems.-----------------------------------------------------------------------------------module System.Taffybar.Widget.FSMonitor ( fsMonitorNew ) where+module System.Taffybar.Widget.FSMonitor (fsMonitorNew) where -import           Control.Monad.IO.Class-import qualified GI.Gtk-import           System.Process ( readProcess )-import           System.Taffybar.Widget.Generic.PollingLabel ( pollingLabelNew )+import Control.Monad.IO.Class import qualified Data.Text as T+import qualified GI.Gtk+import System.Process (readProcess)+import System.Taffybar.Widget.Generic.PollingLabel (pollingLabelNew)+import System.Taffybar.Widget.Util (widgetSetClassGI)  -- | Creates a new filesystem monitor widget. It contains one 'PollingLabel' -- that displays the data returned by the df command. The usage level of all -- requested partitions is extracted in one single operation.-fsMonitorNew-  :: MonadIO m-  => Double -- ^ Polling interval (in seconds, e.g. 500)-  -> [String] -- ^ Names of the partitions to monitor (e.g. [\"\/\", \"\/home\"])-  -> m GI.Gtk.Widget+fsMonitorNew ::+  (MonadIO m) =>+  -- | Polling interval (in seconds, e.g. 500)+  Double ->+  -- | Names of the partitions to monitor (e.g. [\"\/\", \"\/home\"])+  [String] ->+  m GI.Gtk.Widget fsMonitorNew interval fsList = liftIO $ do-  label <- pollingLabelNew interval $ showFSInfo fsList+  label <- pollingLabelNew interval (showFSInfo fsList)+  _ <- widgetSetClassGI label "fs-monitor"   GI.Gtk.widgetShowAll label   GI.Gtk.toWidget label  showFSInfo :: [String] -> IO T.Text showFSInfo fsList = do-  fsOut <- readProcess "df" ("-kP":fsList) ""+  fsOut <- readProcess "df" ("-kP" : fsList) ""   let fss = map (take 2 . reverse . words) $ drop 1 $ lines fsOut   return $ T.pack $ unwords $ map ((\s -> "[" ++ s ++ "]") . unwords) fss
src/System/Taffybar/Widget/FreedesktopNotifications.hs view
@@ -2,6 +2,7 @@ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE ScopedTypeVariables #-}+ -- | This widget listens on DBus for freedesktop notifications -- (<http://developer.gnome.org/notification-spec/>).  Currently it is -- somewhat ugly, but the format is somewhat configurable.@@ -19,51 +20,57 @@ -- A timeout thread is associated with a notification id. -- It sleeps until the specific timeout and then removes every notification -- with that id from the queue- module System.Taffybar.Widget.FreedesktopNotifications-  ( Notification(..)-  , NotificationConfig(..)-  , defaultNotificationConfig-  , notifyAreaNew-  ) where+  ( Notification (..),+    NotificationConfig (..),+    defaultNotificationConfig,+    notifyAreaNew,+  )+where -import           Control.Concurrent-import           Control.Concurrent.STM-import           Control.Monad ( forever, void )-import           Control.Monad.IO.Class-import           DBus-import           DBus.Client-import           Data.Default ( Default(..) )-import           Data.Foldable-import           Data.Int ( Int32 )-import           Data.Map ( Map )-import           Data.Sequence ( Seq, (|>), viewl, ViewL(..) )+import Control.Concurrent+import Control.Concurrent.STM+import Control.Monad (forever, void)+import Control.Monad.IO.Class+import DBus+import DBus.Client+import Data.Default (Default (..))+import Data.Foldable+import Data.Int (Int32)+import Data.Map (Map)+import Data.Sequence (Seq, ViewL (..), viewl, (|>)) import qualified Data.Sequence as S-import           Data.Text ( Text )+import Data.Text (Text) import qualified Data.Text as T-import           Data.Word ( Word32 )-import           GI.GLib (markupEscapeText)-import           GI.Gtk+import Data.Word (Word32)+import GI.GLib (markupEscapeText)+import GI.Gtk import qualified GI.Pango as Pango-import           System.Taffybar.Util+import System.Taffybar.Util+import System.Taffybar.Widget.Util (widgetSetClassGI)  -- | A simple structure representing a Freedesktop notification data Notification = Notification-  { noteAppName :: Text-  , noteReplaceId :: Word32-  , noteSummary :: Text-  , noteBody :: Text-  , noteExpireTimeout :: Maybe Int32-  , noteId :: Word32-  } deriving (Show, Eq)+  { noteAppName :: Text,+    noteReplaceId :: Word32,+    noteSummary :: Text,+    noteBody :: Text,+    noteExpireTimeout :: Maybe Int32,+    noteId :: Word32+  }+  deriving (Show, Eq)  data NotifyState = NotifyState-  { noteWidget :: Label-  , noteContainer :: Widget-  , noteConfig :: NotificationConfig -- ^ The associated configuration-  , noteQueue :: TVar (Seq Notification) -- ^ The queue of active notifications-  , noteIdSource :: TVar Word32 -- ^ A source of fresh notification ids-  , noteChan :: TChan () -- ^ Writing to this channel wakes up the display thread+  { noteWidget :: Label,+    noteContainer :: Widget,+    -- | The associated configuration+    noteConfig :: NotificationConfig,+    -- | The queue of active notifications+    noteQueue :: TVar (Seq Notification),+    -- | A source of fresh notification ids+    noteIdSource :: TVar Word32,+    -- | Writing to this channel wakes up the display thread+    noteChan :: TChan ()   }  initialNoteState :: Widget -> Label -> NotificationConfig -> IO NotifyState@@ -71,18 +78,21 @@   m <- newTVarIO 1   q <- newTVarIO S.empty   ch <- newBroadcastTChanIO-  return NotifyState { noteQueue = q-                     , noteIdSource = m-                     , noteWidget = l-                     , noteContainer = wrapper-                     , noteConfig = cfg-                     , noteChan = ch-                     }+  return+    NotifyState+      { noteQueue = q,+        noteIdSource = m,+        noteWidget = l,+        noteContainer = wrapper,+        noteConfig = cfg,+        noteChan = ch+      }  -- | Removes every notification with id 'nId' from the queue notePurge :: NotifyState -> Word32 -> IO ()-notePurge s nId = atomically . modifyTVar' (noteQueue s) $-  S.filter ((nId /=) . noteId)+notePurge s nId =+  atomically . modifyTVar' (noteQueue s) $+    S.filter ((nId /=) . noteId)  -- | Removes the first (oldest) notification from the queue noteNext :: NotifyState -> IO ()@@ -94,41 +104,54 @@  -- | Generates a fresh notification id noteFreshId :: NotifyState -> IO Word32-noteFreshId NotifyState { noteIdSource } = atomically $ do+noteFreshId NotifyState {noteIdSource} = atomically $ do   nId <- readTVar noteIdSource   writeTVar noteIdSource (succ nId)   return nId  --------------------------------------------------------------------------------+ -- | Handles a new notification-notify :: NotifyState-       -> Text -- ^ Application name-       -> Word32 -- ^ Replaces id-       -> Text -- ^ App icon-       -> Text -- ^ Summary-       -> Text -- ^ Body-       -> [Text] -- ^ Actions-       -> Map Text Variant -- ^ Hints-       -> Int32 -- ^ Expires timeout (milliseconds)-       -> IO Word32+notify ::+  NotifyState ->+  -- | Application name+  Text ->+  -- | Replaces id+  Word32 ->+  -- | App icon+  Text ->+  -- | Summary+  Text ->+  -- | Body+  Text ->+  -- | Actions+  [Text] ->+  -- | Hints+  Map Text Variant ->+  -- | Expires timeout (milliseconds)+  Int32 ->+  IO Word32 notify s appName replaceId _ summary body _ _ timeout = do   realId <- if replaceId == 0 then noteFreshId s else return replaceId   let configTimeout = notificationMaxTimeout (noteConfig s)-      realTimeout = if timeout <= 0 -- Gracefully handle out of spec negative values-                    then configTimeout-                    else case configTimeout of-                           Nothing -> Just timeout-                           Just maxTimeout -> Just (min maxTimeout timeout)+      realTimeout =+        if timeout <= 0 -- Gracefully handle out of spec negative values+          then configTimeout+          else case configTimeout of+            Nothing -> Just timeout+            Just maxTimeout -> Just (min maxTimeout timeout)    escapedSummary <- markupEscapeText summary (-1)   escapedBody <- markupEscapeText body (-1)-  let n = Notification { noteAppName = appName-                       , noteReplaceId = replaceId-                       , noteSummary = escapedSummary-                       , noteBody = escapedBody-                       , noteExpireTimeout = realTimeout-                       , noteId = realId-                       }+  let n =+        Notification+          { noteAppName = appName,+            noteReplaceId = replaceId,+            noteSummary = escapedSummary,+            noteBody = escapedBody,+            noteExpireTimeout = realTimeout,+            noteId = realId+          }   -- Either add the new note to the queue or replace an existing note if their ids match   atomically $ do     queue <- readTVar $ noteQueue s@@ -145,29 +168,34 @@   notePurge s nId   wakeupDisplayThread s -notificationDaemon :: (AutoMethod f1, AutoMethod f2)-                      => f1 -> f2 -> IO ()+notificationDaemon ::+  (AutoMethod f1, AutoMethod f2) =>+  f1 -> f2 -> IO () notificationDaemon onNote onCloseNote = do   client <- connectSession   _ <- requestName client "org.freedesktop.Notifications" [nameAllowReplacement, nameReplaceExisting]   export client "/org/freedesktop/Notifications" interface   where     getServerInformation :: IO (Text, Text, Text, Text)-    getServerInformation = return ("haskell-notification-daemon",-                                   "nochair.net",-                                   "0.0.1",-                                   "1.1")+    getServerInformation =+      return+        ( "haskell-notification-daemon",+          "nochair.net",+          "0.0.1",+          "1.1"+        )     getCapabilities :: IO [Text]     getCapabilities = return ["body", "body-markup"]-    interface = defaultInterface-      { interfaceName = "org.freedesktop.Notifications"-      , interfaceMethods =-          [ autoMethod "GetServerInformation" getServerInformation-          , autoMethod "GetCapabilities" getCapabilities-          , autoMethod "CloseNotification" onCloseNote-          , autoMethod "Notify" onNote-          ]-      }+    interface =+      defaultInterface+        { interfaceName = "org.freedesktop.Notifications",+          interfaceMethods =+            [ autoMethod "GetServerInformation" getServerInformation,+              autoMethod "GetCapabilities" getCapabilities,+              autoMethod "CloseNotification" onCloseNote,+              autoMethod "Notify" onNote+            ]+        }  -------------------------------------------------------------------------------- wakeupDisplayThread :: NotifyState -> IO ()@@ -182,10 +210,10 @@     ns <- readTVarIO (noteQueue s)     postGUIASync $       if S.length ns == 0-      then widgetHide (noteContainer s)-      else do-        labelSetMarkup (noteWidget s) $ formatMessage (noteConfig s) (toList ns)-        widgetShowAll (noteContainer s)+        then widgetHide (noteContainer s)+        else do+          labelSetMarkup (noteWidget s) $ formatMessage (noteConfig s) (toList ns)+          widgetShowAll (noteContainer s)   where     formatMessage NotificationConfig {..} ns =       T.take notificationMaxLength $ notificationFormatter ns@@ -195,28 +223,35 @@ startTimeoutThread s Notification {..} = case noteExpireTimeout of   Nothing -> return ()   Just timeout -> void $ forkIO $ do-    threadDelay (fromIntegral timeout * 10^(3 :: Int))+    threadDelay (fromIntegral timeout * 10 ^ (3 :: Int))     notePurge s noteId     wakeupDisplayThread s  --------------------------------------------------------------------------------++-- | Rendering and behavior settings for the notification widget. data NotificationConfig = NotificationConfig-  { notificationMaxTimeout :: Maybe Int32 -- ^ Maximum time that a notification will be displayed (in seconds).  Default: None-  , notificationMaxLength :: Int -- ^ Maximum length displayed, in characters.  Default: 100-  , notificationFormatter :: [Notification] -> T.Text -- ^ Function used to format notifications, takes the notifications from first to last+  { -- | Maximum time that a notification will be displayed (in seconds).  Default: None+    notificationMaxTimeout :: Maybe Int32,+    -- | Maximum length displayed, in characters.  Default: 100+    notificationMaxLength :: Int,+    -- | Function used to format notifications, takes the notifications from first to last+    notificationFormatter :: [Notification] -> T.Text   }  defaultFormatter :: [Notification] -> T.Text defaultFormatter [] = ""-defaultFormatter (n:ns) =+defaultFormatter (n : ns) =   let count = length ns + 1-      prefix = if count == 1-               then ""-               else "(" <> T.pack (show count) <> ") "-      msg =  if T.null (noteBody n)-             then noteSummary n-             else noteSummary n <> ": " <> noteBody n-  in "<span fgcolor='yellow'>" <> prefix <> "</span>" <> msg+      prefix =+        if count == 1+          then ""+          else "(" <> T.pack (show count) <> ") "+      msg =+        if T.null (noteBody n)+          then noteSummary n+          else noteSummary n <> ": " <> noteBody n+   in "<span fgcolor='yellow'>" <> prefix <> "</span>" <> msg  -- | The default formatter is one of -- * Summary : Body@@ -226,25 +261,32 @@ -- depending on the presence of a notification body, and where N is the number of queued notifications. defaultNotificationConfig :: NotificationConfig defaultNotificationConfig =-  NotificationConfig { notificationMaxTimeout = Nothing-                     , notificationMaxLength = 100-                     , notificationFormatter = defaultFormatter-                     }+  NotificationConfig+    { notificationMaxTimeout = Nothing,+      notificationMaxLength = 100,+      notificationFormatter = defaultFormatter+    }  instance Default NotificationConfig where   def = defaultNotificationConfig  -- | Create a new notification area with the given configuration.-notifyAreaNew :: MonadIO m => NotificationConfig -> m Widget+notifyAreaNew :: (MonadIO m) => NotificationConfig -> m Widget notifyAreaNew cfg = liftIO $ do   frame <- frameNew Nothing+  _ <- widgetSetClassGI frame "notifications-frame"   box <- boxNew OrientationHorizontal 3+  _ <- widgetSetClassGI box "notifications-box"   textArea <- labelNew (Nothing :: Maybe Text)+  _ <- widgetSetClassGI textArea "notification-text"   button <- eventBoxNew+  _ <- widgetSetClassGI button "notification-close"   sep <- separatorNew OrientationHorizontal+  _ <- widgetSetClassGI sep "notification-separator"    bLabel <- labelNew (Nothing :: Maybe Text)   widgetSetName bLabel "NotificationCloseButton"+  _ <- widgetSetClassGI bLabel "notification-close-label"   labelSetMarkup bLabel "×"    labelSetMaxWidthChars textArea (fromIntegral $ notificationMaxLength cfg)@@ -264,6 +306,7 @@   _ <- onWidgetButtonReleaseEvent button (userCancel s)    realizableWrapper <- boxNew OrientationHorizontal 0+  _ <- widgetSetClassGI realizableWrapper "notifications"   boxPackStart realizableWrapper frame False False 0   widgetShow realizableWrapper @@ -277,9 +320,8 @@    -- Don't show the widget by default - it will appear when needed   toWidget realizableWrapper-   where-    -- | Close the current note and pull up the next, if any+    -- \| Close the current note and pull up the next, if any     userCancel s _ = do       noteNext s       wakeupDisplayThread s
src/System/Taffybar/Widget/Generic/AutoFillImage.hs view
@@ -1,46 +1,56 @@ {-# 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+  ( autoFillImage,+    autoFillImageNew,+    AutoFillCache (..),+    fitPixbufToBox,+  )+where  import qualified Control.Concurrent.MVar as MV-import           Control.Monad-import           Control.Monad.IO.Class-import           Data.Int+import Control.Monad+import Control.Monad.IO.Class+import Data.Int import qualified GI.Cairo.Render as C-import           GI.Cairo.Render.Connector+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 GI.GdkPixbuf.Objects.Pixbuf as Gdk import qualified GI.Gtk as Gtk-import           System.Taffybar.Widget.Generic.AutoSizeImage-import           System.Taffybar.Widget.Util+import System.Taffybar.Widget.Generic.AutoSizeImage+import System.Taffybar.Widget.Util +-- | Cached sizing/scaling state for an auto-fill image widget. 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+  { 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)+-- | Scale and center a pixbuf inside the allocated widget content box.+--+-- Returns content width/height, draw offsets, and an optionally scaled pixbuf+-- (GDK may fail and return @Nothing@).+fitPixbufToBox ::+  -- | scale factor+  Int32 ->+  BorderInfo ->+  -- | allocated width (logical px)+  Int32 ->+  -- | allocated height (logical px)+  Int32 ->+  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@@ -58,8 +68,8 @@        scale =         if pbW <= 0 || pbH <= 0-        then 1-        else min (targetW / pbW) (targetH / pbH)+          then 1+          else min (targetW / pbW) (targetH / pbH)        drawWDev = max 1 $ floor (pbW * scale)       drawHDev = max 1 $ floor (pbH * scale)@@ -82,12 +92,12 @@ -- -- 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 ::+  (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@@ -102,93 +112,98 @@   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-    }+  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+  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+        -- 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+        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))+        -- 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+        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+        -- 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+        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-                }+        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+          void $ MV.swapMVar cacheVar newCache+          Gtk.widgetQueueDraw drawArea    -- Redraw when GTK allocates or when style changes.   void $ Gtk.onWidgetSizeAllocate drawArea $ \_ -> recompute False@@ -206,11 +221,11 @@   pure $ recompute True  -- | Convenience constructor for 'autoFillImage'.-autoFillImageNew-  :: MonadIO m-  => (Int32 -> IO (Maybe Gdk.Pixbuf))-  -> Gtk.Orientation-  -> m Gtk.DrawingArea+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
src/System/Taffybar/Widget/Generic/AutoSizeImage.hs view
@@ -1,38 +1,43 @@ {-# LANGUAGE OverloadedStrings #-}++-- | Auto-scaling image helpers that resize pixbufs to widget allocation. module System.Taffybar.Widget.Generic.AutoSizeImage-  ( autoSizeImage-  , autoSizeImageNew-  , imageMenuItemNew-  , ImageScaleStrategy(..)-  , BorderInfo(..)-  , borderInfoZero-  , borderWidth-  , borderHeight-  , getBorderInfo-  , getInsetInfo-  , getContentAllocation-  ) where+  ( 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 Control.Monad+import Control.Monad.IO.Class+import Data.Default (Default (..))+import Data.Int+import Data.Maybe import qualified Data.Text as T import qualified GI.Gdk as Gdk-import           GI.GdkPixbuf.Objects.Pixbuf as Gdk+import GI.GdkPixbuf.Objects.Pixbuf as Gdk import qualified GI.Gtk as Gtk-import           StatusNotifier.Tray (scalePixbufToSize)-import           System.Log.Logger-import           System.Taffybar.Util-import           System.Taffybar.Widget.Util-import           Text.Printf+import StatusNotifier.Tray (scalePixbufToSize)+import System.Log.Logger+import System.Taffybar.Util+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).+  = -- | Use 'Gtk.Image' with 'imageSetFromPixbuf' + 'queueResize' (original behavior).+    ImageResize+  | -- | Use 'Gtk.DrawingArea' with Cairo rendering (avoids resize feedback loops).+    ImageDraw   deriving (Eq, Show)  instance Default ImageScaleStrategy where@@ -43,46 +48,54 @@  borderFunctions :: [Gtk.StyleContext -> [Gtk.StateFlags] -> IO Gtk.Border] borderFunctions =-  [ Gtk.styleContextGetPadding-  , Gtk.styleContextGetMargin-  , Gtk.styleContextGetBorder+  [ Gtk.styleContextGetPadding,+    Gtk.styleContextGetMargin,+    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+  [ Gtk.styleContextGetPadding,+    Gtk.styleContextGetBorder   ] +-- | Aggregate border/padding/margin dimensions for a widget. data BorderInfo = BorderInfo-  { borderTop :: Int16-  , borderBottom :: Int16-  , borderLeft :: Int16-  , borderRight :: Int16-  } deriving (Show, Eq)+  { borderTop :: Int16,+    borderBottom :: Int16,+    borderLeft :: Int16,+    borderRight :: Int16+  }+  deriving (Show, Eq) +-- | Zero-valued 'BorderInfo'. borderInfoZero :: BorderInfo borderInfoZero = BorderInfo 0 0 0 0 +-- | Total horizontal border extent.+-- This includes left + right values. borderWidth, borderHeight :: BorderInfo -> Int16 borderWidth borderInfo = borderLeft borderInfo + borderRight borderInfo++-- | Total vertical border extent.+-- This includes top + bottom values. borderHeight borderInfo = borderTop borderInfo + borderBottom borderInfo  toBorderInfo :: (MonadIO m) => Gtk.Border -> m BorderInfo toBorderInfo border =   BorderInfo-  <$> Gtk.getBorderTop border-  <*> Gtk.getBorderBottom border-  <*> Gtk.getBorderLeft border-  <*> Gtk.getBorderRight border+    <$> Gtk.getBorderTop border+    <*> Gtk.getBorderBottom border+    <*> Gtk.getBorderLeft border+    <*> Gtk.getBorderRight border  addBorderInfo :: BorderInfo -> BorderInfo -> BorderInfo addBorderInfo   (BorderInfo t1 b1 l1 r1)-  (BorderInfo t2 b2 l2 r2)-    = BorderInfo (t1 + t2) (b1 + b2) (l1 + l2) (r1 + r2)+  (BorderInfo t2 b2 l2 r2) =+    BorderInfo (t1 + t2) (b1 + b2) (l1 + l2) (r1 + r2)  -- | Get the total size of the border (the sum of its assigned margin, border -- and padding values) that will be drawn for a widget as a "BorderInfo" record.@@ -113,9 +126,9 @@  -- | Get the actual allocation for a "Gtk.Widget", accounting for the size of -- its CSS assined margin, border and padding values.-getContentAllocation-  :: (MonadIO m, Gtk.IsWidget a)-  => a -> BorderInfo -> m Gdk.Rectangle+getContentAllocation ::+  (MonadIO m, Gtk.IsWidget a) =>+  a -> BorderInfo -> m Gdk.Rectangle getContentAllocation widget borderInfo = do   allocation <- Gtk.widgetGetAllocation widget   currentWidth <- Gdk.getRectangleWidth allocation@@ -123,26 +136,28 @@   currentX <- Gdk.getRectangleX allocation   currentY <- Gdk.getRectangleX allocation -  Gdk.setRectangleWidth allocation $ max 1 $-     currentWidth - fromIntegral (borderWidth borderInfo)-  Gdk.setRectangleHeight allocation $ max 1 $-     currentHeight - fromIntegral (borderHeight borderInfo)+  Gdk.setRectangleWidth allocation $+    max 1 $+      currentWidth - fromIntegral (borderWidth borderInfo)+  Gdk.setRectangleHeight allocation $+    max 1 $+      currentHeight - fromIntegral (borderHeight borderInfo)   Gdk.setRectangleX allocation $-     currentX + fromIntegral (borderLeft borderInfo)+    currentX + fromIntegral (borderLeft borderInfo)   Gdk.setRectangleY allocation $-     currentY + fromIntegral (borderTop borderInfo)+    currentY + fromIntegral (borderTop borderInfo)    return allocation  -- | Automatically update the "Gdk.Pixbuf" of a "Gtk.Image" using the provided -- action whenever the "Gtk.Image" is allocated. Returns an action that forces a -- refresh of the image through the provided action.-autoSizeImage-  :: MonadIO m-  => Gtk.Image-  -> (Int32 -> IO (Maybe Gdk.Pixbuf))-  -> Gtk.Orientation-  -> m (IO ())+autoSizeImage ::+  (MonadIO m) =>+  Gtk.Image ->+  (Int32 -> IO (Maybe Gdk.Pixbuf)) ->+  Gtk.Orientation ->+  m (IO ()) autoSizeImage image getPixbuf orientation = liftIO $ do   case orientation of     Gtk.OrientationHorizontal -> Gtk.widgetSetVexpand image True@@ -177,20 +192,21 @@           pbWidth <- fromMaybe 0 <$> traverse Gdk.getPixbufWidth pixbuf           pbHeight <- fromMaybe 0 <$> traverse Gdk.getPixbufHeight pixbuf           let pbSize = case orientation of-                         Gtk.OrientationHorizontal -> pbHeight-                         _ -> pbWidth+                Gtk.OrientationHorizontal -> pbHeight+                _ -> pbWidth               logLevel = if pbSize <= size then DEBUG else WARNING            imageLog logLevel $-                 printf "Allocating image: size %s, width %s, \-                         \ height %s, aw: %s, ah: %s, pbw: %s pbh: %s"-                 (show size)-                 (show width)-                 (show height)-                 (show _width)-                 (show _height)-                 (show pbWidth)-                 (show pbHeight)+            printf+              "Allocating image: size %s, width %s, \+              \ height %s, aw: %s, ah: %s, pbw: %s pbh: %s"+              (show size)+              (show width)+              (show height)+              (show _width)+              (show _height)+              (show pbWidth)+              (show pbHeight)            Gtk.imageSetFromPixbuf image pixbuf           postGUIASync $ Gtk.widgetQueueResize image@@ -201,20 +217,22 @@ -- | Make a new "Gtk.Image" and call "autoSizeImage" on it. Automatically scale -- the "Gdk.Pixbuf" returned from the provided getter to the appropriate size -- using "scalePixbufToSize".-autoSizeImageNew-  :: MonadIO m-  => (Int32 -> IO Gdk.Pixbuf) -> Gtk.Orientation -> m Gtk.Image+autoSizeImageNew ::+  (MonadIO m) =>+  (Int32 -> IO Gdk.Pixbuf) -> Gtk.Orientation -> m Gtk.Image autoSizeImageNew getPixBuf orientation = do   image <- Gtk.imageNew-  void $ autoSizeImage image-         (\size -> Just <$> (getPixBuf size >>= scalePixbufToSize size orientation))-         orientation+  void $+    autoSizeImage+      image+      (\size -> Just <$> (getPixBuf size >>= scalePixbufToSize size orientation))+      orientation   return image  -- | Make a new "Gtk.MenuItem" that has both a label and an icon.-imageMenuItemNew-  :: MonadIO m-  => T.Text -> (Int32 -> IO (Maybe Gdk.Pixbuf)) -> m Gtk.MenuItem+imageMenuItemNew ::+  (MonadIO m) =>+  T.Text -> (Int32 -> IO (Maybe Gdk.Pixbuf)) -> m Gtk.MenuItem imageMenuItemNew labelText pixbufGetter = do   box <- Gtk.boxNew Gtk.OrientationHorizontal 0   label <- Gtk.labelNew $ Just labelText
src/System/Taffybar/Widget/Generic/ChannelGraph.hs view
@@ -1,3 +1,4 @@+-- | Graph widgets driven by samples arriving over a broadcast channel. module System.Taffybar.Widget.Generic.ChannelGraph where  import Control.Concurrent@@ -11,15 +12,17 @@ -- | Given a broadcast 'TChan' and an action to consume that broadcast chan and -- turn it into graphable values, build a graph that will update as values are -- broadcast over the channel.-channelGraphNew-  :: MonadIO m-  => GraphConfig -> TChan a -> (a -> IO [Double]) -> m GI.Gtk.Widget+channelGraphNew ::+  (MonadIO m) =>+  GraphConfig -> TChan a -> (a -> IO [Double]) -> m GI.Gtk.Widget channelGraphNew config chan sampleBuilder = do   (graphWidget, graphHandle) <- graphNew config   _ <- onWidgetRealize graphWidget $ do-       ourChan <- atomically $ dupTChan chan-       sampleThread <- forkIO $ forever $-         atomically (readTChan ourChan) >>=-         (graphAddSample graphHandle <=< sampleBuilder)-       void $ onWidgetUnrealize graphWidget $ killThread sampleThread+    ourChan <- atomically $ dupTChan chan+    sampleThread <-+      forkIO $+        forever $+          atomically (readTChan ourChan)+            >>= (graphAddSample graphHandle <=< sampleBuilder)+    void $ onWidgetUnrealize graphWidget $ killThread sampleThread   return graphWidget
src/System/Taffybar/Widget/Generic/ChannelWidget.hs view
@@ -1,3 +1,4 @@+-- | Connect widget updates to a broadcast 'TChan' on a dedicated worker thread. module System.Taffybar.Widget.Generic.ChannelWidget where  import Control.Concurrent@@ -16,8 +17,10 @@ channelWidgetNew widget channel updateWidget = do   void $ onWidgetRealize widget $ do     ourChan <- atomically $ dupTChan channel-    processingThreadId <- forkIO $ forever $-      atomically (readTChan ourChan) >>= updateWidget+    processingThreadId <-+      forkIO $+        forever $+          atomically (readTChan ourChan) >>= updateWidget     void $ onWidgetUnrealize widget $ killThread processingThreadId   widgetShowAll widget   return widget
src/System/Taffybar/Widget/Generic/DynamicMenu.hs view
@@ -1,29 +1,35 @@+-- | Build menu buttons whose menu contents are rebuilt each time they are+-- opened. module System.Taffybar.Widget.Generic.DynamicMenu where -import           Control.Monad.IO.Class+import Control.Monad.IO.Class import qualified GI.Gtk as Gtk +-- | Configuration for a dynamic menu button. data DynamicMenuConfig = DynamicMenuConfig-  { dmClickWidget :: Gtk.Widget-  , dmPopulateMenu :: Gtk.Menu -> IO ()+  { dmClickWidget :: Gtk.Widget,+    dmPopulateMenu :: Gtk.Menu -> IO ()   } -dynamicMenuNew :: MonadIO m => DynamicMenuConfig -> m Gtk.Widget-dynamicMenuNew DynamicMenuConfig-                 { dmClickWidget = clickWidget-                 , dmPopulateMenu = populateMenu-                 } = do-  button <- Gtk.menuButtonNew-  menu <- Gtk.menuNew-  Gtk.containerAdd button clickWidget-  Gtk.menuButtonSetPopup button $ Just menu+-- | Wrap a widget in a menu button and repopulate the attached menu on click.+dynamicMenuNew :: (MonadIO m) => DynamicMenuConfig -> m Gtk.Widget+dynamicMenuNew+  DynamicMenuConfig+    { dmClickWidget = clickWidget,+      dmPopulateMenu = populateMenu+    } = do+    button <- Gtk.menuButtonNew+    menu <- Gtk.menuNew+    Gtk.containerAdd button clickWidget+    Gtk.menuButtonSetPopup button $ Just menu -  _ <- Gtk.onButtonPressed button $ emptyMenu menu >> populateMenu menu+    _ <- Gtk.onButtonPressed button $ emptyMenu menu >> populateMenu menu -  Gtk.widgetShowAll button+    Gtk.widgetShowAll button -  Gtk.toWidget button+    Gtk.toWidget button +-- | Remove and destroy all current menu items. emptyMenu :: (Gtk.IsContainer a, MonadIO m) => a -> m () emptyMenu menu =   Gtk.containerForeach menu $ \item ->
src/System/Taffybar/Widget/Generic/Graph.hs view
@@ -1,4 +1,5 @@ {-# LANGUAGE ScopedTypeVariables #-}+ -- | This is a graph widget inspired by the widget of the same name in Awesome -- (the window manager). It plots a series of data points similarly to a bar -- graph. This version must be explicitly fed data with 'graphAddSample'. For a@@ -8,90 +9,105 @@ -- sets are plotted in the order provided by the caller. -- -- Note: all of the data fed to this widget should be in the range [0,1].-module System.Taffybar.Widget.Generic.Graph (-  -- * Types-    GraphHandle-  , GraphConfig(..)-  , GraphDirection(..)-  , GraphStyle(..)-  -- * Functions-  , graphNew-  , graphAddSample-  , defaultGraphConfig-  ) where+module System.Taffybar.Widget.Generic.Graph+  ( -- * Types+    GraphHandle,+    GraphConfig (..),+    GraphDirection (..),+    GraphStyle (..), -import           Control.Concurrent-import           Control.Monad ( when )-import           Control.Monad.IO.Class-import           Data.Default ( Default(..) )-import           Data.Sequence ( Seq(..), (<|), viewl, ViewL(..) )+    -- * Functions+    graphNew,+    graphAddSample,+    defaultGraphConfig,+  )+where++import Control.Concurrent+import Control.Exception (bracket_)+import Control.Monad (forM, when)+import Control.Monad.IO.Class+import Data.Default (Default (..))+import Data.Sequence (Seq (..), ViewL (..), viewl, (<|)) import qualified Data.Sequence as S import qualified Data.Text as T import qualified GI.Cairo.Render as C-import           GI.Cairo.Render.Connector+import GI.Cairo.Render.Connector import qualified GI.Cairo.Render.Matrix as M+import qualified GI.Gdk.Structs.RGBA as GdkRGBA import qualified GI.Gtk as Gtk-import           System.Taffybar.Util-import           System.Taffybar.Widget.Util+import System.Taffybar.Util+import System.Taffybar.Widget.Util +-- | Handle used to add samples to a graph widget. newtype GraphHandle = GH (MVar GraphState)-data GraphState =-  GraphState { graphIsBootstrapped :: Bool-             , graphHistory :: [Seq Double]-             , graphCanvas :: Gtk.DrawingArea-             , graphConfig :: GraphConfig-             } +data GraphState+  = GraphState+  { graphIsBootstrapped :: Bool,+    graphHistory :: [Seq Double],+    graphCanvas :: Gtk.DrawingArea,+    graphConfig :: GraphConfig+  }++-- | Direction in which historical samples flow across the widget. data GraphDirection = LEFT_TO_RIGHT | RIGHT_TO_LEFT deriving (Eq)  -- 'RGBA' represents a color with a transparency.-type RGBA = (Double, Double, Double, Double)+type GraphColor = (Double, Double, Double, Double)  -- | The style of the graph. Generally, you will want to draw all 'Area' graphs -- first, and then all 'Line' graphs. data GraphStyle-    = Area -- ^ Thea area below the value is filled-    | Line -- ^ The values are connected by a line (one pixel wide)+  = -- | Thea area below the value is filled+    Area+  | -- | The values are connected by a line (one pixel wide)+    Line  -- | The configuration options for the graph. The padding is the number of -- pixels reserved as blank space around the widget in each direction.-data GraphConfig = GraphConfig {-  -- | Number of pixels of padding on each side of the graph widget-    graphPadding :: Int-  -- | The background color of the graph (default black)-  , graphBackgroundColor :: RGBA-  -- | The border color drawn around the graph (default gray)-  , graphBorderColor :: RGBA-  -- | The width of the border (default 1, use 0 to disable the border)-  , graphBorderWidth :: Int-  -- | Colors for each data set (default cycles between red, green and blue)-  , graphDataColors :: [RGBA]-  -- | How to draw each data point (default @repeat Area@)-  , graphDataStyles :: [GraphStyle]-  -- | The number of data points to retain for each data set (default 20)-  , graphHistorySize :: Int-  -- | May contain Pango markup (default @Nothing@)-  , graphLabel :: Maybe T.Text-  -- | The width (in pixels) of the graph widget (default 50)-  , graphWidth :: Int-  -- | The direction in which the graph will move as time passes (default LEFT_TO_RIGHT)-  , graphDirection :: GraphDirection+data GraphConfig = GraphConfig+  { -- | Number of pixels of padding on each side of the graph widget+    graphPadding :: Int,+    -- | The background color of the graph (default black)+    graphBackgroundColor :: GraphColor,+    -- | The border color drawn around the graph (default gray)+    graphBorderColor :: GraphColor,+    -- | The width of the border (default 1, use 0 to disable the border)+    graphBorderWidth :: Int,+    -- | Colors for each data set (default cycles between red, green and blue)+    graphDataColors :: [GraphColor],+    -- | Draw graph colors from CSS classes. When enabled, each dataset color is+    -- read from @color@ using @graph-data-N@ classes on the drawing area.+    graphColorsFromCss :: Bool,+    -- | How to draw each data point (default @repeat Area@)+    graphDataStyles :: [GraphStyle],+    -- | The number of data points to retain for each data set (default 20)+    graphHistorySize :: Int,+    -- | May contain Pango markup (default @Nothing@)+    graphLabel :: Maybe T.Text,+    -- | The width (in pixels) of the graph widget (default 50)+    graphWidth :: Int,+    -- | The direction in which the graph will move as time passes (default LEFT_TO_RIGHT)+    graphDirection :: GraphDirection   } +-- | Default graph configuration. defaultGraphConfig :: GraphConfig defaultGraphConfig =   GraphConfig-  { graphPadding = 2-  , graphBackgroundColor = (0.0, 0.0, 0.0, 1.0)-  , graphBorderColor = (0.5, 0.5, 0.5, 1.0)-  , graphBorderWidth = 1-  , graphDataColors = cycle [(1, 0, 0, 0), (0, 1, 0, 0), (0, 0, 1, 0)]-  , graphDataStyles = repeat Area-  , graphHistorySize = 20-  , graphLabel = Nothing-  , graphWidth = 50-  , graphDirection = LEFT_TO_RIGHT-  }+    { graphPadding = 2,+      graphBackgroundColor = (0.0, 0.0, 0.0, 1.0),+      graphBorderColor = (0.5, 0.5, 0.5, 1.0),+      graphBorderWidth = 1,+      graphDataColors = cycle [(1, 0, 0, 0), (0, 1, 0, 0), (0, 0, 1, 0)],+      graphColorsFromCss = False,+      graphDataStyles = repeat Area,+      graphHistorySize = 20,+      graphLabel = Nothing,+      graphWidth = 50,+      graphDirection = LEFT_TO_RIGHT+    }  instance Default GraphConfig where   def = defaultGraphConfig@@ -106,9 +122,9 @@       histsAndNewVals = zip pcts (graphHistory s)       newHists = case graphHistory s of         [] -> map S.singleton pcts-        _ -> map (\(p,h) -> S.take histSize $ p <| h) histsAndNewVals+        _ -> map (\(p, h) -> S.take histSize $ p <| h) histsAndNewVals   when (graphIsBootstrapped s) $ do-    modifyMVar_ mv (\s' -> return s' { graphHistory = newHists })+    modifyMVar_ mv (\s' -> return s' {graphHistory = newHists})     postGUIASync $ Gtk.widgetQueueDraw drawArea   where     pcts = map (clamp 0 1) rawData@@ -118,37 +134,73 @@  outlineData :: (Double -> Double) -> Double -> Double -> C.Render () outlineData pctToY xStep pct = do-  (curX,_) <- C.getCurrentPoint+  (curX, _) <- C.getCurrentPoint   C.lineTo (curX + xStep) (pctToY pct) -renderFrameAndBackground :: GraphConfig -> Int -> Int -> C.Render ()-renderFrameAndBackground cfg w h = do-  let (backR, backG, backB, backA) = graphBackgroundColor cfg-      (frameR, frameG, frameB, frameA) = graphBorderColor cfg-      pad = graphPadding cfg+normalStateFlags :: [Gtk.StateFlags]+normalStateFlags = [Gtk.StateFlagsNormal]++rgbaToGraphColor :: GdkRGBA.RGBA -> IO GraphColor+rgbaToGraphColor rgba = do+  r <- GdkRGBA.getRGBARed rgba+  g <- GdkRGBA.getRGBAGreen rgba+  b <- GdkRGBA.getRGBABlue rgba+  a <- GdkRGBA.getRGBAAlpha rgba+  return (r, g, b, a)++withStyleContextSave :: Gtk.StyleContext -> IO a -> IO a+withStyleContextSave styleContext =+  bracket_+    (Gtk.styleContextSave styleContext)+    (Gtk.styleContextRestore styleContext)++getDataColorFromCss :: Gtk.StyleContext -> Int -> IO GraphColor+getDataColorFromCss styleContext index =+  withStyleContextSave styleContext $ do+    Gtk.styleContextAddClass styleContext (T.pack "graph-data")+    Gtk.styleContextAddClass styleContext (T.pack $ "graph-data-" <> show index)+    Gtk.styleContextGetColor styleContext normalStateFlags >>= rgbaToGraphColor++renderFrameAndBackground :: GraphConfig -> Maybe Gtk.StyleContext -> Int -> Int -> C.Render ()+renderFrameAndBackground cfg styleContext w h = do+  let pad = graphPadding cfg       fpad = fromIntegral pad       fw = fromIntegral w       fh = fromIntegral h--  -- Draw the requested background-  C.setSourceRGBA backR backG backB backA-  C.rectangle fpad fpad (fw - 2 * fpad) (fh - 2 * fpad)-  C.fill--  -- Draw a frame around the widget area (unless equal to background color,-  -- which likely means the user does not want a frame)-  when (graphBorderWidth cfg > 0) $ do-    let p = fromIntegral (graphBorderWidth cfg)-    C.setLineWidth p-    C.setSourceRGBA frameR frameG frameB frameA-    C.rectangle (fpad + (p / 2)) (fpad + (p / 2))-       (fw - 2 * fpad - p) (fh - 2 * fpad - p)-    C.stroke+      frameX = fpad+      frameY = fpad+      frameWidth = fw - 2 * fpad+      frameHeight = fh - 2 * fpad+  case (graphColorsFromCss cfg, styleContext) of+    (True, Just context) ->+      toRender $ \cairoCtx -> do+        Gtk.renderBackground context cairoCtx frameX frameY frameWidth frameHeight+        when (graphBorderWidth cfg > 0) $+          Gtk.renderFrame context cairoCtx frameX frameY frameWidth frameHeight+    _ -> do+      let (backR, backG, backB, backA) = graphBackgroundColor cfg+          (frameR, frameG, frameB, frameA) = graphBorderColor cfg+      -- Draw the requested background+      C.setSourceRGBA backR backG backB backA+      C.rectangle frameX frameY frameWidth frameHeight+      C.fill +      -- Draw a frame around the widget area (unless equal to background color,+      -- which likely means the user does not want a frame)+      when (graphBorderWidth cfg > 0) $ do+        let p = fromIntegral (graphBorderWidth cfg)+        C.setLineWidth p+        C.setSourceRGBA frameR frameG frameB frameA+        C.rectangle+          (fpad + (p / 2))+          (fpad + (p / 2))+          (fw - 2 * fpad - p)+          (fh - 2 * fpad - p)+        C.stroke -renderGraph :: [Seq Double] -> GraphConfig -> Int -> Int -> Double -> C.Render ()-renderGraph hists cfg w h xStep = do-  renderFrameAndBackground cfg w h+renderGraph :: [Seq Double] -> [GraphColor] -> GraphConfig -> Maybe Gtk.StyleContext -> Int -> Int -> Double -> C.Render ()+renderGraph hists dataColors cfg styleContext w h xStep = do+  renderFrameAndBackground cfg styleContext w h    C.setLineWidth 0.1 @@ -167,12 +219,13 @@   -- transformation with an offset to the right equal to the width of the   -- widget.   when (graphDirection cfg == RIGHT_TO_LEFT) $-      C.transform $ M.Matrix (-1) 0 0 1 (fromIntegral w) 0+    C.transform $+      M.Matrix (-1) 0 0 1 (fromIntegral w) 0    let pctToY pct = fromIntegral h * (1 - pct)       renderDataSet hist color style = case viewl hist of-        EmptyL                -> return ()-        _oneSample :< Empty   -> return ()+        EmptyL -> return ()+        _oneSample :< Empty -> return ()         newestSample :< hist' -> do           let (r, g, b, a) = color               originY = pctToY newestSample@@ -191,20 +244,24 @@               C.setLineWidth 1.0               C.stroke --  sequence_ $ zipWith3 renderDataSet hists (graphDataColors cfg)-            (graphDataStyles cfg)+  sequence_ $+    zipWith3+      renderDataSet+      hists+      dataColors+      (graphDataStyles cfg)  drawBorder :: MVar GraphState -> Gtk.DrawingArea -> C.Render () drawBorder mv drawArea = do   (w, h) <- widgetGetAllocatedSize drawArea   s <- liftIO $ readMVar mv   let cfg = graphConfig s-  renderFrameAndBackground cfg w h-  liftIO $ modifyMVar_ mv (\s' -> return s' { graphIsBootstrapped = True })+  styleContext <- C.liftIO $ Gtk.widgetGetStyleContext drawArea+  renderFrameAndBackground cfg (Just styleContext) w h+  liftIO $ modifyMVar_ mv (\s' -> return s' {graphIsBootstrapped = True})   return () -drawGraph :: MVar GraphState -> Gtk.DrawingArea ->  C.Render ()+drawGraph :: MVar GraphState -> Gtk.DrawingArea -> C.Render () drawGraph mv drawArea = do   (w, h) <- widgetGetAllocatedSize drawArea   drawBorder mv drawArea@@ -212,35 +269,50 @@   let hist = graphHistory s       cfg = graphConfig s       histSize = graphHistorySize cfg-      -- Subtract 1 here since the first data point doesn't require+  styleContext <- C.liftIO $ Gtk.widgetGetStyleContext drawArea+  dataColors <-+    if graphColorsFromCss cfg+      then C.liftIO $ forM [1 .. length hist] (getDataColorFromCss styleContext)+      else return $ graphDataColors cfg+  let -- Subtract 1 here since the first data point doesn't require       -- any movement in the X direction       xStep = fromIntegral w / fromIntegral (histSize - 1)    case hist of-    [] -> renderFrameAndBackground cfg w h-    _ -> renderGraph hist cfg w h xStep+    [] -> renderFrameAndBackground cfg (Just styleContext) w h+    _ -> renderGraph hist dataColors cfg (Just styleContext) w h xStep -graphNew :: MonadIO m => GraphConfig -> m (Gtk.Widget, GraphHandle)+-- | Construct a new graph widget and its mutable handle.+graphNew :: (MonadIO m) => GraphConfig -> m (Gtk.Widget, GraphHandle) graphNew cfg = liftIO $ do   drawArea <- Gtk.drawingAreaNew-  mv <- newMVar GraphState { graphIsBootstrapped = False-                           , graphHistory = []-                           , graphCanvas = drawArea-                           , graphConfig = cfg-                           }+  _ <- widgetSetClassGI drawArea (T.pack "graph-canvas")+  Gtk.widgetGetStyleContext drawArea >>= \styleContext ->+    Gtk.styleContextAddClass styleContext (T.pack "graph")+  mv <-+    newMVar+      GraphState+        { graphIsBootstrapped = False,+          graphHistory = [],+          graphCanvas = drawArea,+          graphConfig = cfg+        }    Gtk.widgetSetSizeRequest drawArea (fromIntegral $ graphWidth cfg) (-1)-  _ <- Gtk.onWidgetDraw drawArea $ \ctx -> renderWithContext-       (drawGraph mv drawArea) ctx >> return True+  _ <- Gtk.onWidgetDraw drawArea $ \ctx ->+    renderWithContext+      (drawGraph mv drawArea)+      ctx+      >> return True   box <- Gtk.boxNew Gtk.OrientationHorizontal 1-+  _ <- widgetSetClassGI box (T.pack "graph")    Gtk.widgetSetVexpand drawArea True   Gtk.widgetSetVexpand box True   Gtk.boxPackStart box drawArea True True 0    widget <- case graphLabel cfg of-    Nothing  -> Gtk.toWidget box+    Nothing -> Gtk.toWidget box     Just labelText -> do       overlay <- Gtk.overlayNew       label <- Gtk.labelNew Nothing
src/System/Taffybar/Widget/Generic/Icon.hs view
@@ -1,26 +1,30 @@ -- | This is a simple static image widget, and a polling image widget that -- updates its contents by calling a callback at a set interval. module System.Taffybar.Widget.Generic.Icon-  ( iconImageWidgetNew-  , iconImageWidgetNewFromName-  , pollingIconImageWidgetNew-  , pollingIconImageWidgetNewFromName-  ) where+  ( iconImageWidgetNew,+    iconImageWidgetNewFromName,+    pollingIconImageWidgetNew,+    pollingIconImageWidgetNewFromName,+  )+where -import Control.Concurrent ( forkIO, threadDelay )-import qualified Data.Text as T+import Control.Concurrent (killThread) import Control.Exception as E-import Control.Monad ( forever, void )-import Control.Monad.IO.Class+import Control.Monad (void)+import Control.Monad.IO.Class (MonadIO, liftIO)+import Control.Monad.Trans.Reader (ask, runReaderT)+import Data.GI.Gtk.Threading (postGUIASync)+import qualified Data.Text as T import GI.Gtk-import System.Taffybar.Util+import System.Taffybar.Context (TaffyIO)+import System.Taffybar.Information.Wakeup (taffyForeverWithDelay)  -- | Create a new widget that displays a static image -- -- > iconImageWidgetNew path -- -- returns a widget with icon at @path@.-iconImageWidgetNew :: MonadIO m => FilePath -> m Widget+iconImageWidgetNew :: (MonadIO m) => FilePath -> m Widget iconImageWidgetNew path = liftIO $ imageNewFromFile path >>= putInBox  -- | Create a new widget that displays a static image@@ -29,10 +33,11 @@ -- -- returns a widget with the icon named @name@. Icon -- names are sourced from the current GTK theme.-iconImageWidgetNewFromName :: MonadIO m => T.Text -> m Widget-iconImageWidgetNewFromName name = liftIO $-  imageNewFromIconName (Just name) (fromIntegral $ fromEnum IconSizeMenu)-  >>= putInBox+iconImageWidgetNewFromName :: (MonadIO m) => T.Text -> m Widget+iconImageWidgetNewFromName name =+  liftIO $+    imageNewFromIconName (Just name) (fromIntegral $ fromEnum IconSizeMenu)+      >>= putInBox  -- | Create a new widget that updates itself at regular intervals.  The -- function@@ -45,14 +50,18 @@ -- -- If the IO action throws an exception, it will be swallowed and the -- label will not update until the update interval expires.-pollingIconImageWidgetNew-  :: MonadIO m-  => FilePath -- ^ Initial file path of the icon-  -> Double -- ^ Update interval (in seconds)-  -> IO FilePath -- ^ Command to run to get the input filepath-  -> m Widget+pollingIconImageWidgetNew ::+  -- | Initial file path of the icon+  FilePath ->+  -- | Update interval (in seconds)+  Double ->+  -- | Command to run to get the input filepath+  IO FilePath ->+  TaffyIO Widget pollingIconImageWidgetNew path interval cmd =-  pollingIcon interval cmd+  pollingIcon+    interval+    cmd     (imageNewFromFile path)     (\image path' -> imageSetFromFile image (Just path')) @@ -67,39 +76,55 @@ -- -- If the IO action throws an exception, it will be swallowed and the -- label will not update until the update interval expires.-pollingIconImageWidgetNewFromName-  :: MonadIO m-  => T.Text    -- ^ Icon Name-  -> Double    -- ^ Update interval (in seconds)-  -> IO T.Text -- ^ Command to run update the icon name-  -> m Widget+pollingIconImageWidgetNewFromName ::+  -- | Icon Name+  T.Text ->+  -- | Update interval (in seconds)+  Double ->+  -- | Command to run update the icon name+  IO T.Text ->+  TaffyIO Widget pollingIconImageWidgetNewFromName name interval cmd =-  pollingIcon interval cmd+  pollingIcon+    interval+    cmd     (imageNewFromIconName (Just name) (fromIntegral $ fromEnum IconSizeMenu))     (\image name' -> imageSetFromIconName image (Just name') $ fromIntegral $ fromEnum IconSizeMenu)  -- | Creates a polling icon.-pollingIcon-  :: MonadIO m-  => Double   -- ^ Update Interval (in seconds)-  -> IO name  -- ^ IO action that updates image's icon-name/filepath-  -> IO Image -- ^ MonadIO action that creates the initial image.-  -> (Image -> name -> IO b)-              -- ^ MonadIO action that updates the image.-  -> m Widget -- ^ Polling Icon-pollingIcon interval doUpdateName doInitImage doSetImage = liftIO $ do-  image <- doInitImage-  _ <- onWidgetRealize image $ do-    _ <- forkIO $ forever $ do-      let tryUpdate = liftIO $ do-            name' <- doUpdateName-            postGUIASync $ void $ doSetImage image name'-      E.catch tryUpdate ignoreIOException-      threadDelay $ floor (interval * 1000000)+pollingIcon ::+  -- | Update Interval (in seconds)+  Double ->+  -- | IO action that updates image's icon-name/filepath+  IO name ->+  -- | MonadIO action that creates the initial image.+  IO Image ->+  -- | MonadIO action that updates the image.+  (Image -> name -> IO b) ->+  -- | Polling Icon+  TaffyIO Widget+pollingIcon interval doUpdateName doInitImage doSetImage = do+  context <- ask+  image <- liftIO doInitImage+  liftIO $ do+    _ <- onWidgetRealize image $ do+      sampleThread <-+        runReaderT+          ( taffyForeverWithDelay interval $+              liftIO $+                E.catch+                  ( do+                      name' <- doUpdateName+                      postGUIASync $ void $ doSetImage image name'+                  )+                  ignoreIOException+          )+          context+      void $ onWidgetUnrealize image $ killThread sampleThread     return ()-  putInBox image+  liftIO $ putInBox image -putInBox :: IsWidget child => child -> IO Widget+putInBox :: (IsWidget child) => child -> IO Widget putInBox icon = do   box <- boxNew OrientationHorizontal 0   boxPackStart box icon False False 0
src/System/Taffybar/Widget/Generic/PollingBar.hs view
@@ -1,36 +1,59 @@ -- | Like the vertical bar, but this widget automatically updates -- itself with a callback at fixed intervals.-module System.Taffybar.Widget.Generic.PollingBar (-  -- * Types-  VerticalBarHandle,-  BarConfig(..),-  BarDirection(..),-  -- * Constructors and accessors-  pollingBarNew,-  verticalBarFromCallback,-  defaultBarConfig-  ) where+module System.Taffybar.Widget.Generic.PollingBar+  ( -- * Types+    VerticalBarHandle,+    BarConfig (..),+    BarDirection (..), +    -- * Constructors and accessors+    pollingBarNew,+    verticalBarFromCallback,+    defaultBarConfig,+  )+where+ import Control.Concurrent-import Control.Exception.Enclosed ( tryAny )+import Control.Exception.Enclosed (tryAny)+import Control.Monad (void)+import Control.Monad.IO.Class (MonadIO, liftIO)+import Control.Monad.Trans.Reader (ask, runReaderT)+import Data.Foldable (traverse_) import qualified GI.Gtk-import System.Taffybar.Widget.Util ( backgroundLoop )-import Control.Monad.IO.Class-+import System.Taffybar.Context (TaffyIO)+import System.Taffybar.Information.Wakeup (taffyForeverWithDelay) import System.Taffybar.Widget.Generic.VerticalBar+import System.Taffybar.Widget.Util (backgroundLoop) -verticalBarFromCallback :: MonadIO m-                        => BarConfig -> IO Double -> m GI.Gtk.Widget+-- | Construct a bar widget driven directly by a sample callback.+verticalBarFromCallback ::+  (MonadIO m) =>+  BarConfig -> IO Double -> m GI.Gtk.Widget verticalBarFromCallback cfg action = liftIO $ do   (drawArea, h) <- verticalBarNew cfg   _ <- GI.Gtk.onWidgetRealize drawArea $ backgroundLoop $ do-      esample <- tryAny action-      traverse (verticalBarSetPercent h) esample+    esample <- tryAny action+    traverse (verticalBarSetPercent h) esample   return drawArea -pollingBarNew :: MonadIO m-              => BarConfig -> Double -> IO Double -> m GI.Gtk.Widget-pollingBarNew cfg pollSeconds action =-  liftIO $-  verticalBarFromCallback cfg $ action <* delay-  where delay = threadDelay $ floor (pollSeconds * 1000000)+-- | Construct a polling bar with a fixed polling interval (seconds).+pollingBarNew ::+  BarConfig -> Double -> IO Double -> TaffyIO GI.Gtk.Widget+pollingBarNew cfg pollSeconds action = do+  context <- ask+  (drawArea, h) <- verticalBarNew cfg++  liftIO $ do+    _ <- GI.Gtk.onWidgetRealize drawArea $ do+      sampleThread <-+        runReaderT+          ( taffyForeverWithDelay pollSeconds $+              liftIO $ do+                esample <- tryAny action+                traverse_ (verticalBarSetPercent h) esample+          )+          context+      void $ GI.Gtk.onWidgetUnrealize drawArea $ killThread sampleThread+    return ()++  return drawArea
src/System/Taffybar/Widget/Generic/PollingGraph.hs view
@@ -1,46 +1,58 @@ -- | A variant of the Graph widget that automatically updates itself -- with a callback at a fixed interval.-module System.Taffybar.Widget.Generic.PollingGraph (-  -- * Types-  GraphHandle,-  GraphConfig(..),-  GraphDirection(..),-  GraphStyle(..),-  -- * Constructors and accessors-  pollingGraphNew,-  pollingGraphNewWithTooltip,-  defaultGraphConfig-  ) where+module System.Taffybar.Widget.Generic.PollingGraph+  ( -- * Types+    GraphHandle,+    GraphConfig (..),+    GraphDirection (..),+    GraphStyle (..), -import           Control.Concurrent+    -- * Constructors and accessors+    pollingGraphNew,+    pollingGraphNewWithTooltip,+    defaultGraphConfig,+  )+where++import Control.Concurrent import qualified Control.Exception.Enclosed as E-import           Control.Monad-import           Control.Monad.IO.Class+import Control.Monad+import Control.Monad.IO.Class (liftIO)+import Control.Monad.Trans.Reader (ask, runReaderT) import qualified Data.Text as T-import           GI.Gtk-import           System.Taffybar.Util-import           System.Taffybar.Widget.Generic.Graph+import GI.Gtk+import System.Taffybar.Context (TaffyIO)+import System.Taffybar.Information.Wakeup (taffyForeverWithDelay)+import System.Taffybar.Widget.Generic.Graph -pollingGraphNewWithTooltip-  :: MonadIO m-  => GraphConfig -> Double -> IO ([Double], Maybe T.Text) -> m GI.Gtk.Widget-pollingGraphNewWithTooltip cfg pollSeconds action = liftIO $ do+-- | Construct a polling graph whose callback also supplies tooltip text.+pollingGraphNewWithTooltip ::+  GraphConfig -> Double -> IO ([Double], Maybe T.Text) -> TaffyIO GI.Gtk.Widget+pollingGraphNewWithTooltip cfg pollSeconds action = do+  context <- ask   (graphWidget, graphHandle) <- graphNew cfg -  _ <- onWidgetRealize graphWidget $ do-       sampleThread <- foreverWithDelay pollSeconds $ do-         esample <- E.tryAny action-         case esample of-           Left _ -> return ()-           Right (sample, tooltipStr) -> do-             graphAddSample graphHandle sample-             widgetSetTooltipMarkup graphWidget tooltipStr-       void $ onWidgetUnrealize graphWidget $ killThread sampleThread+  liftIO $ do+    _ <- onWidgetRealize graphWidget $ do+      sampleThread <-+        runReaderT+          ( taffyForeverWithDelay pollSeconds $+              liftIO $ do+                esample <- E.tryAny action+                case esample of+                  Left _ -> return ()+                  Right (sample, tooltipStr) -> do+                    graphAddSample graphHandle sample+                    widgetSetTooltipMarkup graphWidget tooltipStr+          )+          context+      void $ onWidgetUnrealize graphWidget $ killThread sampleThread+    return ()    return graphWidget -pollingGraphNew-  :: MonadIO m-  => GraphConfig -> Double -> IO [Double] -> m GI.Gtk.Widget+-- | Construct a polling graph from a fixed-interval sample callback.+pollingGraphNew ::+  GraphConfig -> Double -> IO [Double] -> TaffyIO GI.Gtk.Widget pollingGraphNew cfg pollSeconds action =-  pollingGraphNewWithTooltip cfg pollSeconds $ fmap (, Nothing) action+  pollingGraphNewWithTooltip cfg pollSeconds $ fmap (,Nothing) action
src/System/Taffybar/Widget/Generic/PollingLabel.hs view
@@ -4,17 +4,17 @@ -- a callback at a set interval. module System.Taffybar.Widget.Generic.PollingLabel where -import           Control.Concurrent-import           Control.Exception.Enclosed as E-import           Control.Monad-import           Control.Monad.IO.Class+import Control.Concurrent+import Control.Exception.Enclosed as E+import Control.Monad+import Control.Monad.IO.Class import qualified Data.Text as T-import           GI.Gtk import qualified GI.Gdk as Gdk-import           System.Log.Logger-import           System.Taffybar.Util-import           System.Taffybar.Widget.Util-import           Text.Printf+import GI.Gtk+import System.Log.Logger+import System.Taffybar.Util+import System.Taffybar.Widget.Util+import Text.Printf  -- | Create a new widget that updates itself at regular intervals.  The -- function@@ -29,62 +29,105 @@ -- -- If the IO action throws an exception, it will be swallowed and the label will -- not update until the update interval expires.-pollingLabelNew-  :: MonadIO m-  => Double -- ^ Update interval (in seconds)-  -> IO T.Text -- ^ Command to run to get the input string-  -> m GI.Gtk.Widget+pollingLabelNew ::+  (MonadIO m) =>+  -- | Update interval (in seconds)+  Double ->+  -- | Command to run to get the input string+  IO T.Text ->+  m GI.Gtk.Widget pollingLabelNew interval cmd =-  pollingLabelNewWithTooltip interval $ (, Nothing) <$> cmd+  pollingLabelNewWithTooltip interval $ (,Nothing) <$> cmd -pollingLabelNewWithTooltip-  :: MonadIO m-  => Double -- ^ Update interval (in seconds)-  -> IO (T.Text, Maybe T.Text) -- ^ Command to run to get the input string-  -> m GI.Gtk.Widget+-- | Like 'pollingLabelNew', but also updates tooltip text.+pollingLabelNewWithTooltip ::+  (MonadIO m) =>+  -- | Update interval (in seconds)+  Double ->+  -- | Command to run to get the input string+  IO (T.Text, Maybe T.Text) ->+  m GI.Gtk.Widget pollingLabelNewWithTooltip interval action =   pollingLabelWithVariableDelay $ withInterval <$> action-    where withInterval (a, b) = (a, b, interval)+  where+    withInterval (a, b) = (a, b, interval) -pollingLabelWithVariableDelay-  :: MonadIO m-  => IO (T.Text, Maybe T.Text, Double)-  -> m GI.Gtk.Widget-pollingLabelWithVariableDelay action =-  pollingLabelWithVariableDelayAndRefresh action False+-- | Create a polling label where each action result controls the next delay.+pollingLabelWithVariableDelay ::+  (MonadIO m) =>+  IO (T.Text, Maybe T.Text, Double) ->+  m GI.Gtk.Widget+pollingLabelWithVariableDelay =+  pollingLabelWithVariableDelayWithConfig defaultPollingLabelConfig +data PollingLabelConfig d = PollingLabelConfig+  { pollingLabelRefreshOnClick :: Bool,+    pollingLabelVariableDelayConfig :: VariableDelayConfig d+  }++defaultPollingLabelConfig :: PollingLabelConfig d+defaultPollingLabelConfig =+  PollingLabelConfig+    { pollingLabelRefreshOnClick = False,+      pollingLabelVariableDelayConfig = defaultVariableDelayConfig+    }+ -- TODO: Customize the delay and message on mouse click-pollingLabelWithVariableDelayAndRefresh-  :: MonadIO m-  => IO (T.Text, Maybe T.Text, Double)-  -> Bool -- ^ Whether to refresh the label on mouse click-  -> m GI.Gtk.Widget++-- | Like 'pollingLabelWithVariableDelay', with optional click-to-refresh.+pollingLabelWithVariableDelayAndRefresh ::+  (MonadIO m) =>+  IO (T.Text, Maybe T.Text, Double) ->+  -- | Whether to refresh the label on mouse click+  Bool ->+  m GI.Gtk.Widget pollingLabelWithVariableDelayAndRefresh action refreshOnClick =+  pollingLabelWithVariableDelayWithConfig+    ( defaultPollingLabelConfig+        { pollingLabelRefreshOnClick = refreshOnClick+        }+    )+    action++pollingLabelWithVariableDelayWithConfig ::+  (MonadIO m) =>+  PollingLabelConfig Double ->+  IO (T.Text, Maybe T.Text, Double) ->+  m GI.Gtk.Widget+pollingLabelWithVariableDelayWithConfig config action =   liftIO $ do     grid <- gridNew     label <- labelNew Nothing     ebox <- eventBoxNew+    _ <- widgetSetClassGI grid "polling-label-container"+    _ <- widgetSetClassGI label "polling-label-text"+    _ <- widgetSetClassGI ebox "polling-label" -    when refreshOnClick $ void $ onWidgetButtonPressEvent ebox $ onClick [Gdk.EventTypeButtonPress] $ do+    when (pollingLabelRefreshOnClick config) $ void $ onWidgetButtonPressEvent ebox $ onClick [Gdk.EventTypeButtonPress] $ do       postGUIASync $ labelSetMarkup label "Refreshing..."       forkIO $ do-        newLavelStr <- E.tryAny action >>= \case-          Left _                  -> return "Error"-          Right (_labelStr, _, _) -> return _labelStr+        newLavelStr <-+          E.tryAny action >>= \case+            Left _ -> return "Error"+            Right (_labelStr, _, _) -> return _labelStr         postGUIASync $ labelSetMarkup label newLavelStr      let updateLabel (labelStr, tooltipStr, delay) = do           postGUIASync $ do-             labelSetMarkup label labelStr-             widgetSetTooltipMarkup label tooltipStr+            labelSetMarkup label labelStr+            widgetSetTooltipMarkup label tooltipStr           logM "System.Taffybar.Widget.Generic.PollingLabel" DEBUG $-               printf "Polling label delay was %s" $ show delay+            printf "Polling label delay was %s" $+              show delay           return delay         updateLabelHandlingErrors =           E.tryAny action >>= either (const $ return 1) updateLabel      _ <- onWidgetRealize label $ do-      sampleThread <- foreverWithVariableDelay updateLabelHandlingErrors+      sampleThread <-+        foreverWithVariableDelayWithConfig+          (pollingLabelVariableDelayConfig config)+          updateLabelHandlingErrors       void $ onWidgetUnrealize label $ killThread sampleThread      vFillCenter label
src/System/Taffybar/Widget/Generic/ScalingImage.hs view
@@ -6,39 +6,40 @@ -- (plain IO with an explicit strategy) instead of calling the underlying -- implementations directly. module System.Taffybar.Widget.Generic.ScalingImage-  ( scalingImageNew-  , scalingImage-  , getScalingImageStrategy-  , setScalingImageStrategy-  ) where+  ( scalingImageNew,+    scalingImage,+    getScalingImageStrategy,+    setScalingImageStrategy,+  )+where -import           Control.Monad-import           Control.Monad.IO.Class-import           Data.Int-import           Data.Typeable+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+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+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 ::+  ImageScaleStrategy ->+  (Int32 -> IO (Maybe Gdk.Pixbuf)) ->+  Gtk.Orientation ->+  IO (Gtk.Widget, IO ()) scalingImageNew ImageResize getPixbuf orientation = do   image <- Gtk.imageNew   let scaledGetter size =@@ -53,10 +54,10 @@   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 ::+  (Int32 -> IO (Maybe Gdk.Pixbuf)) ->+  Gtk.Orientation ->+  TaffyIO (Gtk.Widget, IO ()) scalingImage getPixbuf orientation = do   strategy <- getScalingImageStrategy   liftIO $ scalingImageNew strategy getPixbuf orientation
src/System/Taffybar/Widget/Generic/VerticalBar.hs view
@@ -1,85 +1,96 @@ -- | A vertical bar that can plot data in the range [0, 1].  The -- colors are configurable.-module System.Taffybar.Widget.Generic.VerticalBar (-  -- * Types-  VerticalBarHandle,-  BarConfig(..),-  BarDirection(..),-  -- * Accessors/Constructors-  verticalBarNew,-  verticalBarSetPercent,-  defaultBarConfig,-  defaultBarConfigIO-  ) where+module System.Taffybar.Widget.Generic.VerticalBar+  ( -- * Types+    VerticalBarHandle,+    BarConfig (..),+    BarDirection (..), -import           Control.Concurrent-import           Control.Monad-import           Control.Monad.IO.Class+    -- * Accessors/Constructors+    verticalBarNew,+    verticalBarSetPercent,+    defaultBarConfig,+    defaultBarConfigIO,+  )+where++import Control.Concurrent+import Control.Monad+import Control.Monad.IO.Class import qualified GI.Cairo.Render as C-import           GI.Cairo.Render.Connector-import           GI.Gtk hiding (widgetGetAllocatedSize)-import           System.Taffybar.Util-import           System.Taffybar.Widget.Util+import GI.Cairo.Render.Connector+import GI.Gtk hiding (widgetGetAllocatedSize)+import System.Taffybar.Util+import System.Taffybar.Widget.Util +-- | Handle used to update an existing vertical bar widget. newtype VerticalBarHandle = VBH (MVar VerticalBarState)+ data VerticalBarState = VerticalBarState-  { barIsBootstrapped :: Bool-  , barPercent :: Double-  , barCanvas :: DrawingArea-  , barConfig :: BarConfig+  { barIsBootstrapped :: Bool,+    barPercent :: Double,+    barCanvas :: DrawingArea,+    barConfig :: BarConfig   } +-- | Direction in which the filled portion grows. data BarDirection = HORIZONTAL | VERTICAL +-- | Static or IO-driven configuration for the vertical bar. data BarConfig-  = BarConfig {-     -- | Color of the border drawn around the widget-      barBorderColor :: (Double, Double, Double)-     -- | The background color of the widget-    , barBackgroundColor :: Double -> (Double, Double, Double)-     -- | A function to determine the color of the widget for the current data point-    , barColor :: Double -> (Double, Double, Double)-     -- | Number of pixels of padding around the widget-    , barPadding :: Int-    , barWidth :: Int-    , barDirection :: BarDirection}-  | BarConfigIO { barBorderColorIO :: IO (Double, Double, Double)-                , barBackgroundColorIO :: Double -> IO (Double, Double, Double)-                , barColorIO :: Double -> IO (Double, Double, Double)-                , barPadding :: Int-                , barWidth :: Int-                , barDirection :: BarDirection}+  = BarConfig+      { -- | Color of the border drawn around the widget+        barBorderColor :: (Double, Double, Double),+        -- | The background color of the widget+        barBackgroundColor :: Double -> (Double, Double, Double),+        -- | A function to determine the color of the widget for the current data point+        barColor :: Double -> (Double, Double, Double),+        -- | Number of pixels of padding around the widget+        barPadding :: Int,+        barWidth :: Int,+        barDirection :: BarDirection+      }+  | BarConfigIO+      { barBorderColorIO :: IO (Double, Double, Double),+        barBackgroundColorIO :: Double -> IO (Double, Double, Double),+        barColorIO :: Double -> IO (Double, Double, Double),+        barPadding :: Int,+        barWidth :: Int,+        barDirection :: BarDirection+      }  -- | A default bar configuration.  The color of the active portion of -- the bar must be specified. defaultBarConfig :: (Double -> (Double, Double, Double)) -> BarConfig defaultBarConfig c =   BarConfig-  { barBorderColor = (0.5, 0.5, 0.5)-  , barBackgroundColor = const (0, 0, 0)-  , barColor = c-  , barPadding = 2-  , barWidth = 15-  , barDirection = VERTICAL-  }+    { barBorderColor = (0.5, 0.5, 0.5),+      barBackgroundColor = const (0, 0, 0),+      barColor = c,+      barPadding = 2,+      barWidth = 15,+      barDirection = VERTICAL+    } +-- | IO-driven variant of 'defaultBarConfig'. defaultBarConfigIO :: (Double -> IO (Double, Double, Double)) -> BarConfig defaultBarConfigIO c =   BarConfigIO-  { barBorderColorIO = return (0.5, 0.5, 0.5)-  , barBackgroundColorIO = \_ -> return (0, 0, 0)-  , barColorIO = c-  , barPadding = 2-  , barWidth = 15-  , barDirection = VERTICAL-  }+    { barBorderColorIO = return (0.5, 0.5, 0.5),+      barBackgroundColorIO = \_ -> return (0, 0, 0),+      barColorIO = c,+      barPadding = 2,+      barWidth = 15,+      barDirection = VERTICAL+    } +-- | Update the bar value (clamped to @[0, 1]@) and queue a redraw. verticalBarSetPercent :: VerticalBarHandle -> Double -> IO () verticalBarSetPercent (VBH mv) pct = do   s <- readMVar mv   let drawArea = barCanvas s   when (barIsBootstrapped s) $ do-    modifyMVar_ mv (\s' -> return s' { barPercent = clamp 0 1 pct })+    modifyMVar_ mv (\s' -> return s' {barPercent = clamp 0 1 pct})     postGUIASync $ widgetQueueDraw drawArea  clamp :: Double -> Double -> Double -> Double@@ -88,20 +99,20 @@ liftedBackgroundColor :: BarConfig -> Double -> IO (Double, Double, Double) liftedBackgroundColor bc pct =   case bc of-    BarConfig { barBackgroundColor = bcolor } -> return (bcolor pct)-    BarConfigIO { barBackgroundColorIO = bcolor } -> bcolor pct+    BarConfig {barBackgroundColor = bcolor} -> return (bcolor pct)+    BarConfigIO {barBackgroundColorIO = bcolor} -> bcolor pct  liftedBorderColor :: BarConfig -> IO (Double, Double, Double) liftedBorderColor bc =   case bc of-    BarConfig { barBorderColor = border } -> return border-    BarConfigIO { barBorderColorIO = border } -> border+    BarConfig {barBorderColor = border} -> return border+    BarConfigIO {barBorderColorIO = border} -> border  liftedBarColor :: BarConfig -> Double -> IO (Double, Double, Double) liftedBarColor bc pct =   case bc of-    BarConfig { barColor = c } -> return (c pct)-    BarConfigIO { barColorIO = c } -> c pct+    BarConfig {barColor = c} -> return (c pct)+    BarConfigIO {barColorIO = c} -> c pct  renderFrame_ :: Double -> BarConfig -> Int -> Int -> C.Render () renderFrame_ pct cfg width height = do@@ -127,14 +138,14 @@ renderBar pct cfg width height = do   let direction = barDirection cfg       activeHeight = case direction of-                       VERTICAL   -> pct * fromIntegral height-                       HORIZONTAL -> fromIntegral height-      activeWidth  = case direction of-                       VERTICAL   -> fromIntegral width-                       HORIZONTAL -> pct * fromIntegral width-      newOrigin    = case direction of-                       VERTICAL -> fromIntegral height - activeHeight-                       HORIZONTAL -> 0+        VERTICAL -> pct * fromIntegral height+        HORIZONTAL -> fromIntegral height+      activeWidth = case direction of+        VERTICAL -> fromIntegral width+        HORIZONTAL -> pct * fromIntegral width+      newOrigin = case direction of+        VERTICAL -> fromIntegral height - activeHeight+        HORIZONTAL -> 0       pad = barPadding cfg    renderFrame_ pct cfg width height@@ -156,22 +167,23 @@ drawBar mv drawArea = do   (w, h) <- widgetGetAllocatedSize drawArea   s <- liftIO $ do-         s <- readMVar mv-         modifyMVar_ mv (\s' -> return s' { barIsBootstrapped = True })-         return s+    s <- readMVar mv+    modifyMVar_ mv (\s' -> return s' {barIsBootstrapped = True})+    return s   renderBar (barPercent s) (barConfig s) w h -verticalBarNew :: MonadIO m => BarConfig -> m (GI.Gtk.Widget, VerticalBarHandle)+-- | Construct a bar widget and its mutable update handle.+verticalBarNew :: (MonadIO m) => BarConfig -> m (GI.Gtk.Widget, VerticalBarHandle) verticalBarNew cfg = liftIO $ do   drawArea <- drawingAreaNew   mv <-     newMVar       VerticalBarState-      { barIsBootstrapped = False-      , barPercent = 0-      , barCanvas = drawArea-      , barConfig = cfg-      }+        { barIsBootstrapped = False,+          barPercent = 0,+          barCanvas = drawArea,+          barConfig = cfg+        }   widgetSetSizeRequest drawArea (fromIntegral $ barWidth cfg) (-1)   _ <- onWidgetDraw drawArea $ \ctx -> renderWithContext (drawBar mv drawArea) ctx >> return True   box <- boxNew OrientationHorizontal 1
src/System/Taffybar/Widget/HyprlandLayout.hs view
@@ -1,6 +1,9 @@ {-# LANGUAGE OverloadedStrings #-}  -----------------------------------------------------------------------------++-----------------------------------------------------------------------------+ -- | -- Module      : System.Taffybar.Widget.HyprlandLayout -- Copyright   : (c) Ivan A. Malison@@ -12,54 +15,56 @@ -- -- Simple text widget that shows the Hyprland layout used in the currently -- active workspace.------------------------------------------------------------------------------- module System.Taffybar.Widget.HyprlandLayout-  ( HyprlandLayoutConfig(..)-  , defaultHyprlandLayoutConfig-  , hyprlandLayoutNew-  ) where+  ( 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 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 GI.Gdk import qualified GI.Gtk as Gtk-import           System.Log.Logger (Priority(..))-import           System.Taffybar.Context-import           System.Taffybar.Hyprland-  ( runHyprlandCommandJsonT-  , runHyprlandCommandRawT+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+import System.Taffybar.Information.Wakeup (taffyForeverWithDelay)+import System.Taffybar.Util+import System.Taffybar.Widget.Util +-- | Configuration for 'hyprlandLayoutNew'. data HyprlandLayoutConfig = HyprlandLayoutConfig-  { formatLayout :: T.Text -> TaffyIO T.Text-  , updateIntervalSeconds :: Double-  , onLeftClick :: Maybe [String]-  , onRightClick :: Maybe [String]+  { formatLayout :: T.Text -> TaffyIO T.Text,+    updateIntervalSeconds :: Double,+    onLeftClick :: Maybe [String],+    onRightClick :: Maybe [String]   }  instance Default HyprlandLayoutConfig where   def = defaultHyprlandLayoutConfig +-- | Default Hyprland layout widget configuration. defaultHyprlandLayoutConfig :: HyprlandLayoutConfig defaultHyprlandLayoutConfig =   HyprlandLayoutConfig-  { formatLayout = return-  , updateIntervalSeconds = 1-  , onLeftClick = Nothing-  , onRightClick = Nothing-  }+    { formatLayout = return,+      updateIntervalSeconds = 1,+      onLeftClick = Nothing,+      onRightClick = Nothing+    }  -- | Create a new Hyprland Layout widget. hyprlandLayoutNew :: HyprlandLayoutConfig -> TaffyIO Gtk.Widget@@ -74,8 +79,7 @@         lift $ postGUIASync $ Gtk.labelSetMarkup label markup    void refresh-  threadId <- lift $ foreverWithDelay (updateIntervalSeconds config) $-    void $ runReaderT refresh ctx+  threadId <- taffyForeverWithDelay (updateIntervalSeconds config) (void refresh)    ebox <- lift Gtk.eventBoxNew   lift $ Gtk.containerAdd ebox label@@ -106,15 +110,19 @@       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)+          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)+  }+  deriving (Show, Eq)  instance FromJSON HyprlandActiveWorkspace where   parseJSON = withObject "HyprlandActiveWorkspace" $ \v -> do@@ -126,17 +134,20 @@   result <- runHyprctlJson ["-j", "activeworkspace"]   case result of     Left err ->-      logPrintF "System.Taffybar.Widget.HyprlandLayout" WARNING-        "hyprctl activeworkspace failed: %s" err >>-      return ""+      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 :: (FromJSON a) => [String] -> TaffyIO (Either String a) runHyprctlJson args = do   let args' =         case args of-          ("-j":rest) -> rest+          ("-j" : rest) -> rest           _ -> args   result <- runHyprlandCommandJsonT (Hypr.hyprCommandJson args')   pure $ case result of
− src/System/Taffybar/Widget/HyprlandWindows.hs 
@@ -1,175 +0,0 @@-{-# 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
@@ -1,7 +1,7 @@-{-# LANGUAGE ExistentialQuantification #-}-{-# LANGUAGE OverloadedStrings #-}+-----------------------------------------------------------------------------  -----------------------------------------------------------------------------+ -- | -- Module      : System.Taffybar.Widget.HyprlandWorkspaces -- Copyright   : (c) Ivan A. Malison@@ -10,871 +10,58 @@ -- 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+module System.Taffybar.Widget.HyprlandWorkspaces+  {-# DEPRECATED "Legacy Hyprland workspaces widget API. Use System.Taffybar.Widget.Workspaces (or System.Taffybar.Widget.ChannelWorkspaces) instead." #-}+  ( module System.Taffybar.Widget.Workspaces.Hyprland,+    HyprlandWorkspacesConfig (..),+    defaultHyprlandWorkspacesConfig,+    hyprlandWorkspacesNew,+    hyprlandWorkspacesCommonConfig,+    applyCommonHyprlandWorkspacesConfig,+    refreshWorkspaces,+    applyUrgentState,+    hyprlandBuildLabelController,+    hyprlandBuildIconController,+    hyprlandBuildContentsController,+    hyprlandBuildLabelOverlayController,+    hyprlandBuildCustomOverlayController,+    hyprlandBuildButtonController,+    defaultHyprlandWidgetBuilder,+    buildIconWidget,   )-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+where++import System.Taffybar.Widget.Workspaces.Hyprland hiding+  ( HyprlandWorkspacesConfig (..),+    applyCommonHyprlandWorkspacesConfig,+    applyUrgentState,+    buildIconWidget,+    defaultHyprlandWidgetBuilder,+    defaultHyprlandWorkspacesConfig,+    hyprlandBuildButtonController,+    hyprlandBuildContentsController,+    hyprlandBuildCustomOverlayController,+    hyprlandBuildIconController,+    hyprlandBuildLabelController,+    hyprlandBuildLabelOverlayController,+    hyprlandWorkspacesCommonConfig,+    hyprlandWorkspacesNew,+    refreshWorkspaces,   )-import           System.Taffybar.Widget.Generic.ScalingImage (getScalingImageStrategy)-import           System.Taffybar.Widget.Workspaces.Shared-  ( WorkspaceState(..)-  , setWorkspaceWidgetStatusClass-  , buildWorkspaceIconLabelOverlay-  , mkWorkspaceIconWidget+import System.Taffybar.Widget.Workspaces.Hyprland.Compat+  ( HyprlandWorkspacesConfig (..),+    applyCommonHyprlandWorkspacesConfig,+    applyUrgentState,+    buildIconWidget,+    defaultHyprlandWidgetBuilder,+    defaultHyprlandWorkspacesConfig,+    hyprlandBuildButtonController,+    hyprlandBuildContentsController,+    hyprlandBuildCustomOverlayController,+    hyprlandBuildIconController,+    hyprlandBuildLabelController,+    hyprlandBuildLabelOverlayController,+    hyprlandWorkspacesCommonConfig,+    hyprlandWorkspacesNew,+    refreshWorkspaces,   )-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/ImageCommandButton.hs view
@@ -0,0 +1,80 @@+--------------------------------------------------------------------------------++--------------------------------------------------------------------------------++-- |+-- Module      : System.Taffybar.Widget.ImageCommandButton+-- Copyright   : (c) Ulf Jasper+-- License     : BSD3-style (see LICENSE)+--+-- Maintainer  : Ulf Jasper <ulf.jasper@web.de>+-- Stability   : unstable+-- Portability : unportable+--+-- Simple button which shows an image and runs a user defined command when+-- being clicked.+module System.Taffybar.Widget.ImageCommandButton+  ( -- * Usage+    -- $usage+    imageCommandButtonNew,+    imageCommandButtonNewFromName,+  )+where++import Control.Monad (void)+import Control.Monad.IO.Class+import qualified Data.Text as T+import GI.Gtk+import System.Process++-- $usage+--+-- In order to use this widget add the following lines to your+-- @taffybar.hs@ file:+--+-- > import System.Taffybar.Widget+-- > main = do+-- >   let fileIconButton = imageCommandButtonNew "/path/to/icon.png" "xterm"+-- >       themedIconButton = imageCommandButtonNewFromName "system-shutdown" "systemctl poweroff"+--+-- Now you can use these widgets like any other Taffybar widget.++-- | Creates a new image command button using an icon from a file path.+imageCommandButtonNew ::+  (MonadIO m) =>+  -- | File path of the image.+  FilePath ->+  -- | Command to execute. Should be in $PATH or an absolute path.+  T.Text ->+  m Widget+imageCommandButtonNew path cmd = do+  image <- imageNewFromFile path+  imageCommandButtonWithImage image cmd++-- | Creates a new image command button using an icon from the current GTK+-- theme.+imageCommandButtonNewFromName ::+  (MonadIO m) =>+  -- | Name of the icon in the current GTK icon theme.+  T.Text ->+  -- | Command to execute. Should be in $PATH or an absolute path.+  T.Text ->+  m Widget+imageCommandButtonNewFromName iconName cmd = do+  image <-+    imageNewFromIconName+      (Just iconName)+      (fromIntegral $ fromEnum IconSizeMenu)+  imageCommandButtonWithImage image cmd++imageCommandButtonWithImage ::+  (MonadIO m) =>+  Image ->+  T.Text ->+  m Widget+imageCommandButtonWithImage image cmd = do+  button <- buttonNew+  containerAdd button image+  void $ onButtonClicked button $ void $ spawnCommand $ T.unpack cmd+  widgetShowAll button+  toWidget button
src/System/Taffybar/Widget/Inhibitor.hs view
@@ -1,5 +1,9 @@ {-# LANGUAGE OverloadedStrings #-}+ -----------------------------------------------------------------------------++-----------------------------------------------------------------------------+ -- | -- Module      : System.Taffybar.Widget.Inhibitor -- Copyright   : (c) Ivan A. Malison@@ -27,60 +31,64 @@ -- >         , inhibitorActiveText = "AWAKE" -- >         , inhibitorInactiveText = "zzz" -- >         }------------------------------------------------------------------------------ module System.Taffybar.Widget.Inhibitor   ( -- * Widget constructors-    inhibitorNew-  , inhibitorNewWithConfig-  , inhibitorIconNew-  , inhibitorIconNewWithConfig-  , inhibitorLabelNew-  , inhibitorLabelNewWithConfig+    inhibitorNew,+    inhibitorNewWithConfig,+    inhibitorIconNew,+    inhibitorIconNewWithConfig,+    inhibitorLabelNew,+    inhibitorLabelNewWithConfig,+     -- * Configuration-  , InhibitorConfig(..)-  , defaultInhibitorConfig+    InhibitorConfig (..),+    defaultInhibitorConfig,+     -- * Re-exports-  , InhibitType(..)-  ) where+    InhibitType (..),+  )+where -import           Control.Monad-import           Control.Monad.IO.Class-import           Control.Monad.Trans.Reader+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+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]+    inhibitWhat :: [InhibitType],     -- | Text to display when inhibitor is active-  , inhibitorActiveText :: T.Text+    inhibitorActiveText :: T.Text,     -- | Text to display when inhibitor is inactive-  , inhibitorInactiveText :: T.Text+    inhibitorInactiveText :: T.Text,     -- | Icon to display when inhibitor is active (default: U+F0F4, nf-fa-coffee)-  , inhibitorActiveIcon :: T.Text+    inhibitorActiveIcon :: T.Text,     -- | Icon to display when inhibitor is inactive (default: U+F236, nf-fa-bed)-  , inhibitorInactiveIcon :: T.Text+    inhibitorInactiveIcon :: T.Text,     -- | CSS class prefix (results in "prefix-active" and "prefix-inactive")-  , inhibitorCssPrefix :: T.Text-  } deriving (Eq, Show)+    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"-  }+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@@ -124,11 +132,12 @@   ctx <- ask   liftIO $ do     label <- labelNew Nothing-    let updateIcon state = postGUIASync $-          labelSetText label $-            if inhibitorActive state-            then inhibitorActiveIcon config-            else inhibitorInactiveIcon config+    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@@ -168,14 +177,16 @@     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"-                     )+                  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
src/System/Taffybar/Widget/KeyboardState.hs view
@@ -1,6 +1,9 @@ {-# LANGUAGE OverloadedStrings #-}  --------------------------------------------------------------------------------++--------------------------------------------------------------------------------+ -- | -- Module      : System.Taffybar.Widget.KeyboardState -- Copyright   : (c) Ivan Malison@@ -12,23 +15,23 @@ -- -- 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+    keyboardStateNew,+    keyboardStateNewWithConfig,+    keyboardStateLabelNew,+    keyboardStateLabelNewWithConfig,+    keyboardStateIconNew,+    keyboardStateIconNewWithConfig,+     -- * Configuration-  , KeyboardStateConfig(..)-  , defaultKeyboardStateConfig+    KeyboardStateConfig (..),+    defaultKeyboardStateConfig,+     -- * Format Functions-  , formatKeyboardState-  ) where+    formatKeyboardState,+  )+where  import Control.Monad.IO.Class (MonadIO, liftIO) import qualified Data.Text as T@@ -39,92 +42,99 @@  -- | 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)+  { -- | Text to display when Caps Lock is on. Default: "[CAPS]"+    kscCapsLockOnText :: T.Text,+    -- | Text to display when Caps Lock is off. Default: ""+    kscCapsLockOffText :: T.Text,+    -- | Text to display when Num Lock is on. Default: "[NUM]"+    kscNumLockOnText :: T.Text,+    -- | Text to display when Num Lock is off. Default: ""+    kscNumLockOffText :: T.Text,+    -- | Text to display when Scroll Lock is on. Default: "[SCROLL]"+    kscScrollLockOnText :: T.Text,+    -- | Text to display when Scroll Lock is off. Default: ""+    kscScrollLockOffText :: T.Text,+    -- | Whether to show Caps Lock state. Default: True+    kscShowCapsLock :: Bool,+    -- | Whether to show Num Lock state. Default: False+    kscShowNumLock :: Bool,+    -- | Whether to show Scroll Lock state. Default: False+    kscShowScrollLock :: Bool,+    -- | Separator between lock indicators. Default: " "+    kscSeparator :: T.Text,+    -- | Polling interval in seconds. Default: 0.5+    kscPollingInterval :: Double,+    -- | Icon text for the icon widget variant. Default: keyboard icon (nf-md-keyboard)+    kscIcon :: T.Text+  }+  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"-  }+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+  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 :: (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 :: (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 :: (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 :: (MonadIO m) => KeyboardStateConfig -> m Gtk.Widget keyboardStateIconNewWithConfig cfg = liftIO $ do   label <- Gtk.labelNew (Just (kscIcon cfg))   Gtk.widgetShowAll label@@ -132,12 +142,12 @@  -- | Create a combined keyboard state widget (icon + label) with default -- configuration.-keyboardStateNew :: MonadIO m => m Gtk.Widget+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 :: (MonadIO m) => KeyboardStateConfig -> m Gtk.Widget keyboardStateNewWithConfig cfg = do   iconWidget <- keyboardStateIconNewWithConfig cfg   labelWidget <- keyboardStateLabelNewWithConfig cfg
src/System/Taffybar/Widget/Layout.hs view
@@ -1,5 +1,9 @@ {-# LANGUAGE OverloadedStrings #-}+ -----------------------------------------------------------------------------++-----------------------------------------------------------------------------+ -- | -- Module      : System.Taffybar.Widget.Layout -- Copyright   : (c) Ivan Malison@@ -13,27 +17,25 @@ -- workspace, and that allows to change it by clicking with the mouse: -- left-click to switch to the next layout in the list, right-click to switch to -- the first one (as configured in @xmonad.hs@)------------------------------------------------------------------------------- module System.Taffybar.Widget.Layout-  (-  -- * Usage-  -- $usage-    LayoutConfig(..)-  , defaultLayoutConfig-  , layoutNew-  ) where+  ( -- * Usage+    -- $usage+    LayoutConfig (..),+    defaultLayoutConfig,+    layoutNew,+  )+where -import           Control.Monad.Trans.Class-import           Control.Monad.Trans.Reader-import           Data.Default (Default(..))+import Control.Monad.Trans.Class+import Control.Monad.Trans.Reader+import Data.Default (Default (..)) import qualified Data.Text as T+import GI.Gdk import qualified GI.Gtk as Gtk-import           GI.Gdk-import           System.Taffybar.Context-import           System.Taffybar.Information.X11DesktopInfo-import           System.Taffybar.Util-import           System.Taffybar.Widget.Util+import System.Taffybar.Context+import System.Taffybar.Information.X11DesktopInfo+import System.Taffybar.Util+import System.Taffybar.Widget.Util  -- $usage --@@ -54,10 +56,12 @@ -- -- now you can use @los@ as any other Taffybar widget. +-- | Configuration for how the current layout name is rendered. newtype LayoutConfig = LayoutConfig   { formatLayout :: T.Text -> TaffyIO T.Text   } +-- | Default layout formatting: display the layout name unchanged. defaultLayoutConfig :: LayoutConfig defaultLayoutConfig = LayoutConfig return @@ -102,10 +106,10 @@   buttonNumber <- getEventButtonButton btn   case pressType of     EventTypeButtonPress ->-        case buttonNumber of-          1 -> runReaderT (runX11Def () (switch 1)) context >> return True-          2 -> runReaderT (runX11Def () (switch (-1))) context >> return True-          _ -> return False+      case buttonNumber of+        1 -> runReaderT (runX11Def () (switch 1)) context >> return True+        2 -> runReaderT (runX11Def () (switch (-1))) context >> return True+        _ -> return False     _ -> return False  -- | Emit a new custom event of type _XMONAD_CURRENT_LAYOUT, that can be
src/System/Taffybar/Widget/MPRIS2.hs view
@@ -1,7 +1,11 @@+{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RankNTypes #-}-{-# LANGUAGE FlexibleContexts #-}+ -----------------------------------------------------------------------------++-----------------------------------------------------------------------------+ -- | -- Module      : System.Taffybar.Widget.MPRIS2 -- Copyright   : (c) Ivan A. Malison@@ -14,49 +18,50 @@ -- This is a "Now Playing" widget that listens for MPRIS2 events on DBus. You -- can find the MPRIS2 specification here at -- (<https://specifications.freedesktop.org/mpris-spec/latest/>).------------------------------------------------------------------------------ module System.Taffybar.Widget.MPRIS2 where -import           Control.Arrow+import Control.Arrow import qualified Control.Concurrent.MVar as MV-import           Control.Monad-import           Control.Monad.IO.Class-import           Control.Monad.Trans.Class-import           Control.Monad.Trans.Except-import           Control.Monad.Trans.Reader-import           DBus-import           DBus.Client+import Control.Monad+import Control.Monad.IO.Class+import Control.Monad.Trans.Class+import Control.Monad.Trans.Except+import Control.Monad.Trans.Reader+import DBus+import DBus.Client import qualified DBus.TH as DBus-import           Data.Default (Default(..))-import           Data.GI.Base.Overloading (IsDescendantOf)-import           Data.Int-import           Data.List+import Data.Default (Default (..))+import Data.GI.Base.Overloading (IsDescendantOf)+import Data.Int+import Data.List import qualified Data.Map as M import qualified Data.Text as T import qualified GI.GLib as G-import           GI.GdkPixbuf.Objects.Pixbuf as Gdk+import GI.GdkPixbuf.Objects.Pixbuf as Gdk import qualified GI.Gtk as Gtk-import           System.Environment.XDG.DesktopEntry-import           System.Log.Logger-import           System.Taffybar.Context+import System.Environment.XDG.DesktopEntry+import System.Log.Logger+import System.Taffybar.Context import qualified System.Taffybar.DBus.Client.MPRIS2 as MPRIS2DBus-import           System.Taffybar.Information.MPRIS2-import           System.Taffybar.Util-import           System.Taffybar.Widget.Generic.AutoSizeImage-import           System.Taffybar.Widget.Util-import           System.Taffybar.WindowIcon-import           Text.Printf+import System.Taffybar.Information.MPRIS2+import System.Taffybar.Util+import System.Taffybar.Widget.Generic.AutoSizeImage+import System.Taffybar.Widget.Util+import System.Taffybar.WindowIcon+import Text.Printf +-- | Log helper for this module. mprisLog :: (MonadIO m, Show t) => Priority -> String -> t -> m () mprisLog = logPrintF "System.Taffybar.Widget.MPRIS2"  -- | A type representing a function that produces an IO action that adds the -- provided widget to some container. type WidgetAdder a m =-  (IsDescendantOf Gtk.Widget a-  , MonadIO m-  , Gtk.GObject a-  ) => a -> m ()+  ( IsDescendantOf Gtk.Widget a,+    MonadIO m,+    Gtk.GObject a+  ) =>+  a -> m ()  -- | The type of a customization function that is used to update a widget with -- the provided now playing info. The type a should be the internal state used@@ -69,209 +74,435 @@   (forall w. WidgetAdder w IO) -> Maybe a -> Maybe NowPlaying -> TaffyIO a  -- | Configuration for an MPRIS2 Widget-data MPRIS2Config a =-  MPRIS2Config-  {-  -- | A function that will be used to wrap the outer MPRIS2 grid widget-    mprisWidgetWrapper :: Gtk.Widget -> IO Gtk.Widget-  -- | This function will be called to instantiate and update the player widgets-  -- of each dbus player client. See the docstring for `UpdateMPRIS2PlayerWidget`-  -- for more details.-  , updatePlayerWidget :: UpdateMPRIS2PlayerWidget a+data MPRIS2Config a+  = MPRIS2Config+  { -- | A function that will be used to wrap the outer MPRIS2 grid widget+    mprisWidgetWrapper :: Gtk.Widget -> IO Gtk.Widget,+    -- | This function will be called to instantiate and update the player widgets+    -- of each dbus player client. See the docstring for `UpdateMPRIS2PlayerWidget`+    -- for more details.+    updatePlayerWidget :: UpdateMPRIS2PlayerWidget a   } +-- | Default MPRIS2 widget configuration using 'simplePlayerWidget'. defaultMPRIS2Config :: MPRIS2Config MPRIS2PlayerWidget defaultMPRIS2Config =   MPRIS2Config-  { mprisWidgetWrapper = return-  , updatePlayerWidget = simplePlayerWidget def-  }+    { mprisWidgetWrapper = return,+      updatePlayerWidget = simplePlayerWidget def+    } +-- | Internal widget state for the default simple player renderer. data MPRIS2PlayerWidget = MPRIS2PlayerWidget-  { playerLabel :: Gtk.Label-  , playerWidget :: Gtk.Widget+  { playerLabel :: Gtk.Label,+    playerWidget :: Gtk.Widget   } +data MPRIS2PlayerControlsWidget = MPRIS2PlayerControlsWidget+  { controlsPlayerLabel :: Gtk.Label,+    controlsPlayerWidget :: Gtk.Widget,+    controlsNowPlayingVar :: MV.MVar NowPlaying,+    controlsPreviousButton :: Gtk.Button,+    controlsPlayPauseButton :: Gtk.Button,+    controlsPlayPauseButtonLabel :: Gtk.Label,+    controlsNextButton :: Gtk.Button+  }++defaultMPRIS2ControlsConfig :: MPRIS2Config MPRIS2PlayerControlsWidget+defaultMPRIS2ControlsConfig =+  MPRIS2Config+    { mprisWidgetWrapper = return,+      updatePlayerWidget = simplePlayerWidgetWithControls def+    }++-- | Configuration for 'simplePlayerWidget'. data SimpleMPRIS2PlayerConfig = SimpleMPRIS2PlayerConfig-  { setNowPlayingLabel :: NowPlaying -> IO T.Text-  , showPlayerWidgetFn :: NowPlaying -> IO Bool+  { setNowPlayingLabel :: NowPlaying -> IO T.Text,+    showPlayerWidgetFn :: NowPlaying -> IO Bool   } +-- | Default 'SimpleMPRIS2PlayerConfig'. defaultPlayerConfig :: SimpleMPRIS2PlayerConfig-defaultPlayerConfig = SimpleMPRIS2PlayerConfig-  { setNowPlayingLabel = playingText 20 30-  , showPlayerWidgetFn =-    \NowPlaying { npStatus = status } -> return $ status /= "Stopped"-  }+defaultPlayerConfig =+  SimpleMPRIS2PlayerConfig+    { setNowPlayingLabel = playingText 20 30,+      showPlayerWidgetFn =+        \NowPlaying {npStatus = status} -> return $ status /= "Stopped"+    }  instance Default SimpleMPRIS2PlayerConfig where   def = defaultPlayerConfig +-- | Lift a @Maybe@-producing IO function into an 'ExceptT' with a custom+-- failure message. makeExcept :: String -> (a -> IO (Maybe b)) -> a -> ExceptT String IO b makeExcept errorString actionBuilder =   ExceptT . fmap (maybeToEither errorString) . actionBuilder +-- | Resolve an icon for a player bus name and load it at the requested size.+-- Falls back to a default icon (or a blank pixbuf) on errors. loadIconAtSize ::   Client -> BusName -> Int32 -> IO Gdk.Pixbuf loadIconAtSize client busName size =-  let-    failure err =-      mprisLog WARNING "Failed to load default image: %s" err >>-               pixBufFromColor size 0-    loadDefault =-      loadIcon size "play.svg" >>= either failure return-    logErrorAndLoadDefault err =-      mprisLog WARNING "Failed to get MPRIS icon: %s" err >>-      mprisLog WARNING "MPRIS failure for: %s" busName >>-      loadDefault-    chromeSpecialCase l@(Left _) =-      if "chrom" `isInfixOf` formatBusName busName-      then Right "google-chrome" else l-    chromeSpecialCase x = x-  in-    either logErrorAndLoadDefault return =<<-    runExceptT (ExceptT (left show . chromeSpecialCase <$> MPRIS2DBus.getDesktopEntry client busName)-                          >>= makeExcept "Failed to get desktop entry"-                              getDirectoryEntryDefault-                          >>= makeExcept "Failed to get image"-                                (getImageForDesktopEntry size))+  let failure err =+        mprisLog WARNING "Failed to load default image: %s" err+          >> pixBufFromColor size 0+      loadDefault =+        loadIcon size "play.svg" >>= either failure return+      logErrorAndLoadDefault err =+        mprisLog WARNING "Failed to get MPRIS icon: %s" err+          >> mprisLog WARNING "MPRIS failure for: %s" busName+          >> loadDefault+      chromeSpecialCase l@(Left _) =+        if "chrom" `isInfixOf` formatBusName busName+          then Right "google-chrome"+          else l+      chromeSpecialCase x = x+   in either logErrorAndLoadDefault return+        =<< runExceptT+          ( ExceptT (left show . chromeSpecialCase <$> MPRIS2DBus.getDesktopEntry client busName)+              >>= makeExcept+                "Failed to get desktop entry"+                getDirectoryEntryDefault+              >>= makeExcept+                "Failed to get image"+                (getImageForDesktopEntry size)+          ) --- | This is the default player widget constructor that is used to build mpris--- widgets. It provides only an icon and NowPlaying text.-simplePlayerWidget ::-  SimpleMPRIS2PlayerConfig -> UpdateMPRIS2PlayerWidget MPRIS2PlayerWidget+backIconText :: T.Text+backIconText = "⏮" -simplePlayerWidget _ _-                     (Just p@MPRIS2PlayerWidget { playerWidget = widget })-                     Nothing =-                       lift $ Gtk.widgetHide widget >> return p+playIconText :: T.Text+playIconText = "▶" -simplePlayerWidget c addToParent Nothing-                     np@(Just NowPlaying { npBusName = busName }) = do-  ctx <- ask-  client <- asks sessionDBusClient-  lift $ do-    mprisLog DEBUG "Building widget for %s" busName-    image <- autoSizeImageNew (loadIconAtSize client busName) Gtk.OrientationHorizontal-    playerBox <- Gtk.gridNew-    label <- Gtk.labelNew Nothing-    ebox <- Gtk.eventBoxNew-    _ <- Gtk.onWidgetButtonPressEvent ebox $-         const $ MPRIS2DBus.playPause client busName >> return True-    Gtk.containerAdd playerBox image-    Gtk.containerAdd playerBox label-    Gtk.containerAdd ebox playerBox-    vFillCenter playerBox-    addToParent ebox-    Gtk.widgetSetVexpand playerBox True-    Gtk.widgetSetName playerBox $ T.pack $ formatBusName busName-    Gtk.widgetShowAll ebox-    Gtk.widgetHide ebox-    widget <- Gtk.toWidget ebox-    let widgetData =-          MPRIS2PlayerWidget { playerLabel = label, playerWidget = widget }-    flip runReaderT ctx $-         simplePlayerWidget c addToParent (Just widgetData) np+pauseIconText :: T.Text+pauseIconText = "⏸" -simplePlayerWidget config _-                     (Just w@MPRIS2PlayerWidget-                             { playerLabel = label-                             , playerWidget = widget-                             }) (Just nowPlaying) = lift $ do-  mprisLog DEBUG "Setting state %s" nowPlaying-  Gtk.labelSetMarkup label =<< setNowPlayingLabel config nowPlaying-  shouldShow <- showPlayerWidgetFn config nowPlaying-  if shouldShow-  then Gtk.widgetShowAll widget-  else Gtk.widgetHide widget-  return w+nextIconText :: T.Text+nextIconText = "⏭" +toggleIconText :: T.Text+toggleIconText = "⏯"++isPlaying :: NowPlaying -> Bool+isPlaying NowPlaying {npStatus = status} = status == "Playing"++canTogglePlayback :: NowPlaying -> Bool+canTogglePlayback nowPlaying = npCanPause nowPlaying || npCanPlay nowPlaying++playPauseIconText :: NowPlaying -> T.Text+playPauseIconText nowPlaying+  | isPlaying nowPlaying && npCanPause nowPlaying = pauseIconText+  | npCanPlay nowPlaying = playIconText+  | otherwise = toggleIconText++runPlayPauseAction :: Client -> NowPlaying -> IO ()+runPlayPauseAction client nowPlaying+  | isPlaying nowPlaying && npCanPause nowPlaying =+      void $ MPRIS2DBus.pause client (npBusName nowPlaying)+  | not (isPlaying nowPlaying) && npCanPlay nowPlaying =+      void $ MPRIS2DBus.play client (npBusName nowPlaying)+  | canTogglePlayback nowPlaying =+      void $ MPRIS2DBus.playPause client (npBusName nowPlaying)+  | otherwise = return ()++updateControlButtons :: MPRIS2PlayerControlsWidget -> NowPlaying -> IO ()+updateControlButtons+  MPRIS2PlayerControlsWidget+    { controlsPreviousButton = previousButton,+      controlsPlayPauseButton = playPauseButton,+      controlsPlayPauseButtonLabel = playPauseButtonLabel,+      controlsNextButton = nextButton+    }+  nowPlaying = do+    Gtk.widgetSetVisible previousButton (npCanGoPrevious nowPlaying)+    Gtk.widgetSetSensitive previousButton (npCanGoPrevious nowPlaying)+    Gtk.widgetSetVisible playPauseButton (canTogglePlayback nowPlaying)+    Gtk.widgetSetSensitive playPauseButton (canTogglePlayback nowPlaying)+    Gtk.labelSetText playPauseButtonLabel (playPauseIconText nowPlaying)+    Gtk.widgetSetVisible nextButton (npCanGoNext nowPlaying)+    Gtk.widgetSetSensitive nextButton (npCanGoNext nowPlaying)++newControlButton :: T.Text -> IO (Gtk.Button, Gtk.Label)+newControlButton iconText = do+  button <- Gtk.buttonNew+  label <- Gtk.labelNew $ Just iconText+  Gtk.containerAdd button label+  Gtk.widgetShowAll button+  return (button, label)++-- | This is the default player widget constructor that is used to build mpris+-- widgets. It provides only an icon and NowPlaying text.+simplePlayerWidget ::+  SimpleMPRIS2PlayerConfig -> UpdateMPRIS2PlayerWidget MPRIS2PlayerWidget+simplePlayerWidget+  _+  _+  (Just p@MPRIS2PlayerWidget {playerWidget = widget})+  Nothing =+    lift $ Gtk.widgetHide widget >> return p+simplePlayerWidget+  c+  addToParent+  Nothing+  np@(Just NowPlaying {npBusName = busName}) = do+    ctx <- ask+    client <- asks sessionDBusClient+    lift $ do+      mprisLog DEBUG "Building widget for %s" busName+      image <- autoSizeImageNew (loadIconAtSize client busName) Gtk.OrientationHorizontal+      playerBox <- Gtk.gridNew+      label <- Gtk.labelNew Nothing+      ebox <- Gtk.eventBoxNew+      _ <-+        Gtk.onWidgetButtonPressEvent ebox $+          const $+            MPRIS2DBus.playPause client busName >> return True+      Gtk.containerAdd playerBox image+      Gtk.containerAdd playerBox label+      Gtk.containerAdd ebox playerBox+      vFillCenter playerBox+      addToParent ebox+      Gtk.widgetSetVexpand playerBox True+      Gtk.widgetSetName playerBox $ T.pack $ formatBusName busName+      Gtk.widgetShowAll ebox+      Gtk.widgetHide ebox+      widget <- Gtk.toWidget ebox+      let widgetData =+            MPRIS2PlayerWidget {playerLabel = label, playerWidget = widget}+      flip runReaderT ctx $+        simplePlayerWidget c addToParent (Just widgetData) np+simplePlayerWidget+  config+  _+  ( Just+      w@MPRIS2PlayerWidget+        { playerLabel = label,+          playerWidget = widget+        }+    )+  (Just nowPlaying) = lift $ do+    mprisLog DEBUG "Setting state %s" nowPlaying+    Gtk.labelSetMarkup label =<< setNowPlayingLabel config nowPlaying+    shouldShow <- showPlayerWidgetFn config nowPlaying+    if shouldShow+      then Gtk.widgetShowAll widget+      else Gtk.widgetHide widget+    return w simplePlayerWidget _ _ _ _ =-  mprisLog WARNING "widget update called with no widget or %s"-             ("nowplaying" :: String) >> return undefined+  mprisLog+    WARNING+    "widget update called with no widget or %s"+    ("nowplaying" :: String)+    >> return undefined +-- | This player widget constructor extends the default MPRIS2 row with previous,+-- play/pause, and next buttons.+simplePlayerWidgetWithControls ::+  SimpleMPRIS2PlayerConfig -> UpdateMPRIS2PlayerWidget MPRIS2PlayerControlsWidget+simplePlayerWidgetWithControls+  _+  _+  (Just p@MPRIS2PlayerControlsWidget {controlsPlayerWidget = widget})+  Nothing =+    lift $ Gtk.widgetHide widget >> return p+simplePlayerWidgetWithControls+  c+  addToParent+  Nothing+  np@(Just nowPlaying@NowPlaying {npBusName = busName}) = do+    ctx <- ask+    client <- asks sessionDBusClient+    lift $ do+      mprisLog DEBUG "Building widget for %s" busName+      image <- autoSizeImageNew (loadIconAtSize client busName) Gtk.OrientationHorizontal+      playerBox <- Gtk.boxNew Gtk.OrientationHorizontal 0+      clickArea <- Gtk.boxNew Gtk.OrientationHorizontal 0+      controlsBox <- Gtk.boxNew Gtk.OrientationHorizontal 0+      label <- Gtk.labelNew Nothing+      nowPlayingVar <- MV.newMVar nowPlaying+      (previousButton, _) <- newControlButton backIconText+      (playPauseButton, playPauseButtonLabel) <- newControlButton toggleIconText+      (nextButton, _) <- newControlButton nextIconText+      _ <- widgetSetClassGI controlsBox "mpris-controls"+      _ <- widgetSetClassGI previousButton "mpris-control"+      _ <- widgetSetClassGI previousButton "mpris-control-previous"+      _ <- widgetSetClassGI playPauseButton "mpris-control"+      _ <- widgetSetClassGI playPauseButton "mpris-control-play-pause"+      _ <- widgetSetClassGI nextButton "mpris-control"+      _ <- widgetSetClassGI nextButton "mpris-control-next"+      _ <- Gtk.onButtonClicked previousButton $ do+        currentState <- MV.readMVar nowPlayingVar+        when+          (npCanGoPrevious currentState)+          (void $ MPRIS2DBus.previous client (npBusName currentState))+      _ <- Gtk.onButtonClicked playPauseButton $ do+        currentState <- MV.readMVar nowPlayingVar+        runPlayPauseAction client currentState+      _ <- Gtk.onButtonClicked nextButton $ do+        currentState <- MV.readMVar nowPlayingVar+        when+          (npCanGoNext currentState)+          (void $ MPRIS2DBus.next client (npBusName currentState))+      ebox <- Gtk.eventBoxNew+      _ <-+        Gtk.onWidgetButtonPressEvent ebox $+          const $ do+            currentState <- MV.readMVar nowPlayingVar+            runPlayPauseAction client currentState+            return True+      Gtk.boxPackStart clickArea image False False 0+      Gtk.boxPackStart clickArea label True True 0+      Gtk.containerAdd ebox clickArea+      Gtk.boxPackStart controlsBox previousButton False False 0+      Gtk.boxPackStart controlsBox playPauseButton False False 0+      Gtk.boxPackStart controlsBox nextButton False False 0+      Gtk.boxPackStart playerBox ebox True True 0+      Gtk.boxPackStart playerBox controlsBox False False 0+      vFillCenter playerBox+      addToParent playerBox+      Gtk.widgetSetVexpand playerBox True+      Gtk.widgetSetName playerBox $ T.pack $ formatBusName busName+      Gtk.widgetShowAll playerBox+      Gtk.widgetHide playerBox+      widget <- Gtk.toWidget playerBox+      let widgetData =+            MPRIS2PlayerControlsWidget+              { controlsPlayerLabel = label,+                controlsPlayerWidget = widget,+                controlsNowPlayingVar = nowPlayingVar,+                controlsPreviousButton = previousButton,+                controlsPlayPauseButton = playPauseButton,+                controlsPlayPauseButtonLabel = playPauseButtonLabel,+                controlsNextButton = nextButton+              }+      flip runReaderT ctx $+        simplePlayerWidgetWithControls c addToParent (Just widgetData) np+simplePlayerWidgetWithControls+  config+  _+  ( Just+      w@MPRIS2PlayerControlsWidget+        { controlsPlayerLabel = label,+          controlsPlayerWidget = widget,+          controlsNowPlayingVar = nowPlayingVar+        }+    )+  (Just nowPlaying) = lift $ do+    mprisLog DEBUG "Setting state %s" nowPlaying+    void $ MV.swapMVar nowPlayingVar nowPlaying+    Gtk.labelSetMarkup label =<< setNowPlayingLabel config nowPlaying+    shouldShow <- showPlayerWidgetFn config nowPlaying+    if shouldShow+      then Gtk.widgetShowAll widget >> updateControlButtons w nowPlaying+      else Gtk.widgetHide widget+    return w+simplePlayerWidgetWithControls _ _ _ _ =+  mprisLog+    WARNING+    "widget update called with no widget or %s"+    ("nowplaying" :: String)+    >> return undefined+ -- | Construct a new MPRIS2 widget using the `simplePlayerWidget` constructor. mpris2New :: TaffyIO Gtk.Widget mpris2New = mpris2NewWithConfig defaultMPRIS2Config +-- | Construct a new MPRIS2 widget with transport control buttons+-- (previous/play-pause/next) when the player advertises support for them.+mpris2NewWithControls :: TaffyIO Gtk.Widget+mpris2NewWithControls = mpris2NewWithConfig defaultMPRIS2ControlsConfig+ -- | Construct a new MPRIS2 widget with the provided configuration. mpris2NewWithConfig :: MPRIS2Config a -> TaffyIO Gtk.Widget-mpris2NewWithConfig config = ask >>= \ctx -> asks sessionDBusClient >>= \client -> lift $ do-  grid <- Gtk.gridNew-  outerWidget <- Gtk.toWidget grid >>= mprisWidgetWrapper config-  vFillCenter grid-  playerWidgetsVar <- MV.newMVar M.empty-  let-    updateWidget = updatePlayerWidget config-    updatePlayerWidgets nowPlayings playerWidgets = do-      let-        updateWidgetFromNP np@NowPlaying { npBusName = busName } =-          (busName,) <$> updateWidget (Gtk.containerAdd grid)-                       (M.lookup busName playerWidgets) (Just np)-        activeBusNames = map npBusName nowPlayings-        existingBusNames = M.keys playerWidgets-        inactiveBusNames = existingBusNames \\ activeBusNames-        callForNoPlayingAvailable busName =-          updateWidget (Gtk.containerAdd grid)-                         (M.lookup busName playerWidgets) Nothing+mpris2NewWithConfig config =+  ask >>= \ctx ->+    asks sessionDBusClient >>= \client -> lift $ do+      grid <- Gtk.gridNew+      outerWidget <- Gtk.toWidget grid >>= mprisWidgetWrapper config+      vFillCenter grid+      playerWidgetsVar <- MV.newMVar M.empty+      let updateWidget = updatePlayerWidget config+          updatePlayerWidgets nowPlayings playerWidgets = do+            let updateWidgetFromNP np@NowPlaying {npBusName = busName} =+                  (busName,)+                    <$> updateWidget+                      (Gtk.containerAdd grid)+                      (M.lookup busName playerWidgets)+                      (Just np)+                activeBusNames = map npBusName nowPlayings+                existingBusNames = M.keys playerWidgets+                inactiveBusNames = existingBusNames \\ activeBusNames+                callForNoPlayingAvailable busName =+                  updateWidget+                    (Gtk.containerAdd grid)+                    (M.lookup busName playerWidgets)+                    Nothing -      -- Invoke the widgets with no NowPlaying so they can hide etc.-      mapM_ callForNoPlayingAvailable inactiveBusNames-      -- Update all the other widgets-      updatedWidgets <- M.fromList <$> mapM updateWidgetFromNP nowPlayings-      return $ M.union updatedWidgets playerWidgets+            -- Invoke the widgets with no NowPlaying so they can hide etc.+            mapM_ callForNoPlayingAvailable inactiveBusNames+            -- Update all the other widgets+            updatedWidgets <- M.fromList <$> mapM updateWidgetFromNP nowPlayings+            return $ M.union updatedWidgets playerWidgets -    updatePlayerWidgetsVar nowPlayings = postGUISync $-      MV.modifyMVar_ playerWidgetsVar $ flip runReaderT ctx .-        updatePlayerWidgets nowPlayings+          updatePlayerWidgetsVar nowPlayings =+            postGUISync $+              MV.modifyMVar_ playerWidgetsVar $+                flip runReaderT ctx+                  . updatePlayerWidgets nowPlayings -    setPlayingClass = do-      anyVisible <- anyM Gtk.widgetIsVisible =<< Gtk.containerGetChildren grid-      if anyVisible-      then do-        addClassIfMissing "visible-children" outerWidget-        removeClassIfPresent "no-visible-children" outerWidget-      else do-        addClassIfMissing "no-visible-children" outerWidget-        removeClassIfPresent "visible-children" outerWidget+          setPlayingClass = do+            anyVisible <- anyM Gtk.widgetIsVisible =<< Gtk.containerGetChildren grid+            if anyVisible+              then do+                addClassIfMissing "visible-children" outerWidget+                removeClassIfPresent "no-visible-children" outerWidget+              else do+                addClassIfMissing "no-visible-children" outerWidget+                removeClassIfPresent "visible-children" outerWidget -    doUpdate = do-      nowPlayings <- getNowPlayingInfo client-      updatePlayerWidgetsVar nowPlayings-      setPlayingClass+          doUpdate = do+            nowPlayings <- getNowPlayingInfo client+            updatePlayerWidgetsVar nowPlayings+            setPlayingClass -    signalCallback _ _ _ _ = doUpdate+          signalCallback _ _ _ _ = doUpdate -    propMatcher = matchAny { matchPath = Just "/org/mpris/MediaPlayer2" }+          propMatcher = matchAny {matchPath = Just "/org/mpris/MediaPlayer2"} -    handleNameOwnerChanged _ name _ _ = do-      playerWidgets <- MV.readMVar playerWidgetsVar-      busName <- parseBusName name-      when (busName `M.member` playerWidgets) doUpdate+          handleNameOwnerChanged _ name _ _ = do+            playerWidgets <- MV.readMVar playerWidgetsVar+            busName <- parseBusName name+            when (busName `M.member` playerWidgets) doUpdate -  _ <- Gtk.onWidgetRealize grid $ do-    updateHandler <--      DBus.registerForPropertiesChanged client propMatcher signalCallback-    nameHandler <--      DBus.registerForNameOwnerChanged client matchAny handleNameOwnerChanged-    doUpdate-    void $ Gtk.onWidgetUnrealize grid $-         removeMatch client updateHandler >> removeMatch client nameHandler+      _ <- Gtk.onWidgetRealize grid $ do+        updateHandler <-+          DBus.registerForPropertiesChanged client propMatcher signalCallback+        nameHandler <-+          DBus.registerForNameOwnerChanged client matchAny handleNameOwnerChanged+        doUpdate+        void $+          Gtk.onWidgetUnrealize grid $+            removeMatch client updateHandler >> removeMatch client nameHandler -  Gtk.widgetShow grid-  setPlayingClass-  return outerWidget+      Gtk.widgetShow grid+      setPlayingClass+      return outerWidget  -- | Generate now playing text with the artist truncated to a maximum given by -- the first provided int, and the song title truncated to a maximum given by -- the second provided int.-playingText :: MonadIO m => Int -> Int -> NowPlaying -> m T.Text+playingText :: (MonadIO m) => Int -> Int -> NowPlaying -> m T.Text playingText artistMax songMax NowPlaying {npArtists = artists, npTitle = title} =   G.markupEscapeText formattedText (-1)-  where truncatedTitle = truncateString songMax title-        formattedText = T.pack $ if null artists+  where+    truncatedTitle = truncateString songMax title+    formattedText =+      T.pack $+        if null artists           then truncatedTitle-          else printf-           "%s - %s"-           (truncateString artistMax $ intercalate "," artists)-           truncatedTitle+          else+            printf+              "%s - %s"+              (truncateString artistMax $ intercalate "," artists)+              truncatedTitle
src/System/Taffybar/Widget/NetworkGraph.hs view
@@ -1,4 +1,7 @@ -----------------------------------------------------------------------------++-----------------------------------------------------------------------------+ -- | -- Module      : System.Taffybar.Widget.NetworkGraph -- Copyright   : (c) Ivan A. Malison@@ -9,12 +12,11 @@ -- Portability : unportable -- -- This module provides a channel based network graph widget.------------------------------------------------------------------------------- module System.Taffybar.Widget.NetworkGraph where -import Data.Default (Default(..))+import Data.Default (Default (..)) import Data.Foldable (for_)+import qualified Data.Text as T import qualified GI.Gtk import GI.Gtk.Objects.Widget (widgetSetTooltipMarkup) import System.Taffybar.Context@@ -25,29 +27,32 @@ import System.Taffybar.Widget.Generic.ChannelWidget import System.Taffybar.Widget.Generic.Graph import System.Taffybar.Widget.Text.NetworkMonitor+import System.Taffybar.Widget.Util (widgetSetClassGI)  -- | 'NetworkGraphConfig' configures the network graph widget. data NetworkGraphConfig = NetworkGraphConfig-  { networkGraphGraphConfig :: GraphConfig -- ^ The configuration of the graph itself.-  -- | A tooltip format string, together with the precision that should be used-  -- for numbers in the string.-  , networkGraphTooltipFormat :: Maybe (String, Int)-  -- | A function to scale the y axis of the network config. The default is-  -- `logBase $ 2 ** 32`.-  , networkGraphScale :: Double -> Double-  -- | A filter function that determines whether a given interface will be-  -- included in the network stats.-  , interfacesFilter :: String -> Bool+  { -- | The configuration of the graph itself.+    -- | A tooltip format string, together with the precision that should be used+    -- for numbers in the string.+    networkGraphGraphConfig :: GraphConfig,+    networkGraphTooltipFormat :: Maybe (String, Int),+    -- | A function to scale the y axis of the network config. The default is+    -- `logBase $ 2 ** 32`.+    networkGraphScale :: Double -> Double,+    -- | A filter function that determines whether a given interface will be+    -- included in the network stats.+    interfacesFilter :: String -> Bool   }  -- | Default configuration paramters for the network graph. defaultNetworkGraphConfig :: NetworkGraphConfig-defaultNetworkGraphConfig = NetworkGraphConfig-  { networkGraphGraphConfig = def-  , networkGraphTooltipFormat = Just (defaultNetFormat, 3)-  , networkGraphScale = logBase $ 2 ** 32-  , interfacesFilter = const True-  }+defaultNetworkGraphConfig =+  NetworkGraphConfig+    { networkGraphGraphConfig = def,+      networkGraphTooltipFormat = Just (defaultNetFormat, 3),+      networkGraphScale = logBase $ 2 ** 32,+      interfacesFilter = const True+    }  instance Default NetworkGraphConfig where   def = defaultNetworkGraphConfig@@ -56,10 +61,11 @@ -- and a list of interfaces. networkGraphNew :: GraphConfig -> Maybe [String] -> TaffyIO GI.Gtk.Widget networkGraphNew config interfaces =-  networkGraphNewWith def-                        { networkGraphGraphConfig = config-                        , interfacesFilter = maybe (const True) (flip elem) interfaces-                        }+  networkGraphNewWith+    def+      { networkGraphGraphConfig = config,+        interfacesFilter = maybe (const True) (flip elem) interfaces+      }  -- | 'networkGraphNewWith' instantiates a network graph widget from a -- 'NetworkGraphConfig'.@@ -70,9 +76,10 @@       toSample (up, down) = map (networkGraphScale config . fromRational) [up, down]       sampleBuilder = return . toSample . getUpDown   widget <- channelGraphNew (networkGraphGraphConfig config) chan sampleBuilder+  _ <- widgetSetClassGI widget (T.pack "network-graph")   for_ (networkGraphTooltipFormat config) $ \(format, precision) ->     channelWidgetNew widget chan $ \speedInfo ->       let (up, down) = sumSpeeds $ map snd speedInfo           tooltip = showInfo format precision (fromRational down, fromRational up)-      in postGUIASync $ widgetSetTooltipMarkup widget $ Just tooltip+       in postGUIASync $ widgetSetTooltipMarkup widget $ Just tooltip   return widget
src/System/Taffybar/Widget/NetworkManager.hs view
@@ -1,5 +1,9 @@ {-# LANGUAGE OverloadedStrings #-}+ -----------------------------------------------------------------------------++-----------------------------------------------------------------------------+ -- | -- Module      : System.Taffybar.Widget.NetworkManager -- Copyright   : (c) Ivan A. Malison@@ -10,94 +14,91 @@ -- 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+  ( 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 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.IORef (newIORef, readIORef, writeIORef)+import Data.Int (Int32)+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+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, widgetSetClassGI)+import Text.StringTemplate +-- | Formatting configuration for WiFi label widgets. data WifiWidgetConfig = WifiWidgetConfig-  { wifiConnectedFormat :: String-  , wifiDisconnectedFormat :: String-  , wifiDisabledFormat :: String-  , wifiUnknownFormat :: String-  , wifiTooltipFormat :: Maybe String+  { wifiConnectedFormat :: String,+    wifiDisconnectedFormat :: String,+    wifiDisabledFormat :: String,+    wifiUnknownFormat :: String,+    wifiTooltipFormat :: Maybe String   } +-- | Default 'WifiWidgetConfig'. defaultWifiWidgetConfig :: WifiWidgetConfig defaultWifiWidgetConfig =   WifiWidgetConfig-    { wifiConnectedFormat = "$ssid$ $strength$%"-    , wifiDisconnectedFormat = "disconnected"-    , wifiDisabledFormat = "off"-    , wifiUnknownFormat = "unknown"-    , wifiTooltipFormat =+    { 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 +-- | Build a WiFi status label widget with default formatting. networkManagerWifiLabelNew :: TaffyIO Widget networkManagerWifiLabelNew = networkManagerWifiLabelNewWith defaultWifiWidgetConfig +-- | Build a WiFi status label widget with custom formatting. networkManagerWifiLabelNewWith :: WifiWidgetConfig -> TaffyIO Widget networkManagerWifiLabelNewWith config = do   chan <- getWifiInfoChan@@ -109,43 +110,49 @@           postGUIASync $ do             labelSetMarkup label labelText             widgetSetTooltipMarkup label tooltipText-    void $ onWidgetRealize label $-      runReaderT getWifiInfoState ctx >>= updateWidget-    toWidget =<< channelWidgetNew label chan updateWidget+    void $+      onWidgetRealize label $+        runReaderT getWifiInfoState ctx >>= updateWidget+    (toWidget =<< channelWidgetNew label chan updateWidget)+      >>= (`widgetSetClassGI` "network-manager-wifi-label") +-- | Icon configuration for WiFi icon widgets. data NetworkManagerWifiIconConfig = NetworkManagerWifiIconConfig-  { wifiIconNone :: String-  , wifiIconWeak :: String-  , wifiIconOk :: String-  , wifiIconGood :: String-  , wifiIconExcellent :: String-  , wifiIconDisconnected :: String-  , wifiIconDisabled :: String-  , wifiIconUnknown :: String-  , wifiIconTooltipFormat :: Maybe String+  { wifiIconNone :: String,+    wifiIconWeak :: String,+    wifiIconOk :: String,+    wifiIconGood :: String,+    wifiIconExcellent :: String,+    wifiIconDisconnected :: String,+    wifiIconDisabled :: String,+    wifiIconUnknown :: String,+    wifiIconTooltipFormat :: Maybe String   } +-- | Default 'NetworkManagerWifiIconConfig'. 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 =+    { 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] +-- | Build a WiFi icon widget with default icon names and formatting. networkManagerWifiIconNew :: TaffyIO Widget networkManagerWifiIconNew = networkManagerWifiIconNewWith defaultNetworkManagerWifiIconConfig +-- | Build a WiFi icon widget with custom icon names and tooltip formatting. networkManagerWifiIconNewWith :: NetworkManagerWifiIconConfig -> TaffyIO Widget networkManagerWifiIconNewWith config = do   chan <- getWifiInfoChan@@ -154,36 +161,35 @@   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+  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+    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+    (toWidget =<< channelWidgetNew imageWidget chan updateWidget)+      >>= (`widgetSetClassGI` "network-manager-wifi-icon")  iconTooltipAsLabelConfig :: NetworkManagerWifiIconConfig -> WifiWidgetConfig iconTooltipAsLabelConfig cfg =-  defaultWifiWidgetConfig { wifiTooltipFormat = wifiIconTooltipFormat cfg }+  defaultWifiWidgetConfig {wifiTooltipFormat = wifiIconTooltipFormat cfg}  lookupFirstIcon :: IconTheme -> Int32 -> [String] -> IO (Maybe IconInfo) lookupFirstIcon _ _ [] = return Nothing-lookupFirstIcon theme size (name:names) = do+lookupFirstIcon theme size (name : names) = do   info <- iconThemeLookupIcon theme (T.pack name) size themeLoadFlags   case info of     Just _ -> return info@@ -193,25 +199,25 @@ wifiIconCandidates cfg info =   case wifiState info of     WifiDisabled ->-      [ wifiIconDisabled cfg-      , wifiIconDisconnected cfg-      , wifiIconNone cfg+      [ wifiIconDisabled cfg,+        wifiIconDisconnected cfg,+        wifiIconNone cfg       ]     WifiDisconnected ->-      [ wifiIconDisconnected cfg-      , wifiIconNone cfg+      [ wifiIconDisconnected cfg,+        wifiIconNone cfg       ]     WifiUnknown ->-      [ wifiIconUnknown cfg-      , wifiIconNone cfg+      [ wifiIconUnknown cfg,+        wifiIconNone cfg       ]     WifiConnected ->-      strengthIconName cfg (wifiStrength info) :-      [ wifiIconGood cfg-      , wifiIconOk cfg-      , wifiIconWeak cfg-      , wifiIconNone cfg-      ]+      strengthIconName cfg (wifiStrength info)+        : [ wifiIconGood cfg,+            wifiIconOk cfg,+            wifiIconWeak cfg,+            wifiIconNone cfg+          ]  strengthIconName :: NetworkManagerWifiIconConfig -> Maybe Int -> String strengthIconName cfg strength =@@ -223,27 +229,26 @@       | s < 70 -> wifiIconGood cfg       | otherwise -> wifiIconExcellent cfg +-- | Build a combined WiFi icon and label widget with default configs. networkManagerWifiNew :: TaffyIO Widget networkManagerWifiNew = networkManagerWifiNewWith defaultWifiWidgetConfig defaultNetworkManagerWifiIconConfig -networkManagerWifiNewWith-  :: WifiWidgetConfig-  -> NetworkManagerWifiIconConfig-  -> TaffyIO Widget+-- | Build a combined WiFi icon and label widget with custom configs.+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+  liftIO $+    buildIconLabelBox iconWidget labelWidget+      >>= (`widgetSetClassGI` "network-manager-wifi") -formatWifiWidget-  :: WifiWidgetConfig-  -> WifiInfo-  -> IO (T.Text, Maybe T.Text)+formatWifiWidget ::+  WifiWidgetConfig ->+  WifiInfo ->+  IO (T.Text, Maybe T.Text) formatWifiWidget config info = do   attrs <- buildAttrs info   let labelTemplate = case wifiState info of@@ -260,28 +265,26 @@  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)+  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)+    [ ("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"@@ -300,38 +303,42 @@  -- Network (WiFi + wired + vpn + disconnected) +-- | Formatting configuration for generic network label widgets. data NetworkWidgetConfig = NetworkWidgetConfig-  { networkWifiFormat :: String-  , networkWiredFormat :: String-  , networkVpnFormat :: String-  , networkOtherFormat :: String-  , networkDisconnectedFormat :: String-  , networkWifiDisabledFormat :: String-  , networkUnknownFormat :: String-  , networkTooltipFormat :: Maybe String+  { networkWifiFormat :: String,+    networkWiredFormat :: String,+    networkVpnFormat :: String,+    networkOtherFormat :: String,+    networkDisconnectedFormat :: String,+    networkWifiDisabledFormat :: String,+    networkUnknownFormat :: String,+    networkTooltipFormat :: Maybe String   } +-- | Default 'NetworkWidgetConfig'. defaultNetworkWidgetConfig :: NetworkWidgetConfig defaultNetworkWidgetConfig =   NetworkWidgetConfig-    { networkWifiFormat = "$ssid$ $strength$%"-    , networkWiredFormat = "$connection$"-    , networkVpnFormat = "$connection$"-    , networkOtherFormat = "$type$ $connection$"-    , networkDisconnectedFormat = "disconnected"-    , networkWifiDisabledFormat = "disconnected (wifi off)"-    , networkUnknownFormat = "unknown"-    , networkTooltipFormat =+    { 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 +-- | Build a network status label widget with default formatting. networkManagerNetworkLabelNew :: TaffyIO Widget networkManagerNetworkLabelNew =   networkManagerNetworkLabelNewWith defaultNetworkWidgetConfig +-- | Build a network status label widget with custom formatting. networkManagerNetworkLabelNewWith :: NetworkWidgetConfig -> TaffyIO Widget networkManagerNetworkLabelNewWith config = do   chan <- getNetworkInfoChan@@ -343,47 +350,53 @@           postGUIASync $ do             labelSetMarkup label labelText             widgetSetTooltipMarkup label tooltipText-    void $ onWidgetRealize label $-      runReaderT getNetworkInfoState ctx >>= updateWidget-    toWidget =<< channelWidgetNew label chan updateWidget+    void $+      onWidgetRealize label $+        runReaderT getNetworkInfoState ctx >>= updateWidget+    (toWidget =<< channelWidgetNew label chan updateWidget)+      >>= (`widgetSetClassGI` "network-manager-network-label") +-- | Icon configuration for generic network icon widgets. 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+  { 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   } +-- | Default 'NetworkManagerNetworkIconConfig'. 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 =+    { 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$"     } +-- | Build a network icon widget with default icon names and formatting. networkManagerNetworkIconNew :: TaffyIO Widget networkManagerNetworkIconNew =   networkManagerNetworkIconNewWith defaultNetworkManagerNetworkIconConfig +-- | Build a network icon widget with custom icon names and tooltip formatting. networkManagerNetworkIconNewWith :: NetworkManagerNetworkIconConfig -> TaffyIO Widget networkManagerNetworkIconNewWith config = do   chan <- getNetworkInfoChan@@ -392,76 +405,75 @@   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+  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+    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+    (toWidget =<< channelWidgetNew imageWidget chan updateWidget)+      >>= (`widgetSetClassGI` "network-manager-network-icon")  iconTooltipAsNetworkLabelConfig :: NetworkManagerNetworkIconConfig -> NetworkWidgetConfig iconTooltipAsNetworkLabelConfig cfg =-  defaultNetworkWidgetConfig { networkTooltipFormat = netIconTooltipFormat cfg }+  defaultNetworkWidgetConfig {networkTooltipFormat = netIconTooltipFormat cfg}  networkIconCandidates :: NetworkManagerNetworkIconConfig -> NetworkInfo -> [String] networkIconCandidates cfg info =   case networkState info of     NetworkUnknown ->-      [ netIconUnknown cfg-      , netIconOther cfg-      , netIconDisconnected cfg+      [ netIconUnknown cfg,+        netIconOther cfg,+        netIconDisconnected cfg       ]     NetworkDisconnected ->       case networkWirelessEnabled info of         Just False ->-          [ netIconWifiDisabled cfg-          , netIconDisconnected cfg+          [ netIconWifiDisabled cfg,+            netIconDisconnected cfg           ]         _ ->-          [ netIconDisconnected cfg-          , netIconOther cfg+          [ netIconDisconnected cfg,+            netIconOther cfg           ]     NetworkConnected ->       case networkType info of         Just NetworkWired ->-          [ netIconWired cfg-          , netIconOther cfg+          [ netIconWired cfg,+            netIconOther cfg           ]         Just NetworkVpn ->-          [ netIconVpn cfg-          , netIconOther cfg+          [ netIconVpn cfg,+            netIconOther cfg           ]         Just NetworkWifi ->-          strengthToWifiIcon cfg (networkStrength info) :-          [ netWifiIconGood cfg-          , netWifiIconOk cfg-          , netWifiIconWeak cfg-          , netWifiIconNone cfg-          ]+          strengthToWifiIcon cfg (networkStrength info)+            : [ netWifiIconGood cfg,+                netWifiIconOk cfg,+                netWifiIconWeak cfg,+                netWifiIconNone cfg+              ]         Just (NetworkOther _) ->-          [ netIconOther cfg-          , netIconWired cfg+          [ netIconOther cfg,+            netIconWired cfg           ]         Nothing ->-          [ netIconOther cfg-          , netIconWired cfg-          , netIconDisconnected cfg+          [ netIconOther cfg,+            netIconWired cfg,+            netIconDisconnected cfg           ]  strengthToWifiIcon :: NetworkManagerNetworkIconConfig -> Maybe Int -> String@@ -474,28 +486,27 @@       | s < 70 -> netWifiIconGood cfg       | otherwise -> netWifiIconExcellent cfg +-- | Build a combined network icon and label widget with default configs. networkManagerNetworkNew :: TaffyIO Widget networkManagerNetworkNew =   networkManagerNetworkNewWith defaultNetworkWidgetConfig defaultNetworkManagerNetworkIconConfig -networkManagerNetworkNewWith-  :: NetworkWidgetConfig-  -> NetworkManagerNetworkIconConfig-  -> TaffyIO Widget+-- | Build a combined network icon and label widget with custom configs.+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+  liftIO $+    buildIconLabelBox iconWidget labelWidget+      >>= (`widgetSetClassGI` "network-manager-network") -formatNetworkWidget-  :: NetworkWidgetConfig-  -> NetworkInfo-  -> IO (T.Text, Maybe T.Text)+formatNetworkWidget ::+  NetworkWidgetConfig ->+  NetworkInfo ->+  IO (T.Text, Maybe T.Text) formatNetworkWidget config info = do   attrs <- buildNetworkAttrs info   let labelTemplate =@@ -518,25 +529,24 @@  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)+  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)+    [ ("connection", conn),+      ("type", typ),+      ("ssid", ssid),+      ("strength", strength),+      ("state", state)     ]  networkTypeText :: Maybe NetworkType -> T.Text@@ -570,10 +580,12 @@  -- Wifi text icon +-- | Build a WiFi text-icon label widget with default formatting config. networkManagerWifiTextIconNew :: TaffyIO Widget networkManagerWifiTextIconNew =   networkManagerWifiTextIconNewWith defaultWifiWidgetConfig +-- | Build a WiFi text-icon label widget. networkManagerWifiTextIconNewWith :: WifiWidgetConfig -> TaffyIO Widget networkManagerWifiTextIconNewWith _config = do   chan <- getWifiInfoChan@@ -583,28 +595,36 @@     let updateIcon info = do           let iconText = wifiTextIcon info           postGUIASync $ labelSetText label iconText-    void $ onWidgetRealize label $-      runReaderT getWifiInfoState ctx >>= updateIcon-    toWidget =<< channelWidgetNew label chan updateIcon+    void $+      onWidgetRealize label $+        runReaderT getWifiInfoState ctx >>= updateIcon+    (toWidget =<< channelWidgetNew label chan updateIcon)+      >>= (`widgetSetClassGI` "network-manager-wifi-text-icon")  -- Wifi icon-label +-- | Build a combined WiFi text-icon and label widget with default formatting. networkManagerWifiIconLabelNew :: TaffyIO Widget networkManagerWifiIconLabelNew =   networkManagerWifiIconLabelNewWith defaultWifiWidgetConfig +-- | Build a combined WiFi text-icon and label widget. networkManagerWifiIconLabelNewWith :: WifiWidgetConfig -> TaffyIO Widget networkManagerWifiIconLabelNewWith config = do   iconWidget <- networkManagerWifiTextIconNewWith config   labelWidget <- networkManagerWifiLabelNewWith config-  liftIO $ buildIconLabelBox iconWidget labelWidget+  liftIO $+    buildIconLabelBox iconWidget labelWidget+      >>= (`widgetSetClassGI` "network-manager-wifi-icon-label")  -- Network text icon +-- | Build a network text-icon label widget with default formatting config. networkManagerNetworkTextIconNew :: TaffyIO Widget networkManagerNetworkTextIconNew =   networkManagerNetworkTextIconNewWith defaultNetworkWidgetConfig +-- | Build a network text-icon label widget. networkManagerNetworkTextIconNewWith :: NetworkWidgetConfig -> TaffyIO Widget networkManagerNetworkTextIconNewWith _config = do   chan <- getNetworkInfoChan@@ -614,18 +634,24 @@     let updateIcon info = do           let iconText = networkTextIcon info           postGUIASync $ labelSetText label iconText-    void $ onWidgetRealize label $-      runReaderT getNetworkInfoState ctx >>= updateIcon-    toWidget =<< channelWidgetNew label chan updateIcon+    void $+      onWidgetRealize label $+        runReaderT getNetworkInfoState ctx >>= updateIcon+    (toWidget =<< channelWidgetNew label chan updateIcon)+      >>= (`widgetSetClassGI` "network-manager-network-text-icon")  -- Network icon-label +-- | Build a combined network text-icon and label widget with default formatting. networkManagerNetworkIconLabelNew :: TaffyIO Widget networkManagerNetworkIconLabelNew =   networkManagerNetworkIconLabelNewWith defaultNetworkWidgetConfig +-- | Build a combined network text-icon and label widget. networkManagerNetworkIconLabelNewWith :: NetworkWidgetConfig -> TaffyIO Widget networkManagerNetworkIconLabelNewWith config = do   iconWidget <- networkManagerNetworkTextIconNewWith config   labelWidget <- networkManagerNetworkLabelNewWith config-  liftIO $ buildIconLabelBox iconWidget labelWidget+  liftIO $+    buildIconLabelBox iconWidget labelWidget+      >>= (`widgetSetClassGI` "network-manager-network-icon-label")
src/System/Taffybar/Widget/PowerProfiles.hs view
@@ -1,5 +1,9 @@ {-# LANGUAGE OverloadedStrings #-}+ -----------------------------------------------------------------------------++-----------------------------------------------------------------------------+ -- | -- Module      : System.Taffybar.Widget.PowerProfiles -- Copyright   : (c) Ivan A. Malison@@ -19,52 +23,54 @@ --   * '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+  ( 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 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)+import System.Log.Logger+import System.Taffybar.Context+import System.Taffybar.Information.PowerProfiles+import System.Taffybar.Util (logPrintF, postGUIASync)+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+    powerProfilesFormat :: String,     -- | Nerd font text icon for power-saver mode (default U+F06C9, nf-md-leaf).-  , powerProfilesPowerSaverTextIcon :: T.Text+    powerProfilesPowerSaverTextIcon :: T.Text,     -- | Nerd font text icon for balanced mode (default U+F0A7A, nf-md-scale_balance).-  , powerProfilesBalancedTextIcon :: T.Text+    powerProfilesBalancedTextIcon :: T.Text,     -- | Nerd font text icon for performance mode (default U+F0E4E, nf-md-rocket_launch).-  , powerProfilesPerformanceTextIcon :: T.Text-  } deriving (Eq, Show)+    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"-  }+defaultPowerProfilesConfig =+  PowerProfilesConfig+    { powerProfilesFormat = "$profile$",+      powerProfilesPowerSaverTextIcon = T.pack "\xF06C9",+      powerProfilesBalancedTextIcon = T.pack "\xF0A7A",+      powerProfilesPerformanceTextIcon = T.pack "\xF0E4E"+    }  instance Default PowerProfilesConfig where   def = defaultPowerProfilesConfig@@ -190,7 +196,7 @@     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 :: (Gtk.IsWidget w) => w -> PowerProfileInfo -> IO () updateProfileClasses widget info = do   let profile = currentProfile info       allClasses = ["power-saver", "balanced", "performance"]@@ -203,7 +209,7 @@   Gtk.styleContextAddClass styleCtx currentClass  -- | Update tooltip with current profile info.-updateTooltip :: Gtk.IsWidget w => w -> PowerProfileInfo -> IO ()+updateTooltip :: (Gtk.IsWidget w) => w -> PowerProfileInfo -> IO () updateTooltip widget info = do   let profile = currentProfile info       profileName = powerProfileToString profile
src/System/Taffybar/Widget/Privacy.hs view
@@ -1,6 +1,9 @@ {-# LANGUAGE OverloadedStrings #-}  -----------------------------------------------------------------------------++-----------------------------------------------------------------------------+ -- | -- Module      : System.Taffybar.Widget.Privacy -- Copyright   : (c) Ivan A. Malison@@ -31,27 +34,27 @@ -- * @.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+    privacyNew,+    privacyNewWith,+     -- * Configuration-  , PrivacyWidgetConfig(..)-  , defaultPrivacyWidgetConfig+    PrivacyWidgetConfig (..),+    defaultPrivacyWidgetConfig,+     -- * Re-exports-  , PrivacyConfig(..)-  , defaultPrivacyConfig-  ) where+    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.Default (Default (..)) import Data.Int (Int32) import Data.List (intercalate) import Data.Maybe (catMaybes)@@ -59,43 +62,45 @@ import qualified GI.Gtk as Gtk import System.Taffybar.Context (TaffyIO) import System.Taffybar.Information.Privacy-  ( PrivacyConfig(..)-  , PrivacyInfo(..)-  , PrivacyNode(..)-  , NodeType(..)-  , defaultPrivacyConfig-  , getPrivacyInfoChan-  , getPrivacyInfoState+  ( NodeType (..),+    PrivacyConfig (..),+    PrivacyInfo (..),+    PrivacyNode (..),+    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)+  { -- | Underlying privacy monitoring configuration+    privacyWidgetConfig :: PrivacyConfig,+    -- | Icon name for microphone+    audioInputIcon :: T.Text,+    -- | Icon name for audio output+    audioOutputIcon :: T.Text,+    -- | Icon name for camera/screen share+    videoInputIcon :: T.Text,+    -- | Size of the icons (as Int32 for GTK)+    privacyIconSize :: Int32,+    -- | Spacing between icons+    privacySpacing :: Int+  }+  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-  }+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@@ -195,9 +200,10 @@        formatNode n = "  - " ++ T.unpack (appName n) -      sections = catMaybes-        [ formatSection "Microphone" audioInNodes-        , formatSection "Camera/Screen" videoInNodes-        , formatSection "Audio Output" audioOutNodes-        ]-  in intercalate "\n" sections+      sections =+        catMaybes+          [ formatSection "Microphone" audioInNodes,+            formatSection "Camera/Screen" videoInNodes,+            formatSection "Audio Output" audioOutNodes+          ]+   in intercalate "\n" sections
src/System/Taffybar/Widget/PulseAudio.hs view
@@ -1,5 +1,9 @@ {-# LANGUAGE OverloadedStrings #-}+ -----------------------------------------------------------------------------++-----------------------------------------------------------------------------+ -- | -- Module      : System.Taffybar.Widget.PulseAudio -- Copyright   : (c) Ivan A. Malison@@ -14,70 +18,74 @@ -- 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+  ( 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 Data.Default (Default (..)) import qualified Data.Text as T+import qualified GI.GLib as G import qualified GI.Gdk.Enums as Gdk import qualified GI.Gdk.Structs.EventScroll as GdkEvent-import qualified GI.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 System.Taffybar.Widget.Util (buildIconLabelBox, widgetSetClassGI) import Text.StringTemplate +-- | Configuration for PulseAudio widgets. data PulseAudioWidgetConfig = PulseAudioWidgetConfig-  { pulseAudioSink :: String-  , pulseAudioFormat :: String-  , pulseAudioMuteFormat :: String-  , pulseAudioUnknownFormat :: String-  , pulseAudioTooltipFormat :: Maybe String-  , pulseAudioScrollStepPercent :: Maybe Int-  , pulseAudioToggleMuteOnClick :: Bool+  { pulseAudioSink :: String,+    pulseAudioFormat :: String,+    pulseAudioMuteFormat :: String,+    pulseAudioUnknownFormat :: String,+    pulseAudioTooltipFormat :: Maybe String,+    pulseAudioScrollStepPercent :: Maybe Int,+    pulseAudioToggleMuteOnClick :: Bool   } +-- | Default PulseAudio widget configuration. 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+    { 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 +-- | Create an icon-only PulseAudio widget with default config. pulseAudioIconNew :: TaffyIO Gtk.Widget pulseAudioIconNew = pulseAudioIconNewWith defaultPulseAudioWidgetConfig +-- | Create an icon-only PulseAudio widget with custom config. pulseAudioIconNewWith :: PulseAudioWidgetConfig -> TaffyIO Gtk.Widget pulseAudioIconNewWith config = do   let sinkSpec = pulseAudioSink config   (chan, var) <- getPulseAudioInfoChanAndVar sinkSpec   liftIO $ do     label <- Gtk.labelNew Nothing+    _ <- widgetSetClassGI label "pulse-audio-icon"     let updateIcon info = do           let iconText = case info of                 Nothing -> T.pack "\xF026"@@ -85,11 +93,14 @@           postGUIASync $ Gtk.labelSetText label iconText     void $ Gtk.onWidgetRealize label $ readMVar var >>= updateIcon     Gtk.widgetShowAll label-    Gtk.toWidget =<< channelWidgetNew label chan updateIcon+    (Gtk.toWidget =<< channelWidgetNew label chan updateIcon)+      >>= (`widgetSetClassGI` "pulse-audio-icon") +-- | Create a label-only PulseAudio widget with default config. pulseAudioLabelNew :: TaffyIO Gtk.Widget pulseAudioLabelNew = pulseAudioLabelNewWith defaultPulseAudioWidgetConfig +-- | Create a label-only PulseAudio widget with custom config. pulseAudioLabelNewWith :: PulseAudioWidgetConfig -> TaffyIO Gtk.Widget pulseAudioLabelNewWith config = do   let sinkSpec = pulseAudioSink config@@ -97,41 +108,42 @@    liftIO $ do     label <- Gtk.labelNew Nothing+    _ <- widgetSetClassGI label "pulse-audio-label" -    let-      updateLabel info = do-        (labelText, tooltipText) <- formatPulseAudioWidget config info-        postGUIASync $ do-          Gtk.labelSetMarkup label labelText-          Gtk.widgetSetTooltipMarkup label tooltipText+    let updateLabel info = do+          (labelText, tooltipText) <- formatPulseAudioWidget config info+          postGUIASync $ do+            Gtk.labelSetMarkup label labelText+            Gtk.widgetSetTooltipMarkup label tooltipText -      refreshNow = getPulseAudioInfo sinkSpec >>= updateLabel+        refreshNow = getPulseAudioInfo sinkSpec >>= updateLabel -      whenToggleMute widget =-        when (pulseAudioToggleMuteOnClick config) $-          void $ Gtk.onWidgetButtonPressEvent widget $ \_ -> do-            void $ togglePulseAudioMute sinkSpec-            refreshNow-            return True+        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 ()+        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 @@ -139,59 +151,62 @@     whenScrollAdjust label      Gtk.widgetShowAll label-    Gtk.toWidget =<< channelWidgetNew label chan updateLabel+    (Gtk.toWidget =<< channelWidgetNew label chan updateLabel)+      >>= (`widgetSetClassGI` "pulse-audio-label") +-- | Create a combined icon+label PulseAudio widget with default config. pulseAudioNew :: TaffyIO Gtk.Widget pulseAudioNew = pulseAudioNewWith defaultPulseAudioWidgetConfig +-- | Create a combined icon+label PulseAudio widget with custom config. pulseAudioNewWith :: PulseAudioWidgetConfig -> TaffyIO Gtk.Widget pulseAudioNewWith config = do   iconWidget <- pulseAudioIconNewWith config   labelWidget <- pulseAudioLabelNewWith config-  liftIO $ buildIconLabelBox iconWidget labelWidget+  liftIO $+    buildIconLabelBox iconWidget labelWidget+      >>= (`widgetSetClassGI` "pulse-audio") -formatPulseAudioWidget-  :: PulseAudioWidgetConfig-  -> Maybe PulseAudioInfo-  -> IO (T.Text, Maybe T.Text)+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)+  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+  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)+    [ ("volume", volume),+      ("muted", muted),+      ("sink", sink)     ]  buildUnknownAttrs :: IO [(String, String)] buildUnknownAttrs =   return-    [ ("volume", "?")-    , ("muted", "unknown")-    , ("sink", "unknown")+    [ ("volume", "?"),+      ("muted", "unknown"),+      ("sink", "unknown")     ]  pulseAudioTextIcon :: Maybe Bool -> Maybe Int -> T.Text
src/System/Taffybar/Widget/SNIMenu.hs view
@@ -1,20 +1,23 @@ {-# LANGUAGE OverloadedStrings #-}++-- | Helpers for attaching DBusMenu popups to widgets. module System.Taffybar.Widget.SNIMenu-  ( withSniMenu-  , withNmAppletMenu-  ) where+  ( 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 DBusMenu import qualified GI.GLib as GLib+import qualified GI.Gdk as Gdk (EventType (..), getEventButtonButton, getEventButtonType) import qualified GI.Gtk as Gtk-import qualified DBusMenu-import System.Log.Logger (Priority(..), logM)-import System.Taffybar.Context (Context(..), TaffyIO)+import System.Log.Logger (Priority (..), logM)+import System.Taffybar.Context (Context (..), TaffyIO) import Text.Printf (printf)  sniMenuLogger :: Priority -> String -> IO ()@@ -38,18 +41,22 @@         then do           currentEvent <- Gtk.getCurrentEvent           catchAny-            (do let client = sessionDBusClient ctx+            ( 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+                  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)+                Gtk.menuPopupAtPointer gtkMenu currentEvent+            )+            ( sniMenuLogger WARNING+                . printf "Failed to build SNI menu for %s: %s" (show busName)+                . show+            )           return True         else return False @@ -58,6 +65,7 @@  -- | 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"+withNmAppletMenu =+  withSniMenu+    "org.freedesktop.network-manager-applet"+    "/org/ayatana/NotificationItem/nm_applet/Menu"
src/System/Taffybar/Widget/SNITray.hs view
@@ -1,5 +1,10 @@ {-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RecordWildCards #-}+ -----------------------------------------------------------------------------++-----------------------------------------------------------------------------+ -- | -- Module      : System.Taffybar.Widget.SNITray -- Copyright   : (c) Ivan A. Malison@@ -24,51 +29,283 @@ -- generally not recommended, because it can lead to issues with the -- registration of tray icons if taffybar crashes/restarts, or if tray icon -- providing applications are ever started before taffybar.------------------------------------------------------------------------------- module System.Taffybar.Widget.SNITray-  ( TrayParams-  , module System.Taffybar.Widget.SNITray-  ) where+  ( TrayPriorityConfig,+    module System.Taffybar.Widget.SNITray,+  )+where -import           Control.Monad.Trans.Class-import           Control.Monad.Trans.Reader-import qualified GI.Gtk+import Control.Monad (void)+import Control.Monad.Trans.Class+import Control.Monad.Trans.Reader+import Data.IORef+import Data.List (findIndex)+import qualified Data.Map.Strict as M+import Data.Maybe (fromMaybe)+import qualified Data.Text as T+import qualified GI.GLib as GLib+import qualified GI.Gdk as Gdk+import qualified GI.Gtk as Gtk import qualified StatusNotifier.Host.Service as H-import           StatusNotifier.Tray-import           System.Posix.Process-import           System.Taffybar.Context-import           System.Taffybar.Widget.Util-import           Text.Printf+import StatusNotifier.Tray hiding (TrayItemMatcher, TrayParams, defaultTrayPriorityConfig)+import qualified StatusNotifier.Tray as Tray+import System.Posix.Process+import System.Taffybar.Context+import System.Taffybar.Widget.Util+import Text.Printf +-- | Parameters controlling tray construction and orientation.+type TrayParams = Tray.TrayParams++-- | Predicate used to match tray items in priority configuration.+type TrayItemMatcher = Tray.TrayItemMatcher++-- | Default tray icon priority configuration.+defaultTrayPriorityConfig :: TrayPriorityConfig+defaultTrayPriorityConfig = Tray.defaultTrayPriorityConfig++-- | Configuration for the base SNI tray widget.+data SNITrayConfig = SNITrayConfig+  { sniTrayTrayParams :: TrayParams,+    sniTrayPriorityConfig :: TrayPriorityConfig+  }++-- | Default 'SNITrayConfig'.+defaultSNITrayConfig :: SNITrayConfig+defaultSNITrayConfig =+  SNITrayConfig+    { sniTrayTrayParams = defaultTrayParams,+      sniTrayPriorityConfig = defaultTrayPriorityConfig+    }++-- | Configuration for the collapsible SNI tray widget.+data CollapsibleSNITrayParams = CollapsibleSNITrayParams+  { -- | Base tray configuration used to build the underlying SNI tray.+    collapsibleSNITrayConfig :: SNITrayConfig,+    -- | Maximum number of tray icons to show when collapsed.+    --+    -- Non-positive values disable collapsing.+    collapsibleSNITrayMaxVisibleIcons :: Int,+    -- | Optional collapsed-mode priority cutoff.+    --+    -- When set, collapsed mode shows only icons whose priority index is less+    -- than or equal to this value, where the index comes from+    -- 'trayPriorityMatchers' order in 'TrayPriorityConfig'. This takes+    -- precedence over 'collapsibleSNITrayMaxVisibleIcons' when collapsed.+    collapsibleSNITrayCollapsedPriorityCutoff :: Maybe Int,+    -- | Whether the tray starts expanded.+    collapsibleSNITrayStartExpanded :: Bool,+    -- | Show the indicator while expanded.+    -- Useful to allow clicking it again to collapse.+    collapsibleSNITrayShowIndicatorWhenExpanded :: Bool,+    -- | Label renderer for the indicator.+    --+    -- Arguments: @(hiddenCount, expanded)@.+    collapsibleSNITrayIndicatorLabel :: Int -> Bool -> T.Text+  }++-- | Default indicator label renderer for the collapsible tray.+defaultCollapsibleSNITrayIndicatorLabel :: Int -> Bool -> T.Text+defaultCollapsibleSNITrayIndicatorLabel hiddenCount expanded+  | expanded = "-"+  | otherwise = "+" <> T.pack (show hiddenCount)++-- | Default 'CollapsibleSNITrayParams'.+defaultCollapsibleSNITrayParams :: CollapsibleSNITrayParams+defaultCollapsibleSNITrayParams =+  CollapsibleSNITrayParams+    { collapsibleSNITrayConfig = defaultSNITrayConfig,+      collapsibleSNITrayMaxVisibleIcons = 6,+      collapsibleSNITrayCollapsedPriorityCutoff = Nothing,+      collapsibleSNITrayStartExpanded = False,+      collapsibleSNITrayShowIndicatorWhenExpanded = True,+      collapsibleSNITrayIndicatorLabel = defaultCollapsibleSNITrayIndicatorLabel+    }+ -- | Build a new StatusNotifierItem tray that will share a host with any other -- trays that are constructed automatically-sniTrayNew :: TaffyIO GI.Gtk.Widget-sniTrayNew = sniTrayNewFromParams defaultTrayParams+sniTrayNew :: TaffyIO Gtk.Widget+sniTrayNew = sniTrayNewFromConfig defaultSNITrayConfig +-- | Build a new StatusNotifierItem tray from custom 'SNITrayConfig'.+sniTrayNewFromConfig :: SNITrayConfig -> TaffyIO Gtk.Widget+sniTrayNewFromConfig config =+  getTrayHost False >>= sniTrayNewFromHostConfig config+ -- | Build a new StatusNotifierItem tray from the provided 'TrayParams'.-sniTrayNewFromParams :: TrayParams -> TaffyIO GI.Gtk.Widget+sniTrayNewFromParams :: TrayParams -> TaffyIO Gtk.Widget sniTrayNewFromParams params =-  getTrayHost False >>= sniTrayNewFromHostParams params+  sniTrayNewFromConfig $+    defaultSNITrayConfig {sniTrayTrayParams = params}  -- | Build a new StatusNotifierItem tray from the provided 'TrayParams' and -- 'H.Host'.-sniTrayNewFromHostParams :: TrayParams -> H.Host -> TaffyIO GI.Gtk.Widget-sniTrayNewFromHostParams params host = do+sniTrayNewFromHostParams :: TrayParams -> H.Host -> TaffyIO Gtk.Widget+sniTrayNewFromHostParams params =+  sniTrayNewFromHostConfig $+    defaultSNITrayConfig {sniTrayTrayParams = params}++-- | Build a new StatusNotifierItem tray from custom 'SNITrayConfig' and+-- 'H.Host'.+sniTrayNewFromHostConfig :: SNITrayConfig -> H.Host -> TaffyIO Gtk.Widget+sniTrayNewFromHostConfig SNITrayConfig {..} host = do   client <- asks sessionDBusClient   lift $ do-    tray <- buildTray host client params+    tray <-+      buildTray+        host+        client+        sniTrayTrayParams {trayPriorityConfig = sniTrayPriorityConfig}     _ <- widgetSetClassGI tray "sni-tray"-    GI.Gtk.widgetShowAll tray-    GI.Gtk.toWidget tray+    Gtk.widgetShowAll tray+    Gtk.toWidget tray +-- | Build a collapsible StatusNotifierItem tray with default params.+sniTrayCollapsibleNew :: TaffyIO Gtk.Widget+sniTrayCollapsibleNew =+  sniTrayCollapsibleNewFromParams defaultCollapsibleSNITrayParams++-- | Build a collapsible StatusNotifierItem tray from custom params.+sniTrayCollapsibleNewFromParams ::+  CollapsibleSNITrayParams -> TaffyIO Gtk.Widget+sniTrayCollapsibleNewFromParams params =+  getTrayHost False >>= sniTrayCollapsibleNewFromHostParams params++-- | Build a collapsible StatusNotifierItem tray from custom params and a host.+sniTrayCollapsibleNewFromHostParams ::+  CollapsibleSNITrayParams -> H.Host -> TaffyIO Gtk.Widget+sniTrayCollapsibleNewFromHostParams CollapsibleSNITrayParams {..} host = do+  client <- asks sessionDBusClient+  lift $ do+    let SNITrayConfig {..} = collapsibleSNITrayConfig+        TrayPriorityConfig {trayPriorityMatchers = priorityMatchers} = sniTrayPriorityConfig+    tray <-+      buildTray+        host+        client+        sniTrayTrayParams {trayPriorityConfig = sniTrayPriorityConfig}+    _ <- widgetSetClassGI tray "sni-tray"+    outer <- Gtk.boxNew (trayOrientation sniTrayTrayParams) 0+    _ <- widgetSetClassGI outer "sni-tray-collapsible"++    indicatorLabel <- Gtk.labelNew Nothing+    _ <- widgetSetClassGI indicatorLabel "sni-tray-overflow-indicator-label"+    indicator <- Gtk.eventBoxNew+    _ <- widgetSetClassGI indicator "sni-tray-overflow-indicator"+    Gtk.containerAdd indicator indicatorLabel++    Gtk.boxPackStart outer tray False False 0+    Gtk.boxPackStart outer indicator False False 0++    expandedRef <- newIORef collapsibleSNITrayStartExpanded++    let maxVisible = collapsibleSNITrayMaxVisibleIcons+        refresh = do+          children <- Gtk.containerGetChildren tray++          expanded <- readIORef expandedRef+          priorityVisibleCount <-+            case collapsibleSNITrayCollapsedPriorityCutoff of+              Nothing -> return Nothing+              Just cutoff -> do+                infoMap <- H.itemInfoMap host+                let getPriorityIndex info =+                      fromMaybe+                        (length priorityMatchers)+                        (findIndex (`trayItemMatcherPredicate` info) priorityMatchers)+                    visibleCount =+                      length $+                        filter+                          (\info -> getPriorityIndex info <= cutoff)+                          (M.elems infoMap)+                return (Just visibleCount)+          let shouldLimit = maybe (maxVisible > 0) (const True) priorityVisibleCount+              collapsedVisibleCount = fromMaybe maxVisible priorityVisibleCount+              visibleCount+                | shouldLimit && not expanded = max 0 collapsedVisibleCount+                | otherwise = length children+              visibleChildren = take visibleCount children+              hiddenChildren = drop visibleCount children+              hiddenCount = length hiddenChildren+              showIndicator+                | expanded =+                    shouldLimit+                      && length children > maxVisible+                      && collapsibleSNITrayShowIndicatorWhenExpanded+                | otherwise = hiddenCount > 0+              indicatorText =+                collapsibleSNITrayIndicatorLabel hiddenCount expanded++          mapM_ Gtk.widgetShow visibleChildren+          mapM_ Gtk.widgetHide hiddenChildren++          if showIndicator+            then do+              Gtk.labelSetText indicatorLabel indicatorText+              Gtk.widgetSetTooltipText+                indicator+                ( Just $+                    if expanded+                      then "Collapse tray icons"+                      else T.pack $ "Show " ++ show hiddenCount ++ " more tray icons"+                )+              Gtk.widgetShowAll indicator+            else do+              Gtk.widgetSetTooltipText indicator Nothing+              Gtk.widgetHide indicator++          if expanded+            then addClassIfMissing "sni-tray-collapsible-expanded" outer+            else removeClassIfPresent "sni-tray-collapsible-expanded" outer++          return hiddenCount++    _ <- Gtk.onWidgetButtonPressEvent indicator $ \event -> do+      eventType <- Gdk.getEventButtonType event+      button <- Gdk.getEventButtonButton event+      if eventType == Gdk.EventTypeButtonPress && button == 1+        then do+          hiddenCount <- refresh+          expanded <- readIORef expandedRef+          if hiddenCount > 0 || expanded+            then modifyIORef' expandedRef not >> void refresh >> return True+            else return False+        else return False++    let queueRefresh _ _ =+          void $+            Gdk.threadsAddIdle GLib.PRIORITY_DEFAULT_IDLE $+              void refresh >> return False+    handlerId <- H.addUpdateHandler host queueRefresh+    _ <- Gtk.onWidgetDestroy outer $ H.removeUpdateHandler host handlerId++    _ <- refresh+    Gtk.widgetShowAll outer+    Gtk.toWidget outer+ -- | Build a new StatusNotifierItem tray that also starts its own watcher, -- without depending on status-notifier-icon. This will not register applets -- started before the watcher is started.-sniTrayThatStartsWatcherEvenThoughThisIsABadWayToDoIt :: TaffyIO GI.Gtk.Widget+sniTrayThatStartsWatcherEvenThoughThisIsABadWayToDoIt :: TaffyIO Gtk.Widget sniTrayThatStartsWatcherEvenThoughThisIsABadWayToDoIt =-  getTrayHost True >>= sniTrayNewFromHostParams defaultTrayParams+  sniTrayThatStartsWatcherEvenThoughThisIsABadWayToDoItFromConfig+    defaultSNITrayConfig +-- | Build a new StatusNotifierItem tray that also starts its own watcher,+-- with custom 'SNITrayConfig'.+sniTrayThatStartsWatcherEvenThoughThisIsABadWayToDoItFromConfig ::+  SNITrayConfig -> TaffyIO Gtk.Widget+sniTrayThatStartsWatcherEvenThoughThisIsABadWayToDoItFromConfig config =+  getTrayHost True >>= sniTrayNewFromHostConfig config++-- | Build a collapsible StatusNotifierItem tray that also starts its own+-- watcher, without depending on status-notifier-icon.+sniTrayCollapsibleThatStartsWatcherEvenThoughThisIsABadWayToDoIt ::+  TaffyIO Gtk.Widget+sniTrayCollapsibleThatStartsWatcherEvenThoughThisIsABadWayToDoIt =+  getTrayHost True+    >>= sniTrayCollapsibleNewFromHostParams defaultCollapsibleSNITrayParams+ -- | Get a 'H.Host' from 'TaffyIO' internal state, that can be used to construct -- SNI tray widgets. The boolean parameter determines whether or not a watcher -- will be started the first time 'getTrayHost' is invoked.@@ -76,10 +313,12 @@ getTrayHost startWatcher = getStateDefault $ do   pid <- lift getProcessID   client <- asks sessionDBusClient-  Just host <- lift $ H.build H.defaultParams-     { H.dbusClient = Just client-     , H.uniqueIdentifier = printf "taffybar-%s" $ show pid-     , H.startWatcher = startWatcher-     }+  Just host <-+    lift $+      H.build+        H.defaultParams+          { H.dbusClient = Just client,+            H.uniqueIdentifier = printf "taffybar-%s" $ show pid,+            H.startWatcher = startWatcher+          }   return host-
+ src/System/Taffybar/Widget/SNITray/PrioritizedCollapsible.hs view
@@ -0,0 +1,1030 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE TupleSections #-}++-- |+-- Module      : System.Taffybar.Widget.SNITray.PrioritizedCollapsible+-- Copyright   : (c) Ivan A. Malison+-- License     : BSD3-style (see LICENSE)+--+-- Maintainer  : Ivan A. Malison+-- Stability   : unstable+-- Portability : unportable+--+-- Prioritized, collapsible StatusNotifierItem tray with editable per-icon+-- priorities and persisted priority state.+module System.Taffybar.Widget.SNITray.PrioritizedCollapsible+  ( module System.Taffybar.Widget.SNITray.PrioritizedCollapsible,+  )+where++import Control.Applicative ((<|>))+import Control.Monad (forM_, guard, join, void)+import Control.Monad.Trans.Class+import Control.Monad.Trans.Reader+import qualified DBus as D+import qualified DBus.Client as DBus+import qualified Data.Aeson as A+import qualified Data.Aeson.Key as AKey+import qualified Data.Aeson.KeyMap as AKeyMap+import Data.Aeson.Types (Parser, parseMaybe)+import qualified Data.ByteString as BS+import qualified Data.ByteString.Char8 as BS8+import Data.Char (isAlphaNum, isDigit, toLower)+import Data.IORef+import Data.Int (Int32)+import Data.List (isSuffixOf, nub, sortOn, stripPrefix)+import qualified Data.Map.Strict as M+import Data.Maybe (catMaybes, fromMaybe, isJust, isNothing, listToMaybe, mapMaybe, maybeToList)+import Data.Ord (Down (..))+import qualified Data.Text as T+import Data.Word (Word32)+import qualified Data.Yaml as Y+import qualified GI.GLib as GLib+import qualified GI.Gdk as Gdk+import qualified GI.Gtk as Gtk+import Graphics.UI.GIGtkStrut (StrutAlignment (End))+import qualified StatusNotifier.Host.Service as H+import StatusNotifier.Tray+import qualified StatusNotifier.Tray as Tray+import System.Directory (createDirectoryIfMissing, doesFileExist)+import System.Environment.XDG.BaseDir (getUserConfigFile)+import System.FilePath (isRelative, replaceExtension, takeBaseName, takeDirectory, takeExtension)+import System.Taffybar.Context+import System.Taffybar.Widget.SNITray+  ( CollapsibleSNITrayParams (..),+    SNITrayConfig (..),+    defaultCollapsibleSNITrayParams,+    getTrayHost,+  )+import System.Taffybar.Widget.Util+import Text.Read (readMaybe)++type SNIPriorityMap = M.Map String Int++data SNIPriorityEntry = SNIPriorityEntry+  { sniPriorityEntryKey :: String,+    sniPriorityEntryPriority :: Int+  }++data SNIPriorityFile = SNIPriorityFile+  { sniPriorityFilePriorities :: SNIPriorityMap,+    sniPriorityFileMaxVisibleIcons :: Maybe Int,+    -- Nothing: no persisted override (use config default)+    -- Just Nothing: explicitly no threshold+    -- Just (Just n): explicit threshold n+    sniPriorityFileVisibilityThreshold :: Maybe (Maybe Int)+  }++instance A.FromJSON SNIPriorityEntry where+  parseJSON = A.withObject "SNIPriorityEntry" $ \obj ->+    SNIPriorityEntry+      <$> obj A..: "key"+      <*> obj A..: "priority"++instance A.ToJSON SNIPriorityEntry where+  toJSON SNIPriorityEntry {..} =+    A.object+      [ "key" A..= sniPriorityEntryKey,+        "priority" A..= sniPriorityEntryPriority+      ]++parsePrioritiesValue :: A.Value -> Parser SNIPriorityMap+parsePrioritiesValue value =+  parseEntries value <|> A.parseJSON value+  where+    parseEntries v = do+      entries <- A.parseJSON v :: Parser [SNIPriorityEntry]+      let toPair SNIPriorityEntry {..} =+            (sniPriorityEntryKey, sniPriorityEntryPriority)+      return $ M.fromList (map toPair entries)++instance A.FromJSON SNIPriorityFile where+  parseJSON = A.withObject "SNIPriorityFile" $ \obj -> do+    maybePriorities <- obj A..:? "priorities"+    priorities <- maybe (return M.empty) parsePrioritiesValue maybePriorities+    maxVisibleIcons <- obj A..:? "max_visible_icons"+    let thresholdKey = AKey.fromString "visibility_threshold"+    visibilityThreshold <-+      if AKeyMap.member thresholdKey obj+        then Just <$> obj A..:? "visibility_threshold"+        else return Nothing+    return $+      SNIPriorityFile+        { sniPriorityFilePriorities = priorities,+          sniPriorityFileMaxVisibleIcons = maxVisibleIcons,+          sniPriorityFileVisibilityThreshold = visibilityThreshold+        }++instance A.ToJSON SNIPriorityFile where+  toJSON SNIPriorityFile {..} =+    let sortedEntries =+          map+            (uncurry SNIPriorityEntry)+            (sortOn (\(key, priority) -> (Down priority, key)) (M.toList sniPriorityFilePriorities))+     in A.object+          ( [ "format_version" A..= (2 :: Int),+              "priorities" A..= sortedEntries+            ]+              <> maybe [] (\value -> ["max_visible_icons" A..= value]) sniPriorityFileMaxVisibleIcons+              <> maybe [] (\value -> ["visibility_threshold" A..= value]) sniPriorityFileVisibilityThreshold+          )++-- | Configuration for a collapsible tray with editable icon priorities.+data PrioritizedCollapsibleSNITrayParams = PrioritizedCollapsibleSNITrayParams+  { -- | Base collapsible tray parameters.+    prioritizedCollapsibleSNITrayParams :: CollapsibleSNITrayParams,+    -- | Path for priority state persistence.+    --+    -- Relative paths are resolved under @~/.config/taffybar/@.+    prioritizedCollapsibleSNITrayPriorityStateFile :: FilePath,+    -- | Minimum priority value.+    prioritizedCollapsibleSNITrayPriorityMin :: Int,+    -- | Maximum priority value.+    prioritizedCollapsibleSNITrayPriorityMax :: Int,+    -- | Default priority assigned to unmapped icons.+    prioritizedCollapsibleSNITrayDefaultPriority :: Int,+    -- | Hide icons with priority below this value.+    --+    -- This only applies while collapsed; expanded mode always shows all icons.+    prioritizedCollapsibleSNITrayVisibilityThreshold :: Maybe Int,+    -- | Whether priority edit mode starts enabled.+    prioritizedCollapsibleSNITrayStartPriorityEditMode :: Bool,+    -- | Always show the expand/collapse toggle button.+    prioritizedCollapsibleSNITrayAlwaysShowExpandToggle :: Bool,+    -- | Label renderer for the priority-edit-mode toggle.+    --+    -- Argument: @editing@.+    prioritizedCollapsibleSNITrayPriorityModeLabel :: Bool -> T.Text+  }++defaultPrioritizedCollapsibleSNITrayPriorityModeLabel :: Bool -> T.Text+defaultPrioritizedCollapsibleSNITrayPriorityModeLabel editing+  | editing = "P*"+  | otherwise = "P"++-- | Default params for 'PrioritizedCollapsibleSNITrayParams'.+defaultPrioritizedCollapsibleSNITrayParams :: PrioritizedCollapsibleSNITrayParams+defaultPrioritizedCollapsibleSNITrayParams =+  PrioritizedCollapsibleSNITrayParams+    { prioritizedCollapsibleSNITrayParams = defaultCollapsibleSNITrayParams,+      prioritizedCollapsibleSNITrayPriorityStateFile = "sni-priorities.yaml",+      prioritizedCollapsibleSNITrayPriorityMin = -5,+      prioritizedCollapsibleSNITrayPriorityMax = 5,+      prioritizedCollapsibleSNITrayDefaultPriority = 0,+      prioritizedCollapsibleSNITrayVisibilityThreshold = Nothing,+      prioritizedCollapsibleSNITrayStartPriorityEditMode = False,+      prioritizedCollapsibleSNITrayAlwaysShowExpandToggle = True,+      prioritizedCollapsibleSNITrayPriorityModeLabel = defaultPrioritizedCollapsibleSNITrayPriorityModeLabel+    }++clampPriorityInRange :: Int -> Int -> Int -> Int+clampPriorityInRange priorityMin priorityMax =+  max priorityMin . min priorityMax++resolveSNIPriorityStateFile :: FilePath -> IO FilePath+resolveSNIPriorityStateFile path+  | isRelative path = getUserConfigFile "taffybar" path+  | otherwise = return path++parseLegacySNIPriorityMap :: BS.ByteString -> Maybe SNIPriorityMap+parseLegacySNIPriorityMap content =+  M.fromList <$> (readMaybe (BS8.unpack content) :: Maybe [(String, Int)])++parseLegacySNIPriorityFile :: BS.ByteString -> Maybe SNIPriorityFile+parseLegacySNIPriorityFile content =+  legacyFile <$> parseLegacySNIPriorityMap content+  where+    legacyFile priorities =+      SNIPriorityFile+        { sniPriorityFilePriorities = priorities,+          sniPriorityFileMaxVisibleIcons = Nothing,+          sniPriorityFileVisibilityThreshold = Nothing+        }++parseSNIPriorityFile :: BS.ByteString -> Maybe SNIPriorityFile+parseSNIPriorityFile content =+  parseYamlState <|> parseYamlPriorityOnly <|> parseLegacySNIPriorityFile content+  where+    parseYamlState =+      either+        (const Nothing)+        Just+        (Y.decodeEither' content :: Either Y.ParseException SNIPriorityFile)+    parseYamlPriorityOnly = do+      yamlValue <- either (const Nothing) Just (Y.decodeEither' content :: Either Y.ParseException A.Value)+      priorities <- parseMaybe parsePrioritiesValue yamlValue+      return $+        SNIPriorityFile+          { sniPriorityFilePriorities = priorities,+            sniPriorityFileMaxVisibleIcons = Nothing,+            sniPriorityFileVisibilityThreshold = Nothing+          }++loadSNIPriorityFileFromPath :: FilePath -> IO (Maybe SNIPriorityFile)+loadSNIPriorityFileFromPath path = do+  exists <- doesFileExist path+  if not exists+    then return Nothing+    else parseSNIPriorityFile <$> BS.readFile path++legacyPriorityStateFallbackPath :: FilePath -> Maybe FilePath+legacyPriorityStateFallbackPath path+  | takeExtension path == ".yaml" = Just (replaceExtension path "dat")+  | otherwise = Nothing++loadSNIPriorityFileFromFile :: FilePath -> IO SNIPriorityFile+loadSNIPriorityFileFromFile path = do+  loaded <- loadSNIPriorityFileFromPath path+  case loaded of+    Just priorityFile -> return priorityFile+    Nothing ->+      case legacyPriorityStateFallbackPath path of+        Nothing -> return emptyPriorityFile+        Just legacyPath -> do+          fallbackLoaded <- loadSNIPriorityFileFromPath legacyPath+          case fallbackLoaded of+            Nothing -> return emptyPriorityFile+            Just priorityFile -> do+              -- One-time migration path for existing show/read .dat files.+              persistSNIPriorityFileToFile path priorityFile+              return priorityFile++emptyPriorityFile :: SNIPriorityFile+emptyPriorityFile =+  SNIPriorityFile+    { sniPriorityFilePriorities = M.empty,+      sniPriorityFileMaxVisibleIcons = Nothing,+      sniPriorityFileVisibilityThreshold = Nothing+    }++persistSNIPriorityFileToFile :: FilePath -> SNIPriorityFile -> IO ()+persistSNIPriorityFileToFile path priorityFile = do+  createDirectoryIfMissing True (takeDirectory path)+  BS.writeFile path (Y.encode priorityFile)++nonEmptyString :: String -> Maybe String+nonEmptyString value+  | null value = Nothing+  | otherwise = Just value++itemStableIdentity :: H.ItemInfo -> String+itemStableIdentity info =+  show (H.itemServiceName info) <> "|" <> show (H.itemServicePath info)++itemStableIdentityKey :: H.ItemInfo -> String+itemStableIdentityKey info = "item-identity:" ++ itemStableIdentity info++hasNumericSuffix :: String -> String -> Bool+hasNumericSuffix prefix value =+  case stripPrefix prefix value of+    Just suffix -> not (null suffix) && all isDigit suffix+    Nothing -> False++unstableItemIdPrefixes :: [String]+unstableItemIdPrefixes =+  ["chrome_status_icon_", "systray_", "statusnotifieritem-", "statusnotifieritem_"]++sharedItemIdPrefixes :: [String]+sharedItemIdPrefixes = ["chrome_status_icon_", "systray_"]++matchingItemIdPrefix :: [String] -> String -> Maybe String+matchingItemIdPrefix prefixes itemId =+  let lowerItemId = map toLower itemId+      matchingPrefixes =+        filter (`hasNumericSuffix` lowerItemId) prefixes+   in case matchingPrefixes of+        prefix : _ -> Just (take (length prefix) itemId)+        [] -> Nothing++unstableItemIdPrefix :: String -> Maybe String+unstableItemIdPrefix = matchingItemIdPrefix unstableItemIdPrefixes++sharedItemIdPrefix :: String -> Maybe String+sharedItemIdPrefix = matchingItemIdPrefix sharedItemIdPrefixes++isLikelyUnstableItemId :: String -> Bool+isLikelyUnstableItemId = isJust . unstableItemIdPrefix++stableItemIdKey :: H.ItemInfo -> Maybe String+stableItemIdKey info = do+  itemId <- H.itemId info >>= nonEmptyString+  guard (not (isLikelyUnstableItemId itemId))+  return ("item-id:" ++ itemId)++unstableItemIdKey :: H.ItemInfo -> Maybe String+unstableItemIdKey info = do+  itemId <- H.itemId info >>= nonEmptyString+  guard (isLikelyUnstableItemId itemId)+  return ("item-id:" ++ itemId)++sharedItemIdPrefixIconNameKey :: H.ItemInfo -> Maybe String+sharedItemIdPrefixIconNameKey info = do+  itemId <- H.itemId info >>= nonEmptyString+  prefix <- sharedItemIdPrefix itemId+  iconName <- nonEmptyString (H.iconName info)+  return ("item-id-prefix+icon-name:" ++ prefix ++ "|" ++ iconName)++sharedItemIdPrefixIconTitleKey :: H.ItemInfo -> Maybe String+sharedItemIdPrefixIconTitleKey info = do+  itemId <- H.itemId info >>= nonEmptyString+  prefix <- sharedItemIdPrefix itemId+  iconTitle <- nonEmptyString (H.iconTitle info)+  return ("item-id-prefix+icon-title:" ++ prefix ++ "|" ++ iconTitle)++isLikelySharedItemIdForInfo :: H.ItemInfo -> Bool+isLikelySharedItemIdForInfo info =+  case H.itemId info >>= nonEmptyString of+    Nothing -> False+    Just itemId -> isJust (sharedItemIdPrefix itemId)++normalizeProcessToken :: String -> String+normalizeProcessToken =+  dropWhile (== '-') . reverse . dropWhile (== '-') . reverse . map normalizeChar+  where+    normalizeChar c+      | isAlphaNum c = toLower c+      | otherwise = '-'++processIdentityTokenFromArg :: String -> Maybe String+processIdentityTokenFromArg arg+  | ".asar" `isSuffixOf` arg =+      nonEmptyString (takeBaseName (takeDirectory arg))+  | otherwise = Nothing++processIdentityTokenFromCmdline :: [String] -> Maybe String+processIdentityTokenFromCmdline [] = Nothing+processIdentityTokenFromCmdline (exeArg : args) =+  let argToken = listToMaybe (mapMaybe processIdentityTokenFromArg args)+      exeToken = nonEmptyString (takeBaseName exeArg)+      normalized = normalizeProcessToken <$> (argToken <|> exeToken)+   in normalized >>= nonEmptyString++readProcessCommandLine :: Word32 -> IO [String]+readProcessCommandLine pid = do+  let cmdlinePath = "/proc/" ++ show pid ++ "/cmdline"+  exists <- doesFileExist cmdlinePath+  if not exists+    then return []+    else do+      bytes <- BS.readFile cmdlinePath+      return $ filter (not . null) (map BS8.unpack (BS8.split '\0' bytes))++dbusDaemonName :: D.BusName+dbusDaemonName = D.busName_ "org.freedesktop.DBus"++dbusDaemonPath :: D.ObjectPath+dbusDaemonPath = D.objectPath_ "/org/freedesktop/DBus"++getConnectionUnixProcessID :: DBus.Client -> D.BusName -> IO (Maybe Word32)+getConnectionUnixProcessID client busName = do+  let method =+        (D.methodCall dbusDaemonPath "org.freedesktop.DBus" "GetConnectionUnixProcessID")+          { D.methodCallDestination = Just dbusDaemonName,+            D.methodCallBody = [D.toVariant (D.formatBusName busName)]+          }+  result <- DBus.call client method+  case result of+    Left _ -> return Nothing+    Right reply ->+      case D.methodReturnBody reply of+        [pidVariant] -> return (D.fromVariant pidVariant)+        _ -> return Nothing++processDisambiguationKeyForItem :: DBus.Client -> H.ItemInfo -> IO (Maybe String)+processDisambiguationKeyForItem client info = do+  maybePid <- getConnectionUnixProcessID client (H.itemServiceName info)+  case maybePid of+    Nothing -> return Nothing+    Just pid -> do+      cmdline <- readProcessCommandLine pid+      return $ ("process:" ++) <$> processIdentityTokenFromCmdline cmdline++processDisambiguationKeysForItems :: DBus.Client -> [H.ItemInfo] -> IO (M.Map String String)+processDisambiguationKeysForItems client infos = do+  pairs <- mapM withKey infos+  return $ M.fromList (catMaybes pairs)+  where+    withKey info+      | not (isLikelySharedItemIdForInfo info) = return Nothing+      | otherwise = do+          processKey <- processDisambiguationKeyForItem client info+          return $ fmap (itemStableIdentity info,) processKey++priorityLookupKeyCandidates :: Maybe String -> H.ItemInfo -> [String]+priorityLookupKeyCandidates maybeProcessKey info =+  nub $+    concat+      [ maybeToList maybeProcessKey,+        map ("icon-name:" ++) (maybeToList (nonEmptyString (H.iconName info))),+        maybeToList (stableItemIdKey info),+        map ("icon-title:" ++) (maybeToList (nonEmptyString (H.iconTitle info))),+        maybeToList (sharedItemIdPrefixIconNameKey info),+        maybeToList (sharedItemIdPrefixIconTitleKey info),+        [itemStableIdentityKey info],+        maybeToList (unstableItemIdKey info)+      ]++priorityEditableKeyCandidates :: Maybe String -> H.ItemInfo -> [String]+priorityEditableKeyCandidates maybeProcessKey info =+  nub $+    concat+      [ maybeToList maybeProcessKey,+        map ("icon-name:" ++) (maybeToList (nonEmptyString (H.iconName info))),+        maybeToList (stableItemIdKey info),+        map ("icon-title:" ++) (maybeToList (nonEmptyString (H.iconTitle info))),+        maybeToList (sharedItemIdPrefixIconNameKey info),+        maybeToList (sharedItemIdPrefixIconTitleKey info),+        [itemStableIdentityKey info],+        maybeToList (unstableItemIdKey info)+      ]++priorityKeyFromItem :: Maybe String -> H.ItemInfo -> Maybe String+priorityKeyFromItem maybeProcessKey =+  listToMaybe . priorityEditableKeyCandidates maybeProcessKey++itemPriorityFromMap ::+  Int ->+  Int ->+  Int ->+  SNIPriorityMap ->+  Maybe String ->+  H.ItemInfo ->+  Int+itemPriorityFromMap priorityMin priorityMax defaultPriority priorities maybeProcessKey info =+  let clampPriority = clampPriorityInRange priorityMin priorityMax+      matchedPriority =+        listToMaybe $+          mapMaybe (`M.lookup` priorities) (priorityLookupKeyCandidates maybeProcessKey info)+   in clampPriority (fromMaybe defaultPriority matchedPriority)++itemIdentityMatcher :: H.ItemInfo -> Tray.TrayItemMatcher+itemIdentityMatcher info =+  let stableIdentity = itemStableIdentity info+   in mkTrayItemMatcher+        ("priority:identity:" <> stableIdentity)+        (\candidate -> itemStableIdentity candidate == stableIdentity)++priorityMatchersFromMapAndItems ::+  Bool ->+  Int ->+  Int ->+  Int ->+  SNIPriorityMap ->+  (H.ItemInfo -> Maybe String) ->+  [H.ItemInfo] ->+  [Tray.TrayItemMatcher]+priorityMatchersFromMapAndItems highPriorityFirstInMatcherOrder priorityMin priorityMax defaultPriority priorities processKeyForInfo infos =+  let sortedInfos =+        sortedInfosByPriority+          highPriorityFirstInMatcherOrder+          priorityMin+          priorityMax+          defaultPriority+          priorities+          processKeyForInfo+          infos+      fallbackMatcher = mkTrayItemMatcher "priority:identity:fallback" (const True)+   in map itemIdentityMatcher sortedInfos ++ [fallbackMatcher]++sortedInfosByPriority ::+  Bool ->+  Int ->+  Int ->+  Int ->+  SNIPriorityMap ->+  (H.ItemInfo -> Maybe String) ->+  [H.ItemInfo] ->+  [H.ItemInfo]+sortedInfosByPriority highPriorityFirstInMatcherOrder priorityMin priorityMax defaultPriority priorities processKeyForInfo infos =+  let itemPriority info =+        itemPriorityFromMap+          priorityMin+          priorityMax+          defaultPriority+          priorities+          (processKeyForInfo info)+          info+      prioritySortKey info =+        if highPriorityFirstInMatcherOrder+          then negate (itemPriority info)+          else itemPriority info+   in -- Matchers may need to be reversed to keep higher numeric priorities on the+      -- visual left when the tray is end-aligned.+      sortOn+        (\info -> (prioritySortKey info, itemStableIdentity info))+        infos++lookupExplicitPriority ::+  SNIPriorityMap ->+  Maybe String ->+  H.ItemInfo ->+  Maybe Int+lookupExplicitPriority priorities maybeProcessKey info =+  listToMaybe $ mapMaybe (`M.lookup` priorities) (priorityLookupKeyCandidates maybeProcessKey info)++setExplicitPriorityForItem ::+  IORef SNIPriorityMap ->+  (SNIPriorityMap -> IO ()) ->+  Maybe String ->+  H.ItemInfo ->+  Maybe Int ->+  IO ()+setExplicitPriorityForItem prioritiesRef afterUpdate maybeProcessKey info newPriority =+  case priorityKeyFromItem maybeProcessKey info of+    Nothing -> return ()+    Just primaryKey -> do+      let editableKeys = priorityEditableKeyCandidates maybeProcessKey info+      modifyIORef' prioritiesRef $ \priorities ->+        case newPriority of+          Nothing -> foldr M.delete priorities editableKeys+          Just priority -> M.insert primaryKey priority priorities+      readIORef prioritiesRef >>= afterUpdate++menuIconSize :: Int32+menuIconSize = fromIntegral $ fromEnum Gtk.IconSizeMenu++showPriorityEditMenu ::+  Gtk.Widget ->+  Int ->+  Int ->+  Int ->+  Maybe Int ->+  (Maybe Int -> IO ()) ->+  IO ()+showPriorityEditMenu anchor priorityMin priorityMax defaultPriority currentExplicit onSelection = do+  currentEvent <- Gtk.getCurrentEvent+  menu <- Gtk.menuNew+  Gtk.menuAttachToWidget menu anchor Nothing++  let options = [priorityMax, priorityMax - 1 .. priorityMin]+  forM_ options $ \priority -> do+    let prefix =+          if currentExplicit == Just priority+            then "\x2713 " :: T.Text+            else "   "+        labelText = prefix <> "Set priority " <> T.pack (show priority)+    item <- Gtk.menuItemNewWithLabel labelText+    void $ Gtk.onMenuItemActivate item $ onSelection (Just priority)+    Gtk.menuShellAppend menu item++  sep <- Gtk.separatorMenuItemNew+  Gtk.menuShellAppend menu sep++  let clearPrefix =+        if isNothing currentExplicit+          then "\x2713 " :: T.Text+          else "   "+      clearLabel =+        clearPrefix+          <> "Clear override (default "+          <> T.pack (show defaultPriority)+          <> ")"+  clearItem <- Gtk.menuItemNewWithLabel clearLabel+  void $ Gtk.onMenuItemActivate clearItem $ onSelection Nothing+  Gtk.menuShellAppend menu clearItem++  void $+    Gtk.onWidgetHide menu $+      void $+        GLib.idleAdd GLib.PRIORITY_LOW $ do+          Gtk.widgetDestroy menu+          return False++  Gtk.widgetShowAll menu+  Gtk.menuPopupAtPointer menu currentEvent++showPrioritySettingsMenu ::+  Gtk.EventBox ->+  Int ->+  Int ->+  IORef Int ->+  IORef (Maybe Int) ->+  IO () ->+  IO ()+showPrioritySettingsMenu anchor priorityMin priorityMax maxVisibleRef thresholdRef onSettingsChanged = do+  currentEvent <- Gtk.getCurrentEvent+  currentMaxVisible <- readIORef maxVisibleRef+  currentThreshold <- readIORef thresholdRef++  menu <- Gtk.menuNew+  Gtk.menuAttachToWidget menu anchor Nothing++  maxVisibleItem <- Gtk.menuItemNewWithLabel ("Max visible (collapsed)" :: T.Text)+  maxVisibleMenu <- Gtk.menuNew+  Gtk.menuItemSetSubmenu maxVisibleItem (Just maxVisibleMenu)+  let maxVisibleOptions = [0 .. 20]+  forM_ maxVisibleOptions $ \option -> do+    let optionLabel =+          if option <= 0+            then "No limit" :: T.Text+            else T.pack (show option)+        prefix =+          if option == currentMaxVisible+            then "\x2713 " :: T.Text+            else "   "+    item <- Gtk.menuItemNewWithLabel (prefix <> optionLabel)+    void $ Gtk.onMenuItemActivate item $ do+      writeIORef maxVisibleRef option+      onSettingsChanged+    Gtk.menuShellAppend maxVisibleMenu item+  Gtk.menuShellAppend menu maxVisibleItem++  thresholdItem <- Gtk.menuItemNewWithLabel ("Priority threshold" :: T.Text)+  thresholdMenu <- Gtk.menuNew+  Gtk.menuItemSetSubmenu thresholdItem (Just thresholdMenu)+  let thresholdOptions = Nothing : map Just [priorityMin .. priorityMax]+  forM_ thresholdOptions $ \option -> do+    let optionLabel =+          case option of+            Nothing -> "No threshold" :: T.Text+            Just value -> ">= " <> T.pack (show value)+        prefix =+          if option == currentThreshold+            then "\x2713 " :: T.Text+            else "   "+    item <- Gtk.menuItemNewWithLabel (prefix <> optionLabel)+    void $ Gtk.onMenuItemActivate item $ do+      writeIORef thresholdRef option+      onSettingsChanged+    Gtk.menuShellAppend thresholdMenu item+  Gtk.menuShellAppend menu thresholdItem++  void $+    Gtk.onWidgetHide menu $+      void $+        GLib.idleAdd GLib.PRIORITY_LOW $ do+          Gtk.widgetDestroy menu+          return False++  Gtk.widgetShowAll menu+  Gtk.menuPopupAtPointer menu currentEvent++-- | Build a collapsible StatusNotifierItem tray with priority editing controls+-- and persisted priority state.+sniTrayPrioritizedCollapsibleNew :: TaffyIO Gtk.Widget+sniTrayPrioritizedCollapsibleNew =+  sniTrayPrioritizedCollapsibleNewFromParams defaultPrioritizedCollapsibleSNITrayParams++-- | Build a prioritized collapsible tray from custom params.+sniTrayPrioritizedCollapsibleNewFromParams ::+  PrioritizedCollapsibleSNITrayParams -> TaffyIO Gtk.Widget+sniTrayPrioritizedCollapsibleNewFromParams params =+  getTrayHost False >>= sniTrayPrioritizedCollapsibleNewFromHostParams params++-- | Build a prioritized collapsible tray from custom params and a host.+sniTrayPrioritizedCollapsibleNewFromHostParams ::+  PrioritizedCollapsibleSNITrayParams -> H.Host -> TaffyIO Gtk.Widget+sniTrayPrioritizedCollapsibleNewFromHostParams PrioritizedCollapsibleSNITrayParams {..} host = do+  client <- asks sessionDBusClient+  lift $ do+    let CollapsibleSNITrayParams {..} = prioritizedCollapsibleSNITrayParams+        SNITrayConfig {..} = collapsibleSNITrayConfig+        rawPriorityMin = prioritizedCollapsibleSNITrayPriorityMin+        rawPriorityMax = prioritizedCollapsibleSNITrayPriorityMax+        priorityMin = min rawPriorityMin rawPriorityMax+        priorityMax = max rawPriorityMin rawPriorityMax+        clampPriority = clampPriorityInRange priorityMin priorityMax+        defaultPriority = clampPriority prioritizedCollapsibleSNITrayDefaultPriority+        visibilityThreshold = clampPriority <$> prioritizedCollapsibleSNITrayVisibilityThreshold+        trayOrientation' = trayOrientation sniTrayTrayParams+        highPriorityFirstInMatcherOrder =+          case trayAlignment sniTrayTrayParams of+            End -> False+            _ -> True++    statePath <- resolveSNIPriorityStateFile prioritizedCollapsibleSNITrayPriorityStateFile+    persistedPriorityFile <- loadSNIPriorityFileFromFile statePath+    let persistedPriorities =+          M.map clampPriority (sniPriorityFilePriorities persistedPriorityFile)+        initialMaxVisibleIcons =+          max+            0+            ( fromMaybe+                collapsibleSNITrayMaxVisibleIcons+                (sniPriorityFileMaxVisibleIcons persistedPriorityFile)+            )+        initialVisibilityThreshold =+          case sniPriorityFileVisibilityThreshold persistedPriorityFile of+            Nothing -> visibilityThreshold+            Just persistedThreshold -> clampPriority <$> persistedThreshold+    prioritiesRef <- newIORef persistedPriorities+    expandedRef <- newIORef collapsibleSNITrayStartExpanded+    priorityEditModeRef <- newIORef prioritizedCollapsibleSNITrayStartPriorityEditMode+    maxVisibleIconsRef <- newIORef initialMaxVisibleIcons+    visibilityThresholdRef <- newIORef initialVisibilityThreshold+    knownItemIdentitiesRef <- newIORef ([] :: [String])+    orderedInfosRef <- newIORef ([] :: [H.ItemInfo])+    processDisambiguationKeysRef <- newIORef (M.empty :: M.Map String String)+    trayRef <- newIORef Nothing+    rebuildTrayRef <- newIORef (return ())++    outer <- Gtk.boxNew trayOrientation' 0+    _ <- widgetSetClassGI outer "sni-tray-collapsible"+    _ <- widgetSetClassGI outer "sni-tray-prioritized-collapsible"+    outerWidget <- Gtk.toWidget outer++    trayContainer <- Gtk.boxNew trayOrientation' 0+    _ <- widgetSetClassGI trayContainer "sni-tray-collapsible-container"++    overflowCountLabel <- Gtk.labelNew Nothing+    _ <- widgetSetClassGI overflowCountLabel "sni-tray-overflow-count-label"++    expandIcon <- Gtk.imageNewFromIconName (Just "pan-down-symbolic") menuIconSize+    expandToggle <- Gtk.eventBoxNew+    _ <- widgetSetClassGI expandToggle "sni-tray-expand-toggle"+    Gtk.containerAdd expandToggle expandIcon++    priorityModeIcon <- Gtk.imageNewFromIconName (Just "document-edit-symbolic") menuIconSize+    priorityModeToggle <- Gtk.eventBoxNew+    _ <- widgetSetClassGI priorityModeToggle "sni-tray-edit-toggle"+    Gtk.containerAdd priorityModeToggle priorityModeIcon++    settingsIcon <- Gtk.imageNewFromIconName (Just "emblem-system-symbolic") menuIconSize+    settingsToggle <- Gtk.eventBoxNew+    _ <- widgetSetClassGI settingsToggle "sni-tray-settings-toggle"+    Gtk.containerAdd settingsToggle settingsIcon+    Gtk.widgetSetTooltipText settingsToggle (Just "Tray display settings")++    Gtk.boxPackStart outer trayContainer False False 0+    Gtk.boxPackStart outer overflowCountLabel False False 0+    Gtk.boxPackStart outer expandToggle False False 0+    Gtk.boxPackStart outer priorityModeToggle False False 0+    Gtk.boxPackStart outer settingsToggle False False 0++    let queueRebuild = do+          rebuild <- readIORef rebuildTrayRef+          void $+            Gdk.threadsAddIdle GLib.PRIORITY_DEFAULT_IDLE $+              rebuild >> return False++        persistCurrentState = do+          priorities <- readIORef prioritiesRef+          maxVisibleIcons <- readIORef maxVisibleIconsRef+          visibilityThresholdOverride <- readIORef visibilityThresholdRef+          persistSNIPriorityFileToFile+            statePath+            SNIPriorityFile+              { sniPriorityFilePriorities = priorities,+                sniPriorityFileMaxVisibleIcons = Just (max 0 maxVisibleIcons),+                sniPriorityFileVisibilityThreshold = Just visibilityThresholdOverride+              }++        processKeyForInfoFromMap processKeyMap info =+          M.lookup (itemStableIdentity info) processKeyMap++        editPriorityForClick clickContext = do+          let clickedInfo = trayClickItemInfo clickContext+          priorities <- readIORef prioritiesRef+          processKeyMap <- readIORef processDisambiguationKeysRef+          let maybeProcessKey = processKeyForInfoFromMap processKeyMap clickedInfo+              currentExplicit =+                lookupExplicitPriority priorities maybeProcessKey clickedInfo+              updatePriority newPriority = do+                setExplicitPriorityForItem+                  prioritiesRef+                  (\_ -> persistCurrentState >> queueRebuild)+                  maybeProcessKey+                  clickedInfo+                  (fmap clampPriority newPriority)+          showPriorityEditMenu+            outerWidget+            priorityMin+            priorityMax+            defaultPriority+            currentExplicit+            updatePriority++        refreshPriorityModeToggle = do+          editing <- readIORef priorityEditModeRef+          let tooltipText =+                if editing+                  then "Disable icon priority edit mode"+                  else "Enable icon priority edit mode"+          Gtk.widgetSetTooltipText+            priorityModeToggle+            (Just tooltipText)+          if editing+            then addClassIfMissing "sni-tray-edit-toggle-active" priorityModeToggle+            else removeClassIfPresent "sni-tray-edit-toggle-active" priorityModeToggle+          if editing+            then do+              addClassIfMissing "sni-tray-editing" outer+            else do+              removeClassIfPresent "sni-tray-editing" outer+          Gtk.widgetShowAll priorityModeToggle++        refresh = do+          maybeTray <- readIORef trayRef+          case maybeTray of+            Nothing -> return 0+            Just tray -> do+              children <- Gtk.containerGetChildren tray+              expanded <- readIORef expandedRef+              priorities <- readIORef prioritiesRef+              maxVisibleIcons <- readIORef maxVisibleIconsRef+              thresholdValue <- readIORef visibilityThresholdRef+              orderedInfos <- readIORef orderedInfosRef+              processKeyMap <- readIORef processDisambiguationKeysRef++              let itemPriority info =+                    itemPriorityFromMap+                      priorityMin+                      priorityMax+                      defaultPriority+                      priorities+                      (processKeyForInfoFromMap processKeyMap info)+                      info+                  totalCount = length children+                  collapsedThresholdVisibleCount =+                    case thresholdValue of+                      Nothing -> totalCount+                      Just threshold ->+                        min+                          totalCount+                          (length $ filter (\info -> itemPriority info >= threshold) orderedInfos)+                  collapsedVisibleCount+                    | maxVisibleIcons > 0 =+                        min collapsedThresholdVisibleCount maxVisibleIcons+                    | otherwise = collapsedThresholdVisibleCount+                  visibleCount+                    | expanded = totalCount+                    | otherwise = collapsedVisibleCount+                  visibleChildren = take visibleCount children+                  hiddenChildren = drop visibleCount children+                  hiddenCount = length hiddenChildren+                  showExpandToggle =+                    prioritizedCollapsibleSNITrayAlwaysShowExpandToggle+                      || ( if expanded+                             then collapsibleSNITrayShowIndicatorWhenExpanded && hiddenCount > 0+                             else hiddenCount > 0+                         )+                  expandIconName =+                    if expanded+                      then "pan-up-symbolic"+                      else "pan-down-symbolic"+                  expandTooltip =+                    if expanded+                      then "Allow tray icon hiding"+                      else "Show all tray icons"+                  hiddenCountText = T.pack (show hiddenCount)++              mapM_ Gtk.widgetShow visibleChildren+              mapM_ Gtk.widgetHide hiddenChildren++              Gtk.imageSetFromIconName expandIcon (Just expandIconName) menuIconSize+              if showExpandToggle+                then do+                  Gtk.widgetSetTooltipText expandToggle (Just expandTooltip)+                  Gtk.widgetShowAll expandToggle+                else do+                  Gtk.widgetSetTooltipText expandToggle Nothing+                  Gtk.widgetHide expandToggle++              if hiddenCount > 0+                then do+                  Gtk.labelSetText overflowCountLabel hiddenCountText+                  Gtk.widgetShow overflowCountLabel+                else do+                  Gtk.labelSetText overflowCountLabel ""+                  Gtk.widgetHide overflowCountLabel++              if expanded+                then addClassIfMissing "sni-tray-collapsible-expanded" outer+                else removeClassIfPresent "sni-tray-collapsible-expanded" outer++              return hiddenCount++        buildTrayWithPriorities priorities processKeyMap infos = do+          let priorityConfig =+                sniTrayPriorityConfig+                  { trayPriorityMatchers =+                      priorityMatchersFromMapAndItems+                        highPriorityFirstInMatcherOrder+                        priorityMin+                        priorityMax+                        defaultPriority+                        priorities+                        (processKeyForInfoFromMap processKeyMap)+                        infos+                  }+              baseHooks = trayEventHooks sniTrayTrayParams+              baseClickHook = trayClickHook baseHooks+              combinedClickHook clickContext = do+                editMode <- readIORef priorityEditModeRef+                if editMode+                  then do+                    editPriorityForClick clickContext+                    return ConsumeClick+                  else case baseClickHook of+                    Just clickHook -> clickHook clickContext+                    Nothing -> return UseDefaultClickAction+              trayParams =+                sniTrayTrayParams+                  { trayEventHooks =+                      baseHooks {trayClickHook = Just combinedClickHook}+                  }+          tray <- buildTray host client trayParams {trayPriorityConfig = priorityConfig}+          _ <- widgetSetClassGI tray "sni-tray"+          return tray++        rebuildTray = do+          priorities <- readIORef prioritiesRef+          infoMap <- H.itemInfoMap host+          processKeyMap <- processDisambiguationKeysForItems client (M.elems infoMap)+          let infos = M.elems infoMap+              orderedInfos =+                sortedInfosByPriority+                  highPriorityFirstInMatcherOrder+                  priorityMin+                  priorityMax+                  defaultPriority+                  priorities+                  (processKeyForInfoFromMap processKeyMap)+                  infos+              currentItemIdentities =+                sortOn id (map itemStableIdentity infos)+          tray <- buildTrayWithPriorities priorities processKeyMap orderedInfos+          Gtk.widgetHide tray+          oldTray <- readIORef trayRef+          forM_ oldTray $ \existingTray -> do+            Gtk.containerRemove trayContainer existingTray+            Gtk.widgetDestroy existingTray+          Gtk.boxPackStart trayContainer tray False False 0+          writeIORef trayRef (Just tray)+          writeIORef orderedInfosRef orderedInfos+          writeIORef processDisambiguationKeysRef processKeyMap+          writeIORef knownItemIdentitiesRef currentItemIdentities+          void refresh+          Gtk.widgetShow tray++    writeIORef rebuildTrayRef rebuildTray++    _ <- Gtk.onWidgetButtonPressEvent expandToggle $ \event -> do+      eventType <- Gdk.getEventButtonType event+      button <- Gdk.getEventButtonButton event+      if eventType == Gdk.EventTypeButtonPress && button == 1+        then do+          modifyIORef' expandedRef not+          void refresh+          return True+        else return False++    _ <- Gtk.onWidgetButtonPressEvent priorityModeToggle $ \event -> do+      eventType <- Gdk.getEventButtonType event+      button <- Gdk.getEventButtonButton event+      if eventType == Gdk.EventTypeButtonPress && button == 1+        then do+          modifyIORef' priorityEditModeRef not+          refreshPriorityModeToggle+          return True+        else return False++    _ <- Gtk.onWidgetButtonPressEvent settingsToggle $ \event -> do+      eventType <- Gdk.getEventButtonType event+      button <- Gdk.getEventButtonButton event+      if eventType == Gdk.EventTypeButtonPress && button == 1+        then do+          showPrioritySettingsMenu+            settingsToggle+            priorityMin+            priorityMax+            maxVisibleIconsRef+            visibilityThresholdRef+            (persistCurrentState >> void refresh)+          return True+        else return False++    let queueRefresh updateType _ =+          void $+            Gdk.threadsAddIdle GLib.PRIORITY_DEFAULT_IDLE $+              do+                case updateType of+                  H.ItemAdded -> do+                    infoMap <- H.itemInfoMap host+                    knownItemIdentities <- readIORef knownItemIdentitiesRef+                    let currentItemIdentities =+                          sortOn id (map itemStableIdentity (M.elems infoMap))+                    if currentItemIdentities /= knownItemIdentities+                      then do+                        join (readIORef rebuildTrayRef)+                      else void refresh+                  H.ItemRemoved -> do+                    infoMap <- H.itemInfoMap host+                    knownItemIdentities <- readIORef knownItemIdentitiesRef+                    let currentItemIdentities =+                          sortOn id (map itemStableIdentity (M.elems infoMap))+                    if currentItemIdentities /= knownItemIdentities+                      then do+                        join (readIORef rebuildTrayRef)+                      else void refresh+                  _ -> void refresh+                return False+    handlerId <- H.addUpdateHandler host queueRefresh+    _ <- Gtk.onWidgetDestroy outer $ H.removeUpdateHandler host handlerId++    rebuildTray+    refreshPriorityModeToggle+    _ <- refresh+    Gtk.widgetShowAll outer+    return outerWidget
src/System/Taffybar/Widget/ScreenLock.hs view
@@ -1,5 +1,9 @@ {-# LANGUAGE OverloadedStrings #-}+ -----------------------------------------------------------------------------++-----------------------------------------------------------------------------+ -- | -- Module      : System.Taffybar.Widget.ScreenLock -- Copyright   : (c) Ivan A. Malison@@ -33,44 +37,46 @@ -- >       { screenLockIcon = "\xF023" -- >       , screenLockInhibitTypes = [InhibitIdle, InhibitSleep] -- >       }------------------------------------------------------------------------------ module System.Taffybar.Widget.ScreenLock-  ( screenLockNew-  , screenLockNewWithConfig-  , ScreenLockConfig(..)-  , defaultScreenLockConfig-  ) where+  ( screenLockNew,+    screenLockNewWithConfig,+    ScreenLockConfig (..),+    defaultScreenLockConfig,+  )+where -import           Control.Monad-import           Control.Monad.IO.Class-import           Control.Monad.Trans.Reader-import           Data.Default (Default(..))+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.GLib as GLib+import qualified GI.Gdk as Gdk import qualified GI.Gtk as Gtk-import           System.Log.Logger-import           System.Taffybar.Context-import           System.Taffybar.Information.Inhibitor (InhibitType(..), InhibitorState(..))-import           System.Taffybar.Information.ScreenLock-import           System.Taffybar.Util (postGUIASync)-import           System.Taffybar.Widget.Generic.ChannelWidget-import           System.Taffybar.Widget.Util (widgetSetClassGI, addClassIfMissing, removeClassIfPresent)+import System.Log.Logger+import System.Taffybar.Context+import System.Taffybar.Information.Inhibitor (InhibitType (..), InhibitorState (..))+import System.Taffybar.Information.ScreenLock+import System.Taffybar.Util (postGUIASync)+import System.Taffybar.Widget.Generic.ChannelWidget+import System.Taffybar.Widget.Util (addClassIfMissing, removeClassIfPresent, widgetSetClassGI)  -- | Configuration for the screen lock widget. data ScreenLockConfig = ScreenLockConfig   { -- | Icon text to display (default: U+F023, nf-fa-lock).-    screenLockIcon :: T.Text+    screenLockIcon :: T.Text,     -- | What types of inhibitors to manage (default: @[InhibitIdle]@).-  , screenLockInhibitTypes :: [InhibitType]-  } deriving (Eq, Show)+    screenLockInhibitTypes :: [InhibitType]+  }+  deriving (Eq, Show)  -- | Default configuration for the screen lock widget. defaultScreenLockConfig :: ScreenLockConfig-defaultScreenLockConfig = ScreenLockConfig-  { screenLockIcon = T.pack "\xF023"-  , screenLockInhibitTypes = [InhibitIdle]-  }+defaultScreenLockConfig =+  ScreenLockConfig+    { screenLockIcon = T.pack "\xF023",+      screenLockInhibitTypes = [InhibitIdle]+    }  instance Default ScreenLockConfig where   def = defaultScreenLockConfig@@ -78,7 +84,7 @@ screenLockLogPath :: String screenLockLogPath = "System.Taffybar.Widget.ScreenLock" -screenLockLog :: MonadIO m => Priority -> String -> m ()+screenLockLog :: (MonadIO m) => Priority -> String -> m () screenLockLog priority = liftIO . logM screenLockLogPath priority  -- | Create a screen lock widget with default configuration.@@ -114,8 +120,8 @@             else removeClassIfPresent "screen-lock-inhibited" ebox           let tooltipText =                 if active-                then "Screen Lock (idle inhibitor active)"-                else "Screen Lock"+                  then "Screen Lock (idle inhibitor active)"+                  else "Screen Lock"           Gtk.widgetSetTooltipText ebox (Just tooltipText)      -- Set initial state on realize@@ -172,10 +178,12 @@   Gtk.menuShellAppend menu inhibitItem    -- Destroy menu when hidden (same pattern as SNIMenu)-  void $ Gtk.onWidgetHide menu $-    void $ GLib.idleAdd GLib.PRIORITY_LOW $ do-      Gtk.widgetDestroy menu-      return False+  void $+    Gtk.onWidgetHide menu $+      void $+        GLib.idleAdd GLib.PRIORITY_LOW $ do+          Gtk.widgetDestroy menu+          return False    Gtk.widgetShowAll menu   Gtk.menuPopupAtPointer menu currentEvent
src/System/Taffybar/Widget/SimpleClock.hs view
@@ -1,30 +1,33 @@ {-# LANGUAGE OverloadedStrings #-}++-- | Text clock widget with optional popup calendar. module System.Taffybar.Widget.SimpleClock-  ( textClockNew-  , textClockNewWith-  , defaultClockConfig-  , ClockConfig(..)-  , ClockUpdateStrategy(..)-  ) where+  ( textClockNew,+    textClockNewWith,+    defaultClockConfig,+    ClockConfig (..),+    ClockUpdateStrategy (..),+  )+where -import           Control.Monad.IO.Class-import           Data.Default ( Default(..) )-import           Data.Maybe+import Control.Monad.IO.Class+import Data.Default (Default (..))+import Data.Maybe import qualified Data.Text as T-import           Data.Time.Calendar ( toGregorian )+import Data.Time.Calendar (toGregorian) import qualified Data.Time.Clock as Clock-import           Data.Time.Format-import           Data.Time.LocalTime+import Data.Time.Format+import Data.Time.LocalTime import qualified Data.Time.Locale.Compat as L import qualified GI.Gdk as Gdk-import           GI.Gtk-import           System.Taffybar.Widget.Generic.PollingLabel-import           System.Taffybar.Widget.Util+import GI.Gtk+import System.Taffybar.Util (VariableDelayConfig, defaultVariableDelayConfig)+import System.Taffybar.Widget.Generic.PollingLabel+import System.Taffybar.Widget.Util  -- | This module implements a very simple text-based clock widget. The widget -- also toggles a calendar widget when clicked. This calendar is not fancy at -- all and has no data backend.- makeCalendar :: IO TimeZone -> IO Window makeCalendar tzfn = do   container <- windowNew WindowTypeToplevel@@ -39,11 +42,11 @@ resetCalendarDate cal tzfn = do   tz <- tzfn   current <- Clock.getCurrentTime-  let (y,m,d) = toGregorian $ localDay $ utcToLocalTime tz current+  let (y, m, d) = toGregorian $ localDay $ utcToLocalTime tz current   calendarSelectMonth cal (fromIntegral m - 1) (fromIntegral y)   calendarSelectDay cal (fromIntegral d) -toggleCalendar :: IsWidget w => w -> Window -> IO Bool+toggleCalendar :: (IsWidget w) => w -> Window -> IO Bool toggleCalendar w c = do   isVis <- widgetGetVisible c   if isVis@@ -57,35 +60,47 @@ -- parameter. The format string can include Pango markup -- (<http://developer.gnome.org/pango/stable/PangoMarkupFormat.html>). textClockNew ::-  MonadIO m => Maybe L.TimeLocale -> String -> Double -> m GI.Gtk.Widget+  (MonadIO m) => Maybe L.TimeLocale -> String -> Double -> m GI.Gtk.Widget textClockNew userLocale format interval =   textClockNewWith cfg   where-    cfg = def { clockTimeLocale = userLocale-              , clockFormatString = format-              , clockUpdateStrategy = ConstantInterval interval-              }+    cfg =+      def+        { clockTimeLocale = userLocale,+          clockFormatString = format,+          clockUpdateStrategy = ConstantInterval interval+        } +-- | Strategy for scheduling clock updates. data ClockUpdateStrategy-  = ConstantInterval Double-  | RoundedTargetInterval Int Double+  = -- | Re-render at a fixed interval in seconds.+    ConstantInterval Double+  | -- | Re-render near rounded time boundaries.+    -- The first argument is the rounding step in seconds and the second is an+    -- offset in seconds.+    RoundedTargetInterval Int Double   deriving (Eq, Ord, Show) +-- | Configuration for 'textClockNewWith'. data ClockConfig = ClockConfig-  { clockTimeZone :: Maybe TimeZone-  , clockTimeLocale :: Maybe L.TimeLocale-  , clockFormatString :: String-  , clockUpdateStrategy :: ClockUpdateStrategy-  } deriving (Eq, Ord, Show)+  { clockTimeZone :: Maybe TimeZone,+    clockTimeLocale :: Maybe L.TimeLocale,+    clockFormatString :: String,+    clockUpdateStrategy :: ClockUpdateStrategy,+    clockVariableDelayConfig :: VariableDelayConfig Double+  }+  deriving (Eq, Ord, Show)  -- | A clock configuration that defaults to the current locale defaultClockConfig :: ClockConfig-defaultClockConfig = ClockConfig-  { clockTimeZone = Nothing-  , clockTimeLocale = Nothing-  , clockFormatString = "%a %b %_d %r"-  , clockUpdateStrategy = RoundedTargetInterval 5 0.0-  }+defaultClockConfig =+  ClockConfig+    { clockTimeZone = Nothing,+      clockTimeLocale = Nothing,+      clockFormatString = "%a %b %_d %r",+      clockUpdateStrategy = RoundedTargetInterval 5 0.0,+      clockVariableDelayConfig = defaultVariableDelayConfig+    }  instance Default ClockConfig where   def = defaultClockConfig@@ -94,54 +109,64 @@ -- a configurable time zone through the 'ClockConfig'. -- -- See also 'textClockNew'.-textClockNewWith :: MonadIO m => ClockConfig -> m Widget-textClockNewWith ClockConfig-                   { clockTimeZone = userZone-                   , clockTimeLocale = userLocale-                   , clockFormatString = formatString-                   , clockUpdateStrategy = updateStrategy-                   } = liftIO $ do-  let getTZ = maybe getCurrentTimeZone return userZone-      locale = fromMaybe L.defaultTimeLocale userLocale+textClockNewWith :: (MonadIO m) => ClockConfig -> m Widget+textClockNewWith+  ClockConfig+    { clockTimeZone = userZone,+      clockTimeLocale = userLocale,+      clockFormatString = formatString,+      clockUpdateStrategy = updateStrategy,+      clockVariableDelayConfig = variableDelayConfig+    } = liftIO $ do+    let getTZ = maybe getCurrentTimeZone return userZone+        locale = fromMaybe L.defaultTimeLocale userLocale -  let getUserZonedTime =-        utcToZonedTime <$> getTZ <*> Clock.getCurrentTime+    let getUserZonedTime =+          utcToZonedTime <$> getTZ <*> Clock.getCurrentTime -      doTimeFormat zonedTime = T.pack $ formatTime locale formatString zonedTime+        doTimeFormat zonedTime = T.pack $ formatTime locale formatString zonedTime -      getRoundedTimeAndNextTarget = do-        zonedTime <- getUserZonedTime-        return $ case updateStrategy of-          ConstantInterval interval ->-            (doTimeFormat zonedTime, Nothing, interval)-          RoundedTargetInterval roundSeconds offset ->-            let roundSecondsDiffTime = fromIntegral roundSeconds-                addTheRound = addLocalTime roundSecondsDiffTime-                localTime = zonedTimeToLocalTime zonedTime-                ourLocalTimeOfDay = localTimeOfDay localTime-                seconds = round $ todSec ourLocalTimeOfDay-                secondsFactor = seconds `div` roundSeconds-                displaySeconds = secondsFactor * roundSeconds-                baseLocalTimeOfDay =-                  ourLocalTimeOfDay { todSec = fromIntegral displaySeconds }-                ourLocalTime =-                  localTime { localTimeOfDay = baseLocalTimeOfDay }-                roundedLocalTime =-                  if seconds `mod` roundSeconds > roundSeconds `div` 2-                  then addTheRound ourLocalTime-                  else ourLocalTime-                roundedZonedTime =-                  zonedTime { zonedTimeToLocalTime = roundedLocalTime }-                nextTarget = addTheRound ourLocalTime-                amountToWait = realToFrac $ diffLocalTime nextTarget localTime-            in (doTimeFormat roundedZonedTime, Nothing, amountToWait - offset)+        getRoundedTimeAndNextTarget = do+          zonedTime <- getUserZonedTime+          return $ case updateStrategy of+            ConstantInterval interval ->+              (doTimeFormat zonedTime, Nothing, interval)+            RoundedTargetInterval roundSeconds offset ->+              let roundSecondsDiffTime = fromIntegral roundSeconds+                  addTheRound = addLocalTime roundSecondsDiffTime+                  localTime = zonedTimeToLocalTime zonedTime+                  ourLocalTimeOfDay = localTimeOfDay localTime+                  seconds = round $ todSec ourLocalTimeOfDay+                  secondsFactor = seconds `div` roundSeconds+                  displaySeconds = secondsFactor * roundSeconds+                  baseLocalTimeOfDay =+                    ourLocalTimeOfDay {todSec = fromIntegral displaySeconds}+                  ourLocalTime =+                    localTime {localTimeOfDay = baseLocalTimeOfDay}+                  roundedLocalTime =+                    if seconds `mod` roundSeconds > roundSeconds `div` 2+                      then addTheRound ourLocalTime+                      else ourLocalTime+                  roundedZonedTime =+                    zonedTime {zonedTimeToLocalTime = roundedLocalTime}+                  nextTarget = addTheRound ourLocalTime+                  amountToWait = realToFrac $ diffLocalTime nextTarget localTime+               in (doTimeFormat roundedZonedTime, Nothing, amountToWait - offset) -  label <- pollingLabelWithVariableDelay getRoundedTimeAndNextTarget-  ebox <- eventBoxNew-  containerAdd ebox label-  eventBoxSetVisibleWindow ebox False-  cal <- makeCalendar getTZ-  _ <- onWidgetButtonPressEvent ebox $ onClick [Gdk.EventTypeButtonPress] $-       toggleCalendar label cal-  widgetShowAll ebox-  toWidget ebox+    let pollingConfig =+          defaultPollingLabelConfig+            { pollingLabelVariableDelayConfig = variableDelayConfig+            }+    label <- pollingLabelWithVariableDelayWithConfig pollingConfig getRoundedTimeAndNextTarget+    _ <- widgetSetClassGI label "text-clock-label"+    ebox <- eventBoxNew+    _ <- widgetSetClassGI ebox "text-clock"+    containerAdd ebox label+    eventBoxSetVisibleWindow ebox False+    cal <- makeCalendar getTZ+    _ <-+      onWidgetButtonPressEvent ebox $+        onClick [Gdk.EventTypeButtonPress] $+          toggleCalendar label cal+    widgetShowAll ebox+    toWidget ebox
src/System/Taffybar/Widget/SimpleCommandButton.hs view
@@ -1,4 +1,9 @@+{-# LANGUAGE OverloadedStrings #-}+ --------------------------------------------------------------------------------++--------------------------------------------------------------------------------+ -- | -- Module      : System.Taffybar.Widget.SimpleCommandButton -- Copyright   : (c) Ulf Jasper@@ -9,19 +14,19 @@ -- Portability : unportable -- -- Simple button which runs a user defined command when being clicked-----------------------------------------------------------------------------------module System.Taffybar.Widget.SimpleCommandButton (-  -- * Usage-  -- $usage-  simpleCommandButtonNew)+module System.Taffybar.Widget.SimpleCommandButton+  ( -- * Usage+    -- $usage+    simpleCommandButtonNew,+  ) where -import           Control.Monad (void)-import           Control.Monad.IO.Class-import           GI.Gtk-import           System.Process+import Control.Monad (void)+import Control.Monad.IO.Class import qualified Data.Text as T+import GI.Gtk+import System.Process+import System.Taffybar.Widget.Util (widgetSetClassGI)  -- $usage --@@ -35,12 +40,15 @@ -- Now you can use @cmdButton@ like any other Taffybar widget.  -- | Creates a new simple command button.-simpleCommandButtonNew-  :: MonadIO m-  => T.Text -- ^ Contents of the button's label.-  -> T.Text -- ^ Command to execute. Should be in $PATH or an absolute path-  -> m Widget-simpleCommandButtonNew  txt cmd = do+simpleCommandButtonNew ::+  (MonadIO m) =>+  -- | Contents of the button's label.+  T.Text ->+  -- | Command to execute. Should be in $PATH or an absolute path+  T.Text ->+  m Widget+simpleCommandButtonNew txt cmd = do   button <- buttonNewWithLabel txt+  _ <- widgetSetClassGI button "simple-command-button"   void $ onButtonClicked button $ void $ spawnCommand $ T.unpack cmd   toWidget button
src/System/Taffybar/Widget/Systemd.hs view
@@ -1,5 +1,9 @@ {-# LANGUAGE OverloadedStrings #-}+ -----------------------------------------------------------------------------++-----------------------------------------------------------------------------+ -- | -- Module      : System.Taffybar.Widget.Systemd -- Copyright   : (c) Ivan A. Malison@@ -26,58 +30,60 @@ -- > .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+  ( 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 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+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+    systemdFormat :: String,     -- | Format string when there are no failures (only used if hideOnOk is False).-  , systemdFormatOk :: String+    systemdFormatOk :: String,     -- | Whether to hide the widget when there are no failed units.-  , systemdHideOnOk :: Bool+    systemdHideOnOk :: Bool,     -- | Whether to monitor system units.-  , systemdMonitorSystem :: Bool+    systemdMonitorSystem :: Bool,     -- | Whether to monitor user units.-  , systemdMonitorUser :: Bool+    systemdMonitorUser :: Bool,     -- | Nerd font icon character (default U+F071, warning triangle).-  , systemdIcon :: T.Text-  } deriving (Eq, Show)+    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-  }+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@@ -140,7 +146,7 @@ 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+   in sysCount + usrCount  -- | Update the label text based on the current state. updateSystemdLabel :: SystemdConfig -> Gtk.Label -> SystemdInfo -> IO ()@@ -149,11 +155,13 @@       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+      tpl' =+        setManyAttrib+          [ ("count", show effectiveCount),+            ("system", show (systemFailedCount info)),+            ("user", show (userFailedCount info))+          ]+          tpl   labelSetMarkup label (render tpl')  -- | Update widget visibility based on configuration.
src/System/Taffybar/Widget/Temperature.hs view
@@ -1,4 +1,7 @@ --------------------------------------------------------------------------------+--------------------------------------------------------------------------------+{-# LANGUAGE OverloadedStrings #-}+ -- | -- Module      : System.Taffybar.Widget.Temperature -- Copyright   : (c) Ivan Malison@@ -11,58 +14,57 @@ -- 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+    temperatureNew,+    temperatureNewWith,+     -- * Icon-only widget-  , temperatureIconNew-  , temperatureIconNewWith+    temperatureIconNew,+    temperatureIconNewWith,+     -- * Label-only widget-  , temperatureLabelNew-  , temperatureLabelNewWith+    temperatureLabelNew,+    temperatureLabelNewWith,+     -- * Configuration-  , TemperatureConfig(..)-  , defaultTemperatureConfig+    TemperatureConfig (..),+    defaultTemperatureConfig,+     -- * Re-exports-  , TemperatureUnit(..)-  ) where+    TemperatureUnit (..),+  )+where  import Control.Monad.IO.Class (MonadIO, liftIO)-import Data.Default (Default(..))+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)+import System.Taffybar.Widget.Util (buildIconLabelBox, widgetSetClassGI)+import qualified Text.StringTemplate as ST  -- | Configuration for the temperature widget data TemperatureConfig = TemperatureConfig-  { tempFormat :: String-    -- ^ Format string for the label. Available variables:+  { -- | 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).+    tempFormat :: String,+    -- | Unit to use for the {temp} variable (default: Celsius)+    tempUnit :: TemperatureUnit,+    -- | Temperature (in Celsius) at which to show warning style (default: 70)+    tempWarningThreshold :: Double,+    -- | Temperature (in Celsius) at which to show critical style (default: 85)+    tempCriticalThreshold :: Double,+    -- | How often to poll for temperature updates, in seconds (default: 10)+    tempPollInterval :: Double,+    -- | Filter function to select which sensors to monitor (default: all)+    tempSensorFilter :: ThermalSensor -> Bool,+    -- | How to aggregate multiple sensor readings (default: maximum)+    tempAggregation :: [TemperatureInfo] -> Maybe Double,+    -- | Nerd font icon character (default U+F2C9, nf-fa-thermometer).+    temperatureIcon :: T.Text   }  instance Default TemperatureConfig where@@ -70,48 +72,51 @@  -- | 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"-  }+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 :: (MonadIO m) => m Gtk.Widget temperatureNew = temperatureNewWith defaultTemperatureConfig  -- | Create a combined icon+label temperature widget.-temperatureNewWith :: MonadIO m => TemperatureConfig -> m Gtk.Widget+temperatureNewWith :: (MonadIO m) => TemperatureConfig -> m Gtk.Widget temperatureNewWith config = liftIO $ do   iconWidget <- temperatureIconNewWith config   labelWidget <- temperatureLabelNewWith config   buildIconLabelBox iconWidget labelWidget+    >>= (`widgetSetClassGI` "temperature")  -- | Create a temperature icon widget with default configuration.-temperatureIconNew :: MonadIO m => m Gtk.Widget+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 :: (MonadIO m) => TemperatureConfig -> m Gtk.Widget temperatureIconNewWith config = liftIO $ do   label <- Gtk.labelNew (Just (temperatureIcon config))+  _ <- widgetSetClassGI label "temperature-icon"   Gtk.widgetShowAll label   Gtk.toWidget label  -- | Create a temperature label widget with default configuration.-temperatureLabelNew :: MonadIO m => m Gtk.Widget+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 :: (MonadIO m) => TemperatureConfig -> m Gtk.Widget temperatureLabelNewWith config = liftIO $ do   -- Discover sensors once at startup, filtered by config   allSensors <- discoverSensors@@ -128,13 +133,7 @@             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-+  widgetSetClassGI widget "temperature-label"   where     readTemperaturesFiltered :: [ThermalSensor] -> IO [TemperatureInfo]     readTemperaturesFiltered sensors =@@ -144,13 +143,15 @@ 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'+      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)@@ -161,5 +162,7 @@   T.pack $ intercalate "\n" $ map formatSensor temps   where     formatSensor info =-      sensorName (tempSensor info) ++ ": " ++-      show (round (tempCelsius info) :: Int) ++ "\176C"+      sensorName (tempSensor info)+        ++ ": "+        ++ show (round (tempCelsius info) :: Int)+        ++ "\176C"
src/System/Taffybar/Widget/Text/CPUMonitor.hs view
@@ -1,30 +1,52 @@+{-# LANGUAGE NamedFieldPuns #-}++-- | Textual CPU monitor widgets. module System.Taffybar.Widget.Text.CPUMonitor (textCpuMonitorNew) where -import Control.Monad.IO.Class ( MonadIO )-import Text.Printf ( printf )-import qualified Text.StringTemplate as ST-import System.Taffybar.Information.CPU-import System.Taffybar.Widget.Generic.PollingLabel ( pollingLabelNew )+import Control.Monad (void)+import Control.Monad.IO.Class (MonadIO, liftIO)+import qualified Data.Text as T import qualified GI.Gtk+import System.Taffybar.Information.CPU2 (CPULoad (..), getCPULoadChan)+import System.Taffybar.Util (postGUIASync)+import System.Taffybar.Widget.Generic.ChannelWidget (channelWidgetNew)+import System.Taffybar.Widget.Util (widgetSetClassGI)+import Text.Printf (printf)+import qualified Text.StringTemplate as ST  -- | Creates a simple textual CPU monitor. It updates once every polling -- period (in seconds).-textCpuMonitorNew :: MonadIO m-                  => String -- ^ Format. You can use variables: $total$, $user$, $system$-                  -> Double -- ^ Polling period (in seconds)-                  -> m GI.Gtk.Widget-textCpuMonitorNew fmt period = do-  label <- pollingLabelNew period callback-  GI.Gtk.toWidget label-  where-    callback = do-      (userLoad, systemLoad, totalLoad) <- cpuLoad-      let pct = formatPercent . (* 100)-      let template = ST.newSTMP fmt-      let template' = ST.setManyAttrib [ ("user", pct userLoad),-                                         ("system", pct systemLoad),-                                         ("total", pct totalLoad) ] template-      return $ ST.render template'+textCpuMonitorNew ::+  (MonadIO m) =>+  -- | Format. You can use variables: $total$, $user$, $system$+  String ->+  -- | Polling period (in seconds)+  Double ->+  m GI.Gtk.Widget+textCpuMonitorNew fmt period = liftIO $ do+  chan <- getCPULoadChan "cpu" period+  label <- GI.Gtk.labelNew Nothing+  _ <- widgetSetClassGI label (T.pack "text-cpu-monitor")+  void $+    channelWidgetNew label chan $ \sample ->+      postGUIASync $+        GI.Gtk.labelSetMarkup label $+          renderCpuInfo fmt sample+  widget <- GI.Gtk.toWidget label+  widgetSetClassGI widget (T.pack "text-cpu-monitor")++renderCpuInfo :: String -> CPULoad -> T.Text+renderCpuInfo fmt CPULoad {cpuUserLoad, cpuSystemLoad, cpuTotalLoad} =+  let pct = formatPercent . (* 100)+      template = ST.newSTMP fmt+      template' =+        ST.setManyAttrib+          [ ("user", pct cpuUserLoad),+            ("system", pct cpuSystemLoad),+            ("total", pct cpuTotalLoad)+          ]+          template+   in T.pack $ ST.render template'  formatPercent :: Double -> String formatPercent = printf "%.2f"
src/System/Taffybar/Widget/Text/MemoryMonitor.hs view
@@ -1,64 +1,99 @@+-- | Text memory monitor helpers built on top of+-- "System.Taffybar.Information.Memory". module System.Taffybar.Widget.Text.MemoryMonitor (textMemoryMonitorNew, showMemoryInfo) where -import Control.Monad.IO.Class ( MonadIO )+import Control.Monad.IO.Class (MonadIO) import qualified Data.Text as T-import qualified Text.StringTemplate as ST-import System.Taffybar.Information.Memory-import System.Taffybar.Widget.Generic.PollingLabel ( pollingLabelNew ) import qualified GI.Gtk-import Text.Printf ( printf )+import System.Taffybar.Information.Memory+import System.Taffybar.Widget.Generic.PollingLabel (pollingLabelNew)+import System.Taffybar.Widget.Util (widgetSetClassGI)+import Text.Printf (printf)+import qualified Text.StringTemplate as ST  -- | Creates a simple textual memory monitor. It updates once every polling -- period (in seconds).-textMemoryMonitorNew :: MonadIO m-                     => String -- ^ Format. You can use variables: "used", "total", "free", "buffer",-                               -- "cache", "rest", "available", "swapUsed", "swapTotal", "swapFree".-                     -> Double -- ^ Polling period in seconds.-                     -> m GI.Gtk.Widget+textMemoryMonitorNew ::+  (MonadIO m) =>+  -- | Format. You can use variables: "used", "total", "free", "buffer",+  -- "cache", "rest", "available", "swapUsed", "swapTotal", "swapFree",+  -- "usedRatio", "swapUsedRatio", "usedPercent", "swapUsedPercent".+  String ->+  -- | Polling period in seconds.+  Double ->+  m GI.Gtk.Widget textMemoryMonitorNew fmt period = do-    label <- pollingLabelNew period (showMemoryInfo fmt 3 <$> parseMeminfo)-    GI.Gtk.toWidget label+  label <- pollingLabelNew period (showMemoryInfo fmt 3 <$> parseMeminfo)+  widgetSetClassGI label (T.pack "text-memory-monitor") +-- | Render a 'MemoryInfo' snapshot into a template string.+--+-- The template supports keys documented in 'textMemoryMonitorNew'. showMemoryInfo :: String -> Int -> MemoryInfo -> T.Text showMemoryInfo fmt prec info =   let template = ST.newSTMP fmt-      labels = [ "used"-               , "total"-               , "free"-               , "buffer"-               , "cache"-               , "rest"-               , "available"-               , "swapUsed"-               , "swapTotal"-               , "swapFree"-               ]-      actions = [ memoryUsed-                , memoryTotal-                , memoryFree-                , memoryBuffer-                , memoryCache-                , memoryRest-                , memoryAvailable-                , memorySwapUsed-                , memorySwapTotal-                , memorySwapFree-                ]-      actions' = map (toAuto prec .) actions-      stats = [f info | f <- actions']-      template' = ST.setManyAttrib (zip labels stats) template-  in ST.render template'+      sizeLabels =+        [ "used",+          "total",+          "free",+          "buffer",+          "cache",+          "rest",+          "available",+          "swapUsed",+          "swapTotal",+          "swapFree"+        ]+      sizeActions =+        [ memoryUsed,+          memoryTotal,+          memoryFree,+          memoryBuffer,+          memoryCache,+          memoryRest,+          memoryAvailable,+          memorySwapUsed,+          memorySwapTotal,+          memorySwapFree+        ]+      sizeStats =+        [ (label, toAuto prec (action info))+        | (label, action) <- zip sizeLabels sizeActions+        ]+      ratioStats =+        [ ("usedRatio", toRatio prec (memoryUsedRatio info)),+          ("swapUsedRatio", toRatio prec (memorySwapUsedRatio info))+        ]+      percentStats =+        [ ("usedPercent", toPercent 1 (memoryUsedRatio info)),+          ("swapUsedPercent", toPercent 1 (memorySwapUsedRatio info))+        ]+      template' = ST.setManyAttrib (sizeStats ++ ratioStats ++ percentStats) template+   in ST.render template'  toAuto :: Int -> Double -> String toAuto prec value = printf "%.*f%s" p v unit-  where value' = max 0 value-        mag :: Int-        mag = if value' == 0 then 0 else max 0 $ min 2 $ floor $ logBase 1024 value'-        v = value' / 1024 ** fromIntegral mag-        unit = case mag of-          0 -> "MiB"-          1 -> "GiB"-          2 -> "TiB"-          _ -> "??B" -- unreachable-        p :: Int-        p = max 0 $ floor $ fromIntegral prec - logBase 10 v+  where+    value' = max 0 value+    mag :: Int+    mag = if value' == 0 then 0 else max 0 $ min 2 $ floor $ logBase 1024 value'+    v = value' / 1024 ** fromIntegral mag+    unit = case mag of+      0 -> "MiB"+      1 -> "GiB"+      2 -> "TiB"+      _ -> "??B" -- unreachable+    p :: Int+    p = max 0 $ floor $ fromIntegral prec - logBase 10 v++toRatio :: Int -> Double -> String+toRatio prec value = printf "%.*f" p value'+  where+    p = max 0 prec+    value' = max 0 value++toPercent :: Int -> Double -> String+toPercent prec value = printf "%.*f%%" p (value' * 100)+  where+    p = max 0 prec+    value' = max 0 value
src/System/Taffybar/Widget/Text/NetworkMonitor.hs view
@@ -1,68 +1,82 @@+-- | Text network throughput widget. module System.Taffybar.Widget.Text.NetworkMonitor where -import           Control.Monad-import           Control.Monad.Trans.Class+import Control.Monad+import Control.Monad.Trans.Class import qualified Data.Text as T-import           GI.Gtk-import           System.Taffybar.Context-import           System.Taffybar.Hooks-import           System.Taffybar.Information.Network-import           System.Taffybar.Util-import           System.Taffybar.Widget.Generic.ChannelWidget-import           Text.Printf-import           Text.StringTemplate+import GI.Gtk+import System.Taffybar.Context+import System.Taffybar.Hooks+import System.Taffybar.Information.Network+import System.Taffybar.Util+import System.Taffybar.Widget.Generic.ChannelWidget+import System.Taffybar.Widget.Util (widgetSetClassGI)+import Text.Printf+import Text.StringTemplate +-- | Default template for 'networkMonitorNew'. defaultNetFormat :: String defaultNetFormat = "▼ $inAuto$ ▲ $outAuto$" +-- | Render inbound/outbound speeds into a template. showInfo :: String -> Int -> (Double, Double) -> T.Text showInfo template prec (incomingb, outgoingb) =-  let-    attribs = [ ("inB", show incomingb)-              , ("inKB", toKB prec incomingb)-              , ("inMB", toMB prec incomingb)-              , ("inAuto", toAuto prec incomingb)-              , ("outB", show outgoingb)-              , ("outKB", toKB prec outgoingb)-              , ("outMB", toMB prec outgoingb)-              , ("outAuto", toAuto prec outgoingb)-              ]-  in-    render . setManyAttrib attribs $ newSTMP template+  let attribs =+        [ ("inB", show incomingb),+          ("inKB", toKB prec incomingb),+          ("inMB", toMB prec incomingb),+          ("inAuto", toAuto prec incomingb),+          ("outB", show outgoingb),+          ("outKB", toKB prec outgoingb),+          ("outMB", toMB prec outgoingb),+          ("outAuto", toAuto prec outgoingb)+        ]+   in render . setManyAttrib attribs $ newSTMP template +-- | Convert bytes per second to KiB/s. toKB :: Int -> Double -> String-toKB prec = setDigits prec . (/1024)+toKB prec = setDigits prec . (/ 1024) +-- | Convert bytes per second to MiB/s. toMB :: Int -> Double -> String toMB prec = setDigits prec . (/ (1024 * 1024)) +-- | Render a floating-point value with fixed precision. setDigits :: Int -> Double -> String setDigits dig = printf format-    where format = "%." ++ show dig ++ "f"+  where+    format = "%." ++ show dig ++ "f" +-- | Convert bytes per second to an automatically chosen unit. toAuto :: Int -> Double -> String toAuto prec value = printf "%.*f%s" p v unit-  where value' = max 0 value-        mag :: Int-        mag = if value' == 0 then 0 else max 0 $ min 4 $ floor $ logBase 1024 value'-        v = value' / 1024 ** fromIntegral mag-        unit = case mag of-          0 -> "B/s"-          1 -> "KiB/s"-          2 -> "MiB/s"-          3 -> "GiB/s"-          4 -> "TiB/s"-          _ -> "??B/s" -- unreachable-        p :: Int-        p = max 0 $ floor $ fromIntegral prec - logBase 10 v+  where+    value' = max 0 value+    mag :: Int+    mag = if value' == 0 then 0 else max 0 $ min 4 $ floor $ logBase 1024 value'+    v = value' / 1024 ** fromIntegral mag+    unit = case mag of+      0 -> "B/s"+      1 -> "KiB/s"+      2 -> "MiB/s"+      3 -> "GiB/s"+      4 -> "TiB/s"+      _ -> "??B/s" -- unreachable+    p :: Int+    p = max 0 $ floor $ fromIntegral prec - logBase 10 v +-- | Create a text network monitor widget.+--+-- The optional interface list restricts aggregation to matching interface+-- names; when omitted, all interfaces are included. networkMonitorNew :: String -> Maybe [String] -> TaffyIO GI.Gtk.Widget networkMonitorNew template interfaces = do   NetworkInfoChan chan <- getNetworkChan   let filterFn = maybe (const True) (flip elem) interfaces   label <- lift $ labelNew Nothing+  _ <- lift $ widgetSetClassGI label (T.pack "text-network-monitor")   void $ channelWidgetNew label chan $ \speedInfo ->     let (up, down) = sumSpeeds $ map snd $ filter (filterFn . fst) speedInfo         labelString = showInfo template 3 (fromRational down, fromRational up)-    in postGUIASync $ labelSetMarkup label labelString+     in postGUIASync $ labelSetMarkup label labelString   toWidget label
src/System/Taffybar/Widget/Util.hs view
@@ -1,8 +1,11 @@ {-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE TypeApplications #-} {-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TypeApplications #-}  -----------------------------------------------------------------------------++-----------------------------------------------------------------------------+ -- | -- Module      : System.Taffybar.Widget.Util -- Copyright   : (c) Ivan Malison@@ -13,41 +16,37 @@ -- Portability : unportable -- -- Utility functions to facilitate building GTK interfaces.---------------------------------------------------------------------------------- module System.Taffybar.Widget.Util where -import           Control.Concurrent ( forkIO )+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)-import           Data.Int+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)+import Data.Int import qualified Data.Text as T import qualified GI.Gdk as D import qualified GI.GdkPixbuf.Objects.Pixbuf as GI 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-import           Text.Printf--import           Paths_taffybar ( getDataDir )+import GI.Gtk as Gtk+import Paths_taffybar (getDataDir)+import StatusNotifier.Tray (scalePixbufToSize)+import System.Environment.XDG.DesktopEntry+import System.FilePath.Posix+import System.Log.Logger (Priority (..))+import System.Taffybar.Util+import Text.Printf  -- | 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 ()+  { 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@@ -56,7 +55,7 @@ -- -- 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 :: (MonadIO m) => Maybe Int32 -> m (WindowIconWidget a) mkWindowIconWidgetBase _mSize = liftIO $ do   windowVar <- MV.newMVar Nothing   ebox <- Gtk.eventBoxNew@@ -64,10 +63,10 @@   placeholder <- Gtk.toWidget ebox   return     WindowIconWidget-      { iconContainer = ebox-      , iconImage = placeholder-      , iconWindow = windowVar-      , iconForceUpdate = return ()+      { iconContainer = ebox,+        iconImage = placeholder,+        iconWindow = windowVar,+        iconForceUpdate = return ()       }  -- | List of possible status class names for window icon widgets.@@ -78,18 +77,19 @@  -- | 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 ()+  (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)+      removeIfPresent klass =+        unless (klass `elem` toAdd) $+          hasClass klass >>= (`when` Gtk.styleContextRemoveClass context klass)   mapM_ removeIfPresent toRemove   mapM_ addIfMissing toAdd @@ -111,14 +111,16 @@     [statusString]     possibleStatusStrings +-- | Wrap an icon getter to scale returned pixbufs to the requested size. 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)+  getter size windowData+    >>= traverse (liftIO . scalePixbufToSize size Gtk.OrientationHorizontal) +-- | Catch exceptions from a pixbuf getter and log them. handlePixbufGetterException ::   (MonadBaseControl IO m, Show a) =>   (Priority -> String -> m ()) ->@@ -128,32 +130,42 @@   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)+    _ <-+      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.-        -> IO a    -- ^ Action to execute.-        -> D.EventButton-        -> IO Bool+onClick ::+  -- | Types of button clicks to listen to.+  [D.EventType] ->+  -- | Action to execute.+  IO a ->+  D.EventButton ->+  IO Bool onClick triggers action btn = do   click <- D.getEventButtonType btn   if click `elem` triggers-  then action >> return True-  else return False+    then action >> return True+    else return False  -- | Attach the given widget as a popup with the given title to the -- given window. The newly attached popup is not shown initially. Use -- the 'displayPopup' function to display it.-attachPopup :: (Gtk.IsWidget w, Gtk.IsWindow wnd) =>-               w      -- ^ The widget to set as popup.-            -> T.Text -- ^ The title of the popup.-            -> wnd    -- ^ The window to attach the popup to.-            -> IO ()+attachPopup ::+  (Gtk.IsWidget w, Gtk.IsWindow wnd) =>+  -- | The widget to set as popup.+  w ->+  -- | The title of the popup.+  T.Text ->+  -- | The window to attach the popup to.+  wnd ->+  IO () attachPopup widget title window = do-   windowSetTitle window title   windowSetTypeHint window D.WindowTypeHintTooltip   windowSetSkipTaskbarHint window True@@ -165,20 +177,23 @@   where     getWindow :: IO (Maybe Window)     getWindow = do-          windowGType <- glibType @Window-          Just ancestor <- Gtk.widgetGetAncestor widget windowGType-          castTo Window ancestor+      windowGType <- glibType @Window+      Just ancestor <- Gtk.widgetGetAncestor widget windowGType+      castTo Window ancestor  -- | Display the given popup widget (previously prepared using the -- 'attachPopup' function) immediately beneath (or above) the given -- window.-displayPopup :: (Gtk.IsWidget w, Gtk.IsWidget wnd, Gtk.IsWindow wnd) =>-                w   -- ^ The popup widget.-             -> wnd -- ^ The window the widget was attached to.-             -> IO ()+displayPopup ::+  (Gtk.IsWidget w, Gtk.IsWidget wnd, Gtk.IsWindow wnd) =>+  -- | The popup widget.+  w ->+  -- | The window the widget was attached to.+  wnd ->+  IO () displayPopup widget window = do   windowSetPosition window WindowPositionMouse-  (x, y ) <- windowGetPosition window+  (x, y) <- windowGetPosition window   (_, natReq) <- widgetGetPreferredSize =<< widgetGetToplevel widget   y' <- getRequisitionHeight natReq   widgetShowAll window@@ -186,9 +201,10 @@     then windowMove window x (y - y')     else windowMove window x y' -widgetGetAllocatedSize-  :: (Gtk.IsWidget self, MonadIO m)-  => self -> m (Int, Int)+-- | Read current allocated widget width and height.+widgetGetAllocatedSize ::+  (Gtk.IsWidget self, MonadIO m) =>+  self -> m (Int, Int) widgetGetAllocatedSize widget = do   w <- Gtk.widgetGetAllocatedWidth widget   h <- Gtk.widgetGetAllocatedHeight widget@@ -196,101 +212,125 @@  -- | Creates markup with the given foreground and background colors and the -- given contents.-colorize :: String -- ^ Foreground color.-         -> String -- ^ Background color.-         -> String -- ^ Contents.-         -> String+colorize ::+  -- | Foreground color.+  String ->+  -- | Background color.+  String ->+  -- | Contents.+  String ->+  String colorize fg bg = printf "<span%s%s>%s</span>" (attr ("fg" :: String) fg :: String) (attr ("bg" :: String) bg :: String)-  where attr name value-          | null value = ""-          | otherwise  = printf " %scolor=\"%s\"" name value+  where+    attr name value+      | null value = ""+      | otherwise = printf " %scolor=\"%s\"" name value +-- | Run an action forever on a background thread. backgroundLoop :: IO a -> IO () backgroundLoop = void . forkIO . forever -drawOn :: Gtk.IsWidget object => object -> IO () -> IO object+-- | Register an action on widget realization and return the widget.+drawOn :: (Gtk.IsWidget object) => object -> IO () -> IO object drawOn drawArea action = Gtk.onWidgetRealize drawArea action $> drawArea +-- | Add a CSS class to a widget and return it. widgetSetClassGI :: (Gtk.IsWidget b, MonadIO m) => b -> T.Text -> m b widgetSetClassGI widget klass =-  Gtk.widgetGetStyleContext widget >>=-    flip Gtk.styleContextAddClass klass >> return widget+  Gtk.widgetGetStyleContext widget+    >>= flip Gtk.styleContextAddClass klass+    >> return widget +-- | Standard icon-theme load flags used by icon helpers. themeLoadFlags :: [Gtk.IconLookupFlags] themeLoadFlags =-  [ Gtk.IconLookupFlagsGenericFallback-  , Gtk.IconLookupFlagsUseBuiltin+  [ Gtk.IconLookupFlagsGenericFallback,+    Gtk.IconLookupFlagsUseBuiltin   ] +-- | Resolve and load an icon for a desktop entry. getImageForDesktopEntry :: Int32 -> DesktopEntry -> IO (Maybe GI.Pixbuf) getImageForDesktopEntry size de = getImageForMaybeIconName (T.pack <$> deIcon de) size +-- | Resolve and load an icon from an optional icon name. getImageForMaybeIconName :: Maybe T.Text -> Int32 -> IO (Maybe GI.Pixbuf) getImageForMaybeIconName mIconName size =   join <$> traverse (`getImageForIconName` size) mIconName +-- | Resolve and load an icon by theme name or filesystem path. getImageForIconName :: T.Text -> Int32 -> IO (Maybe GI.Pixbuf) getImageForIconName iconName size =-  maybeTCombine (loadPixbufByName size iconName)-                  (getPixbufFromFilePath (T.unpack iconName) >>=-                   traverse (scalePixbufToSize size Gtk.OrientationHorizontal))+  maybeTCombine+    (loadPixbufByName size iconName)+    ( getPixbufFromFilePath (T.unpack iconName)+        >>= traverse (scalePixbufToSize size Gtk.OrientationHorizontal)+    ) +-- | Load an icon pixbuf from the current icon theme by symbolic name. loadPixbufByName :: Int32 -> T.Text -> IO (Maybe GI.Pixbuf) loadPixbufByName size name = do   iconTheme <- Gtk.iconThemeGetDefault   hasIcon <- Gtk.iconThemeHasIcon iconTheme name   if hasIcon-  then Gtk.iconThemeLoadIcon iconTheme name size themeLoadFlags-  else return Nothing+    then Gtk.iconThemeLoadIcon iconTheme name size themeLoadFlags+    else return Nothing +-- | Center a widget in both axes. alignCenter :: (Gtk.IsWidget o, MonadIO m) => o -> m () alignCenter widget =-  Gtk.setWidgetValign widget Gtk.AlignCenter >>-  Gtk.setWidgetHalign widget Gtk.AlignCenter+  Gtk.setWidgetValign widget Gtk.AlignCenter+    >> Gtk.setWidgetHalign widget Gtk.AlignCenter +-- | Make a widget vertically fill and horizontally centered. vFillCenter :: (Gtk.IsWidget o, MonadIO m) => o -> m () vFillCenter widget =-  Gtk.widgetSetVexpand widget True >>-  Gtk.setWidgetValign widget Gtk.AlignFill >>-  Gtk.setWidgetHalign widget Gtk.AlignCenter+  Gtk.widgetSetVexpand widget True+    >> Gtk.setWidgetValign widget Gtk.AlignFill+    >> Gtk.setWidgetHalign widget Gtk.AlignCenter +-- | Load and scale a pixbuf from file to a target height. pixbufNewFromFileAtScaleByHeight :: Int32 -> String -> IO (Either String PB.Pixbuf) pixbufNewFromFileAtScaleByHeight height name =-  fmap (handleResult . first show) $ catchGErrorsAsLeft $-  PB.pixbufNewFromFileAtScale name (-1) height True+  fmap (handleResult . first show) $+    catchGErrorsAsLeft $+      PB.pixbufNewFromFileAtScale name (-1) height True   where     handleResult = (maybe (Left "gdk function returned NULL") Right =<<) +-- | Load an icon shipped with taffybar's data files. loadIcon :: Int32 -> String -> IO (Either String PB.Pixbuf) loadIcon height name =-  getDataDir >>=-  pixbufNewFromFileAtScaleByHeight height . (</> "icons" </> name)+  getDataDir+    >>= pixbufNewFromFileAtScaleByHeight height . (</> "icons" </> name) +-- | Set a minimum widget width while preserving natural height. setMinWidth :: (Gtk.IsWidget w, MonadIO m) => Int -> w -> m w setMinWidth width widget = liftIO $ do   Gtk.widgetSetSizeRequest widget (fromIntegral width) (-1)   return widget +-- | Add a CSS class if it is not already present. addClassIfMissing ::   (IsDescendantOf Widget a, MonadIO m, GObject a) => T.Text -> a -> m () addClassIfMissing klass widget = do   context <- Gtk.widgetGetStyleContext widget-  Gtk.styleContextHasClass context klass >>=-       (`when` Gtk.styleContextAddClass context klass) . not+  Gtk.styleContextHasClass context klass+    >>= (`when` Gtk.styleContextAddClass context klass) . not +-- | Remove a CSS class when it is currently present. removeClassIfPresent ::   (IsDescendantOf Widget a, MonadIO m, GObject a) => T.Text -> a -> m () removeClassIfPresent klass widget = do   context <- Gtk.widgetGetStyleContext widget-  Gtk.styleContextHasClass context klass >>=-       (`when` Gtk.styleContextRemoveClass context klass)+  Gtk.styleContextHasClass context klass+    >>= (`when` Gtk.styleContextRemoveClass context klass)  -- | Wrap a widget with two container boxes. The inner box will have the class -- "inner-pad", and the outer box will have the class "outer-pad". These boxes -- can be used to add padding between the outline of the widget and its -- contents, or for the purpose of displaying a different background behind the -- widget.-buildPadBox :: MonadIO m => Gtk.Widget -> m Gtk.Widget+buildPadBox :: (MonadIO m) => Gtk.Widget -> m Gtk.Widget buildPadBox contents = liftIO $ do   innerBox <- Gtk.boxNew Gtk.OrientationHorizontal 0   outerBox <- Gtk.boxNew Gtk.OrientationHorizontal 0@@ -304,7 +344,8 @@   Gtk.widgetShow innerBox   Gtk.toWidget outerBox -buildContentsBox :: MonadIO m => Gtk.Widget -> m Gtk.Widget+-- | Wrap a widget in a @contents@ box and then in the standard pad boxes.+buildContentsBox :: (MonadIO m) => Gtk.Widget -> m Gtk.Widget buildContentsBox widget = liftIO $ do   contents <- Gtk.boxNew Gtk.OrientationHorizontal 0   Gtk.containerAdd contents widget@@ -315,7 +356,7 @@ -- | 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 :: (MonadIO m) => Gtk.Widget -> Gtk.Widget -> m Gtk.Widget buildIconLabelBox iconWidget labelWidget = liftIO $ do   box <- Gtk.boxNew Gtk.OrientationHorizontal 0   _ <- widgetSetClassGI iconWidget "icon"@@ -330,7 +371,7 @@ -- 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 :: (MonadIO m) => Gtk.Widget -> [Gtk.Widget] -> m Gtk.Widget buildOverlayWithPassThrough base overlays = liftIO $ do   overlay <- Gtk.overlayNew   Gtk.containerAdd overlay base@@ -343,7 +384,7 @@ -- -- 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 :: (MonadIO m) => T.Text -> Gtk.Widget -> m Gtk.Widget buildBottomLeftAlignedBox boxClass child = liftIO $ do   ebox <- Gtk.eventBoxNew   _ <- widgetSetClassGI ebox boxClass@@ -368,7 +409,7 @@       shownItems = take maxNeeded items       paddedItems =         map Just shownItems ++ replicate (targetLen - length shownItems) Nothing-  in (effectiveMinIcons, targetLen, paddedItems)+   in (effectiveMinIcons, targetLen, paddedItems)  -- | CSS class name for a window icon given its state. --
+ src/System/Taffybar/Widget/WakeupDebug.hs view
@@ -0,0 +1,216 @@+{-# LANGUAGE OverloadedStrings #-}++-- | Debug widget for coordinated wakeup scheduler visibility.+module System.Taffybar.Widget.WakeupDebug+  ( WakeupDebugWidgetConfig (..),+    defaultWakeupDebugWidgetConfig,+    wakeupDebugWidgetNew,+    wakeupDebugWidgetNewWithConfig,+  )+where++import Control.Concurrent (forkIO, killThread, threadDelay)+import Control.Concurrent.STM (atomically)+import Control.Concurrent.STM.TChan (TChan, readTChan)+import Control.Monad (forever, void, when)+import Control.Monad.IO.Class (liftIO)+import Control.Monad.Trans.Reader (ask, runReaderT)+import Data.IORef (IORef, atomicModifyIORef', newIORef, readIORef)+import Data.List (nub, sort)+import qualified Data.Text as T+import Data.Word (Word64)+import qualified GI.Gdk as Gdk+import qualified GI.Gtk as Gtk+import Numeric (showFFloat)+import System.Taffybar.Context (TaffyIO)+import System.Taffybar.Information.Wakeup+  ( WakeupEvent (..),+    WakeupSchedulerEvent (..),+    getRegisteredWakeupIntervalsNanoseconds,+    getWakeupSchedulerEvents,+  )+import System.Taffybar.Util (postGUIASync)+import System.Taffybar.Widget.Util (onClick, widgetSetClassGI)++-- | Configuration for 'wakeupDebugWidgetNewWithConfig'.+data WakeupDebugWidgetConfig = WakeupDebugWidgetConfig+  { wakeupDebugFlashDurationMilliseconds :: Int,+    wakeupDebugExpandedByDefault :: Bool+  }+  deriving (Eq, Ord, Show)++defaultWakeupDebugWidgetConfig :: WakeupDebugWidgetConfig+defaultWakeupDebugWidgetConfig =+  WakeupDebugWidgetConfig+    { wakeupDebugFlashDurationMilliseconds = 180,+      wakeupDebugExpandedByDefault = False+    }++data WakeupDebugState = WakeupDebugState+  { wakeupDebugLastEvents :: [WakeupEvent],+    wakeupDebugRegisteredIntervals :: [Word64],+    wakeupDebugExpanded :: Bool+  }++wakeupDebugWidgetNew :: TaffyIO Gtk.Widget+wakeupDebugWidgetNew =+  wakeupDebugWidgetNewWithConfig defaultWakeupDebugWidgetConfig++wakeupDebugWidgetNewWithConfig :: WakeupDebugWidgetConfig -> TaffyIO Gtk.Widget+wakeupDebugWidgetNewWithConfig config = do+  context <- ask+  schedulerEvents <- getWakeupSchedulerEvents+  registered <- getRegisteredWakeupIntervalsNanoseconds+  liftIO $ do+    label <- Gtk.labelNew (Nothing :: Maybe T.Text)+    eventBox <- Gtk.eventBoxNew+    _ <- widgetSetClassGI eventBox "wakeup-debug"+    _ <- widgetSetClassGI label "wakeup-debug-label"+    Gtk.eventBoxSetVisibleWindow eventBox False+    Gtk.containerAdd eventBox label++    flashTokenRef <- newIORef (0 :: Int)+    stateRef <-+      newIORef+        WakeupDebugState+          { wakeupDebugLastEvents = [],+            wakeupDebugRegisteredIntervals = registered,+            wakeupDebugExpanded = wakeupDebugExpandedByDefault config+          }++    refreshWidget stateRef label eventBox++    let refreshRegisteredIntervals = runReaderT getRegisteredWakeupIntervalsNanoseconds context++    _ <-+      Gtk.onWidgetButtonPressEvent eventBox $+        onClick [Gdk.EventTypeButtonPress] $ do+          intervals <- refreshRegisteredIntervals+          _ <-+            atomicModifyIORef' stateRef $ \state ->+              let nextState =+                    state+                      { wakeupDebugRegisteredIntervals = intervals,+                        wakeupDebugExpanded = not (wakeupDebugExpanded state)+                      }+               in (nextState, nextState)+          refreshWidget stateRef label eventBox++    _ <- Gtk.onWidgetRealize eventBox $ do+      listenerThread <- forkIO $ wakeupDebugLoop schedulerEvents refreshRegisteredIntervals stateRef label eventBox flashTokenRef config+      void $ Gtk.onWidgetUnrealize eventBox $ killThread listenerThread++    Gtk.widgetShowAll eventBox+    Gtk.toWidget eventBox++wakeupDebugLoop ::+  TChan WakeupSchedulerEvent ->+  IO [Word64] ->+  IORef WakeupDebugState ->+  Gtk.Label ->+  Gtk.EventBox ->+  IORef Int ->+  WakeupDebugWidgetConfig ->+  IO ()+wakeupDebugLoop schedulerEvents refreshRegisteredIntervals stateRef label eventBox flashTokenRef config =+  forever $ do+    wakeupEvent <- atomically $ readTChan schedulerEvents+    intervals <- refreshRegisteredIntervals+    _ <-+      atomicModifyIORef' stateRef $ \state ->+        let nextState =+              state+                { wakeupDebugLastEvents = wakeupDueEvents wakeupEvent,+                  wakeupDebugRegisteredIntervals = intervals+                }+         in (nextState, nextState)+    refreshWidget stateRef label eventBox+    triggerFlash flashTokenRef (wakeupDebugFlashDurationMilliseconds config) eventBox++refreshWidget :: IORef WakeupDebugState -> Gtk.Label -> Gtk.EventBox -> IO ()+refreshWidget stateRef label eventBox = do+  state <- readIORef stateRef+  postGUIASync $ do+    Gtk.labelSetText label (renderWakeupDebugLabel state)+    Gtk.widgetSetTooltipText eventBox (Just (renderWakeupDebugTooltip state))++triggerFlash :: IORef Int -> Int -> Gtk.EventBox -> IO ()+triggerFlash tokenRef flashDurationMs eventBox = do+  token <- atomicModifyIORef' tokenRef $ \cur -> let next = cur + 1 in (next, next)+  postGUIASync $ setFlashClass eventBox True+  _ <- forkIO $ do+    threadDelay (flashDurationMs * 1000)+    latestToken <- readIORef tokenRef+    when (latestToken == token) $+      postGUIASync $+        setFlashClass eventBox False+  pure ()++setFlashClass :: Gtk.EventBox -> Bool -> IO ()+setFlashClass eventBox shouldSet = do+  context <- Gtk.widgetGetStyleContext eventBox+  if shouldSet+    then Gtk.styleContextAddClass context "wakeup-debug-hit"+    else Gtk.styleContextRemoveClass context "wakeup-debug-hit"++renderWakeupDebugLabel :: WakeupDebugState -> T.Text+renderWakeupDebugLabel state =+  if wakeupDebugExpanded state+    then+      T.intercalate+        "\n"+        [ "wake " <> formatEventIntervals (wakeupDebugLastEvents state),+          "reg " <> formatIntervals (wakeupDebugRegisteredIntervals state)+        ]+    else "wake " <> formatEventIntervals (wakeupDebugLastEvents state)++renderWakeupDebugTooltip :: WakeupDebugState -> T.Text+renderWakeupDebugTooltip state =+  T.intercalate+    "\n"+    [ "Click to toggle registered interval list",+      "Last wakeup intervals: " <> formatEventIntervals (wakeupDebugLastEvents state),+      "Last wakeup ticks: " <> formatEventTicks (wakeupDebugLastEvents state),+      "Registered intervals: " <> formatIntervals (wakeupDebugRegisteredIntervals state)+    ]++formatEventIntervals :: [WakeupEvent] -> T.Text+formatEventIntervals events =+  formatIntervals $ fmap wakeupIntervalNanoseconds events++formatEventTicks :: [WakeupEvent] -> T.Text+formatEventTicks events+  | null events = "none"+  | otherwise = T.intercalate ", " $ fmap renderEvent events+  where+    renderEvent event =+      formatIntervalNanoseconds (wakeupIntervalNanoseconds event)+        <> "#"+        <> T.pack (show (wakeupTickCount event))++formatIntervals :: [Word64] -> T.Text+formatIntervals intervals+  | null intervals = "none"+  | otherwise = T.intercalate ", " $ fmap formatIntervalNanoseconds (sort (nub intervals))++formatIntervalNanoseconds :: Word64 -> T.Text+formatIntervalNanoseconds nanoseconds+  | nanoseconds `mod` secondsToNanoseconds == 0 =+      T.pack (show (nanoseconds `div` secondsToNanoseconds)) <> "s"+  | nanoseconds `mod` millisecondsToNanoseconds == 0 =+      T.pack (show (nanoseconds `div` millisecondsToNanoseconds)) <> "ms"+  | nanoseconds `mod` microsecondsToNanoseconds == 0 =+      T.pack (show (nanoseconds `div` microsecondsToNanoseconds)) <> "us"+  | otherwise = T.pack (showFFloat (Just 3) secondsValue "s")+  where+    secondsValue :: Double+    secondsValue = fromIntegral nanoseconds / 1000000000++secondsToNanoseconds :: Word64+secondsToNanoseconds = 1000000000++millisecondsToNanoseconds :: Word64+millisecondsToNanoseconds = 1000000++microsecondsToNanoseconds :: Word64+microsecondsToNanoseconds = 1000
src/System/Taffybar/Widget/Weather.hs view
@@ -1,4 +1,5 @@ {-# LANGUAGE OverloadedStrings #-}+ -- | This module defines a simple textual weather widget that polls -- NOAA for weather data.  To find your weather station, you can use -- either of the following:@@ -61,15 +62,15 @@ -- Implementation Note: the weather data parsing code is taken from xmobar. This -- version of the code makes direct HTTP requests instead of invoking a separate -- cURL process.- module System.Taffybar.Widget.Weather-  ( WeatherConfig(..)-  , WeatherInfo(..)-  , WeatherFormatter(WeatherFormatter)-  , weatherNew-  , weatherCustomNew-  , defaultWeatherConfig-  ) where+  ( WeatherConfig (..),+    WeatherInfo (..),+    WeatherFormatter (WeatherFormatter),+    weatherNew,+    weatherCustomNew,+    defaultWeatherConfig,+  )+where  import Control.Monad.IO.Class import qualified Data.ByteString.Lazy as LB@@ -77,34 +78,36 @@ import Data.Maybe (fromMaybe) import qualified Data.Text as T import qualified Data.Text.Encoding as T-import GI.GLib(markupEscapeText)+import GI.GLib (markupEscapeText) import GI.Gtk import Network.HTTP.Client import Network.HTTP.Client.TLS (tlsManagerSettings) import Network.HTTP.Types.Status import System.Log.Logger+import System.Taffybar.Widget.Generic.PollingLabel+import System.Taffybar.Widget.Util (widgetSetClassGI) import Text.Parsec import Text.Printf import Text.StringTemplate -import System.Taffybar.Widget.Generic.PollingLabel-+-- | Parsed NOAA weather report values used by the weather widget. data WeatherInfo = WI-  { stationPlace :: String-  , stationState :: String-  , year :: String-  , month :: String-  , day :: String-  , hour :: String-  , wind :: String-  , visibility :: String-  , skyCondition :: String-  , tempC :: Int-  , tempF :: Int-  , dewPoint :: String-  , humidity :: Int-  , pressure :: Int-  } deriving (Show)+  { stationPlace :: String,+    stationState :: String,+    year :: String,+    month :: String,+    day :: String,+    hour :: String,+    wind :: String,+    visibility :: String,+    skyCondition :: String,+    tempC :: Int,+    tempF :: Int,+    dewPoint :: String,+    humidity :: Int,+    pressure :: Int+  }+  deriving (Show)  -- Parsers stolen from xmobar @@ -118,9 +121,9 @@   _ <- char '.'   d <- getNumbersAsString   _ <- char ' '-  (h:hh:mi:mimi) <- getNumbersAsString+  (h : hh : mi : mimi) <- getNumbersAsString   _ <- char ' '-  return (y, m, d , [h]++[hh]++":"++[mi]++mimi)+  return (y, m, d, [h] ++ [hh] ++ ":" ++ [mi] ++ mimi)  pTemp :: Parser (Int, Int) pTemp = do@@ -149,12 +152,12 @@   _ <- space   ss <- getAllBut '('   _ <- skipRestOfLine >> getAllBut '/'-  (y,m,d,h) <- pTime+  (y, m, d, h) <- pTime   w <- getAfterString "Wind: "   v <- getAfterString "Visibility: "   sk <- getAfterString "Sky conditions: "   _ <- skipTillString "Temperature: "-  (tC,tF) <- pTemp+  (tC, tF) <- pTemp   dp <- getAfterString "Dew Point: "   _ <- skipTillString "Relative Humidity: "   rh <- pRh@@ -175,7 +178,7 @@  skipTillString :: String -> Parser String skipTillString s =-    manyTill skipRestOfLine $ string s+  manyTill skipRestOfLine $ string s  getNumbersAsString :: Parser String getNumbersAsString = skipMany space >> many1 digit >>= \n -> return n@@ -190,8 +193,9 @@ downloadURL mgr request = do   response <- httpLbs request mgr   case responseStatus response of-    s | s >= status200 && s < status300 ->-      return $ Right (T.unpack . T.decodeUtf8 . LB.toStrict $ responseBody response)+    s+      | s >= status200 && s < status300 ->+          return $ Right (T.unpack . T.decodeUtf8 . LB.toStrict $ responseBody response)     otherStatus ->       return . Left $ "HTTP 2XX status was expected but received " ++ show otherStatus @@ -208,27 +212,31 @@ defaultFormatter :: StringTemplate String -> WeatherInfo -> String defaultFormatter tpl wi = render tpl'   where-    tpl' = setManyAttrib [ ("stationPlace", stationPlace wi)-                         , ("stationState", stationState wi)-                         , ("year", year wi)-                         , ("month", month wi)-                         , ("day", day wi)-                         , ("hour", hour wi)-                         , ("wind", wind wi)-                         , ("visibility", visibility wi)-                         , ("skyCondition", skyCondition wi)-                         , ("tempC", show (tempC wi))-                         , ("tempF", show (tempF wi))-                         , ("dewPoint", dewPoint wi)-                         , ("humidity", show (humidity wi))-                         , ("pressure", show (pressure wi))-                         ] tpl+    tpl' =+      setManyAttrib+        [ ("stationPlace", stationPlace wi),+          ("stationState", stationState wi),+          ("year", year wi),+          ("month", month wi),+          ("day", day wi),+          ("hour", hour wi),+          ("wind", wind wi),+          ("visibility", visibility wi),+          ("skyCondition", skyCondition wi),+          ("tempC", show (tempC wi)),+          ("tempF", show (tempF wi)),+          ("dewPoint", dewPoint wi),+          ("humidity", show (humidity wi)),+          ("pressure", show (pressure wi))+        ]+        tpl -getCurrentWeather :: IO (Either String WeatherInfo)-    -> StringTemplate String-    -> StringTemplate String-    -> WeatherFormatter-    -> IO (T.Text, Maybe T.Text)+getCurrentWeather ::+  IO (Either String WeatherInfo) ->+  StringTemplate String ->+  StringTemplate String ->+  WeatherFormatter ->+  IO (T.Text, Maybe T.Text) getCurrentWeather getter labelTpl tooltipTpl formatter = do   dat <- getter   case dat of@@ -256,19 +264,26 @@ -- The default interpolates variables into a string as described -- above.  Custom formatters can do basically anything. data WeatherFormatter-  = WeatherFormatter (WeatherInfo -> String) -- ^ Specify a custom formatter for 'WeatherInfo'-  | DefaultWeatherFormatter -- ^ Use the default StringTemplate formatter+  = -- | Specify a custom formatter for 'WeatherInfo'+    WeatherFormatter (WeatherInfo -> String)+  | -- | Use the default StringTemplate formatter+    DefaultWeatherFormatter  -- | The configuration for the weather widget.  You can provide a custom -- format string through 'weatherTemplate' as described above, or you can -- provide a custom function to turn a 'WeatherInfo' into a String via the -- 'weatherFormatter' field. data WeatherConfig = WeatherConfig-  { weatherStation :: String -- ^ The weather station to poll. No default-  , weatherTemplate :: String -- ^ Template string, as described above.  Default: $tempF$ °F-  , weatherTemplateTooltip :: String -- ^ Template string, as described above.  Default: $tempF$ °F-  , weatherFormatter :: WeatherFormatter -- ^ Default: substitute in all interpolated variables (above)-  , weatherProxy :: Maybe String -- ^ The proxy server, e.g. "http://proxy:port". Default: Nothing+  { -- | The weather station to poll. No default+    weatherStation :: String,+    -- | Template string, as described above.  Default: $tempF$ °F+    weatherTemplate :: String,+    -- | Template string, as described above.  Default: $tempF$ °F+    weatherTemplateTooltip :: String,+    -- | Default: substitute in all interpolated variables (above)+    weatherFormatter :: WeatherFormatter,+    -- | The proxy server, e.g. "http://proxy:port". Default: Nothing+    weatherProxy :: Maybe String   }  -- | A sensible default configuration for the weather widget that just@@ -276,29 +291,32 @@ defaultWeatherConfig :: String -> WeatherConfig defaultWeatherConfig station =   WeatherConfig-  { weatherStation = station-  , weatherTemplate = "$tempF$ °F"-  , weatherTemplateTooltip =-      unlines-        [ "Station: $stationPlace$"-        , "Time: $day$.$month$.$year$ $hour$"-        , "Temperature: $tempF$ °F"-        , "Pressure: $pressure$ hPa"-        , "Wind: $wind$"-        , "Visibility: $visibility$"-        , "Sky Condition: $skyCondition$"-        , "Dew Point: $dewPoint$"-        , "Humidity: $humidity$"-        ]-  , weatherFormatter = DefaultWeatherFormatter-  , weatherProxy = Nothing-  }+    { weatherStation = station,+      weatherTemplate = "$tempF$ °F",+      weatherTemplateTooltip =+        unlines+          [ "Station: $stationPlace$",+            "Time: $day$.$month$.$year$ $hour$",+            "Temperature: $tempF$ °F",+            "Pressure: $pressure$ hPa",+            "Wind: $wind$",+            "Visibility: $visibility$",+            "Sky Condition: $skyCondition$",+            "Dew Point: $dewPoint$",+            "Humidity: $humidity$"+          ],+      weatherFormatter = DefaultWeatherFormatter,+      weatherProxy = Nothing+    }  -- | Create a periodically-updating weather widget that polls NOAA.-weatherNew :: MonadIO m-           => WeatherConfig -- ^ Configuration to render-           -> Double     -- ^ Polling period in _minutes_-           -> m GI.Gtk.Widget+weatherNew ::+  (MonadIO m) =>+  -- | Configuration to render+  WeatherConfig ->+  -- | Polling period in _minutes_+  Double ->+  m GI.Gtk.Widget weatherNew cfg delayMinutes = liftIO $ do   -- TODO: add explicit proxy host/port to WeatherConfig and   -- get rid of this ugly stringly-typed setting@@ -307,32 +325,43 @@         Just str ->           let strToBs = T.encodeUtf8 . T.pack               noHttp = fromMaybe str $ stripPrefix "http://" str-              (phost, pport) = case span (':'/=) noHttp of+              (phost, pport) = case span (':' /=) noHttp of                 (h, "") -> (strToBs h, 80) -- HTTP seems to assume 80 to be the default-                (h, ':':p) -> (strToBs h, read p)+                (h, ':' : p) -> (strToBs h, read p)                 _ -> error "unreachable: broken span"-          in useProxy $ Proxy phost pport+           in useProxy $ Proxy phost pport   mgr <- newManager $ managerSetProxy usedProxy tlsManagerSettings   let url = printf "%s/%s.TXT" baseUrl (weatherStation cfg)   let getter = getWeather mgr url-  weatherCustomNew getter (weatherTemplate cfg) (weatherTemplateTooltip cfg)-    (weatherFormatter cfg) delayMinutes+  weatherCustomNew+    getter+    (weatherTemplate cfg)+    (weatherTemplateTooltip cfg)+    (weatherFormatter cfg)+    delayMinutes  -- | Create a periodically-updating weather widget using custom weather getter-weatherCustomNew-  :: MonadIO m-  => IO (Either String WeatherInfo) -- ^ Weather querying action-  -> String -- ^ Weather template-  -> String -- ^ Weather template-  -> WeatherFormatter -- ^ Weather formatter-  -> Double -- ^ Polling period in _minutes_-  -> m GI.Gtk.Widget+weatherCustomNew ::+  (MonadIO m) =>+  -- | Weather querying action+  IO (Either String WeatherInfo) ->+  -- | Weather template+  String ->+  -- | Weather template+  String ->+  -- | Weather formatter+  WeatherFormatter ->+  -- | Polling period in _minutes_+  Double ->+  m GI.Gtk.Widget weatherCustomNew getter labelTpl tooltipTpl formatter delayMinutes = liftIO $ do   let labelTpl' = newSTMP labelTpl       tooltipTpl' = newSTMP tooltipTpl -  l <- pollingLabelNewWithTooltip (delayMinutes * 60)-       (getCurrentWeather getter labelTpl' tooltipTpl' formatter)-+  l <-+    pollingLabelNewWithTooltip+      (delayMinutes * 60)+      (getCurrentWeather getter labelTpl' tooltipTpl' formatter)+  _ <- widgetSetClassGI l "weather"   GI.Gtk.widgetShowAll l   return l
src/System/Taffybar/Widget/Windows.hs view
@@ -1,5 +1,9 @@ {-# LANGUAGE OverloadedStrings #-}+ -----------------------------------------------------------------------------++-----------------------------------------------------------------------------+ -- | -- Module      : System.Taffybar.Widget.Windows -- Copyright   : (c) Ivan Malison@@ -11,131 +15,254 @@ -- -- Menu widget that shows the title of the currently focused window and that, -- when clicked, displays a menu from which the user may select a window to--- which to switch the focus.-------------------------------------------------------------------------------+-- switch focus to. module System.Taffybar.Widget.Windows where -import           Control.Monad-import           Control.Monad.Trans.Class-import           Control.Monad.Trans.Reader-import           Control.Monad.Trans.Maybe-import           Data.Default (Default(..))-import           Data.Maybe+import qualified Control.Concurrent.MVar as MV+import Control.Concurrent.STM.TChan (TChan)+import Control.Monad (forM_, void)+import Control.Monad.IO.Class (liftIO)+import Control.Monad.Trans.Class+import Control.Monad.Trans.Maybe+import Control.Monad.Trans.Reader+import Data.Default (Default (..))+import Data.IORef (IORef, newIORef, readIORef, writeIORef)+import Data.Int (Int32)+import Data.List (find)+import qualified Data.Set as Set import qualified Data.Text as T-import           GI.GLib (markupEscapeText)+import qualified GI.GdkPixbuf.Objects.Pixbuf as Gdk import qualified GI.Gtk as Gtk-import           System.Taffybar.Context-import           System.Taffybar.Information.EWMHDesktopInfo-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+import qualified GI.Pango as Pango+import System.Taffybar.Context+import System.Taffybar.Information.EWMHDesktopInfo+  ( ewmhWMIcon,+  )+import System.Taffybar.Information.Workspaces.EWMH+  ( defaultEWMHWorkspaceProviderConfig,+    getEWMHWorkspaceStateChanAndVarWith,+    workspaceUpdateEvents,+  )+import System.Taffybar.Information.Workspaces.Hyprland+  ( getHyprlandWorkspaceStateChanAndVar,+  )+import System.Taffybar.Information.Workspaces.Model+import System.Taffybar.Util+import System.Taffybar.Widget.Generic.ChannelWidget (channelWidgetNew)+import System.Taffybar.Widget.Generic.ScalingImage (scalingImage)+import System.Taffybar.Widget.Util (widgetSetClassGI)+import System.Taffybar.Widget.Workspaces+  ( defaultOnWindowClick,+    getWindowIconPixbufByClassHints,+    sortWindowsByPosition,+  ) +-- | Behavior configuration for the windows menu widget. data WindowsConfig = WindowsConfig-  { getMenuLabel :: X11Window -> TaffyIO T.Text-  -- ^ A monadic function that will be used to make a label for the window in-  -- the window menu.-  , getActiveLabel :: TaffyIO T.Text-  -- ^ Action to build the label text for the active window.-  , getActiveWindowIconPixbuf :: Maybe WindowIconPixbufGetter-  -- ^ Optional function to retrieve a pixbuf to show next to the-  -- window label.+  { -- | A monadic function used to build labels for windows in the menu.+    getMenuLabel :: WindowInfo -> TaffyIO T.Text,+    -- | Action to build the label text for the active window.+    getActiveLabel :: Maybe WindowInfo -> TaffyIO T.Text,+    -- | Optional function to retrieve a pixbuf to show next to the+    -- active-window label.+    getActiveWindowIconPixbuf :: Maybe (Int32 -> WindowInfo -> TaffyIO (Maybe Gdk.Pixbuf)),+    -- | Sort menu windows before rendering.+    menuWindowSort :: [WindowInfo] -> TaffyIO [WindowInfo],+    -- | Action when a menu item is selected.+    onMenuWindowClick :: WindowInfo -> TaffyIO ()   } -defaultGetMenuLabel :: X11Window -> TaffyIO T.Text-defaultGetMenuLabel window = do-  windowString <- runX11Def "(nameless window)" (getWindowTitle window)-  return $ T.pack windowString+defaultChannelEWMHWorkspaceStateSource ::+  TaffyIO (TChan WorkspaceSnapshot, MV.MVar WorkspaceSnapshot)+defaultChannelEWMHWorkspaceStateSource =+  getEWMHWorkspaceStateChanAndVarWith providerConfig+  where+    providerConfig =+      defaultEWMHWorkspaceProviderConfig+        { workspaceUpdateEvents =+            ewmhWMIcon : workspaceUpdateEvents defaultEWMHWorkspaceProviderConfig+        } -defaultGetActiveLabel :: TaffyIO T.Text-defaultGetActiveLabel = do-  label <- fromMaybe "" <$> (runX11Def Nothing getActiveWindow >>=-                                       traverse defaultGetMenuLabel)-  markupEscapeText label (-1)+autoWindowStateSource :: TaffyIO (TChan WorkspaceSnapshot, MV.MVar WorkspaceSnapshot)+autoWindowStateSource = do+  backendType <- asks backend+  case backendType of+    BackendWayland -> getHyprlandWorkspaceStateChanAndVar+    BackendX11 -> defaultChannelEWMHWorkspaceStateSource -truncatedGetActiveLabel :: Int -> TaffyIO T.Text-truncatedGetActiveLabel maxLength =-  truncateText maxLength <$> defaultGetActiveLabel+-- | Build a menu label from the window title.+defaultGetMenuLabel :: WindowInfo -> TaffyIO T.Text+defaultGetMenuLabel = truncatedGetMenuLabel 35 -truncatedGetMenuLabel :: Int -> X11Window -> TaffyIO T.Text-truncatedGetMenuLabel maxLength =-  fmap (truncateText maxLength) . defaultGetMenuLabel+-- | Default active-window label renderer.+defaultGetActiveLabel :: Maybe WindowInfo -> TaffyIO T.Text+defaultGetActiveLabel = maybe (return "") defaultGetMenuLabel +-- | Truncate the active-window label to a maximum length.+truncatedGetActiveLabel :: Int -> Maybe WindowInfo -> TaffyIO T.Text+truncatedGetActiveLabel maxLength windowInfo =+  truncateText maxLength <$> defaultGetActiveLabel windowInfo++-- | Truncate window labels in the popup menu to a maximum length.+truncatedGetMenuLabel :: Int -> WindowInfo -> TaffyIO T.Text+truncatedGetMenuLabel maxLength windowInfo =+  return $ truncateText maxLength (windowTitle windowInfo)++-- | Default configuration used by 'windowsNew'. defaultWindowsConfig :: WindowsConfig defaultWindowsConfig =   WindowsConfig-  { getMenuLabel = truncatedGetMenuLabel 35-  , getActiveLabel = truncatedGetActiveLabel 35-  , getActiveWindowIconPixbuf = Just defaultGetWindowIconPixbuf-  }+    { getMenuLabel = defaultGetMenuLabel,+      getActiveLabel = defaultGetActiveLabel,+      getActiveWindowIconPixbuf = Just getWindowIconPixbufByClassHints,+      menuWindowSort = pure . sortWindowsByPosition,+      onMenuWindowClick = defaultOnWindowClick+    } +-- | EWMH/X11 preset configuration.+defaultEWMHWindowsConfig :: WindowsConfig+defaultEWMHWindowsConfig = defaultWindowsConfig+ instance Default WindowsConfig where   def = defaultWindowsConfig --- | Create a new Windows widget that will use the given Pager as--- its source of events.+-- | Create a new channel-driven backend-agnostic windows widget. windowsNew :: WindowsConfig -> TaffyIO Gtk.Widget windowsNew config = do   hbox <- lift $ Gtk.boxNew Gtk.OrientationHorizontal 0+  menu <- lift Gtk.menuNew+  (stateChan, stateVar) <- autoWindowStateSource+  initialSnapshot <- liftIO $ MV.readMVar stateVar+  activeWindowRef <- liftIO $ newIORef $ getActiveWindow initialSnapshot    refreshIcon <- case getActiveWindowIconPixbuf config of     Just getIcon -> do-      (rf, icon) <- buildWindowsIcon getIcon+      (rf, icon) <- buildWindowsIcon activeWindowRef 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 = getActiveLabel config >>= lift . setLabelTitle -  subscription <- subscribeToPropertyEvents-    [ewmhActiveWindow, ewmhWMName, ewmhWMClass]-    (const $ refreshLabel >> lift refreshIcon)+  let refreshFromSnapshot snapshot = do+        let activeWindow = getActiveWindow snapshot+        liftIO $ writeIORef activeWindowRef activeWindow+        labelText <- getActiveLabel config activeWindow+        lift $ setLabelTitle labelText+        lift refreshIcon+        lift $ clearMenu menu+        fillMenu config snapshot menu -  void $ mapReaderT (Gtk.onWidgetUnrealize hbox) (unsubscribe subscription)+  void $ refreshFromSnapshot initialSnapshot -  Gtk.widgetShowAll hbox-  boxWidget <- Gtk.toWidget hbox+  ctx <- ask+  _ <-+    liftIO $+      Gtk.onWidgetRealize hbox $ do+        latestSnapshot <- MV.readMVar stateVar+        void $ runReaderT (refreshFromSnapshot latestSnapshot) ctx+  _ <-+    liftIO $+      channelWidgetNew+        hbox+        stateChan+        (\snapshot -> postGUIASync $ runReaderT (refreshFromSnapshot snapshot) ctx) -  runTaffy <- asks (flip runReaderT)-  menu <- dynamicMenuNew-    DynamicMenuConfig { dmClickWidget = boxWidget-                      , dmPopulateMenu = runTaffy . fillMenu config-                      }+  boxWidget <- Gtk.toWidget hbox+  button <- lift Gtk.menuButtonNew+  lift $ Gtk.containerAdd button boxWidget+  lift $ Gtk.menuButtonSetPopup button $ Just menu+  lift $ Gtk.widgetShowAll button+  menuButtonWidget <- Gtk.toWidget button -  widgetSetClassGI menu "windows"+  widgetSetClassGI menuButtonWidget "windows" +-- | Build the active-window label and return an update action for it. buildWindowsLabel :: TaffyIO (T.Text -> IO (), Gtk.Widget) buildWindowsLabel = do   label <- lift $ Gtk.labelNew Nothing-  let setLabelTitle title = postGUIASync $ Gtk.labelSetMarkup label title+  lift $ Gtk.labelSetSingleLineMode label True+  lift $ Gtk.labelSetEllipsize label Pango.EllipsizeModeEnd+  let setLabelTitle title = postGUIASync $ Gtk.labelSetText label title   (setLabelTitle,) <$> Gtk.toWidget label -buildWindowsIcon :: WindowIconPixbufGetter -> TaffyIO (IO (), Gtk.Widget)-buildWindowsIcon windowIconPixbufGetter = do+-- | Build the active-window icon and return an update action for it.+buildWindowsIcon ::+  IORef (Maybe WindowInfo) ->+  (Int32 -> WindowInfo -> TaffyIO (Maybe Gdk.Pixbuf)) ->+  TaffyIO (IO (), Gtk.Widget)+buildWindowsIcon activeWindowRef windowIconPixbufGetter = do   runTaffy <- asks (flip runReaderT)   let getActiveWindowPixbuf size = runTaffy . runMaybeT $ do-        wd <- MaybeT $ runX11Def Nothing $-          traverse (getWindowData Nothing []) =<< getActiveWindow-        MaybeT $ windowIconPixbufGetter size wd+        windowInfo <- MaybeT $ liftIO $ readIORef activeWindowRef+        MaybeT $ windowIconPixbufGetter size windowInfo    (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 ()-fillMenu config menu = ask >>= \context ->-  runX11Def () $ do-    windowIds <- getWindows-    forM_ windowIds $ \windowId ->+-- | Populate the given menu widget with the list of currently open windows.+fillMenu ::+  (Gtk.IsMenuShell a) =>+  WindowsConfig ->+  WorkspaceSnapshot ->+  a ->+  ReaderT Context IO ()+fillMenu config snapshot menu =+  ask >>= \context -> do+    windows <- menuWindowSort config (getWindows snapshot)+    forM_ windows $ \windowInfo ->       lift $ do-        labelText <- runReaderT (getMenuLabel config windowId) context-        let focusCallback = runReaderT (runX11 $ focusWindow windowId) context >>-                            return True-        item <- Gtk.menuItemNewWithLabel labelText+        labelText <- runReaderT (getMenuLabel config windowInfo) context+        iconPixbuf <-+          case getActiveWindowIconPixbuf config of+            Nothing -> pure Nothing+            Just getIcon -> runReaderT (getIcon windowsMenuIconSize windowInfo) context+        let focusCallback =+              runReaderT (onMenuWindowClick config windowInfo) context+                >> return True+        item <- Gtk.menuItemNew+        content <- Gtk.boxNew Gtk.OrientationHorizontal 6+        forM_ iconPixbuf $ \pixbuf -> do+          icon <- Gtk.imageNewFromPixbuf (Just pixbuf)+          Gtk.boxPackStart content icon False False 0+          pure icon+        label <- Gtk.labelNew (Just labelText)+        Gtk.labelSetXalign label 0+        Gtk.boxPackStart content label True True 0+        Gtk.containerAdd item content         _ <- Gtk.onWidgetButtonPressEvent item $ const focusCallback         Gtk.menuShellAppend menu item-        Gtk.widgetShow item+        Gtk.widgetShowAll item++clearMenu :: (Gtk.IsContainer a) => a -> IO ()+clearMenu menu =+  Gtk.containerForeach menu $ \item ->+    Gtk.containerRemove menu item >> Gtk.widgetDestroy item++windowsMenuIconSize :: Int32+windowsMenuIconSize = fromIntegral $ fromEnum Gtk.IconSizeMenu++getWindows :: WorkspaceSnapshot -> [WindowInfo]+getWindows snapshot = reverse ordered+  where+    allWindows =+      [ win+      | wsInfo <- snapshotWorkspaces snapshot,+        win <- workspaceWindows wsInfo+      ]+    (_, ordered) = foldl keepFirst (Set.empty, []) allWindows+    keepFirst (seen, acc) windowInfo+      | windowIdentity windowInfo `Set.member` seen = (seen, acc)+      | otherwise =+          (Set.insert (windowIdentity windowInfo) seen, windowInfo : acc)++getActiveWindow :: WorkspaceSnapshot -> Maybe WindowInfo+getActiveWindow snapshot =+  find windowActive allWindows+  where+    allWindows =+      [ win+      | wsInfo <- snapshotWorkspaces snapshot,+        win <- workspaceWindows wsInfo+      ]
src/System/Taffybar/Widget/WirePlumber.hs view
@@ -42,15 +42,15 @@ import Data.Char (ord) import Data.Default (Default (..)) import qualified Data.Text as T+import qualified GI.GLib as G import qualified GI.Gdk.Enums as Gdk import qualified GI.Gdk.Structs.EventScroll as GdkEvent-import qualified GI.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 System.Taffybar.Widget.Util (buildIconLabelBox, widgetSetClassGI) import Text.StringTemplate  -- | Configuration for the WirePlumber widget.@@ -113,6 +113,7 @@   initialInfo <- getWirePlumberInfoState nodeSpec   liftIO $ do     label <- Gtk.labelNew Nothing+    _ <- widgetSetClassGI label "wire-plumber-icon"     let updateIcon info = do           let iconText = case info of                 Nothing -> T.pack "\xF026"@@ -123,7 +124,8 @@           postGUIASync $ Gtk.labelSetText label iconText     void $ Gtk.onWidgetRealize label $ updateIcon initialInfo     Gtk.widgetShowAll label-    Gtk.toWidget =<< channelWidgetNew label chan updateIcon+    (Gtk.toWidget =<< channelWidgetNew label chan updateIcon)+      >>= (`widgetSetClassGI` "wire-plumber-icon")  -- | Create a WirePlumber label-only widget for the default audio sink. -- Includes scroll-to-adjust and click-to-mute interaction.@@ -139,6 +141,7 @@    liftIO $ do     label <- Gtk.labelNew Nothing+    _ <- widgetSetClassGI label "wire-plumber-label"      let updateLabel info = do           (labelText, tooltipText) <- formatWirePlumberWidget config info@@ -181,7 +184,8 @@     whenScrollAdjust label      Gtk.widgetShowAll label-    Gtk.toWidget =<< channelWidgetNew label chan updateLabel+    (Gtk.toWidget =<< channelWidgetNew label chan updateLabel)+      >>= (`widgetSetClassGI` "wire-plumber-label")  -- | Create a combined icon + label WirePlumber widget for the default audio sink. wirePlumberNew :: TaffyIO Gtk.Widget@@ -192,15 +196,19 @@ wirePlumberNewWith config = do   iconWidget <- wirePlumberIconNewWith config   labelWidget <- wirePlumberLabelNewWith config-  liftIO $ buildIconLabelBox iconWidget labelWidget+  liftIO $+    buildIconLabelBox iconWidget labelWidget+      >>= (`widgetSetClassGI` "wire-plumber")  -- | Create a new WirePlumber widget for the default audio source (microphone). wirePlumberSourceNew :: TaffyIO Gtk.Widget-wirePlumberSourceNew = wirePlumberNewWith defaultWirePlumberSourceWidgetConfig+wirePlumberSourceNew = wirePlumberSourceNewWith defaultWirePlumberSourceWidgetConfig  -- | Create a new WirePlumber widget for audio source with custom configuration. wirePlumberSourceNewWith :: WirePlumberWidgetConfig -> TaffyIO Gtk.Widget-wirePlumberSourceNewWith = wirePlumberNewWith+wirePlumberSourceNewWith config = do+  widget <- wirePlumberNewWith config+  liftIO $ widgetSetClassGI widget "wire-plumber-source"  formatWirePlumberWidget ::   WirePlumberWidgetConfig ->
src/System/Taffybar/Widget/Wlsunset.hs view
@@ -1,5 +1,9 @@ {-# LANGUAGE OverloadedStrings #-}+ -----------------------------------------------------------------------------++-----------------------------------------------------------------------------+ -- | -- Module      : System.Taffybar.Widget.Wlsunset -- Copyright   : (c) Ivan A. Malison@@ -15,56 +19,58 @@ -- The widget displays a sun icon whose CSS class reflects the current -- wlsunset state: -----   * @wlsunset-warm@ -- forced warm (night) temperature---   * @wlsunset-cool@ -- forced cool (day) temperature---   * @wlsunset-off@  -- process stopped---   * (no extra class) -- automatic\/running normally+--   * @wlsunset-high-temp@ -- forced high (day) temperature, no shift+--   * @wlsunset-low-temp@  -- forced low (night) temperature+--   * @wlsunset-off@       -- process stopped+--   * (no extra class)     -- automatic\/running normally -- -- Left-clicking opens a popup menu for mode selection and start\/stop. -- Right-clicking quick-toggles the process on\/off.------------------------------------------------------------------------------ module System.Taffybar.Widget.Wlsunset-  ( wlsunsetNew-  , wlsunsetNewWithConfig-  , WlsunsetWidgetConfig(..)-  , defaultWlsunsetWidgetConfig-  ) where+  ( wlsunsetNew,+    wlsunsetNewWithConfig,+    WlsunsetWidgetConfig (..),+    defaultWlsunsetWidgetConfig,+  )+where -import           Control.Monad (void, forM_, replicateM_)-import           Control.Monad.IO.Class (liftIO)-import           Control.Monad.Trans.Reader (ask, runReaderT)-import           Data.Default (Default(..))+import Control.Monad (forM_, replicateM_, void)+import Control.Monad.IO.Class (liftIO)+import Control.Monad.Trans.Reader (ask, runReaderT)+import Data.Default (Default (..)) import qualified Data.Text as T-import qualified GI.Gdk as Gdk import qualified GI.GLib as GLib+import qualified GI.Gdk as Gdk import qualified GI.Gtk as Gtk-import           System.Taffybar.Context (Context, TaffyIO)-import           System.Taffybar.Information.Wlsunset-import           System.Taffybar.Util (postGUIASync)-import           System.Taffybar.Widget.Generic.ChannelWidget (channelWidgetNew)+import System.Taffybar.Context (Context, TaffyIO)+import System.Taffybar.Information.Wlsunset+import System.Taffybar.Util (postGUIASync)+import System.Taffybar.Widget.Generic.ChannelWidget (channelWidgetNew)  -- | Widget-level configuration for the wlsunset widget. Wraps the -- underlying 'WlsunsetConfig' from the Information layer. data WlsunsetWidgetConfig = WlsunsetWidgetConfig   { -- | The underlying information-layer config.-    wlsunsetWidgetInfoConfig :: WlsunsetConfig+    wlsunsetWidgetInfoConfig :: WlsunsetConfig,     -- | Text icon to display (default: sun icon U+F0599, nf-md-white_balance_sunny).-  , wlsunsetWidgetIcon       :: T.Text-  } deriving (Eq, Show)+    wlsunsetWidgetIcon :: T.Text+  }+  deriving (Eq, Show)  -- | Default widget configuration. defaultWlsunsetWidgetConfig :: WlsunsetWidgetConfig-defaultWlsunsetWidgetConfig = WlsunsetWidgetConfig-  { wlsunsetWidgetInfoConfig = def-  , wlsunsetWidgetIcon       = T.pack "\xF0599"-  }+defaultWlsunsetWidgetConfig =+  WlsunsetWidgetConfig+    { wlsunsetWidgetInfoConfig = def,+      wlsunsetWidgetIcon = T.pack "\xF0599"+    }  instance Default WlsunsetWidgetConfig where   def = defaultWlsunsetWidgetConfig  -- | All CSS classes that the widget may toggle based on state. allStateClasses :: [T.Text]-allStateClasses = ["wlsunset-warm", "wlsunset-cool", "wlsunset-off"]+allStateClasses = ["wlsunset-high-temp", "wlsunset-low-temp", "wlsunset-off"]  -- | Create a wlsunset widget with the default configuration. wlsunsetNew :: TaffyIO Gtk.Widget@@ -93,7 +99,7 @@      let updateWidget st = postGUIASync $ do           updateStateClasses ebox st-          updateTooltip ebox st+          updateTooltip infoCfg ebox st      void $ Gtk.onWidgetRealize ebox $ do       initialState <- runReaderT (getWlsunsetState infoCfg) ctx@@ -108,7 +114,7 @@ -- ---------------------------------------------------------------------------  -- | Update CSS classes on a widget based on the current wlsunset state.-updateStateClasses :: Gtk.IsWidget w => w -> WlsunsetState -> IO ()+updateStateClasses :: (Gtk.IsWidget w) => w -> WlsunsetState -> IO () updateStateClasses widget st = do   styleCtx <- Gtk.widgetGetStyleContext widget   -- Remove all state classes first@@ -121,22 +127,24 @@ stateToClass st   | not (wlsunsetRunning st) = Just "wlsunset-off"   | otherwise = case wlsunsetMode st of-      WlsunsetAuto       -> Nothing-      WlsunsetForcedWarm -> Just "wlsunset-warm"-      WlsunsetForcedCool -> Just "wlsunset-cool"+      WlsunsetAuto -> Nothing+      WlsunsetForcedHighTemp -> Just "wlsunset-high-temp"+      WlsunsetForcedLowTemp -> Just "wlsunset-low-temp"  -- --------------------------------------------------------------------------- -- Tooltip -- ---------------------------------------------------------------------------  -- | Update the tooltip text to reflect the current state.-updateTooltip :: Gtk.IsWidget w => w -> WlsunsetState -> IO ()-updateTooltip widget st = do-  let text = case (wlsunsetRunning st, wlsunsetMode st) of-        (False, _)                -> "wlsunset: stopped"-        (True, WlsunsetAuto)       -> "wlsunset: automatic"-        (True, WlsunsetForcedWarm) -> "wlsunset: forced warm"-        (True, WlsunsetForcedCool) -> "wlsunset: forced cool"+updateTooltip :: (Gtk.IsWidget w) => WlsunsetConfig -> w -> WlsunsetState -> IO ()+updateTooltip _cfg widget st = do+  let highT = T.pack $ show (wlsunsetEffectiveHighTemp st) ++ "K"+      lowT = T.pack $ show (wlsunsetEffectiveLowTemp st) ++ "K"+      text = case (wlsunsetRunning st, wlsunsetMode st) of+        (False, _) -> "wlsunset: stopped"+        (True, WlsunsetAuto) -> "wlsunset: automatic (" <> lowT <> " – " <> highT <> ")"+        (True, WlsunsetForcedHighTemp) -> "wlsunset: high temp (" <> highT <> ")"+        (True, WlsunsetForcedLowTemp) -> "wlsunset: low temp (" <> lowT <> ")"   Gtk.widgetSetTooltipText widget (Just text)  -- ---------------------------------------------------------------------------@@ -166,6 +174,10 @@ -- Popup menu -- --------------------------------------------------------------------------- +-- | Temperature presets from 2500K to 6500K in 500K increments.+tempPresets :: [Int]+tempPresets = [2500, 3000, 3500, 4000, 4500, 5000, 5500, 6000, 6500]+ -- | Build and show a popup menu attached to the event box. showPopupMenu :: Context -> Gtk.EventBox -> WlsunsetConfig -> IO () showPopupMenu ctx ebox infoCfg = do@@ -178,38 +190,95 @@   -- Mode items (disabled when not running)   let running = wlsunsetRunning st       currentMode = wlsunsetMode st-      modes = [ ("Automatic",  WlsunsetAuto)-              , ("Force Warm", WlsunsetForcedWarm)-              , ("Force Cool", WlsunsetForcedCool)-              ]+      effectiveHigh = wlsunsetEffectiveHighTemp st+      effectiveLow = wlsunsetEffectiveLowTemp st+      highT = T.pack $ show effectiveHigh ++ "K"+      lowT = T.pack $ show effectiveLow ++ "K"+      modes =+        [ ("Automatic", WlsunsetAuto),+          ("High Temp (" <> highT <> ")", WlsunsetForcedHighTemp),+          ("Low Temp (" <> lowT <> ")", WlsunsetForcedLowTemp)+        ]    forM_ modes $ \(labelText, targetMode) -> do-    let prefix = if running && currentMode == targetMode-                   then "\x2713 " :: T.Text  -- checkmark-                   else "   "+    let prefix =+          if running && currentMode == targetMode+            then "\x2713 " :: T.Text -- checkmark+            else "   "     item <- Gtk.menuItemNewWithLabel (prefix <> labelText)     Gtk.widgetSetSensitive item running-    void $ Gtk.onMenuItemActivate item $-      runReaderT (cycleToMode infoCfg currentMode targetMode) ctx+    void $+      Gtk.onMenuItemActivate item $+        runReaderT (cycleToMode infoCfg currentMode targetMode) ctx     Gtk.menuShellAppend menu item -  -- Separator-  sep <- Gtk.separatorMenuItemNew-  Gtk.menuShellAppend menu sep+  -- Separator before temperature presets+  sep1 <- Gtk.separatorMenuItemNew+  Gtk.menuShellAppend menu sep1 +  -- Temperature presets submenu+  tempSubMenuItem <- Gtk.menuItemNewWithLabel ("Set Temperature" :: T.Text)+  tempSubmenu <- Gtk.menuNew+  Gtk.menuItemSetSubmenu tempSubMenuItem (Just tempSubmenu)++  let isFixedTemp = effectiveLow == effectiveHigh+  forM_ tempPresets $ \temp -> do+    let label = T.pack $ show temp ++ "K"+        prefix =+          if running && isFixedTemp && effectiveLow == temp+            then "\x2713 " :: T.Text+            else "   "+    tempItem <- Gtk.menuItemNewWithLabel (prefix <> label)+    Gtk.widgetSetSensitive tempItem running+    void $+      Gtk.onMenuItemActivate tempItem $+        runReaderT (restartWlsunsetWithTemps infoCfg temp temp) ctx+    Gtk.menuShellAppend tempSubmenu tempItem++  -- "Reset to default" item in the submenu+  resetSep <- Gtk.separatorMenuItemNew+  Gtk.menuShellAppend tempSubmenu resetSep++  let defaultLow = wlsunsetLowTemp infoCfg+      defaultHigh = wlsunsetHighTemp infoCfg+      resetLabel =+        T.pack $+          "Reset (" ++ show defaultLow ++ "K – " ++ show defaultHigh ++ "K)"+      resetPrefix =+        if running && effectiveLow == defaultLow && effectiveHigh == defaultHigh+          then "\x2713 " :: T.Text+          else "   "+  resetItem <- Gtk.menuItemNewWithLabel (resetPrefix <> resetLabel)+  Gtk.widgetSetSensitive resetItem running+  void $+    Gtk.onMenuItemActivate resetItem $+      runReaderT (restartWlsunsetWithTemps infoCfg defaultLow defaultHigh) ctx+  Gtk.menuShellAppend tempSubmenu resetItem++  Gtk.menuShellAppend menu tempSubMenuItem++  -- Separator before toggle+  sep2 <- Gtk.separatorMenuItemNew+  Gtk.menuShellAppend menu sep2+   -- Start/Stop item-  let toggleLabel = if running then "Stop wlsunset" :: T.Text-                               else "Start wlsunset"+  let toggleLabel =+        if running+          then "Stop wlsunset" :: T.Text+          else "Start wlsunset"   toggleItem <- Gtk.menuItemNewWithLabel toggleLabel-  void $ Gtk.onMenuItemActivate toggleItem $-    runReaderT (toggleWlsunset infoCfg) ctx+  void $+    Gtk.onMenuItemActivate toggleItem $+      runReaderT (toggleWlsunset infoCfg) ctx   Gtk.menuShellAppend menu toggleItem    -- Cleanup: destroy menu after it hides-  void $ Gtk.onWidgetHide menu $-    void $ GLib.idleAdd GLib.PRIORITY_LOW $ do-      Gtk.widgetDestroy menu-      return False+  void $+    Gtk.onWidgetHide menu $+      void $+        GLib.idleAdd GLib.PRIORITY_LOW $ do+          Gtk.widgetDestroy menu+          return False    Gtk.widgetShowAll menu   Gtk.menuPopupAtPointer menu currentEvent@@ -219,7 +288,7 @@ -- ---------------------------------------------------------------------------  -- | Cycle from the current mode to a target mode. The mode ring is:--- Auto -> ForcedWarm -> ForcedCool -> Auto. We calculate the number of+-- Auto -> ForcedHighTemp -> ForcedLowTemp -> Auto. We calculate the number of -- SIGUSR1 signals needed and send them. cycleToMode :: WlsunsetConfig -> WlsunsetMode -> WlsunsetMode -> TaffyIO () cycleToMode infoCfg currentMode targetMode = do@@ -227,13 +296,13 @@   replicateM_ cyclesNeeded (cycleWlsunsetMode infoCfg)  -- | Calculate how many SIGUSR1 cycles are needed to go from one mode--- to another in the ring Auto -> ForcedWarm -> ForcedCool -> Auto.+-- to another in the ring Auto -> ForcedHighTemp -> ForcedLowTemp -> Auto. cyclesToReach :: WlsunsetMode -> WlsunsetMode -> Int cyclesToReach from to   | from == to = 0-  | otherwise  = (toOrd to - toOrd from) `mod` 3+  | otherwise = (toOrd to - toOrd from) `mod` 3   where     toOrd :: WlsunsetMode -> Int-    toOrd WlsunsetAuto       = 0-    toOrd WlsunsetForcedWarm = 1-    toOrd WlsunsetForcedCool = 2+    toOrd WlsunsetAuto = 0+    toOrd WlsunsetForcedHighTemp = 1+    toOrd WlsunsetForcedLowTemp = 2
src/System/Taffybar/Widget/Workspaces.hs view
@@ -1,787 +1,663 @@-{-# OPTIONS_GHC -fno-warn-type-defaults #-}-{-# LANGUAGE ScopedTypeVariables, ExistentialQuantification, RankNTypes, OverloadedStrings, StrictData #-}--------------------------------------------------------------------------------- |--- Module      : System.Taffybar.Widget.Workspaces--- Copyright   : (c) Ivan A. Malison--- License     : BSD3-style (see LICENSE)------ Maintainer  : Ivan A. Malison--- Stability   : unstable--- Portability : unportable--------------------------------------------------------------------------------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.Monad-import           Control.Monad.IO.Class-import           Control.Monad.Trans.Class-import           Control.Monad.Trans.Reader-import           Control.RateLimit-import           Data.Default (Default(..))-import qualified Data.Foldable as F-import           Data.GI.Base.ManagedPtr (unsafeCastTo)-import           Data.Int-import           Data.List (elemIndex, intersect, sortBy, (\\))-import qualified Data.Map as M-import           Data.Maybe-import qualified Data.MultiMap as MM-import qualified Data.Set as Set-import qualified Data.Text as T-import           Data.Time.Units-import           Data.Tuple.Select-import           Data.Tuple.Sequence-import qualified GI.Gdk.Enums as Gdk-import qualified GI.Gdk.Structs.EventScroll as Gdk-import qualified GI.GdkPixbuf.Objects.Pixbuf as Gdk-import qualified GI.Gtk as Gtk-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.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 WindowData = WindowData-  { windowId :: X11Window-  , windowTitle :: String-  , windowClass :: String-  , windowUrgent :: Bool-  , windowActive :: Bool-  , windowMinimized :: Bool-  } deriving (Show, Eq)--data WidgetUpdate = WorkspaceUpdate Workspace | IconUpdate [X11Window]--data Workspace = Workspace-  { workspaceIdx :: WorkspaceId-  , workspaceName :: String-  , workspaceState :: WorkspaceState-  , windows :: [WindowData]-  } deriving (Show, Eq)--data WorkspacesContext = WorkspacesContext-  { controllersVar :: MV.MVar (M.Map WorkspaceId WWC)-  , workspacesVar :: MV.MVar (M.Map WorkspaceId Workspace)-  , workspacesWidget :: Gtk.Box-  , workspacesConfig :: WorkspacesConfig-  , taffyContext :: Context-  }--type WorkspacesIO a = ReaderT WorkspacesContext IO a--liftContext :: TaffyIO a -> WorkspacesIO a-liftContext action = asks taffyContext >>= lift . runReaderT action--liftX11Def :: a -> X11Property a -> WorkspacesIO a-liftX11Def dflt prop = liftContext $ runX11Def dflt prop--class WorkspaceWidgetController wc where-  getWidget :: wc -> WorkspacesIO Gtk.Widget-  updateWidget :: wc -> WidgetUpdate -> WorkspacesIO wc-  updateWidgetX11 :: wc -> WidgetUpdate -> WorkspacesIO wc-  updateWidgetX11 cont _ = return cont--data WWC = forall a. WorkspaceWidgetController a => WWC a--instance WorkspaceWidgetController WWC where-  getWidget (WWC wc) = getWidget wc-  updateWidget (WWC wc) update = WWC <$> updateWidget wc update-  updateWidgetX11 (WWC wc) update = WWC <$> updateWidgetX11 wc update--type ControllerConstructor = Workspace -> WorkspacesIO WWC-type ParentControllerConstructor =-  ControllerConstructor -> ControllerConstructor--type WindowIconPixbufGetter =-  Int32 -> WindowData -> TaffyIO (Maybe Gdk.Pixbuf)--data WorkspacesConfig =-  WorkspacesConfig-  { widgetBuilder :: ControllerConstructor-  , widgetGap :: Int-  , maxIcons :: Maybe Int-  , minIcons :: Int-  , getWindowIconPixbuf :: WindowIconPixbufGetter-  , labelSetter :: Workspace -> WorkspacesIO String-  , showWorkspaceFn :: Workspace -> Bool-  , borderWidth :: Int-  , updateEvents :: [String]-  , updateRateLimitMicroseconds :: Integer-  , iconSort :: [WindowData] -> WorkspacesIO [WindowData]-  , urgentWorkspaceState :: Bool-  }--defaultWorkspacesConfig :: WorkspacesConfig-defaultWorkspacesConfig =-  WorkspacesConfig-  { widgetBuilder = buildButtonController defaultBuildContentsController-  , widgetGap = 0-  , maxIcons = Nothing-  , minIcons = 0-  , getWindowIconPixbuf = defaultGetWindowIconPixbuf-  , labelSetter = return . workspaceName-  , showWorkspaceFn = const True-  , borderWidth = 2-  , iconSort = sortWindowsByPosition-  , updateEvents = allEWMHProperties \\ [ewmhWMIcon]-  , updateRateLimitMicroseconds = 100000-  , urgentWorkspaceState = False-  }--instance Default WorkspacesConfig where-  def = defaultWorkspacesConfig--hideEmpty :: Workspace -> Bool-hideEmpty Workspace { workspaceState = Empty } = False-hideEmpty _ = True--wLog :: MonadIO m => Priority -> String -> m ()-wLog l s = liftIO $ logM "System.Taffybar.Widget.Workspaces" l s--updateVar :: MV.MVar a -> (a -> WorkspacesIO a) -> WorkspacesIO a-updateVar var modify = do-  ctx <- ask-  lift $ MV.modifyMVar var $ fmap (\a -> (a, a)) . flip runReaderT ctx . modify--updateWorkspacesVar :: WorkspacesIO (M.Map WorkspaceId Workspace)-updateWorkspacesVar = do-  workspacesRef <- asks workspacesVar-  updateVar workspacesRef buildWorkspaceData--getWorkspaceToWindows ::-  [X11Window] -> X11Property (MM.MultiMap WorkspaceId X11Window)-getWorkspaceToWindows =-  foldM-    (\theMap window ->-       MM.insert <$> getWorkspace window <*> pure window <*> pure theMap)-    MM.empty--getWindowData :: Maybe X11Window-              -> [X11Window]-              -> X11Window-              -> X11Property WindowData-getWindowData activeWindow urgentWindows window = do-  wTitle <- getWindowTitle window-  wClass <- getWindowClass window-  wMinimized <- getWindowMinimized window-  return-    WindowData-    { windowId = window-    , windowTitle = wTitle-    , windowClass = wClass-    , windowUrgent = window `elem` urgentWindows-    , windowActive = Just window == activeWindow-    , windowMinimized = wMinimized-    }--buildWorkspaceData :: M.Map WorkspaceId Workspace-                -> WorkspacesIO (M.Map WorkspaceId Workspace)-buildWorkspaceData _ = ask >>= \context -> liftX11Def M.empty $ do-  names <- getWorkspaceNames-  wins <- getWindows-  workspaceToWindows <- getWorkspaceToWindows wins-  urgentWindows <- filterM isWindowUrgent wins-  activeWindow <- getActiveWindow-  active:visible <- getVisibleWorkspaces-  let getWorkspaceState idx ws-        | idx == active = Active-        | idx `elem` visible = Visible-        | urgentWorkspaceState (workspacesConfig context) &&-          not (null (ws `intersect` urgentWindows)) =-          Urgent-        | null ws = Empty-        | otherwise = Hidden-  foldM-    (\theMap (idx, name) -> do-       let ws = MM.lookup idx workspaceToWindows-       windowInfos <- mapM (getWindowData activeWindow urgentWindows) ws-       return $-         M.insert-           idx-           Workspace-           { workspaceIdx = idx-           , workspaceName = name-           , workspaceState = getWorkspaceState idx ws-           , windows = windowInfos-           }-           theMap)-    M.empty-    names--addWidgetsToTopLevel :: WorkspacesIO ()-addWidgetsToTopLevel = do-  WorkspacesContext-    { controllersVar = controllersRef-    , workspacesWidget = cont-    } <- ask-  controllersMap <- lift $ MV.readMVar controllersRef-  -- Elems returns elements in ascending order of their keys so this will always-  -- add the widgets in the correct order-  mapM_ addWidget $ M.elems controllersMap-  lift $ Gtk.widgetShowAll cont--addWidget :: WWC -> WorkspacesIO ()-addWidget controller = do-  cont <- asks workspacesWidget-  workspaceWidget <- getWidget controller-  lift $ do-     -- XXX: This hbox exists to (hopefully) prevent the issue where workspace-     -- widgets appear out of order, in the switcher, by acting as an empty-     -- place holder when the actual widget is hidden.-    hbox <- Gtk.boxNew Gtk.OrientationHorizontal 0-    void $ Gtk.widgetGetParent workspaceWidget >>=-         traverse (unsafeCastTo Gtk.Box) >>=-         traverse (`Gtk.containerRemove` workspaceWidget)-    Gtk.containerAdd hbox workspaceWidget-    Gtk.containerAdd cont hbox--workspacesNew :: WorkspacesConfig -> TaffyIO Gtk.Widget-workspacesNew cfg = ask >>= \tContext -> lift $ do-  cont <- Gtk.boxNew Gtk.OrientationHorizontal $ fromIntegral (widgetGap cfg)-  controllersRef <- MV.newMVar M.empty-  workspacesRef <- MV.newMVar M.empty-  let context =-        WorkspacesContext-        { controllersVar = controllersRef-        , workspacesVar = workspacesRef-        , workspacesWidget = cont-        , workspacesConfig = cfg-        , taffyContext = tContext-        }-  -- This will actually create all the widgets-  runReaderT updateAllWorkspaceWidgets context-  updateHandler <- onWorkspaceUpdate context-  iconHandler <- onIconsChanged context-  let doUpdate = lift . updateHandler-      handleConfigureEvents e@(ConfigureEvent {}) = doUpdate e-      handleConfigureEvents _ = return ()-  (workspaceSubscription, iconSubscription, geometrySubscription) <--    flip runReaderT tContext $ sequenceT-         ( subscribeToPropertyEvents (updateEvents cfg) doUpdate-         , subscribeToPropertyEvents [ewmhWMIcon] (lift . onIconChanged iconHandler)-         , subscribeToAll handleConfigureEvents-         )-  let doUnsubscribe = flip runReaderT tContext $-        mapM_ unsubscribe-              [ iconSubscription-              , workspaceSubscription-              , geometrySubscription-              ]-  _ <- Gtk.onWidgetUnrealize cont doUnsubscribe-  _ <- widgetSetClassGI cont "workspaces"-  Gtk.toWidget cont--updateAllWorkspaceWidgets :: WorkspacesIO ()-updateAllWorkspaceWidgets = do-  wLog DEBUG "Updating workspace widgets"--  workspacesMap <- updateWorkspacesVar-  wLog DEBUG $ printf "Workspaces: %s" $ show workspacesMap--  wLog DEBUG "Adding and removing widgets"-  updateWorkspaceControllers--  let updateController' idx controller =-        maybe (return controller)-              (updateWidget controller . WorkspaceUpdate) $-              M.lookup idx workspacesMap-      logUpdateController i =-        wLog DEBUG $ printf "Updating %s workspace widget" $ show i-      updateController i cont = logUpdateController i >>-                                updateController' i cont--  wLog DEBUG "Done updating individual widget"--  doWidgetUpdate updateController--  wLog DEBUG "Showing and hiding controllers"-  setControllerWidgetVisibility--setControllerWidgetVisibility :: WorkspacesIO ()-setControllerWidgetVisibility = do-  ctx@WorkspacesContext-    { workspacesVar = workspacesRef-    , controllersVar = controllersRef-    , workspacesConfig = cfg-    } <- ask-  lift $ do-    workspacesMap <- MV.readMVar workspacesRef-    controllersMap <- MV.readMVar controllersRef-    forM_ (M.elems workspacesMap) $ \ws ->-      let action = if showWorkspaceFn cfg ws-                   then Gtk.widgetShow-                   else Gtk.widgetHide-      in-        traverse (flip runReaderT ctx . getWidget)-                    (M.lookup (workspaceIdx ws) controllersMap) >>=-        maybe (return ()) action--doWidgetUpdate :: (WorkspaceId -> WWC -> WorkspacesIO WWC) -> WorkspacesIO ()-doWidgetUpdate updateController = do-  c@WorkspacesContext { controllersVar = controllersRef } <- ask-  lift $ MV.modifyMVar_ controllersRef $ \controllers -> do-    wLog DEBUG "Updating controllers ref"-    controllersList <--      mapM-      (\(idx, controller) -> do-         newController <- runReaderT (updateController idx controller) c-         return (idx, newController)) $-      M.toList controllers-    return $ M.fromList controllersList--updateWorkspaceControllers :: WorkspacesIO ()-updateWorkspaceControllers = do-  WorkspacesContext-    { controllersVar = controllersRef-    , workspacesVar = workspacesRef-    , workspacesWidget = cont-    , workspacesConfig = cfg-    } <- ask-  workspacesMap <- lift $ MV.readMVar workspacesRef-  controllersMap <- lift $ MV.readMVar controllersRef--  let newWorkspacesSet = M.keysSet workspacesMap-      existingWorkspacesSet = M.keysSet controllersMap--  when (existingWorkspacesSet /= newWorkspacesSet) $ do-    let addWorkspaces = Set.difference newWorkspacesSet existingWorkspacesSet-        removeWorkspaces = Set.difference existingWorkspacesSet newWorkspacesSet-        builder = widgetBuilder cfg--    _ <- updateVar controllersRef $ \controllers -> do-      let oldRemoved = F.foldl' (flip M.delete) controllers removeWorkspaces-          buildController idx = builder <$> M.lookup idx workspacesMap-          buildAndAddController theMap idx =-            maybe (return theMap) (>>= return . flip (M.insert idx) theMap)-                    (buildController idx)-      foldM buildAndAddController oldRemoved $ Set.toList addWorkspaces-    -- Clear the container and repopulate it-    lift $ Gtk.containerForeach cont (Gtk.containerRemove cont)-    addWidgetsToTopLevel--rateLimitFn-  :: forall req resp.-     WorkspacesContext-  -> (req -> IO resp)-  -> ResultsCombiner req resp-  -> IO (req -> IO resp)-rateLimitFn context =-  let limit = (updateRateLimitMicroseconds $ workspacesConfig context)-      rate = fromMicroseconds limit :: Microsecond in-  generateRateLimitedFunction $ PerInvocation rate--onWorkspaceUpdate :: WorkspacesContext -> IO (Event -> IO ())-onWorkspaceUpdate context = do-  rateLimited <- rateLimitFn context doUpdate combineRequests-  let withLog event = do-        case event of-          PropertyEvent _ _ _ _ _ atom _ _ ->-            wLog DEBUG $ printf "Event %s" $ show atom-          _anythingElse -> return ()-        void $ forkIO $ rateLimited event-  return withLog-  where-    combineRequests _ b = Just (b, const ((), ()))-    doUpdate _ = postGUIASync $ runReaderT updateAllWorkspaceWidgets context--onIconChanged :: (Set.Set X11Window -> IO ()) -> Event -> IO ()-onIconChanged handler event =-  case event of-    PropertyEvent { ev_window = wid } -> do-      wLog DEBUG  $ printf "Icon changed event %s" $ show wid-      handler $ Set.singleton wid-    _ -> return ()--onIconsChanged :: WorkspacesContext -> IO (Set.Set X11Window -> IO ())-onIconsChanged context = rateLimitFn context onIconsChanged' combineRequests-  where-    combineRequests windows1 windows2 =-      Just (Set.union windows1 windows2, const ((), ()))-    onIconsChanged' wids = do-      wLog DEBUG $ printf "Icon update execute %s" $ show wids-      postGUIASync $ flip runReaderT context $-        doWidgetUpdate-          (\idx c ->-             wLog DEBUG (printf "Updating %s icons." $ show idx) >>-             updateWidget c (IconUpdate $ Set.toList wids))--initializeWWC ::-  WorkspaceWidgetController a => a -> Workspace -> ReaderT WorkspacesContext IO WWC-initializeWWC controller ws =-  WWC <$> updateWidget controller (WorkspaceUpdate ws)---- | A WrappingController can be used to wrap some child widget with another--- abitrary widget.-data WrappingController = WrappingController-  { wrappedWidget :: Gtk.Widget-  , wrappedController :: WWC-  }--instance WorkspaceWidgetController WrappingController where-  getWidget = lift . Gtk.toWidget . wrappedWidget-  updateWidget wc update = do-    updated <- updateWidget (wrappedController wc) update-    return wc { wrappedController = updated }--data WorkspaceContentsController = WorkspaceContentsController-  { containerWidget :: Gtk.Widget-  , contentsControllers :: [WWC]-  }--buildContentsController :: [ControllerConstructor] -> ControllerConstructor-buildContentsController constructors ws = do-  controllers <- mapM ($ ws) constructors-  ctx <- ask-  tempController <- lift $ do-    cons <- Gtk.boxNew Gtk.OrientationHorizontal 0-    mapM_ (flip runReaderT ctx . getWidget >=> Gtk.containerAdd cons) controllers-    outerBox <- Gtk.toWidget cons >>= buildPadBox-    _ <- widgetSetClassGI cons "contents"-    widget <- Gtk.toWidget outerBox-    return-      WorkspaceContentsController-      { containerWidget = widget-      , contentsControllers = controllers-      }-  initializeWWC tempController ws--defaultBuildContentsController :: ControllerConstructor-defaultBuildContentsController =-  buildContentsController [buildLabelController, buildIconController]--bottomLeftAlignedBoxWrapper :: T.Text -> ControllerConstructor -> ControllerConstructor-bottomLeftAlignedBoxWrapper boxClass constructor ws = do-  controller <- constructor ws-  widget <- getWidget controller-  wrapped <- lift $ buildBottomLeftAlignedBox boxClass widget-  let wrappingController = WrappingController-                           { wrappedWidget = wrapped-                           , wrappedController = controller-                           }-  initializeWWC wrappingController ws--buildLabelOverlayController :: ControllerConstructor-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-buildOverlayContentsController mainConstructors overlayConstructors ws = do-  controllers <- mapM ($ ws) mainConstructors-  overlayControllers <- mapM ($ ws) overlayConstructors-  ctx <- ask-  tempController <- lift $ do-    mainContents <- Gtk.boxNew Gtk.OrientationHorizontal 0-    mapM_ (flip runReaderT ctx . getWidget >=> Gtk.containerAdd mainContents)-        controllers-    outerBox <- Gtk.toWidget mainContents >>= buildPadBox-    _ <- widgetSetClassGI mainContents "contents"-    overlayWidgets <- mapM (flip runReaderT ctx . getWidget) overlayControllers-    widget <- buildOverlayWithPassThrough outerBox overlayWidgets-    return-      WorkspaceContentsController-      { containerWidget = widget-      , contentsControllers = controllers ++ overlayControllers-      }-  initializeWWC tempController ws--instance WorkspaceWidgetController WorkspaceContentsController where-  getWidget = return . containerWidget-  updateWidget cc update = do-    WorkspacesContext {} <- ask-    case update of-      WorkspaceUpdate newWorkspace ->-        lift $ setWorkspaceWidgetStatusClass (workspaceState newWorkspace) $ containerWidget cc-      _ -> return ()-    newControllers <- mapM (`updateWidget` update) $ contentsControllers cc-    return cc {contentsControllers = newControllers}-  updateWidgetX11 cc update = do-    newControllers <- mapM (`updateWidgetX11` update) $ contentsControllers cc-    return cc {contentsControllers = newControllers}--newtype LabelController = LabelController { label :: Gtk.Label }--buildLabelController :: ControllerConstructor-buildLabelController ws = do-  tempController <- lift $ do-    lbl <- Gtk.labelNew Nothing-    _ <- widgetSetClassGI lbl "workspace-label"-    return LabelController { label = lbl }-  initializeWWC tempController ws--instance WorkspaceWidgetController LabelController where-  getWidget = lift . Gtk.toWidget . label-  updateWidget lc (WorkspaceUpdate newWorkspace) = do-    WorkspacesContext { workspacesConfig = cfg } <- ask-    labelText <- labelSetter cfg newWorkspace-    lift $ do-      Gtk.labelSetMarkup (label lc) $ T.pack labelText-      setWorkspaceWidgetStatusClass (workspaceState newWorkspace) $ label lc-    return lc-  updateWidget lc _ = return lc--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-    iconWidget <--      mkWorkspaceIconWidget-        strategy-        Nothing-        transparentOnNone-        getPB-        (`pixBufFromColor` 0)-    _ <--      Gtk.onWidgetButtonPressEvent (iconContainer iconWidget) $-      const $ liftIO $ do-        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--data IconController = IconController-  { iconsContainer :: Gtk.Box-  , iconImages :: [IconWidget]-  , iconWorkspace :: Workspace-  }--buildIconController :: ControllerConstructor-buildIconController ws = do-  tempController <--    lift $ do-      hbox <- Gtk.boxNew Gtk.OrientationHorizontal 0-      return-        IconController-        {iconsContainer = hbox, iconImages = [], iconWorkspace = ws}-  initializeWWC tempController ws--instance WorkspaceWidgetController IconController where-  getWidget = lift . Gtk.toWidget . iconsContainer-  updateWidget ic (WorkspaceUpdate newWorkspace) = do-    newImages <- updateImages ic newWorkspace-    return ic { iconImages = newImages, iconWorkspace = newWorkspace }-  updateWidget ic (IconUpdate updatedIcons) =-    updateWindowIconsById ic updatedIcons >> return ic--updateWindowIconsById ::-  IconController -> [X11Window] -> WorkspacesIO ()-updateWindowIconsById ic windowIds =-  mapM_ maybeUpdateWindowIcon $ iconImages ic-  where-    maybeUpdateWindowIcon widget =-      do-        info <- lift $ MV.readMVar $ iconWindow widget-        when (maybe False (flip elem windowIds . windowId) info) $-         updateIconWidget ic widget info--scaledWindowIconPixbufGetter :: WindowIconPixbufGetter -> WindowIconPixbufGetter-scaledWindowIconPixbufGetter = scaledPixbufGetter--constantScaleWindowIconPixbufGetter ::-  Int32 -> WindowIconPixbufGetter -> WindowIconPixbufGetter-constantScaleWindowIconPixbufGetter constantSize getter =-  const $ scaledWindowIconPixbufGetter getter constantSize--handleIconGetterException :: WindowIconPixbufGetter -> WindowIconPixbufGetter-handleIconGetterException = handlePixbufGetterException wLog--getWindowIconPixbufFromEWMH :: WindowIconPixbufGetter-getWindowIconPixbufFromEWMH = handleIconGetterException $ \size windowData ->-  runX11Def Nothing (getIconPixBufFromEWMH size $ windowId windowData)--getWindowIconPixbufFromClass :: WindowIconPixbufGetter-getWindowIconPixbufFromClass = handleIconGetterException $ \size windowData ->-  lift $ getWindowIconFromClasses size (windowClass windowData)--getWindowIconPixbufFromDesktopEntry :: WindowIconPixbufGetter-getWindowIconPixbufFromDesktopEntry = handleIconGetterException $ \size windowData ->-  getWindowIconFromDesktopEntryByClasses size (windowClass windowData)--getWindowIconPixbufFromChrome :: WindowIconPixbufGetter-getWindowIconPixbufFromChrome _ windowData =-  getPixBufFromChromeData $ windowId windowData--defaultGetWindowIconPixbuf :: WindowIconPixbufGetter-defaultGetWindowIconPixbuf =-  scaledWindowIconPixbufGetter unscaledDefaultGetWindowIconPixbuf--unscaledDefaultGetWindowIconPixbuf :: WindowIconPixbufGetter-unscaledDefaultGetWindowIconPixbuf =-  getWindowIconPixbufFromDesktopEntry <|||>-  getWindowIconPixbufFromClass <|||>-  getWindowIconPixbufFromEWMH--addCustomIconsToDefaultWithFallbackByPath-  :: (WindowData -> Maybe FilePath)-  -> FilePath-  -> WindowIconPixbufGetter-addCustomIconsToDefaultWithFallbackByPath getCustomIconPath fallbackPath =-  addCustomIconsAndFallback-    getCustomIconPath-    (const $ lift $ getPixbufFromFilePath fallbackPath)-    unscaledDefaultGetWindowIconPixbuf--addCustomIconsAndFallback-  :: (WindowData -> Maybe FilePath)-  -> (Int32 -> TaffyIO (Maybe Gdk.Pixbuf))-  -> WindowIconPixbufGetter-  -> WindowIconPixbufGetter-addCustomIconsAndFallback getCustomIconPath fallback defaultGetter =-  scaledWindowIconPixbufGetter $-  getCustomIcon <|||> defaultGetter <|||> (\s _ -> fallback s)-  where-    getCustomIcon :: Int32 -> WindowData -> TaffyIO (Maybe Gdk.Pixbuf)-    getCustomIcon _ wdata =-      lift $-      maybe (return Nothing) getPixbufFromFilePath $ getCustomIconPath wdata---- | Sort windows by top-left corner position.-sortWindowsByPosition :: [WindowData] -> WorkspacesIO [WindowData]-sortWindowsByPosition wins = do-  let getGeometryWorkspaces w = getDisplay >>= liftIO . (`safeGetGeometry` w)-      getGeometries = mapM-                      (forkM return-                               (((sel2 &&& sel3) <$>) . getGeometryWorkspaces) .-                               windowId)-                      wins-  windowGeometries <- liftX11Def [] getGeometries-  let getLeftPos wd =-        fromMaybe (999999999, 99999999) $ lookup (windowId wd) windowGeometries-      compareWindowData a b =-        compare-          (windowMinimized a, getLeftPos a)-          (windowMinimized b, getLeftPos b)-  return $ sortBy compareWindowData wins---- | Sort windows in reverse _NET_CLIENT_LIST_STACKING order.--- Starting in xmonad-contrib 0.17.0, this is effectively focus history, active first.--- Previous versions erroneously stored focus-sort-order in _NET_CLIENT_LIST.-sortWindowsByStackIndex :: [WindowData] -> WorkspacesIO [WindowData]-sortWindowsByStackIndex wins = do-  stackingWindows <- liftX11Def [] getWindowsStacking-  let getStackIdx wd = fromMaybe (-1) $ elemIndex (windowId wd) stackingWindows-      compareWindowData a b = compare (getStackIdx b) (getStackIdx a)-  return $ sortBy compareWindowData wins--updateImages :: IconController -> Workspace -> WorkspacesIO [IconWidget]-updateImages ic ws = do-  WorkspacesContext {workspacesConfig = cfg} <- ask-  sortedWindows <- iconSort cfg $ windows ws-  wLog DEBUG $ printf "Updating images for %s" (show ws)-  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 =-  windowStatusClassFromFlags-    (windowMinimized windowData)-    (windowActive windowData)-    (windowUrgent windowData)--updateIconWidget-  :: IconController-  -> IconWidget-  -> Maybe WindowData-  -> WorkspacesIO ()-updateIconWidget _ iconWidget windowData =-  updateWindowIconWidgetState-    iconWidget-    windowData-    (T.pack . windowTitle)-    getWindowStatusString--data WorkspaceButtonController = WorkspaceButtonController-  { button :: Gtk.EventBox-  , buttonWorkspace :: Workspace-  , contentsController :: WWC-  }--buildButtonController :: ParentControllerConstructor-buildButtonController contentsBuilder workspace = do-  cc <- contentsBuilder workspace-  workspacesRef <- asks workspacesVar-  ctx <- ask-  widget <- getWidget cc-  lift $ do-    ebox <- Gtk.eventBoxNew-    Gtk.containerAdd ebox widget-    Gtk.eventBoxSetVisibleWindow ebox False-    _ <--      Gtk.onWidgetScrollEvent ebox $ \scrollEvent -> do-        dir <- Gdk.getEventScrollDirection scrollEvent-        workspaces <- liftIO $ MV.readMVar workspacesRef-        let switchOne a =-              liftIO $-              flip runReaderT ctx $-              liftX11Def-                ()-                (switchOneWorkspace a (length (M.toList workspaces) - 1)) >>-              return True-        case dir of-          Gdk.ScrollDirectionUp -> switchOne True-          Gdk.ScrollDirectionLeft -> switchOne True-          Gdk.ScrollDirectionDown -> switchOne False-          Gdk.ScrollDirectionRight -> switchOne False-          _ -> return False-    _ <- Gtk.onWidgetButtonPressEvent ebox $ const $ switch ctx $ workspaceIdx workspace-    return $-      WWC-        WorkspaceButtonController-        { button = ebox, buttonWorkspace = workspace, contentsController = cc }--switch :: (MonadIO m) => WorkspacesContext -> WorkspaceId -> m Bool-switch ctx idx = do-  liftIO $ flip runReaderT ctx $ liftX11Def () $ switchToWorkspace idx-  return True--instance WorkspaceWidgetController WorkspaceButtonController-  where-    getWidget wbc = lift $ Gtk.toWidget $ button wbc-    updateWidget wbc update = do-      newContents <- updateWidget (contentsController wbc) update-      return wbc { contentsController = newContents }+{-# LANGUAGE OverloadedStrings #-}++-----------------------------------------------------------------------------++-----------------------------------------------------------------------------++-- |+-- Module      : System.Taffybar.Widget.Workspaces+-- Copyright   : (c) Ivan A. Malison+-- License     : BSD3-style (see LICENSE)+--+-- Maintainer  : Ivan A. Malison+-- Stability   : unstable+-- Portability : unportable+--+-- Channel-driven workspace widget that renders backend-agnostic workspace state.+module System.Taffybar.Widget.Workspaces+  ( WorkspacesConfig (..),+    WorkspaceWidgetController (..),+    ControllerConstructor,+    defaultWidgetBuilder,+    WindowIconPixbufGetter,+    defaultWorkspacesConfig,+    defaultEWMHWorkspacesConfig,+    workspacesNew,+    hideEmpty,+    sortWindowsByPosition,+    sortWindowsByStackIndex,+    scaledWindowIconPixbufGetter,+    constantScaleWindowIconPixbufGetter,+    handleIconGetterException,+    getWindowIconPixbufFromClassHints,+    getWindowIconPixbufFromDesktopEntry,+    getWindowIconPixbufFromClass,+    getWindowIconPixbufByClassHints,+    getWindowIconPixbufFromChrome,+    getWindowIconPixbufFromEWMH,+    defaultGetWindowIconPixbuf,+    unscaledDefaultGetWindowIconPixbuf,+    addCustomIconsToDefaultWithFallbackByPath,+    addCustomIconsAndFallback,+    defaultOnWorkspaceClick,+    defaultOnWorkspaceClickEWMH,+    defaultOnWindowClick,+  )+where++import qualified Control.Concurrent.MVar as MV+import Control.Concurrent.STM.TChan (TChan)+import Control.Exception.Enclosed (catchAny)+import Control.Monad (foldM, forM_, guard, when)+import Control.Monad.IO.Class (liftIO)+import Control.Monad.Trans.Reader (ask, asks, runReaderT)+import Data.Default (Default (..))+import Data.IORef (IORef, newIORef, readIORef, writeIORef)+import Data.Int (Int32)+import Data.List (elemIndex, sortBy, sortOn)+import qualified Data.Map.Strict as M+import Data.Maybe (fromMaybe)+import qualified Data.Text as T+import Data.Word (Word64)+import qualified GI.Gdk.Enums as Gdk+import qualified GI.Gdk.Structs.EventScroll as Gdk+import qualified GI.GdkPixbuf.Objects.Pixbuf as Gdk+import qualified GI.Gtk as Gtk+import System.Log.Logger (Priority (..), logM)+import System.Taffybar.Context (Backend (..), TaffyIO, backend, runX11Def)+import System.Taffybar.Hyprland (getHyprlandClient)+import System.Taffybar.Information.EWMHDesktopInfo+  ( WorkspaceId (WorkspaceId),+    ewmhWMIcon,+    focusWindow,+    getWindowsStacking,+    switchToWorkspace,+  )+import qualified System.Taffybar.Information.Hyprland.API as HyprAPI+import System.Taffybar.Information.Workspaces.EWMH+  ( EWMHWorkspaceProviderConfig,+    defaultEWMHWorkspaceProviderConfig,+    getEWMHWorkspaceStateChanAndVarWith,+    workspaceUpdateEvents,+  )+import System.Taffybar.Information.Workspaces.Hyprland+  ( getHyprlandWorkspaceStateChanAndVar,+  )+import System.Taffybar.Information.Workspaces.Model+import System.Taffybar.Util (getPixbufFromFilePath, postGUIASync, (<|||>))+import System.Taffybar.Widget.Generic.ChannelWidget (channelWidgetNew)+import System.Taffybar.Widget.Generic.ScalingImage (getScalingImageStrategy)+import System.Taffybar.Widget.Util+  ( WindowIconWidget (..),+    computeIconStripLayout,+    handlePixbufGetterException,+    scaledPixbufGetter,+    syncWidgetPool,+    updateWindowIconWidgetState,+    widgetSetClassGI,+    windowStatusClassFromFlags,+  )+import System.Taffybar.Widget.Workspaces.Shared+  ( WorkspaceState (..),+    buildWorkspaceIconLabelOverlay,+    mkWorkspaceIconWidget,+    setWorkspaceWidgetStatusClass,+  )+import System.Taffybar.WindowIcon+  ( getCachedIconPixBufFromEWMH,+    getCachedWindowIconFromClasses,+    getCachedWindowIconFromDesktopEntryByClasses,+    getPixBufFromChromeData,+    pixBufFromColor,+  )++type WindowIconPixbufGetter = Int32 -> WindowInfo -> TaffyIO (Maybe Gdk.Pixbuf)++data WorkspaceWidgetController = WorkspaceWidgetController+  { controllerWidget :: Gtk.Widget,+    controllerUpdate :: WorkspaceInfo -> TaffyIO (),+    controllerRefreshIcons :: WorkspaceInfo -> TaffyIO ()+  }++type ControllerConstructor =+  WorkspacesConfig -> WorkspaceInfo -> TaffyIO WorkspaceWidgetController++data WorkspacesConfig = WorkspacesConfig+  { widgetGap :: Int,+    widgetBuilder :: ControllerConstructor,+    iconSize :: Maybe Int32,+    maxIcons :: Maybe Int,+    minIcons :: Int,+    getWindowIconPixbuf :: WindowIconPixbufGetter,+    labelSetter :: WorkspaceInfo -> TaffyIO String,+    showWorkspaceFn :: WorkspaceInfo -> Bool,+    iconSort :: [WindowInfo] -> TaffyIO [WindowInfo],+    urgentWorkspaceState :: Bool,+    onWorkspaceClick :: WorkspaceInfo -> TaffyIO (),+    onWindowClick :: WindowInfo -> TaffyIO ()+  }++data WorkspaceEntry = WorkspaceEntry+  { entryWrapper :: Gtk.Widget,+    entryButton :: Gtk.EventBox,+    entryController :: WorkspaceWidgetController,+    entryWorkspaceRef :: IORef WorkspaceInfo,+    entryLastWorkspace :: WorkspaceInfo+  }++data WorkspaceCache = WorkspaceCache+  { cacheEntries :: M.Map WorkspaceIdentity WorkspaceEntry,+    cacheOrder :: [WorkspaceIdentity],+    cacheLastWorkspaces :: [WorkspaceInfo],+    cacheLastRevision :: Word64+  }++defaultChannelEWMHWorkspaceProviderConfig :: EWMHWorkspaceProviderConfig+defaultChannelEWMHWorkspaceProviderConfig =+  defaultEWMHWorkspaceProviderConfig+    { workspaceUpdateEvents =+        ewmhWMIcon : workspaceUpdateEvents defaultEWMHWorkspaceProviderConfig+    }++defaultEWMHWorkspaceStateSource ::+  TaffyIO (TChan WorkspaceSnapshot, MV.MVar WorkspaceSnapshot)+defaultEWMHWorkspaceStateSource =+  getEWMHWorkspaceStateChanAndVarWith defaultChannelEWMHWorkspaceProviderConfig++autoWorkspaceStateSource :: TaffyIO (TChan WorkspaceSnapshot, MV.MVar WorkspaceSnapshot)+autoWorkspaceStateSource = do+  backendType <- asks backend+  case backendType of+    BackendWayland -> getHyprlandWorkspaceStateChanAndVar+    BackendX11 -> defaultEWMHWorkspaceStateSource++defaultWorkspacesConfig :: WorkspacesConfig+defaultWorkspacesConfig =+  WorkspacesConfig+    { widgetGap = 0,+      widgetBuilder = defaultWidgetBuilder,+      iconSize = Just 16,+      maxIcons = Nothing,+      minIcons = 0,+      getWindowIconPixbuf = defaultGetWindowIconPixbuf,+      labelSetter = return . T.unpack . workspaceName . workspaceIdentity,+      showWorkspaceFn = \ws -> hideEmpty ws && not (workspaceIsSpecial ws),+      iconSort = pure . sortWindowsByPosition,+      urgentWorkspaceState = False,+      onWorkspaceClick = defaultOnWorkspaceClick,+      onWindowClick = defaultOnWindowClick+    }++defaultEWMHWorkspacesConfig :: WorkspacesConfig+defaultEWMHWorkspacesConfig = defaultWorkspacesConfig++defaultWidgetBuilder :: ControllerConstructor+defaultWidgetBuilder cfg wsInfo = do+  wsRef <- liftIO $ newIORef wsInfo+  lastWorkspaceRef <- liftIO $ newIORef wsInfo+  iconsRef <- liftIO $ newIORef []+  iconsBox <- liftIO $ Gtk.boxNew Gtk.OrientationHorizontal 0+  label <- liftIO $ Gtk.labelNew Nothing+  _ <- widgetSetClassGI label "workspace-label"+  iconsWidget <- Gtk.toWidget iconsBox+  labelWidget <- Gtk.toWidget label+  contents <- buildWorkspaceIconLabelOverlay iconsWidget labelWidget+  let updateController forceIcons newWs = do+        oldWs <- liftIO $ readIORef lastWorkspaceRef+        liftIO $ writeIORef wsRef newWs+        labelText <- labelSetter cfg newWs+        let wsState = toCSSState cfg newWs+        liftIO $ Gtk.labelSetMarkup label (T.pack labelText)+        liftIO $ setWorkspaceWidgetStatusClass wsState contents+        liftIO $ setWorkspaceWidgetStatusClass wsState label+        currentIcons <- liftIO $ readIORef iconsRef+        let needsIconUpdate =+              forceIcons+                || null currentIcons+                || workspaceWindows oldWs /= workspaceWindows newWs+        updatedIcons <-+          if needsIconUpdate+            then updateWorkspaceIcons cfg wsRef iconsBox currentIcons newWs+            else return currentIcons+        liftIO $ writeIORef iconsRef updatedIcons+        liftIO $ writeIORef lastWorkspaceRef newWs+      controller =+        WorkspaceWidgetController+          { controllerWidget = contents,+            controllerUpdate = updateController False,+            controllerRefreshIcons = updateController True+          }+  controllerRefreshIcons controller wsInfo+  return controller++instance Default WorkspacesConfig where+  def = defaultWorkspacesConfig++hideEmpty :: WorkspaceInfo -> Bool+hideEmpty WorkspaceInfo {workspaceState = WorkspaceEmpty} = False+hideEmpty _ = True++sortWindowsByPosition :: [WindowInfo] -> [WindowInfo]+sortWindowsByPosition =+  sortOn $ \w ->+    ( windowMinimized w,+      fromMaybe (999999999, 999999999) (windowPosition w)+    )++sortWindowsByStackIndex :: [WindowInfo] -> TaffyIO [WindowInfo]+sortWindowsByStackIndex wins = do+  stackingWindows <- runX11Def [] getWindowsStacking+  let getStackIdx windowInfo =+        case windowIdentity windowInfo of+          X11WindowIdentity wid -> fromMaybe (-1) $ elemIndex (fromIntegral wid) stackingWindows+          HyprlandWindowIdentity _ -> -1+      compareWindowData a b = compare (getStackIdx b) (getStackIdx a)+  return $ sortBy compareWindowData wins++scaledWindowIconPixbufGetter :: WindowIconPixbufGetter -> WindowIconPixbufGetter+scaledWindowIconPixbufGetter = scaledPixbufGetter++constantScaleWindowIconPixbufGetter ::+  Int32 -> WindowIconPixbufGetter -> WindowIconPixbufGetter+constantScaleWindowIconPixbufGetter constantSize getter =+  const $ scaledWindowIconPixbufGetter getter constantSize++handleIconGetterException :: WindowIconPixbufGetter -> WindowIconPixbufGetter+handleIconGetterException = handlePixbufGetterException wLog++getWindowIconPixbufFromClassHints :: WindowIconPixbufGetter+getWindowIconPixbufFromClassHints =+  getWindowIconPixbufFromDesktopEntry <|||> getWindowIconPixbufFromClass++getWindowIconPixbufFromDesktopEntry :: WindowIconPixbufGetter+getWindowIconPixbufFromDesktopEntry = handleIconGetterException $ \size winInfo ->+  tryHints size (map T.unpack (windowClassHints winInfo))+  where+    tryHints _ [] = return Nothing+    tryHints requestedSize (klass : rest) = do+      fromDesktopEntry <- getCachedWindowIconFromDesktopEntryByClasses requestedSize klass+      case fromDesktopEntry of+        Just _ -> return fromDesktopEntry+        Nothing -> tryHints requestedSize rest++getWindowIconPixbufFromClass :: WindowIconPixbufGetter+getWindowIconPixbufFromClass = handleIconGetterException $ \size winInfo ->+  tryHints size (map T.unpack (windowClassHints winInfo))+  where+    tryHints _ [] = return Nothing+    tryHints requestedSize (klass : rest) = do+      fromClass <- getCachedWindowIconFromClasses requestedSize klass+      case fromClass of+        Just _ -> return fromClass+        Nothing -> tryHints requestedSize rest++getWindowIconPixbufByClassHints :: Int32 -> WindowInfo -> TaffyIO (Maybe Gdk.Pixbuf)+getWindowIconPixbufByClassHints = getWindowIconPixbufFromClassHints++getWindowIconPixbufFromChrome :: WindowIconPixbufGetter+getWindowIconPixbufFromChrome _ windowData =+  case windowIdentity windowData of+    X11WindowIdentity wid -> getPixBufFromChromeData (fromIntegral wid)+    HyprlandWindowIdentity _ -> return Nothing++getWindowIconPixbufFromEWMH :: WindowIconPixbufGetter+getWindowIconPixbufFromEWMH = handleIconGetterException $ \size windowData ->+  case windowIdentity windowData of+    X11WindowIdentity wid -> getCachedIconPixBufFromEWMH size (fromIntegral wid)+    HyprlandWindowIdentity _ -> return Nothing++defaultGetWindowIconPixbuf :: WindowIconPixbufGetter+defaultGetWindowIconPixbuf =+  scaledWindowIconPixbufGetter unscaledDefaultGetWindowIconPixbuf++unscaledDefaultGetWindowIconPixbuf :: WindowIconPixbufGetter+unscaledDefaultGetWindowIconPixbuf =+  getWindowIconPixbufFromDesktopEntry+    <|||> getWindowIconPixbufFromClass+    <|||> getWindowIconPixbufFromEWMH++addCustomIconsToDefaultWithFallbackByPath ::+  (WindowInfo -> Maybe FilePath) ->+  FilePath ->+  WindowIconPixbufGetter+addCustomIconsToDefaultWithFallbackByPath getCustomIconPath fallbackPath =+  addCustomIconsAndFallback+    getCustomIconPath+    (const $ liftIO $ getPixbufFromFilePath fallbackPath)+    unscaledDefaultGetWindowIconPixbuf++addCustomIconsAndFallback ::+  (WindowInfo -> Maybe FilePath) ->+  (Int32 -> TaffyIO (Maybe Gdk.Pixbuf)) ->+  WindowIconPixbufGetter ->+  WindowIconPixbufGetter+addCustomIconsAndFallback getCustomIconPath fallback defaultGetter =+  scaledWindowIconPixbufGetter $+    getCustomIcon <|||> defaultGetter <|||> (\s _ -> fallback s)+  where+    getCustomIcon :: WindowIconPixbufGetter+    getCustomIcon _ windowInfo =+      maybe (return Nothing) (liftIO . getPixbufFromFilePath) $+        getCustomIconPath windowInfo++defaultOnWorkspaceClick :: WorkspaceInfo -> TaffyIO ()+defaultOnWorkspaceClick wsInfo = do+  backendType <- asks backend+  case backendType of+    BackendX11 -> defaultOnWorkspaceClickEWMH wsInfo+    BackendWayland -> defaultOnWorkspaceClickHyprland wsInfo++defaultOnWorkspaceClickHyprland :: WorkspaceInfo -> TaffyIO ()+defaultOnWorkspaceClickHyprland wsInfo = do+  client <- getHyprlandClient+  let targetText = workspaceName (workspaceIdentity wsInfo)+  case HyprAPI.mkHyprlandWorkspaceTarget targetText of+    Left err ->+      wLog WARNING $+        "Failed to build Hyprland workspace target for " <> show targetText <> ": " <> show err+    Right target -> do+      result <- liftIO $ HyprAPI.dispatchHyprland client (HyprAPI.DispatchWorkspace target)+      case result of+        Left err ->+          wLog WARNING $+            "Failed to switch workspace via Hyprland dispatch: " <> show err+        Right _ -> return ()++defaultOnWorkspaceClickEWMH :: WorkspaceInfo -> TaffyIO ()+defaultOnWorkspaceClickEWMH wsInfo =+  case workspaceNumericId (workspaceIdentity wsInfo) of+    Nothing ->+      wLog WARNING $+        "Workspace has no numeric id for EWMH switch: " <> show (workspaceIdentity wsInfo)+    Just workspaceId ->+      runX11Def () (switchToWorkspace (WorkspaceId workspaceId))+        `catchAny` \err ->+          wLog WARNING $+            "Failed to switch EWMH workspace " <> show workspaceId <> ": " <> show err++defaultOnWindowClick :: WindowInfo -> TaffyIO ()+defaultOnWindowClick windowInfo =+  case windowIdentity windowInfo of+    X11WindowIdentity wid ->+      runX11Def () (focusWindow (fromIntegral wid))+        `catchAny` \err ->+          wLog WARNING $+            "Failed to focus X11 window " <> show wid <> ": " <> show err+    HyprlandWindowIdentity address -> do+      client <- getHyprlandClient+      case HyprAPI.mkHyprlandAddress address of+        Left err ->+          wLog WARNING $+            "Failed to build Hyprland window address " <> show address <> ": " <> show err+        Right addr -> do+          result <-+            liftIO $+              HyprAPI.dispatchHyprland client (HyprAPI.DispatchFocusWindowAddress addr)+          case result of+            Left err ->+              wLog WARNING $+                "Failed to focus Hyprland window " <> show address <> ": " <> show err+            Right _ -> return ()++workspacesNew :: WorkspacesConfig -> TaffyIO Gtk.Widget+workspacesNew cfg = do+  ctx <- ask+  cont <- liftIO $ Gtk.boxNew Gtk.OrientationHorizontal (fromIntegral $ widgetGap cfg)+  _ <- widgetSetClassGI cont "workspaces"+  cacheVar <- liftIO $ MV.newMVar (WorkspaceCache M.empty [] [] 0)+  (chan, snapshotVar) <- autoWorkspaceStateSource+  initialSnapshot <- liftIO $ MV.readMVar snapshotVar+  renderWorkspaces cfg cont cacheVar initialSnapshot+  _ <-+    liftIO $+      Gtk.onWidgetRealize cont $ do+        latestSnapshot <- MV.readMVar snapshotVar+        postGUIASync $+          runReaderT+            (renderWorkspaces cfg cont cacheVar latestSnapshot)+            ctx+  _ <-+    liftIO $+      channelWidgetNew+        cont+        chan+        (\snapshot -> postGUIASync $ runReaderT (renderWorkspaces cfg cont cacheVar snapshot) ctx)+  Gtk.toWidget cont++renderWorkspaces ::+  WorkspacesConfig ->+  Gtk.Box ->+  MV.MVar WorkspaceCache ->+  WorkspaceSnapshot ->+  TaffyIO ()+renderWorkspaces cfg cont cacheVar snapshot = do+  ctx <- ask+  liftIO $+    MV.modifyMVar_ cacheVar $ \oldCache ->+      runReaderT (updateCache cfg cont cacheVar snapshot oldCache) ctx++updateCache ::+  WorkspacesConfig ->+  Gtk.Box ->+  MV.MVar WorkspaceCache ->+  WorkspaceSnapshot ->+  WorkspaceCache ->+  TaffyIO WorkspaceCache+updateCache cfg cont cacheVar snapshot oldCache = do+  let workspaces = snapshotWorkspaces snapshot+      forceIconRefresh =+        snapshotBackend snapshot == WorkspaceBackendEWMH+          && snapshotRevision snapshot /= cacheLastRevision oldCache+  if workspaces == cacheLastWorkspaces oldCache && not forceIconRefresh+    then return oldCache+    else do+      let oldEntries = cacheEntries oldCache+          buildOrUpdate (cacheAcc, entriesAcc) wsInfo = do+            let wsKey = workspaceIdentity wsInfo+            entry <-+              case M.lookup wsKey oldEntries of+                Just existing+                  | entryLastWorkspace existing == wsInfo ->+                      if forceIconRefresh+                        then refreshWorkspaceEntryIcons existing wsInfo+                        else return existing+                  | otherwise -> updateWorkspaceEntry existing wsInfo+                Nothing -> buildWorkspaceEntry cfg cacheVar wsInfo+            return (M.insert wsKey entry cacheAcc, (wsInfo, entry) : entriesAcc)+      (newEntries, orderedEntriesRev) <-+        foldM buildOrUpdate (M.empty, []) workspaces+      let orderedEntries = reverse orderedEntriesRev+          removed = M.difference oldEntries newEntries+          added = M.difference newEntries oldEntries+      forM_ (M.elems removed) $+        liftIO . Gtk.containerRemove cont . entryWrapper+      forM_ (M.elems added) $ \entry -> do+        liftIO $ Gtk.containerAdd cont (entryWrapper entry)+        liftIO $ Gtk.widgetShowAll (entryWrapper entry)+      let desiredOrder = map (workspaceIdentity . fst) orderedEntries+          needsReorder =+            desiredOrder /= cacheOrder oldCache+              || not (M.null added)+              || not (M.null removed)+      when needsReorder $+        forM_ (zip [0 :: Int ..] orderedEntries) $ \(position, (_wsInfo, entry)) ->+          liftIO $ Gtk.boxReorderChild cont (entryWrapper entry) (fromIntegral position)+      forM_ orderedEntries $ \(wsInfo, entry) ->+        if showWorkspaceFn cfg wsInfo+          then liftIO $ Gtk.widgetShow (entryButton entry)+          else liftIO $ Gtk.widgetHide (entryButton entry)+      return+        WorkspaceCache+          { cacheEntries = newEntries,+            cacheOrder = desiredOrder,+            cacheLastWorkspaces = workspaces,+            cacheLastRevision = snapshotRevision snapshot+          }++buildWorkspaceEntry ::+  WorkspacesConfig ->+  MV.MVar WorkspaceCache ->+  WorkspaceInfo ->+  TaffyIO WorkspaceEntry+buildWorkspaceEntry cfg cacheVar wsInfo = do+  wsRef <- liftIO $ newIORef wsInfo+  controller <- widgetBuilder cfg cfg wsInfo+  button <- liftIO Gtk.eventBoxNew+  _ <- widgetSetClassGI button "workspace-button"+  liftIO $ Gtk.eventBoxSetVisibleWindow button False+  liftIO $ Gtk.containerAdd button (controllerWidget controller)+  wrapperBox <- liftIO $ Gtk.boxNew Gtk.OrientationHorizontal 0+  liftIO $ Gtk.containerAdd wrapperBox button+  wrapper <- Gtk.toWidget wrapperBox+  _ <- widgetSetClassGI wrapper "workspace-wrapper"+  ctx <- ask+  _ <-+    liftIO $+      Gtk.onWidgetButtonPressEvent button $+        const $ do+          currentWs <- readIORef wsRef+          runReaderT (onWorkspaceClick cfg currentWs) ctx+          return True+  _ <-+    liftIO $+      Gtk.onWidgetScrollEvent button $ \scrollEvent -> do+        direction <- Gdk.getEventScrollDirection scrollEvent+        let scrollPrevious = runReaderT (switchWorkspaceRelative cfg cacheVar wsRef True) ctx+            scrollNext = runReaderT (switchWorkspaceRelative cfg cacheVar wsRef False) ctx+        case direction of+          Gdk.ScrollDirectionUp -> scrollPrevious+          Gdk.ScrollDirectionLeft -> scrollPrevious+          Gdk.ScrollDirectionDown -> scrollNext+          Gdk.ScrollDirectionRight -> scrollNext+          _ -> return False+  return+    WorkspaceEntry+      { entryWrapper = wrapper,+        entryButton = button,+        entryController = controller,+        entryWorkspaceRef = wsRef,+        entryLastWorkspace = wsInfo+      }++updateWorkspaceEntry ::+  WorkspaceEntry ->+  WorkspaceInfo ->+  TaffyIO WorkspaceEntry+updateWorkspaceEntry entry wsInfo = do+  liftIO $ writeIORef (entryWorkspaceRef entry) wsInfo+  controllerUpdate (entryController entry) wsInfo+  return entry {entryLastWorkspace = wsInfo}++refreshWorkspaceEntryIcons ::+  WorkspaceEntry ->+  WorkspaceInfo ->+  TaffyIO WorkspaceEntry+refreshWorkspaceEntryIcons entry wsInfo = do+  liftIO $ writeIORef (entryWorkspaceRef entry) wsInfo+  controllerRefreshIcons (entryController entry) wsInfo+  return entry {entryLastWorkspace = wsInfo}++switchWorkspaceRelative ::+  WorkspacesConfig ->+  MV.MVar WorkspaceCache ->+  IORef WorkspaceInfo ->+  Bool ->+  TaffyIO Bool+switchWorkspaceRelative cfg cacheVar wsRef moveBackward = do+  currentWs <- liftIO $ readIORef wsRef+  cache <- liftIO $ MV.readMVar cacheVar+  let identities = cacheOrder cache+      currentIdentity = workspaceIdentity currentWs+      step = if moveBackward then (-1) else 1+      getTargetIdentity = do+        idx <- elemIndex currentIdentity identities+        let total = length identities+        guard (total > 0)+        let wrappedIndex = (idx + step + total) `mod` total+        return (identities !! wrappedIndex)+  case getTargetIdentity >>= (`M.lookup` cacheEntries cache) of+    Nothing -> return False+    Just targetEntry -> do+      targetWorkspace <- liftIO $ readIORef (entryWorkspaceRef targetEntry)+      onWorkspaceClick cfg targetWorkspace+      return True++updateWorkspaceIcons ::+  WorkspacesConfig ->+  IORef WorkspaceInfo ->+  Gtk.Box ->+  [WindowIconWidget WindowInfo] ->+  WorkspaceInfo ->+  TaffyIO [WindowIconWidget WindowInfo]+updateWorkspaceIcons cfg workspaceRef iconsBox iconWidgets wsInfo = do+  sortedWindows <- iconSort cfg (workspaceWindows wsInfo)+  let (effectiveMinIcons, _targetLen, paddedWindows) =+        computeIconStripLayout+          (minIcons cfg)+          (maxIcons cfg)+          sortedWindows+      buildOne i = buildIconWidget cfg workspaceRef (i < effectiveMinIcons)+      updateOne = updateIconWidget+  syncWidgetPool iconsBox iconWidgets paddedWindows buildOne iconContainer updateOne++buildIconWidget ::+  WorkspacesConfig ->+  IORef WorkspaceInfo ->+  Bool ->+  TaffyIO (WindowIconWidget WindowInfo)+buildIconWidget cfg workspaceRef transparentOnNone = do+  ctx <- ask+  strategy <- getScalingImageStrategy+  let getPB size windowInfo = runReaderT (getWindowIconPixbuf cfg size windowInfo) ctx+  iconWidget <-+    liftIO $+      mkWorkspaceIconWidget+        strategy+        (iconSize cfg)+        transparentOnNone+        getPB+        (`pixBufFromColor` 0)+  _ <-+    liftIO $+      Gtk.onWidgetButtonPressEvent (iconContainer iconWidget) $+        const $ do+          maybeWindow <- MV.readMVar (iconWindow iconWidget)+          case maybeWindow of+            Just windowInfo -> runReaderT (onWindowClick cfg windowInfo) ctx+            Nothing -> do+              currentWs <- readIORef workspaceRef+              runReaderT (onWorkspaceClick cfg currentWs) ctx+          return True+  return iconWidget++updateIconWidget :: WindowIconWidget WindowInfo -> Maybe WindowInfo -> TaffyIO ()+updateIconWidget iconWidget windowData =+  updateWindowIconWidgetState+    iconWidget+    windowData+    windowTitle+    getWindowStatusString++getWindowStatusString :: WindowInfo -> T.Text+getWindowStatusString windowInfo =+  windowStatusClassFromFlags+    (windowMinimized windowInfo)+    (windowActive windowInfo)+    (windowUrgent windowInfo)++toCSSState :: WorkspacesConfig -> WorkspaceInfo -> WorkspaceState+toCSSState cfg wsInfo+  | urgentWorkspaceState cfg+      && workspaceState wsInfo == WorkspaceHidden+      && workspaceHasUrgentWindow wsInfo =+      Urgent+  | otherwise =+      case workspaceState wsInfo of+        WorkspaceActive -> Active+        WorkspaceVisible -> Visible+        WorkspaceHidden -> Hidden+        WorkspaceEmpty -> Empty++wLog :: Priority -> String -> TaffyIO ()+wLog level message =+  liftIO $ logM "System.Taffybar.Widget.Workspaces" level message
+ src/System/Taffybar/Widget/Workspaces/Channel.hs view
@@ -0,0 +1,21 @@+{-# OPTIONS_GHC -Wno-deprecations #-}++-----------------------------------------------------------------------------++-----------------------------------------------------------------------------++-- |+-- Module      : System.Taffybar.Widget.Workspaces.Channel+-- Copyright   : (c) Ivan A. Malison+-- License     : BSD3-style (see LICENSE)+--+-- Maintainer  : Ivan A. Malison+-- Stability   : unstable+-- Portability : unportable+module System.Taffybar.Widget.Workspaces.Channel+  {-# DEPRECATED "Use System.Taffybar.Widget.Workspaces instead." #-}+  ( module System.Taffybar.Widget.Workspaces,+  )+where++import System.Taffybar.Widget.Workspaces
+ src/System/Taffybar/Widget/Workspaces/Common.hs view
@@ -0,0 +1,19 @@+-----------------------------------------------------------------------------++-----------------------------------------------------------------------------++-- |+-- Module      : System.Taffybar.Widget.Workspaces.Common+-- Copyright   : (c) Ivan A. Malison+-- License     : BSD3-style (see LICENSE)+--+-- Maintainer  : Ivan A. Malison+-- Stability   : unstable+-- Portability : unportable+module System.Taffybar.Widget.Workspaces.Common+  {-# DEPRECATED "Use System.Taffybar.Widget.Workspaces.Config" #-}+  ( module System.Taffybar.Widget.Workspaces.Config,+  )+where++import System.Taffybar.Widget.Workspaces.Config
+ src/System/Taffybar/Widget/Workspaces/Config.hs view
@@ -0,0 +1,41 @@+{-# LANGUAGE RankNTypes #-}++-----------------------------------------------------------------------------++-----------------------------------------------------------------------------++-- |+-- Module      : System.Taffybar.Widget.Workspaces.Config+-- Copyright   : (c) Ivan A. Malison+-- License     : BSD3-style (see LICENSE)+--+-- Maintainer  : Ivan A. Malison+-- Stability   : unstable+-- Portability : unportable+--+-- Shared configuration shape used by both workspace widgets.+module System.Taffybar.Widget.Workspaces.Config+  ( WorkspaceWidgetCommonConfig (..),+  )+where++import Data.Int (Int32)+import qualified GI.GdkPixbuf.Objects.Pixbuf as Gdk+import System.Taffybar.Context (TaffyIO)++-- | Common, backend-agnostic workspace-widget configuration.+--+-- The @m@ type parameter captures the backend-specific context monad used for+-- widget/controller updates.+data WorkspaceWidgetCommonConfig m workspace window controller+  = WorkspaceWidgetCommonConfig+  { widgetBuilder :: workspace -> m controller,+    widgetGap :: Int,+    maxIcons :: Maybe Int,+    minIcons :: Int,+    getWindowIconPixbuf :: Int32 -> window -> TaffyIO (Maybe Gdk.Pixbuf),+    labelSetter :: workspace -> m String,+    showWorkspaceFn :: workspace -> Bool,+    iconSort :: [window] -> m [window],+    urgentWorkspaceState :: Bool+  }
+ src/System/Taffybar/Widget/Workspaces/EWMH.hs view
@@ -0,0 +1,884 @@+{-# LANGUAGE ExistentialQuantification #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE StrictData #-}+{-# OPTIONS_GHC -fno-warn-type-defaults #-}++-----------------------------------------------------------------------------++-----------------------------------------------------------------------------++-- |+-- Module      : System.Taffybar.Widget.Workspaces.EWMH+-- Copyright   : (c) Ivan A. Malison+-- License     : BSD3-style (see LICENSE)+--+-- Maintainer  : Ivan A. Malison+-- Stability   : unstable+-- Portability : unportable+module System.Taffybar.Widget.Workspaces.EWMH+  ( module System.Taffybar.Widget.Workspaces.EWMH,+    module System.Taffybar.Widget.Workspaces.Shared,+    module System.Taffybar.Widget.Workspaces.Config,+  )+where++import Control.Arrow ((&&&))+import Control.Concurrent+import qualified Control.Concurrent.MVar as MV+import Control.Monad+import Control.Monad.IO.Class+import Control.Monad.Trans.Class+import Control.Monad.Trans.Reader+import Control.RateLimit+import Data.Char (toLower)+import Data.Default (Default (..))+import qualified Data.Foldable as F+import Data.GI.Base.ManagedPtr (unsafeCastTo)+import Data.Int+import Data.List (elemIndex, intersect, isPrefixOf, sortBy, (\\))+import qualified Data.Map as M+import Data.Maybe+import qualified Data.MultiMap as MM+import qualified Data.Set as Set+import qualified Data.Text as T+import Data.Time.Units+import Data.Tuple.Select+import Data.Tuple.Sequence+import qualified GI.Gdk.Enums as Gdk+import qualified GI.Gdk.Structs.EventScroll as Gdk+import qualified GI.GdkPixbuf.Objects.Pixbuf as Gdk+import qualified GI.Gtk as Gtk+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.ScalingImage (getScalingImageStrategy)+import System.Taffybar.Widget.Util+import System.Taffybar.Widget.Workspaces.Config+  ( WorkspaceWidgetCommonConfig (WorkspaceWidgetCommonConfig),+  )+import qualified System.Taffybar.Widget.Workspaces.Config as WorkspaceWidgetConfig+import System.Taffybar.Widget.Workspaces.Shared+  ( WorkspaceState (..),+    buildWorkspaceIconLabelOverlay,+    cssWorkspaceStates,+    getCSSClass,+    mkWorkspaceIconWidget,+    setWorkspaceWidgetStatusClass,+  )+import System.Taffybar.WindowIcon+import Text.Printf++data WindowData = WindowData+  { windowId :: X11Window,+    windowTitle :: String,+    windowClass :: String,+    windowUrgent :: Bool,+    windowActive :: Bool,+    windowMinimized :: Bool+  }+  deriving (Show, Eq)++data WidgetUpdate = WorkspaceUpdate Workspace | IconUpdate [X11Window]++data Workspace = Workspace+  { workspaceIdx :: WorkspaceId,+    workspaceName :: String,+    workspaceState :: WorkspaceState,+    windows :: [WindowData]+  }+  deriving (Show, Eq)++data WorkspacesContext = WorkspacesContext+  { controllersVar :: MV.MVar (M.Map WorkspaceId WWC),+    workspacesVar :: MV.MVar (M.Map WorkspaceId Workspace),+    workspacesWidget :: Gtk.Box,+    ewmhConfig :: WorkspacesConfig,+    taffyContext :: Context+  }++type WorkspacesIO a = ReaderT WorkspacesContext IO a++liftContext :: TaffyIO a -> WorkspacesIO a+liftContext action = asks taffyContext >>= lift . runReaderT action++liftX11Def :: a -> X11Property a -> WorkspacesIO a+liftX11Def dflt prop = liftContext $ runX11Def dflt prop++class WorkspaceWidgetController wc where+  getWidget :: wc -> WorkspacesIO Gtk.Widget+  updateWidget :: wc -> WidgetUpdate -> WorkspacesIO wc+  updateWidgetX11 :: wc -> WidgetUpdate -> WorkspacesIO wc+  updateWidgetX11 cont _ = return cont++data WWC = forall a. (WorkspaceWidgetController a) => WWC a++instance WorkspaceWidgetController WWC where+  getWidget (WWC wc) = getWidget wc+  updateWidget (WWC wc) update = WWC <$> updateWidget wc update+  updateWidgetX11 (WWC wc) update = WWC <$> updateWidgetX11 wc update++type ControllerConstructor = Workspace -> WorkspacesIO WWC++type ParentControllerConstructor =+  ControllerConstructor -> ControllerConstructor++type WindowIconPixbufGetter =+  Int32 -> WindowData -> TaffyIO (Maybe Gdk.Pixbuf)++data WorkspacesConfig+  = WorkspacesConfig+  { workspacesConfig ::+      WorkspaceWidgetCommonConfig+        (ReaderT WorkspacesContext IO)+        Workspace+        WindowData+        WWC,+    borderWidth :: Int,+    updateEvents :: [String],+    updateRateLimitMicroseconds :: Integer+  }++workspacesCommonConfig ::+  WorkspacesConfig ->+  WorkspaceWidgetCommonConfig (ReaderT WorkspacesContext IO) Workspace WindowData WWC+workspacesCommonConfig = workspacesConfig++-- | Modify the nested 'WorkspaceWidgetCommonConfig' inside a 'WorkspacesConfig'.+--+-- Prefer this helper when overriding multiple fields to avoid accidentally+-- introducing a self-recursive config definition that can hang at runtime.+modifyCommonWorkspacesConfig ::+  ( WorkspaceWidgetCommonConfig (ReaderT WorkspacesContext IO) Workspace WindowData WWC ->+    WorkspaceWidgetCommonConfig (ReaderT WorkspacesContext IO) Workspace WindowData WWC+  ) ->+  WorkspacesConfig ->+  WorkspacesConfig+modifyCommonWorkspacesConfig f cfg =+  cfg {workspacesConfig = f (workspacesConfig cfg)}++-- | Replace the nested common config inside 'WorkspacesConfig'.+--+-- If you're just tweaking a few fields, prefer 'modifyCommonWorkspacesConfig'+-- to avoid accidentally creating a self-recursive definition that can hang at+-- runtime.+applyCommonWorkspacesConfig ::+  WorkspaceWidgetCommonConfig (ReaderT WorkspacesContext IO) Workspace WindowData WWC ->+  WorkspacesConfig ->+  WorkspacesConfig+applyCommonWorkspacesConfig common cfg =+  cfg {workspacesConfig = common}++defaultWorkspacesConfig :: WorkspacesConfig+defaultWorkspacesConfig =+  WorkspacesConfig+    { workspacesConfig =+        WorkspaceWidgetCommonConfig+          { WorkspaceWidgetConfig.widgetBuilder =+              buildButtonController defaultBuildContentsController,+            WorkspaceWidgetConfig.widgetGap = 0,+            WorkspaceWidgetConfig.maxIcons = Nothing,+            WorkspaceWidgetConfig.minIcons = 0,+            WorkspaceWidgetConfig.getWindowIconPixbuf = defaultGetWindowIconPixbuf,+            WorkspaceWidgetConfig.labelSetter = return . workspaceName,+            WorkspaceWidgetConfig.showWorkspaceFn = \ws -> hideEmpty ws && hideSpecial ws,+            WorkspaceWidgetConfig.iconSort = sortWindowsByPosition,+            WorkspaceWidgetConfig.urgentWorkspaceState = False+          },+      borderWidth = 2,+      updateEvents = allEWMHProperties \\ [ewmhWMIcon],+      updateRateLimitMicroseconds = 100000+    }++instance Default WorkspacesConfig where+  def = defaultWorkspacesConfig++hideEmpty :: Workspace -> Bool+hideEmpty Workspace {workspaceState = Empty} = False+hideEmpty _ = True++hideSpecial :: Workspace -> Bool+hideSpecial Workspace {workspaceName = name} =+  let lowered = map toLower name+   in lowered /= "nsp" && not ("special:" `isPrefixOf` lowered)++wLog :: (MonadIO m) => Priority -> String -> m ()+wLog l s = liftIO $ logM "System.Taffybar.Widget.Workspaces" l s++updateVar :: MV.MVar a -> (a -> WorkspacesIO a) -> WorkspacesIO a+updateVar var modify = do+  ctx <- ask+  lift $ MV.modifyMVar var $ fmap (\a -> (a, a)) . flip runReaderT ctx . modify++updateWorkspacesVar :: WorkspacesIO (M.Map WorkspaceId Workspace)+updateWorkspacesVar = do+  workspacesRef <- asks workspacesVar+  updateVar workspacesRef buildWorkspaceData++getWorkspaceToWindows ::+  [X11Window] -> X11Property (MM.MultiMap WorkspaceId X11Window)+getWorkspaceToWindows =+  foldM+    ( \theMap window ->+        MM.insert <$> getWorkspace window <*> pure window <*> pure theMap+    )+    MM.empty++getWindowData ::+  Maybe X11Window ->+  [X11Window] ->+  X11Window ->+  X11Property WindowData+getWindowData activeWindow urgentWindows window = do+  wTitle <- getWindowTitle window+  wClass <- getWindowClass window+  wMinimized <- getWindowMinimized window+  return+    WindowData+      { windowId = window,+        windowTitle = wTitle,+        windowClass = wClass,+        windowUrgent = window `elem` urgentWindows,+        windowActive = Just window == activeWindow,+        windowMinimized = wMinimized+      }++buildWorkspaceData ::+  M.Map WorkspaceId Workspace ->+  WorkspacesIO (M.Map WorkspaceId Workspace)+buildWorkspaceData _ =+  ask >>= \context -> liftX11Def M.empty $ do+    names <- getWorkspaceNames+    wins <- getWindows+    workspaceToWindows <- getWorkspaceToWindows wins+    urgentWindows <- filterM isWindowUrgent wins+    activeWindow <- getActiveWindow+    active : visible <- getVisibleWorkspaces+    let common = workspacesCommonConfig (ewmhConfig context)+        getWorkspaceState idx ws+          | idx == active = Active+          | idx `elem` visible = Visible+          | WorkspaceWidgetConfig.urgentWorkspaceState common+              && not (null (ws `intersect` urgentWindows)) =+              Urgent+          | null ws = Empty+          | otherwise = Hidden+    foldM+      ( \theMap (idx, name) -> do+          let ws = MM.lookup idx workspaceToWindows+          windowInfos <- mapM (getWindowData activeWindow urgentWindows) ws+          return $+            M.insert+              idx+              Workspace+                { workspaceIdx = idx,+                  workspaceName = name,+                  workspaceState = getWorkspaceState idx ws,+                  windows = windowInfos+                }+              theMap+      )+      M.empty+      names++addWidgetsToTopLevel :: WorkspacesIO ()+addWidgetsToTopLevel = do+  WorkspacesContext+    { controllersVar = controllersRef,+      workspacesWidget = cont+    } <-+    ask+  controllersMap <- lift $ MV.readMVar controllersRef+  -- Elems returns elements in ascending order of their keys so this will always+  -- add the widgets in the correct order+  mapM_ addWidget $ M.elems controllersMap+  lift $ Gtk.widgetShowAll cont++addWidget :: WWC -> WorkspacesIO ()+addWidget controller = do+  cont <- asks workspacesWidget+  workspaceWidget <- getWidget controller+  lift $ do+    -- XXX: This hbox exists to (hopefully) prevent the issue where workspace+    -- widgets appear out of order, in the switcher, by acting as an empty+    -- place holder when the actual widget is hidden.+    hbox <- Gtk.boxNew Gtk.OrientationHorizontal 0+    void $+      Gtk.widgetGetParent workspaceWidget+        >>= traverse (unsafeCastTo Gtk.Box)+        >>= traverse (`Gtk.containerRemove` workspaceWidget)+    Gtk.containerAdd hbox workspaceWidget+    Gtk.containerAdd cont hbox++workspacesNew :: WorkspacesConfig -> TaffyIO Gtk.Widget+workspacesNew cfg =+  ask >>= \tContext -> lift $ do+    let common = workspacesCommonConfig cfg+    cont <- Gtk.boxNew Gtk.OrientationHorizontal $ fromIntegral (WorkspaceWidgetConfig.widgetGap common)+    controllersRef <- MV.newMVar M.empty+    workspacesRef <- MV.newMVar M.empty+    let context =+          WorkspacesContext+            { controllersVar = controllersRef,+              workspacesVar = workspacesRef,+              workspacesWidget = cont,+              ewmhConfig = cfg,+              taffyContext = tContext+            }+    -- This will actually create all the widgets+    runReaderT updateAllWorkspaceWidgets context+    updateHandler <- onWorkspaceUpdate context+    iconHandler <- onIconsChanged context+    let doUpdate = lift . updateHandler+        handleConfigureEvents e@(ConfigureEvent {}) = doUpdate e+        handleConfigureEvents _ = return ()+    (workspaceSubscription, iconSubscription, geometrySubscription) <-+      flip runReaderT tContext $+        sequenceT+          ( subscribeToPropertyEvents (updateEvents cfg) doUpdate,+            subscribeToPropertyEvents [ewmhWMIcon] (lift . onIconChanged iconHandler),+            subscribeToAll handleConfigureEvents+          )+    let doUnsubscribe =+          flip runReaderT tContext $+            mapM_+              unsubscribe+              [ iconSubscription,+                workspaceSubscription,+                geometrySubscription+              ]+    _ <- Gtk.onWidgetUnrealize cont doUnsubscribe+    _ <- widgetSetClassGI cont "workspaces"+    Gtk.toWidget cont++updateAllWorkspaceWidgets :: WorkspacesIO ()+updateAllWorkspaceWidgets = do+  wLog DEBUG "Updating workspace widgets"++  workspacesMap <- updateWorkspacesVar+  wLog DEBUG $ printf "Workspaces: %s" $ show workspacesMap++  wLog DEBUG "Adding and removing widgets"+  updateWorkspaceControllers++  let updateController' idx controller =+        maybe+          (return controller)+          (updateWidget controller . WorkspaceUpdate)+          $ M.lookup idx workspacesMap+      logUpdateController i =+        wLog DEBUG $ printf "Updating %s workspace widget" $ show i+      updateController i cont =+        logUpdateController i+          >> updateController' i cont++  wLog DEBUG "Done updating individual widget"++  doWidgetUpdate updateController++  wLog DEBUG "Showing and hiding controllers"+  setControllerWidgetVisibility++setControllerWidgetVisibility :: WorkspacesIO ()+setControllerWidgetVisibility = do+  ctx@WorkspacesContext+    { workspacesVar = workspacesRef,+      controllersVar = controllersRef,+      ewmhConfig = cfg+    } <-+    ask+  let common = workspacesCommonConfig cfg+  lift $ do+    workspacesMap <- MV.readMVar workspacesRef+    controllersMap <- MV.readMVar controllersRef+    forM_ (M.elems workspacesMap) $ \ws ->+      let action =+            if WorkspaceWidgetConfig.showWorkspaceFn common ws+              then Gtk.widgetShow+              else Gtk.widgetHide+       in traverse+            (flip runReaderT ctx . getWidget)+            (M.lookup (workspaceIdx ws) controllersMap)+            >>= maybe (return ()) action++doWidgetUpdate :: (WorkspaceId -> WWC -> WorkspacesIO WWC) -> WorkspacesIO ()+doWidgetUpdate updateController = do+  c@WorkspacesContext {controllersVar = controllersRef} <- ask+  lift $ MV.modifyMVar_ controllersRef $ \controllers -> do+    wLog DEBUG "Updating controllers ref"+    controllersList <-+      mapM+        ( \(idx, controller) -> do+            newController <- runReaderT (updateController idx controller) c+            return (idx, newController)+        )+        $ M.toList controllers+    return $ M.fromList controllersList++updateWorkspaceControllers :: WorkspacesIO ()+updateWorkspaceControllers = do+  WorkspacesContext+    { controllersVar = controllersRef,+      workspacesVar = workspacesRef,+      workspacesWidget = cont,+      ewmhConfig = cfg+    } <-+    ask+  workspacesMap <- lift $ MV.readMVar workspacesRef+  controllersMap <- lift $ MV.readMVar controllersRef++  let newWorkspacesSet = M.keysSet workspacesMap+      existingWorkspacesSet = M.keysSet controllersMap+      common = workspacesCommonConfig cfg++  when (existingWorkspacesSet /= newWorkspacesSet) $ do+    let addWorkspaces = Set.difference newWorkspacesSet existingWorkspacesSet+        removeWorkspaces = Set.difference existingWorkspacesSet newWorkspacesSet+        builder = WorkspaceWidgetConfig.widgetBuilder common++    _ <- updateVar controllersRef $ \controllers -> do+      let oldRemoved = F.foldl' (flip M.delete) controllers removeWorkspaces+          buildController idx = builder <$> M.lookup idx workspacesMap+          buildAndAddController theMap idx =+            maybe+              (return theMap)+              (>>= return . flip (M.insert idx) theMap)+              (buildController idx)+      foldM buildAndAddController oldRemoved $ Set.toList addWorkspaces+    -- Clear the container and repopulate it+    lift $ Gtk.containerForeach cont (Gtk.containerRemove cont)+    addWidgetsToTopLevel++rateLimitFn ::+  forall req resp.+  WorkspacesContext ->+  (req -> IO resp) ->+  ResultsCombiner req resp ->+  IO (req -> IO resp)+rateLimitFn context =+  let limit = (updateRateLimitMicroseconds $ ewmhConfig context)+      rate = fromMicroseconds limit :: Microsecond+   in generateRateLimitedFunction $ PerInvocation rate++onWorkspaceUpdate :: WorkspacesContext -> IO (Event -> IO ())+onWorkspaceUpdate context = do+  rateLimited <- rateLimitFn context doUpdate combineRequests+  let withLog event = do+        case event of+          PropertyEvent _ _ _ _ _ atom _ _ ->+            wLog DEBUG $ printf "Event %s" $ show atom+          _anythingElse -> return ()+        void $ forkIO $ rateLimited event+  return withLog+  where+    combineRequests _ b = Just (b, const ((), ()))+    doUpdate _ = postGUIASync $ runReaderT updateAllWorkspaceWidgets context++onIconChanged :: (Set.Set X11Window -> IO ()) -> Event -> IO ()+onIconChanged handler event =+  case event of+    PropertyEvent {ev_window = wid} -> do+      wLog DEBUG $ printf "Icon changed event %s" $ show wid+      handler $ Set.singleton wid+    _ -> return ()++onIconsChanged :: WorkspacesContext -> IO (Set.Set X11Window -> IO ())+onIconsChanged context = rateLimitFn context onIconsChanged' combineRequests+  where+    combineRequests windows1 windows2 =+      Just (Set.union windows1 windows2, const ((), ()))+    onIconsChanged' wids = do+      wLog DEBUG $ printf "Icon update execute %s" $ show wids+      postGUIASync $+        flip runReaderT context $+          doWidgetUpdate+            ( \idx c ->+                wLog DEBUG (printf "Updating %s icons." $ show idx)+                  >> updateWidget c (IconUpdate $ Set.toList wids)+            )++initializeWWC ::+  (WorkspaceWidgetController a) => a -> Workspace -> ReaderT WorkspacesContext IO WWC+initializeWWC controller ws =+  WWC <$> updateWidget controller (WorkspaceUpdate ws)++-- | A WrappingController can be used to wrap some child widget with another+-- abitrary widget.+data WrappingController = WrappingController+  { wrappedWidget :: Gtk.Widget,+    wrappedController :: WWC+  }++instance WorkspaceWidgetController WrappingController where+  getWidget = lift . Gtk.toWidget . wrappedWidget+  updateWidget wc update = do+    updated <- updateWidget (wrappedController wc) update+    return wc {wrappedController = updated}++data WorkspaceContentsController = WorkspaceContentsController+  { containerWidget :: Gtk.Widget,+    contentsControllers :: [WWC]+  }++buildContentsController :: [ControllerConstructor] -> ControllerConstructor+buildContentsController constructors ws = do+  controllers <- mapM ($ ws) constructors+  ctx <- ask+  tempController <- lift $ do+    cons <- Gtk.boxNew Gtk.OrientationHorizontal 0+    mapM_ (flip runReaderT ctx . getWidget >=> Gtk.containerAdd cons) controllers+    outerBox <- Gtk.toWidget cons >>= buildPadBox+    _ <- widgetSetClassGI cons "contents"+    widget <- Gtk.toWidget outerBox+    return+      WorkspaceContentsController+        { containerWidget = widget,+          contentsControllers = controllers+        }+  initializeWWC tempController ws++defaultBuildContentsController :: ControllerConstructor+defaultBuildContentsController =+  buildContentsController [buildLabelController, buildIconController]++bottomLeftAlignedBoxWrapper :: T.Text -> ControllerConstructor -> ControllerConstructor+bottomLeftAlignedBoxWrapper boxClass constructor ws = do+  controller <- constructor ws+  widget <- getWidget controller+  wrapped <- lift $ buildBottomLeftAlignedBox boxClass widget+  let wrappingController =+        WrappingController+          { wrappedWidget = wrapped,+            wrappedController = controller+          }+  initializeWWC wrappingController ws++buildLabelOverlayController :: ControllerConstructor+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+buildOverlayContentsController mainConstructors overlayConstructors ws = do+  controllers <- mapM ($ ws) mainConstructors+  overlayControllers <- mapM ($ ws) overlayConstructors+  ctx <- ask+  tempController <- lift $ do+    mainContents <- Gtk.boxNew Gtk.OrientationHorizontal 0+    mapM_+      (flip runReaderT ctx . getWidget >=> Gtk.containerAdd mainContents)+      controllers+    outerBox <- Gtk.toWidget mainContents >>= buildPadBox+    _ <- widgetSetClassGI mainContents "contents"+    overlayWidgets <- mapM (flip runReaderT ctx . getWidget) overlayControllers+    widget <- buildOverlayWithPassThrough outerBox overlayWidgets+    return+      WorkspaceContentsController+        { containerWidget = widget,+          contentsControllers = controllers ++ overlayControllers+        }+  initializeWWC tempController ws++instance WorkspaceWidgetController WorkspaceContentsController where+  getWidget = return . containerWidget+  updateWidget cc update = do+    WorkspacesContext {} <- ask+    case update of+      WorkspaceUpdate newWorkspace ->+        lift $ setWorkspaceWidgetStatusClass (workspaceState newWorkspace) $ containerWidget cc+      _ -> return ()+    newControllers <- mapM (`updateWidget` update) $ contentsControllers cc+    return cc {contentsControllers = newControllers}+  updateWidgetX11 cc update = do+    newControllers <- mapM (`updateWidgetX11` update) $ contentsControllers cc+    return cc {contentsControllers = newControllers}++newtype LabelController = LabelController {label :: Gtk.Label}++buildLabelController :: ControllerConstructor+buildLabelController ws = do+  tempController <- lift $ do+    lbl <- Gtk.labelNew Nothing+    _ <- widgetSetClassGI lbl "workspace-label"+    return LabelController {label = lbl}+  initializeWWC tempController ws++instance WorkspaceWidgetController LabelController where+  getWidget = lift . Gtk.toWidget . label+  updateWidget lc (WorkspaceUpdate newWorkspace) = do+    WorkspacesContext {ewmhConfig = cfg} <- ask+    let common = workspacesCommonConfig cfg+    labelText <- WorkspaceWidgetConfig.labelSetter common newWorkspace+    lift $ do+      Gtk.labelSetMarkup (label lc) $ T.pack labelText+      setWorkspaceWidgetStatusClass (workspaceState newWorkspace) $ label lc+    return lc+  updateWidget lc _ = return lc++type IconWidget = WindowIconWidget WindowData++buildIconWidget :: Bool -> Workspace -> WorkspacesIO IconWidget+buildIconWidget transparentOnNone ws = do+  ctx <- ask+  let tContext = taffyContext ctx+      cfg = ewmhConfig ctx+      common = workspacesCommonConfig cfg+      getPB size windowData =+        runReaderT (WorkspaceWidgetConfig.getWindowIconPixbuf common size windowData) tContext+  strategy <- liftContext getScalingImageStrategy+  lift $ do+    iconWidget <-+      mkWorkspaceIconWidget+        strategy+        Nothing+        transparentOnNone+        getPB+        (`pixBufFromColor` 0)+    _ <-+      Gtk.onWidgetButtonPressEvent (iconContainer iconWidget) $+        const $+          liftIO $ do+            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++data IconController = IconController+  { iconsContainer :: Gtk.Box,+    iconImages :: [IconWidget],+    iconWorkspace :: Workspace+  }++buildIconController :: ControllerConstructor+buildIconController ws = do+  tempController <-+    lift $ do+      hbox <- Gtk.boxNew Gtk.OrientationHorizontal 0+      return+        IconController+          { iconsContainer = hbox,+            iconImages = [],+            iconWorkspace = ws+          }+  initializeWWC tempController ws++instance WorkspaceWidgetController IconController where+  getWidget = lift . Gtk.toWidget . iconsContainer+  updateWidget ic (WorkspaceUpdate newWorkspace) = do+    newImages <- updateImages ic newWorkspace+    return ic {iconImages = newImages, iconWorkspace = newWorkspace}+  updateWidget ic (IconUpdate updatedIcons) =+    updateWindowIconsById ic updatedIcons >> return ic++updateWindowIconsById ::+  IconController -> [X11Window] -> WorkspacesIO ()+updateWindowIconsById ic windowIds =+  mapM_ maybeUpdateWindowIcon $ iconImages ic+  where+    maybeUpdateWindowIcon widget =+      do+        info <- lift $ MV.readMVar $ iconWindow widget+        when (maybe False (flip elem windowIds . windowId) info) $+          updateIconWidget ic widget info++scaledWindowIconPixbufGetter :: WindowIconPixbufGetter -> WindowIconPixbufGetter+scaledWindowIconPixbufGetter = scaledPixbufGetter++constantScaleWindowIconPixbufGetter ::+  Int32 -> WindowIconPixbufGetter -> WindowIconPixbufGetter+constantScaleWindowIconPixbufGetter constantSize getter =+  const $ scaledWindowIconPixbufGetter getter constantSize++handleIconGetterException :: WindowIconPixbufGetter -> WindowIconPixbufGetter+handleIconGetterException = handlePixbufGetterException wLog++getWindowIconPixbufFromEWMH :: WindowIconPixbufGetter+getWindowIconPixbufFromEWMH = handleIconGetterException $ \size windowData ->+  getCachedIconPixBufFromEWMH size (windowId windowData)++getWindowIconPixbufFromClass :: WindowIconPixbufGetter+getWindowIconPixbufFromClass = handleIconGetterException $ \size windowData ->+  getCachedWindowIconFromClasses size (windowClass windowData)++getWindowIconPixbufFromDesktopEntry :: WindowIconPixbufGetter+getWindowIconPixbufFromDesktopEntry = handleIconGetterException $ \size windowData ->+  getCachedWindowIconFromDesktopEntryByClasses size (windowClass windowData)++getWindowIconPixbufFromChrome :: WindowIconPixbufGetter+getWindowIconPixbufFromChrome _ windowData =+  getPixBufFromChromeData $ windowId windowData++defaultGetWindowIconPixbuf :: WindowIconPixbufGetter+defaultGetWindowIconPixbuf =+  scaledWindowIconPixbufGetter unscaledDefaultGetWindowIconPixbuf++unscaledDefaultGetWindowIconPixbuf :: WindowIconPixbufGetter+unscaledDefaultGetWindowIconPixbuf =+  getWindowIconPixbufFromDesktopEntry+    <|||> getWindowIconPixbufFromClass+    <|||> getWindowIconPixbufFromEWMH++addCustomIconsToDefaultWithFallbackByPath ::+  (WindowData -> Maybe FilePath) ->+  FilePath ->+  WindowIconPixbufGetter+addCustomIconsToDefaultWithFallbackByPath getCustomIconPath fallbackPath =+  addCustomIconsAndFallback+    getCustomIconPath+    (const $ lift $ getPixbufFromFilePath fallbackPath)+    unscaledDefaultGetWindowIconPixbuf++addCustomIconsAndFallback ::+  (WindowData -> Maybe FilePath) ->+  (Int32 -> TaffyIO (Maybe Gdk.Pixbuf)) ->+  WindowIconPixbufGetter ->+  WindowIconPixbufGetter+addCustomIconsAndFallback getCustomIconPath fallback defaultGetter =+  scaledWindowIconPixbufGetter $+    getCustomIcon <|||> defaultGetter <|||> (\s _ -> fallback s)+  where+    getCustomIcon :: Int32 -> WindowData -> TaffyIO (Maybe Gdk.Pixbuf)+    getCustomIcon _ wdata =+      lift $+        maybe (return Nothing) getPixbufFromFilePath $+          getCustomIconPath wdata++-- | Sort windows by top-left corner position.+sortWindowsByPosition :: [WindowData] -> WorkspacesIO [WindowData]+sortWindowsByPosition wins = do+  let getGeometryWorkspaces w = getDisplay >>= liftIO . (`safeGetGeometry` w)+      getGeometries =+        mapM+          ( forkM+              return+              (((sel2 &&& sel3) <$>) . getGeometryWorkspaces)+              . windowId+          )+          wins+  windowGeometries <- liftX11Def [] getGeometries+  let getLeftPos wd =+        fromMaybe (999999999, 99999999) $ lookup (windowId wd) windowGeometries+      compareWindowData a b =+        compare+          (windowMinimized a, getLeftPos a)+          (windowMinimized b, getLeftPos b)+  return $ sortBy compareWindowData wins++-- | Sort windows in reverse _NET_CLIENT_LIST_STACKING order.+-- Starting in xmonad-contrib 0.17.0, this is effectively focus history, active first.+-- Previous versions erroneously stored focus-sort-order in _NET_CLIENT_LIST.+sortWindowsByStackIndex :: [WindowData] -> WorkspacesIO [WindowData]+sortWindowsByStackIndex wins = do+  stackingWindows <- liftX11Def [] getWindowsStacking+  let getStackIdx wd = fromMaybe (-1) $ elemIndex (windowId wd) stackingWindows+      compareWindowData a b = compare (getStackIdx b) (getStackIdx a)+  return $ sortBy compareWindowData wins++updateImages :: IconController -> Workspace -> WorkspacesIO [IconWidget]+updateImages ic ws = do+  WorkspacesContext {ewmhConfig = cfg} <- ask+  let common = workspacesCommonConfig cfg+  sortedWindows <- WorkspaceWidgetConfig.iconSort common $ windows ws+  wLog DEBUG $ printf "Updating images for %s" (show ws)+  let (effectiveMinIcons, _targetLen, paddedWindows) =+        computeIconStripLayout+          (WorkspaceWidgetConfig.minIcons common)+          (WorkspaceWidgetConfig.maxIcons common)+          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 =+  windowStatusClassFromFlags+    (windowMinimized windowData)+    (windowActive windowData)+    (windowUrgent windowData)++updateIconWidget ::+  IconController ->+  IconWidget ->+  Maybe WindowData ->+  WorkspacesIO ()+updateIconWidget _ iconWidget windowData =+  updateWindowIconWidgetState+    iconWidget+    windowData+    (T.pack . windowTitle)+    getWindowStatusString++data WorkspaceButtonController = WorkspaceButtonController+  { button :: Gtk.EventBox,+    buttonWorkspace :: Workspace,+    contentsController :: WWC+  }++buildButtonController :: ParentControllerConstructor+buildButtonController contentsBuilder workspace = do+  cc <- contentsBuilder workspace+  workspacesRef <- asks workspacesVar+  ctx <- ask+  widget <- getWidget cc+  lift $ do+    ebox <- Gtk.eventBoxNew+    Gtk.containerAdd ebox widget+    Gtk.eventBoxSetVisibleWindow ebox False+    _ <-+      Gtk.onWidgetScrollEvent ebox $ \scrollEvent -> do+        dir <- Gdk.getEventScrollDirection scrollEvent+        workspaces <- liftIO $ MV.readMVar workspacesRef+        let switchOne a =+              liftIO $+                flip runReaderT ctx $+                  liftX11Def+                    ()+                    (switchOneWorkspace a (length (M.toList workspaces) - 1))+                    >> return True+        case dir of+          Gdk.ScrollDirectionUp -> switchOne True+          Gdk.ScrollDirectionLeft -> switchOne True+          Gdk.ScrollDirectionDown -> switchOne False+          Gdk.ScrollDirectionRight -> switchOne False+          _ -> return False+    _ <- Gtk.onWidgetButtonPressEvent ebox $ const $ switch ctx $ workspaceIdx workspace+    return $+      WWC+        WorkspaceButtonController+          { button = ebox,+            buttonWorkspace = workspace,+            contentsController = cc+          }++switch :: (MonadIO m) => WorkspacesContext -> WorkspaceId -> m Bool+switch ctx idx = do+  liftIO $ flip runReaderT ctx $ liftX11Def () $ switchToWorkspace idx+  return True++instance WorkspaceWidgetController WorkspaceButtonController where+  getWidget wbc = lift $ Gtk.toWidget $ button wbc+  updateWidget wbc update = do+    newContents <- updateWidget (contentsController wbc) update+    return wbc {contentsController = newContents}
+ src/System/Taffybar/Widget/Workspaces/EWMH/Compat.hs view
@@ -0,0 +1,171 @@+{-# LANGUAGE StrictData #-}+{-# OPTIONS_GHC -Wno-deprecations #-}++-----------------------------------------------------------------------------++-----------------------------------------------------------------------------++-- |+-- Module      : System.Taffybar.Widget.Workspaces.EWMH.Compat+-- Copyright   : (c) Ivan A. Malison+-- License     : BSD3-style (see LICENSE)+--+-- Maintainer  : Ivan A. Malison+-- Stability   : unstable+-- Portability : unportable+--+-- Flat legacy compatibility config for EWMH workspaces.+--+-- This module is intentionally not re-exported by the umbrella widget+-- modules so that consumers opt in explicitly.+module System.Taffybar.Widget.Workspaces.EWMH.Compat+  ( WorkspacesConfig (..),+    defaultWorkspacesConfig,+    workspacesNew,+    workspacesCommonConfig,+    modifyCommonWorkspacesConfig,+    applyCommonWorkspacesConfig,+    toEWMHWorkspacesConfig,+    fromEWMHWorkspacesConfig,+    FlatWorkspacesConfig,+    defaultFlatWorkspacesConfig,+    fromFlatWorkspacesConfig,+    toFlatWorkspacesConfig,+  )+where++import Control.Monad.Trans.Reader (ReaderT)+import Data.Default (Default (..))+import qualified GI.Gtk as Gtk+import System.Taffybar.Context (TaffyIO)+import System.Taffybar.Widget.Workspaces.Config+  ( WorkspaceWidgetCommonConfig (WorkspaceWidgetCommonConfig),+  )+import qualified System.Taffybar.Widget.Workspaces.Config as WorkspaceConfig+import qualified System.Taffybar.Widget.Workspaces.EWMH as EWMH++data WorkspacesConfig+  = WorkspacesConfig+  { widgetBuilder :: EWMH.ControllerConstructor,+    widgetGap :: Int,+    maxIcons :: Maybe Int,+    minIcons :: Int,+    getWindowIconPixbuf :: EWMH.WindowIconPixbufGetter,+    labelSetter :: EWMH.Workspace -> EWMH.WorkspacesIO String,+    showWorkspaceFn :: EWMH.Workspace -> Bool,+    borderWidth :: Int,+    updateEvents :: [String],+    updateRateLimitMicroseconds :: Integer,+    iconSort :: [EWMH.WindowData] -> EWMH.WorkspacesIO [EWMH.WindowData],+    urgentWorkspaceState :: Bool+  }++{-# DEPRECATED widgetBuilder "Legacy flat config field. Use the nested `workspacesConfig` field in `System.Taffybar.Widget.Workspaces.EWMH.WorkspacesConfig` instead." #-}++{-# DEPRECATED widgetGap "Legacy flat config field. Use the nested `workspacesConfig` field in `System.Taffybar.Widget.Workspaces.EWMH.WorkspacesConfig` instead." #-}++{-# DEPRECATED maxIcons "Legacy flat config field. Use the nested `workspacesConfig` field in `System.Taffybar.Widget.Workspaces.EWMH.WorkspacesConfig` instead." #-}++{-# DEPRECATED minIcons "Legacy flat config field. Use the nested `workspacesConfig` field in `System.Taffybar.Widget.Workspaces.EWMH.WorkspacesConfig` instead." #-}++{-# DEPRECATED getWindowIconPixbuf "Legacy flat config field. Use the nested `workspacesConfig` field in `System.Taffybar.Widget.Workspaces.EWMH.WorkspacesConfig` instead." #-}++{-# DEPRECATED labelSetter "Legacy flat config field. Use the nested `workspacesConfig` field in `System.Taffybar.Widget.Workspaces.EWMH.WorkspacesConfig` instead." #-}++{-# DEPRECATED showWorkspaceFn "Legacy flat config field. Use the nested `workspacesConfig` field in `System.Taffybar.Widget.Workspaces.EWMH.WorkspacesConfig` instead." #-}++{-# DEPRECATED borderWidth "Legacy flat config field. Use `System.Taffybar.Widget.Workspaces.EWMH.borderWidth` on the canonical EWMH config type instead." #-}++{-# DEPRECATED updateEvents "Legacy flat config field. Use `System.Taffybar.Widget.Workspaces.EWMH.updateEvents` on the canonical EWMH config type instead." #-}++{-# DEPRECATED updateRateLimitMicroseconds "Legacy flat config field. Use `System.Taffybar.Widget.Workspaces.EWMH.updateRateLimitMicroseconds` on the canonical EWMH config type instead." #-}++{-# DEPRECATED iconSort "Legacy flat config field. Use the nested `workspacesConfig` field in `System.Taffybar.Widget.Workspaces.EWMH.WorkspacesConfig` instead." #-}++{-# DEPRECATED urgentWorkspaceState "Legacy flat config field. Use the nested `workspacesConfig` field in `System.Taffybar.Widget.Workspaces.EWMH.WorkspacesConfig` instead." #-}++toEWMHWorkspacesConfig :: WorkspacesConfig -> EWMH.WorkspacesConfig+toEWMHWorkspacesConfig flat =+  EWMH.WorkspacesConfig+    { EWMH.workspacesConfig =+        WorkspaceWidgetCommonConfig+          { WorkspaceConfig.widgetBuilder = widgetBuilder flat,+            WorkspaceConfig.widgetGap = widgetGap flat,+            WorkspaceConfig.maxIcons = maxIcons flat,+            WorkspaceConfig.minIcons = minIcons flat,+            WorkspaceConfig.getWindowIconPixbuf = getWindowIconPixbuf flat,+            WorkspaceConfig.labelSetter = labelSetter flat,+            WorkspaceConfig.showWorkspaceFn = showWorkspaceFn flat,+            WorkspaceConfig.iconSort = iconSort flat,+            WorkspaceConfig.urgentWorkspaceState = urgentWorkspaceState flat+          },+      EWMH.borderWidth = borderWidth flat,+      EWMH.updateEvents = updateEvents flat,+      EWMH.updateRateLimitMicroseconds = updateRateLimitMicroseconds flat+    }++fromEWMHWorkspacesConfig :: EWMH.WorkspacesConfig -> WorkspacesConfig+fromEWMHWorkspacesConfig cfg =+  let common = EWMH.workspacesConfig cfg+   in WorkspacesConfig+        { widgetBuilder = WorkspaceConfig.widgetBuilder common,+          widgetGap = WorkspaceConfig.widgetGap common,+          maxIcons = WorkspaceConfig.maxIcons common,+          minIcons = WorkspaceConfig.minIcons common,+          getWindowIconPixbuf = WorkspaceConfig.getWindowIconPixbuf common,+          labelSetter = WorkspaceConfig.labelSetter common,+          showWorkspaceFn = WorkspaceConfig.showWorkspaceFn common,+          borderWidth = EWMH.borderWidth cfg,+          updateEvents = EWMH.updateEvents cfg,+          updateRateLimitMicroseconds = EWMH.updateRateLimitMicroseconds cfg,+          iconSort = WorkspaceConfig.iconSort common,+          urgentWorkspaceState = WorkspaceConfig.urgentWorkspaceState common+        }++defaultWorkspacesConfig :: WorkspacesConfig+defaultWorkspacesConfig =+  fromEWMHWorkspacesConfig EWMH.defaultWorkspacesConfig++workspacesNew :: WorkspacesConfig -> TaffyIO Gtk.Widget+workspacesNew = EWMH.workspacesNew . toEWMHWorkspacesConfig++workspacesCommonConfig ::+  WorkspacesConfig ->+  WorkspaceWidgetCommonConfig (ReaderT EWMH.WorkspacesContext IO) EWMH.Workspace EWMH.WindowData EWMH.WWC+workspacesCommonConfig =+  EWMH.workspacesConfig . toEWMHWorkspacesConfig++-- | Modify the nested common config inside a legacy flat workspaces config.+--+-- Prefer this over defining @common@ in terms of a recursively-defined @cfg@,+-- which can accidentally create a black-hole and hang at runtime.+modifyCommonWorkspacesConfig ::+  ( WorkspaceWidgetCommonConfig (ReaderT EWMH.WorkspacesContext IO) EWMH.Workspace EWMH.WindowData EWMH.WWC ->+    WorkspaceWidgetCommonConfig (ReaderT EWMH.WorkspacesContext IO) EWMH.Workspace EWMH.WindowData EWMH.WWC+  ) ->+  WorkspacesConfig ->+  WorkspacesConfig+modifyCommonWorkspacesConfig f cfg =+  applyCommonWorkspacesConfig (f (workspacesCommonConfig cfg)) cfg++applyCommonWorkspacesConfig ::+  WorkspaceWidgetCommonConfig (ReaderT EWMH.WorkspacesContext IO) EWMH.Workspace EWMH.WindowData EWMH.WWC ->+  WorkspacesConfig ->+  WorkspacesConfig+applyCommonWorkspacesConfig common cfg =+  fromEWMHWorkspacesConfig $+    EWMH.applyCommonWorkspacesConfig common (toEWMHWorkspacesConfig cfg)++type FlatWorkspacesConfig = WorkspacesConfig++defaultFlatWorkspacesConfig :: FlatWorkspacesConfig+defaultFlatWorkspacesConfig = defaultWorkspacesConfig++fromFlatWorkspacesConfig :: FlatWorkspacesConfig -> EWMH.WorkspacesConfig+fromFlatWorkspacesConfig = toEWMHWorkspacesConfig++toFlatWorkspacesConfig :: EWMH.WorkspacesConfig -> FlatWorkspacesConfig+toFlatWorkspacesConfig = fromEWMHWorkspacesConfig++instance Default WorkspacesConfig where+  def = defaultWorkspacesConfig
+ src/System/Taffybar/Widget/Workspaces/Hyprland.hs view
@@ -0,0 +1,963 @@+{-# LANGUAGE ExistentialQuantification #-}+{-# LANGUAGE OverloadedStrings #-}++-----------------------------------------------------------------------------++-----------------------------------------------------------------------------++-- |+-- Module      : System.Taffybar.Widget.Workspaces.Hyprland+-- 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.Workspaces.Hyprland 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 qualified Data.ByteString as BS+import Data.Char (toLower)+import Data.Default (Default (..))+import qualified Data.Foldable as F+import Data.IORef (IORef, newIORef, readIORef, writeIORef)+import Data.Int (Int32)+import Data.List (intercalate, sortOn, stripPrefix)+import qualified Data.Map.Strict as M+import Data.Maybe (fromMaybe, listToMaybe, mapMaybe)+import qualified Data.MultiMap as MM+import Data.Text (Text)+import qualified Data.Text as T+import qualified GI.GdkPixbuf.Objects.Pixbuf as Gdk+import qualified GI.Gtk as Gtk+import System.Environment.XDG.DesktopEntry+  ( DesktopEntry,+    deFilename,+    getDirectoryEntriesDefault,+  )+import System.Log.Logger (Priority (..), logM)+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.Generic.ScalingImage (getScalingImageStrategy)+import System.Taffybar.Widget.Util+  ( WindowIconWidget (..),+    computeIconStripLayout,+    getImageForDesktopEntry,+    handlePixbufGetterException,+    scaledPixbufGetter,+    syncWidgetPool,+    updateWindowIconWidgetState,+    widgetSetClassGI,+    windowStatusClassFromFlags,+  )+import System.Taffybar.Widget.Workspaces.Config+  ( WorkspaceWidgetCommonConfig (WorkspaceWidgetCommonConfig),+  )+import qualified System.Taffybar.Widget.Workspaces.Config as WorkspaceWidgetConfig+import System.Taffybar.Widget.Workspaces.Shared+  ( WorkspaceState (..),+    buildWorkspaceIconLabelOverlay,+    mkWorkspaceIconWidget,+    setWorkspaceWidgetStatusClass,+  )+import System.Taffybar.WindowIcon (getCachedWindowIconFromClasses, pixBufFromColor)+import Text.Printf (printf)++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,+    iconSize :: Int32,+    workspacesConfig ::+      WorkspaceWidgetCommonConfig+        (ReaderT Context IO)+        HyprlandWorkspace+        HyprlandWindow+        HyprlandWWC+  }++hyprlandWorkspacesCommonConfig ::+  HyprlandWorkspacesConfig ->+  WorkspaceWidgetCommonConfig (ReaderT Context IO) HyprlandWorkspace HyprlandWindow HyprlandWWC+hyprlandWorkspacesCommonConfig = workspacesConfig++-- | Modify the nested 'WorkspaceWidgetCommonConfig' inside a+-- 'HyprlandWorkspacesConfig'.+--+-- This helper exists to avoid accidental self-recursive config definitions+-- when overriding multiple fields. Prefer:+--+-- > cfg = modifyCommonHyprlandWorkspacesConfig (\c -> c { WorkspaceWidgetConfig.minIcons = 1 }) defaultHyprlandWorkspacesConfig+--+-- over tying the knot yourself (e.g. defining @common@ in terms of @cfg@ while+-- also defining @cfg@ in terms of @common@), which can hang at runtime.+modifyCommonHyprlandWorkspacesConfig ::+  ( WorkspaceWidgetCommonConfig (ReaderT Context IO) HyprlandWorkspace HyprlandWindow HyprlandWWC ->+    WorkspaceWidgetCommonConfig (ReaderT Context IO) HyprlandWorkspace HyprlandWindow HyprlandWWC+  ) ->+  HyprlandWorkspacesConfig ->+  HyprlandWorkspacesConfig+modifyCommonHyprlandWorkspacesConfig f cfg =+  cfg {workspacesConfig = f (workspacesConfig cfg)}++-- | Replace the nested common config inside 'HyprlandWorkspacesConfig'.+--+-- If you're just tweaking a few fields, prefer+-- 'modifyCommonHyprlandWorkspacesConfig' to avoid accidentally creating a+-- self-recursive definition that can hang at runtime.+applyCommonHyprlandWorkspacesConfig ::+  WorkspaceWidgetCommonConfig (ReaderT Context IO) HyprlandWorkspace HyprlandWindow HyprlandWWC ->+  HyprlandWorkspacesConfig ->+  HyprlandWorkspacesConfig+applyCommonHyprlandWorkspacesConfig common cfg =+  cfg {workspacesConfig = common}++defaultHyprlandWorkspacesConfig :: HyprlandWorkspacesConfig+defaultHyprlandWorkspacesConfig = cfg+  where+    cfg =+      HyprlandWorkspacesConfig+        { getWorkspaces = getHyprlandWorkspaces,+          switchToWorkspace = hyprlandSwitchToWorkspace,+          updateIntervalSeconds = 1,+          iconSize = 16,+          workspacesConfig =+            WorkspaceWidgetCommonConfig+              { WorkspaceWidgetConfig.widgetBuilder = defaultHyprlandWidgetBuilder cfg,+                WorkspaceWidgetConfig.widgetGap = 0,+                WorkspaceWidgetConfig.maxIcons = Nothing,+                WorkspaceWidgetConfig.minIcons = 0,+                WorkspaceWidgetConfig.getWindowIconPixbuf = defaultHyprlandGetWindowIconPixbuf,+                WorkspaceWidgetConfig.labelSetter = return . workspaceName,+                WorkspaceWidgetConfig.showWorkspaceFn = \ws ->+                  workspaceState ws /= Empty && not (isSpecialHyprWorkspace ws),+                -- Match the X11 Workspaces widget default: order icons by window position.+                WorkspaceWidgetConfig.iconSort = pure . sortHyprlandWindowsByPosition,+                WorkspaceWidgetConfig.urgentWorkspaceState = False+              }+        }++instance Default HyprlandWorkspacesConfig where+  def = defaultHyprlandWorkspacesConfig++hyprlandWorkspacesNew :: HyprlandWorkspacesConfig -> TaffyIO Gtk.Widget+hyprlandWorkspacesNew cfg = do+  let common = hyprlandWorkspacesCommonConfig cfg+  cont <-+    liftIO $+      Gtk.boxNew Gtk.OrientationHorizontal $+        fromIntegral (WorkspaceWidgetConfig.widgetGap common)+  _ <- 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+  let common = hyprlandWorkspacesCommonConfig cfg+  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 (WorkspaceWidgetConfig.showWorkspaceFn common) ws))+          (WorkspaceWidgetConfig.minIcons common)+          (show (WorkspaceWidgetConfig.maxIcons common))+          (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 common = hyprlandWorkspacesCommonConfig cfg+  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 <- WorkspaceWidgetConfig.widgetBuilder common 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 = WorkspaceWidgetConfig.showWorkspaceFn common+      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+  | WorkspaceWidgetConfig.urgentWorkspaceState (hyprlandWorkspacesCommonConfig 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+  let common = hyprlandWorkspacesCommonConfig cfg+  lbl <- liftIO $ Gtk.labelNew Nothing+  _ <- widgetSetClassGI lbl "workspace-label"+  labelText <- WorkspaceWidgetConfig.labelSetter common ws+  liftIO $ Gtk.labelSetMarkup lbl (T.pack labelText)+  liftIO $ setWorkspaceWidgetStatusClass (workspaceState ws) lbl+  return $+    HyprlandWWC $+      HyprlandLabelController+        { hlcLabel = lbl,+          hlcLabelSetter = WorkspaceWidgetConfig.labelSetter common+        }++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+  let common = hyprlandWorkspacesCommonConfig cfg+  sortedWindows <- WorkspaceWidgetConfig.iconSort common $ windows ws+  let (effectiveMinIcons, _targetLen, paddedWindows) =+        computeIconStripLayout+          (WorkspaceWidgetConfig.minIcons common)+          (WorkspaceWidgetConfig.maxIcons common)+          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+  let common = hyprlandWorkspacesCommonConfig cfg+  strategy <- getScalingImageStrategy+  liftIO $+    mkWorkspaceIconWidget+      strategy+      (Just $ iconSize cfg)+      transparentOnNone+      (\size w -> runReaderT (WorkspaceWidgetConfig.getWindowIconPixbuf common 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) (getCachedWindowIconFromClasses size) (windowClass windowData))+    (maybe (return Nothing) (getCachedWindowIconFromClasses 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/Workspaces/Hyprland/Compat.hs view
@@ -0,0 +1,253 @@+{-# LANGUAGE StrictData #-}+{-# OPTIONS_GHC -Wno-deprecations #-}++-----------------------------------------------------------------------------++-----------------------------------------------------------------------------++-- |+-- Module      : System.Taffybar.Widget.Workspaces.Hyprland.Compat+-- Copyright   : (c) Ivan A. Malison+-- License     : BSD3-style (see LICENSE)+--+-- Maintainer  : Ivan A. Malison+-- Stability   : unstable+-- Portability : unportable+--+-- Flat legacy compatibility config for Hyprland workspaces.+--+-- This module is intentionally not re-exported by the umbrella widget+-- modules so that consumers opt in explicitly.+module System.Taffybar.Widget.Workspaces.Hyprland.Compat+  ( HyprlandWorkspacesConfig (..),+    defaultHyprlandWorkspacesConfig,+    hyprlandWorkspacesNew,+    hyprlandWorkspacesCommonConfig,+    modifyCommonHyprlandWorkspacesConfig,+    applyCommonHyprlandWorkspacesConfig,+    toHyprlandWorkspacesConfig,+    fromHyprlandWorkspacesConfig,+    refreshWorkspaces,+    applyUrgentState,+    hyprlandBuildLabelController,+    hyprlandBuildIconController,+    hyprlandBuildContentsController,+    hyprlandBuildLabelOverlayController,+    hyprlandBuildCustomOverlayController,+    hyprlandBuildButtonController,+    defaultHyprlandWidgetBuilder,+    buildIconWidget,+    FlatHyprlandWorkspacesConfig,+    defaultFlatHyprlandWorkspacesConfig,+    fromFlatHyprlandWorkspacesConfig,+    toFlatHyprlandWorkspacesConfig,+  )+where++import Control.Monad.Trans.Reader (ReaderT)+import Data.Default (Default (..))+import Data.Int (Int32)+import qualified GI.Gtk as Gtk+import System.Taffybar.Context (Context, TaffyIO)+import System.Taffybar.Widget.Workspaces.Config+  ( WorkspaceWidgetCommonConfig (WorkspaceWidgetCommonConfig),+  )+import qualified System.Taffybar.Widget.Workspaces.Config as WorkspaceConfig+import qualified System.Taffybar.Widget.Workspaces.Hyprland as Hyprland++data HyprlandWorkspacesConfig+  = HyprlandWorkspacesConfig+  { getWorkspaces :: TaffyIO [Hyprland.HyprlandWorkspace],+    switchToWorkspace :: Hyprland.HyprlandWorkspace -> TaffyIO (),+    updateIntervalSeconds :: Double,+    widgetBuilder :: Hyprland.HyprlandControllerConstructor,+    widgetGap :: Int,+    maxIcons :: Maybe Int,+    minIcons :: Int,+    iconSize :: Int32,+    getWindowIconPixbuf :: Hyprland.HyprlandWindowIconPixbufGetter,+    labelSetter :: Hyprland.HyprlandWorkspace -> TaffyIO String,+    showWorkspaceFn :: Hyprland.HyprlandWorkspace -> Bool,+    iconSort :: [Hyprland.HyprlandWindow] -> TaffyIO [Hyprland.HyprlandWindow],+    urgentWorkspaceState :: Bool+  }++{-# DEPRECATED getWorkspaces "Legacy flat config field. Use `System.Taffybar.Widget.Workspaces.Hyprland.getWorkspaces` on the canonical nested config type instead." #-}++{-# DEPRECATED switchToWorkspace "Legacy flat config field. Use `System.Taffybar.Widget.Workspaces.Hyprland.switchToWorkspace` on the canonical nested config type instead." #-}++{-# DEPRECATED updateIntervalSeconds "Legacy flat config field. Use `System.Taffybar.Widget.Workspaces.Hyprland.updateIntervalSeconds` on the canonical nested config type instead." #-}++{-# DEPRECATED widgetBuilder "Legacy flat config field. Use the nested `workspacesConfig` field in `System.Taffybar.Widget.Workspaces.Hyprland.HyprlandWorkspacesConfig` instead." #-}++{-# DEPRECATED widgetGap "Legacy flat config field. Use the nested `workspacesConfig` field in `System.Taffybar.Widget.Workspaces.Hyprland.HyprlandWorkspacesConfig` instead." #-}++{-# DEPRECATED maxIcons "Legacy flat config field. Use the nested `workspacesConfig` field in `System.Taffybar.Widget.Workspaces.Hyprland.HyprlandWorkspacesConfig` instead." #-}++{-# DEPRECATED minIcons "Legacy flat config field. Use the nested `workspacesConfig` field in `System.Taffybar.Widget.Workspaces.Hyprland.HyprlandWorkspacesConfig` instead." #-}++{-# DEPRECATED iconSize "Legacy flat config field. Use `System.Taffybar.Widget.Workspaces.Hyprland.iconSize` on the canonical nested config type instead." #-}++{-# DEPRECATED getWindowIconPixbuf "Legacy flat config field. Use the nested `workspacesConfig` field in `System.Taffybar.Widget.Workspaces.Hyprland.HyprlandWorkspacesConfig` instead." #-}++{-# DEPRECATED labelSetter "Legacy flat config field. Use the nested `workspacesConfig` field in `System.Taffybar.Widget.Workspaces.Hyprland.HyprlandWorkspacesConfig` instead." #-}++{-# DEPRECATED showWorkspaceFn "Legacy flat config field. Use the nested `workspacesConfig` field in `System.Taffybar.Widget.Workspaces.Hyprland.HyprlandWorkspacesConfig` instead." #-}++{-# DEPRECATED iconSort "Legacy flat config field. Use the nested `workspacesConfig` field in `System.Taffybar.Widget.Workspaces.Hyprland.HyprlandWorkspacesConfig` instead." #-}++{-# DEPRECATED urgentWorkspaceState "Legacy flat config field. Use the nested `workspacesConfig` field in `System.Taffybar.Widget.Workspaces.Hyprland.HyprlandWorkspacesConfig` instead." #-}++toHyprlandWorkspacesConfig ::+  HyprlandWorkspacesConfig -> Hyprland.HyprlandWorkspacesConfig+toHyprlandWorkspacesConfig flat =+  Hyprland.HyprlandWorkspacesConfig+    { Hyprland.getWorkspaces = getWorkspaces flat,+      Hyprland.switchToWorkspace = switchToWorkspace flat,+      Hyprland.updateIntervalSeconds = updateIntervalSeconds flat,+      Hyprland.iconSize = iconSize flat,+      Hyprland.workspacesConfig =+        WorkspaceWidgetCommonConfig+          { WorkspaceConfig.widgetBuilder = widgetBuilder flat,+            WorkspaceConfig.widgetGap = widgetGap flat,+            WorkspaceConfig.maxIcons = maxIcons flat,+            WorkspaceConfig.minIcons = minIcons flat,+            WorkspaceConfig.getWindowIconPixbuf = getWindowIconPixbuf flat,+            WorkspaceConfig.labelSetter = labelSetter flat,+            WorkspaceConfig.showWorkspaceFn = showWorkspaceFn flat,+            WorkspaceConfig.iconSort = iconSort flat,+            WorkspaceConfig.urgentWorkspaceState = urgentWorkspaceState flat+          }+    }++fromHyprlandWorkspacesConfig ::+  Hyprland.HyprlandWorkspacesConfig -> HyprlandWorkspacesConfig+fromHyprlandWorkspacesConfig cfg =+  let common = Hyprland.workspacesConfig cfg+   in HyprlandWorkspacesConfig+        { getWorkspaces = Hyprland.getWorkspaces cfg,+          switchToWorkspace = Hyprland.switchToWorkspace cfg,+          updateIntervalSeconds = Hyprland.updateIntervalSeconds cfg,+          widgetBuilder = WorkspaceConfig.widgetBuilder common,+          widgetGap = WorkspaceConfig.widgetGap common,+          maxIcons = WorkspaceConfig.maxIcons common,+          minIcons = WorkspaceConfig.minIcons common,+          iconSize = Hyprland.iconSize cfg,+          getWindowIconPixbuf = WorkspaceConfig.getWindowIconPixbuf common,+          labelSetter = WorkspaceConfig.labelSetter common,+          showWorkspaceFn = WorkspaceConfig.showWorkspaceFn common,+          iconSort = WorkspaceConfig.iconSort common,+          urgentWorkspaceState = WorkspaceConfig.urgentWorkspaceState common+        }++defaultHyprlandWorkspacesConfig :: HyprlandWorkspacesConfig+defaultHyprlandWorkspacesConfig =+  fromHyprlandWorkspacesConfig Hyprland.defaultHyprlandWorkspacesConfig++hyprlandWorkspacesNew :: HyprlandWorkspacesConfig -> TaffyIO Gtk.Widget+hyprlandWorkspacesNew =+  Hyprland.hyprlandWorkspacesNew . toHyprlandWorkspacesConfig++hyprlandWorkspacesCommonConfig ::+  HyprlandWorkspacesConfig ->+  WorkspaceWidgetCommonConfig (ReaderT Context IO) Hyprland.HyprlandWorkspace Hyprland.HyprlandWindow Hyprland.HyprlandWWC+hyprlandWorkspacesCommonConfig =+  Hyprland.workspacesConfig . toHyprlandWorkspacesConfig++-- | Modify the nested common config inside a legacy flat Hyprland workspaces+-- config.+--+-- Prefer this over defining @common@ in terms of a recursively-defined @cfg@,+-- which can accidentally create a black-hole and hang at runtime.+modifyCommonHyprlandWorkspacesConfig ::+  ( WorkspaceWidgetCommonConfig (ReaderT Context IO) Hyprland.HyprlandWorkspace Hyprland.HyprlandWindow Hyprland.HyprlandWWC ->+    WorkspaceWidgetCommonConfig (ReaderT Context IO) Hyprland.HyprlandWorkspace Hyprland.HyprlandWindow Hyprland.HyprlandWWC+  ) ->+  HyprlandWorkspacesConfig ->+  HyprlandWorkspacesConfig+modifyCommonHyprlandWorkspacesConfig f cfg =+  applyCommonHyprlandWorkspacesConfig (f (hyprlandWorkspacesCommonConfig cfg)) cfg++applyCommonHyprlandWorkspacesConfig ::+  WorkspaceWidgetCommonConfig (ReaderT Context IO) Hyprland.HyprlandWorkspace Hyprland.HyprlandWindow Hyprland.HyprlandWWC ->+  HyprlandWorkspacesConfig ->+  HyprlandWorkspacesConfig+applyCommonHyprlandWorkspacesConfig common cfg =+  fromHyprlandWorkspacesConfig $+    Hyprland.applyCommonHyprlandWorkspacesConfig common (toHyprlandWorkspacesConfig cfg)++refreshWorkspaces ::+  HyprlandWorkspacesConfig -> Gtk.Box -> ReaderT Context IO ()+refreshWorkspaces cfg =+  Hyprland.refreshWorkspaces (toHyprlandWorkspacesConfig cfg)++applyUrgentState ::+  HyprlandWorkspacesConfig ->+  Hyprland.HyprlandWorkspace ->+  Hyprland.HyprlandWorkspace+applyUrgentState cfg =+  Hyprland.applyUrgentState (toHyprlandWorkspacesConfig cfg)++hyprlandBuildLabelController ::+  HyprlandWorkspacesConfig -> Hyprland.HyprlandControllerConstructor+hyprlandBuildLabelController =+  Hyprland.hyprlandBuildLabelController . toHyprlandWorkspacesConfig++hyprlandBuildIconController ::+  HyprlandWorkspacesConfig -> Hyprland.HyprlandControllerConstructor+hyprlandBuildIconController =+  Hyprland.hyprlandBuildIconController . toHyprlandWorkspacesConfig++hyprlandBuildContentsController ::+  [Hyprland.HyprlandControllerConstructor] -> Hyprland.HyprlandControllerConstructor+hyprlandBuildContentsController =+  Hyprland.hyprlandBuildContentsController++hyprlandBuildLabelOverlayController ::+  HyprlandWorkspacesConfig ->+  Hyprland.HyprlandControllerConstructor+hyprlandBuildLabelOverlayController =+  Hyprland.hyprlandBuildLabelOverlayController . toHyprlandWorkspacesConfig++hyprlandBuildCustomOverlayController ::+  (Gtk.Widget -> Gtk.Widget -> TaffyIO Gtk.Widget) ->+  HyprlandWorkspacesConfig ->+  Hyprland.HyprlandControllerConstructor+hyprlandBuildCustomOverlayController overlay cfg =+  Hyprland.hyprlandBuildCustomOverlayController+    overlay+    (toHyprlandWorkspacesConfig cfg)++hyprlandBuildButtonController ::+  HyprlandWorkspacesConfig ->+  Hyprland.HyprlandParentControllerConstructor+hyprlandBuildButtonController cfg =+  Hyprland.hyprlandBuildButtonController (toHyprlandWorkspacesConfig cfg)++defaultHyprlandWidgetBuilder ::+  HyprlandWorkspacesConfig -> Hyprland.HyprlandControllerConstructor+defaultHyprlandWidgetBuilder =+  Hyprland.defaultHyprlandWidgetBuilder . toHyprlandWorkspacesConfig++buildIconWidget ::+  Bool ->+  HyprlandWorkspacesConfig ->+  ReaderT Context IO Hyprland.HyprlandIconWidget+buildIconWidget transparentOnNone cfg =+  Hyprland.buildIconWidget transparentOnNone (toHyprlandWorkspacesConfig cfg)++type FlatHyprlandWorkspacesConfig = HyprlandWorkspacesConfig++defaultFlatHyprlandWorkspacesConfig :: FlatHyprlandWorkspacesConfig+defaultFlatHyprlandWorkspacesConfig = defaultHyprlandWorkspacesConfig++fromFlatHyprlandWorkspacesConfig ::+  FlatHyprlandWorkspacesConfig -> Hyprland.HyprlandWorkspacesConfig+fromFlatHyprlandWorkspacesConfig = toHyprlandWorkspacesConfig++toFlatHyprlandWorkspacesConfig ::+  Hyprland.HyprlandWorkspacesConfig -> FlatHyprlandWorkspacesConfig+toFlatHyprlandWorkspacesConfig = fromHyprlandWorkspacesConfig++instance Default HyprlandWorkspacesConfig where+  def = defaultHyprlandWorkspacesConfig
src/System/Taffybar/Widget/Workspaces/Shared.hs view
@@ -1,6 +1,9 @@ {-# LANGUAGE OverloadedStrings #-}  -----------------------------------------------------------------------------++-----------------------------------------------------------------------------+ -- | -- Module      : System.Taffybar.Widget.Workspaces.Shared -- Copyright   : (c) Ivan A. Malison@@ -11,37 +14,33 @@ -- 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+  ( 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 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+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@@ -70,9 +69,11 @@ -- 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.+  (MonadIO m) =>+  -- | Widget containing the window icon strip.+  Gtk.Widget ->+  -- | Workspace label widget.+  Gtk.Widget ->   m Gtk.Widget buildWorkspaceIconLabelOverlay iconsWidget labelWidget = do   base <- buildContentsBox iconsWidget@@ -85,11 +86,16 @@ -- 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.+  -- | Which scaling implementation to use.+  ImageScaleStrategy ->+  -- | Optional size request for the icon image.+  Maybe Int32 ->+  -- | Whether to render a transparent placeholder when there is no data.+  Bool ->+  -- | Icon pixbuf getter.+  (Int32 -> a -> IO (Maybe Gdk.Pixbuf)) ->+  -- | Transparent placeholder pixbuf generator.+  (Int32 -> IO Gdk.Pixbuf) ->   IO (WindowIconWidget a) mkWorkspaceIconWidget strategy mSize transparentOnNone getPixbufFor mkTransparent = do   base <- mkWindowIconWidgetBase mSize@@ -114,5 +120,4 @@   forM_ mSize $ \s ->     Gtk.widgetSetSizeRequest imageWidget (fromIntegral s) (fromIntegral s)   Gtk.containerAdd (iconContainer base) imageWidget-  return base { iconImage = imageWidget, iconForceUpdate = refreshImage }-+  return base {iconImage = imageWidget, iconForceUpdate = refreshImage}
+ src/System/Taffybar/Widget/Workspaces/X11.hs view
@@ -0,0 +1,18 @@+-----------------------------------------------------------------------------++-----------------------------------------------------------------------------++-- |+-- Module      : System.Taffybar.Widget.Workspaces.X11+-- Copyright   : (c) Ivan A. Malison+-- License     : BSD3-style (see LICENSE)+--+-- Maintainer  : Ivan A. Malison+-- Stability   : unstable+-- Portability : unportable+module System.Taffybar.Widget.Workspaces.X11+  ( module System.Taffybar.Widget.Workspaces.EWMH,+  )+where++import System.Taffybar.Widget.Workspaces.EWMH
src/System/Taffybar/Widget/WttrIn.hs view
@@ -41,16 +41,17 @@ -- > -- seconds. -- > textWttrNew "http://wttr.in/London?format=3" 60 textWttrNew ::-  MonadIO m =>+  (MonadIO m) =>   -- | URL. All non-alphanumeric characters must be properly %-encoded.   String ->   -- | Update Interval (in seconds)   Double ->   m Widget textWttrNew url interval = pollingLabelWithVariableDelayAndRefresh action True-  where action = do-          rsp <- callWttr url-          return (rsp, Nothing, interval)+  where+    action = do+      rsp <- callWttr url+      return (rsp, Nothing, interval)  -- | IO Action that calls wttr.in as per the user's request. callWttr :: String -> IO T.Text
src/System/Taffybar/Widget/XDGMenu/Menu.hs view
@@ -1,4 +1,7 @@ -----------------------------------------------------------------------------++-----------------------------------------------------------------------------+ -- | -- Module      : System.Taffybar.Widget.XDGMenu.Menu -- Copyright   : 2017 Ulf Jasper@@ -13,14 +16,13 @@ -- https://specifications.freedesktop.org/menu-spec/menu-spec-1.1.html -- -- See also 'MenuWidget'.------------------------------------------------------------------------------- module System.Taffybar.Widget.XDGMenu.Menu-  ( Menu(..)-  , MenuEntry(..)-  , buildMenu-  , getApplicationEntries-  ) where+  ( Menu (..),+    MenuEntry (..),+    buildMenu,+    getApplicationEntries,+  )+where  import Data.Char (toLower) import Data.List@@ -31,21 +33,23 @@  -- | Displayable menu data Menu = Menu-  { fmName :: String-  , fmComment :: String-  , fmIcon :: Maybe String-  , fmSubmenus :: [Menu]-  , fmEntries :: [MenuEntry]-  , fmOnlyUnallocated :: Bool-  } deriving (Eq, Show)+  { fmName :: String,+    fmComment :: String,+    fmIcon :: Maybe String,+    fmSubmenus :: [Menu],+    fmEntries :: [MenuEntry],+    fmOnlyUnallocated :: Bool+  }+  deriving (Eq, Show)  -- | Displayable menu entry data MenuEntry = MenuEntry-  { feName :: T.Text-  , feComment :: T.Text-  , feCommand :: String-  , feIcon :: Maybe T.Text-  } deriving (Eq, Show)+  { feName :: T.Text,+    feComment :: T.Text,+    feCommand :: String,+    feIcon :: Maybe T.Text+  }+  deriving (Eq, Show)  -- | Fetch menus and desktop entries and assemble the menu. buildMenu :: Maybe String -> IO Menu@@ -62,53 +66,68 @@       return fm'  -- | Convert xdg menu to displayable menu-xdgToMenu-  :: String-  -> [String]-  -> [FilePath]-  -> [DesktopEntry]-  -> XDGMenu-  -> IO (Menu, [MenuEntry])+xdgToMenu ::+  String ->+  [String] ->+  [FilePath] ->+  [DesktopEntry] ->+  XDGMenu ->+  IO (Menu, [MenuEntry]) xdgToMenu desktop langs dirDirs des xm = do   dirEntry <- getDirectoryEntry dirDirs (xmDirectory xm)   mas <- mapM (xdgToMenu desktop langs dirDirs des) (xmSubmenus xm)   let (menus, subaes) = unzip mas-      menus' = sortBy (\fm1 fm2 -> compare (map toLower $ fmName fm1)-                                   (map toLower $ fmName fm2)) menus-      entries = map (xdgToMenuEntry langs) $-                -- hide NoDisplay-                filter (not . deNoDisplay) $-                -- onlyshowin-                filter (matchesOnlyShowIn desktop) $-                -- excludes-                filter (not . flip matchesCondition (fromMaybe None (xmExclude xm))) $+      menus' =+        sortBy+          ( \fm1 fm2 ->+              compare+                (map toLower $ fmName fm1)+                (map toLower $ fmName fm2)+          )+          menus+      entries =+        map (xdgToMenuEntry langs) $+          -- hide NoDisplay+          filter (not . deNoDisplay) $+            -- onlyshowin+            filter (matchesOnlyShowIn desktop) $+              -- excludes+              filter (not . flip matchesCondition (fromMaybe None (xmExclude xm))) $                 -- includes                 filter (`matchesCondition` fromMaybe None (xmInclude xm)) des       onlyUnallocated = xmOnlyUnallocated xm       aes = if onlyUnallocated then [] else entries ++ concat subaes-  let fm = Menu {fmName            = maybe (xmName xm) (deName langs) dirEntry,-                 fmComment         = maybe "???" (fromMaybe "???" . deComment langs) dirEntry,-                 fmIcon            = deIcon =<< dirEntry,-                 fmSubmenus        = menus',-                 fmEntries         = entries,-                 fmOnlyUnallocated = onlyUnallocated}+  let fm =+        Menu+          { fmName = maybe (xmName xm) (deName langs) dirEntry,+            fmComment = maybe "???" (fromMaybe "???" . deComment langs) dirEntry,+            fmIcon = deIcon =<< dirEntry,+            fmSubmenus = menus',+            fmEntries = entries,+            fmOnlyUnallocated = onlyUnallocated+          }   return (fm, aes)  -- | Check the "only show in" logic matchesOnlyShowIn :: String -> DesktopEntry -> Bool matchesOnlyShowIn desktop de = matchesShowIn && notMatchesNotShowIn-  where matchesShowIn = case deOnlyShowIn de of-                          [] -> True-                          desktops -> desktop `elem` desktops-        notMatchesNotShowIn = case deNotShowIn de of-                                [] -> True-                                desktops -> desktop `notElem` desktops+  where+    matchesShowIn = case deOnlyShowIn de of+      [] -> True+      desktops -> desktop `elem` desktops+    notMatchesNotShowIn = case deNotShowIn de of+      [] -> True+      desktops -> desktop `notElem` desktops  -- | convert xdg desktop entry to displayble menu entry xdgToMenuEntry :: [String] -> DesktopEntry -> MenuEntry xdgToMenuEntry langs de =   MenuEntry-  {feName = name, feComment = comment, feCommand = cmd, feIcon = mIcon}+    { feName = name,+      feComment = comment,+      feCommand = cmd,+      feIcon = mIcon+    }   where     mc =       case deCommand de of@@ -116,10 +135,10 @@         Just c -> Just $ "(" ++ c ++ ")"     comment =       T.pack $-      fromMaybe "??" $-      case deComment langs de of-        Nothing -> mc-        Just tt -> Just $ tt ++ maybe "" ("\n" ++) mc+        fromMaybe "??" $+          case deComment langs de of+            Nothing -> mc+            Just tt -> Just $ tt ++ maybe "" ("\n" ++) mc     cmd = fromMaybe "FIXME" $ deCommand de     name = T.pack $ deName langs de     mIcon = T.pack <$> deIcon de@@ -128,9 +147,9 @@ fixOnlyUnallocated :: [MenuEntry] -> Menu -> Menu fixOnlyUnallocated fes fm =   fm-  { fmEntries = entries-  , fmSubmenus = map (fixOnlyUnallocated fes) (fmSubmenus fm)-  }+    { fmEntries = entries,+      fmSubmenus = map (fixOnlyUnallocated fes) (fmSubmenus fm)+    }   where     entries =       if fmOnlyUnallocated fm
src/System/Taffybar/Widget/XDGMenu/MenuWidget.hs view
@@ -1,4 +1,7 @@ -----------------------------------------------------------------------------++-----------------------------------------------------------------------------+ -- | -- Module      : System.Taffybar.Widget.XDGMenu.MenuWidget -- Copyright   : 2017 Ulf Jasper@@ -13,25 +16,22 @@ -- according to the version 1.1 of the XDG "Desktop Menu -- Specification", see -- https://specifications.freedesktop.org/menu-spec/menu-spec-1.1.html------------------------------------------------------------------------------- module System.Taffybar.Widget.XDGMenu.MenuWidget-  (-  -- * Usage-  -- $usage-  menuWidgetNew+  ( -- * Usage+    -- $usage+    menuWidgetNew,   ) where -import           Control.Monad-import           Control.Monad.IO.Class+import Control.Monad+import Control.Monad.IO.Class import qualified Data.Text as T-import           GI.Gtk hiding (Menu, imageMenuItemNew)-import           System.Log.Logger-import           System.Process-import           System.Taffybar.Widget.Generic.AutoSizeImage-import           System.Taffybar.Widget.Util-import           System.Taffybar.Widget.XDGMenu.Menu+import GI.Gtk hiding (Menu, imageMenuItemNew)+import System.Log.Logger+import System.Process+import System.Taffybar.Widget.Generic.AutoSizeImage+import System.Taffybar.Widget.Util+import System.Taffybar.Widget.XDGMenu.Menu  -- $usage --@@ -60,10 +60,13 @@ logHere = logM "System.Taffybar.Widget.XDGMenu.MenuWidget"  -- | Add a desktop entry to a gtk menu by appending a gtk menu item.-addItem :: (IsMenuShell msc) =>-           msc -- ^ GTK menu-        -> MenuEntry -- ^ Desktop entry-        -> IO ()+addItem ::+  (IsMenuShell msc) =>+  -- | GTK menu+  msc ->+  -- | Desktop entry+  MenuEntry ->+  IO () addItem ms de = do   item <- imageMenuItemNew (feName de) (getImageForMaybeIconName (feIcon de))   setWidgetTooltipText item (feComment de)@@ -76,17 +79,21 @@   return ()  -- | Add an xdg menu to a gtk menu by appending gtk menu items and submenus.-addMenu-  :: (IsMenuShell msc)-  => msc -- ^ A GTK menu-  -> Menu -- ^ A menu object-  -> IO ()+addMenu ::+  (IsMenuShell msc) =>+  -- | A GTK menu+  msc ->+  -- | A menu object+  Menu ->+  IO () addMenu ms fm = do   let subMenus = fmSubmenus fm       items = fmEntries fm   when (not (null items) || not (null subMenus)) $ do-    item <- imageMenuItemNew (T.pack $ fmName fm)-            (getImageForMaybeIconName (T.pack <$> fmIcon fm))+    item <-+      imageMenuItemNew+        (T.pack $ fmName fm)+        (getImageForMaybeIconName (T.pack <$> fmIcon fm))     menuShellAppend ms item     subMenu <- menuNew     menuItemSetSubmenu item (Just subMenu)@@ -94,10 +101,11 @@     mapM_ (addItem subMenu) items  -- | Create a new XDG Menu Widget.-menuWidgetNew-  :: MonadIO m-  => Maybe String -- ^ menu name, must end with a dash, e.g. "mate-" or "gnome-"-  -> m GI.Gtk.Widget+menuWidgetNew ::+  (MonadIO m) =>+  -- | menu name, must end with a dash, e.g. "mate-" or "gnome-"+  Maybe String ->+  m GI.Gtk.Widget menuWidgetNew mMenuPrefix = liftIO $ do   mb <- menuBarNew   m <- buildMenu mMenuPrefix
+ src/System/Taffybar/Window/FocusedMonitor.hs view
@@ -0,0 +1,133 @@+{-# LANGUAGE OverloadedStrings #-}++-----------------------------------------------------------------------------++-----------------------------------------------------------------------------++-- |+-- Module      : System.Taffybar.Window.FocusedMonitor+-- Copyright   : (c) Ivan A. Malison+-- License     : BSD3-style (see LICENSE)+--+-- Maintainer  : Ivan A. Malison+-- Stability   : unstable+-- Portability : unportable+--+-- Focused-monitor CSS class updates for bar windows.+module System.Taffybar.Window.FocusedMonitor+  ( FocusedMonitorHooks (..),+    setupFocusedMonitorClassUpdates,+  )+where++import Control.Concurrent (forkIO, killThread)+import Control.Concurrent.STM.TChan (TChan, readTChan)+import Control.Monad (forever, when)+import Control.Monad.STM (atomically)+import Data.Int (Int32)+import qualified Data.Text as T+import Data.Unique (Unique)+import qualified GI.Gdk as Gdk+import qualified GI.Gtk as Gtk+import System.Taffybar.Util (postGUIASync)+import System.Taffybar.Widget.Util (updateWidgetClasses)++data FocusedMonitorHooks+  = FocusedMonitorHooksX11+      { resolveFocusedMonitorX11 :: IO (Maybe Gdk.Monitor),+        subscribeToFocusedMonitorX11Events :: IO () -> IO Unique,+        unsubscribeFromFocusedMonitorX11Events :: Unique -> IO ()+      }+  | FocusedMonitorHooksWayland+      { resolveFocusedMonitorWayland :: IO (Maybe Gdk.Monitor),+        getFocusedMonitorHyprlandEvents :: IO (TChan T.Text)+      }++focusedMonitorClasses :: [T.Text]+focusedMonitorClasses = ["focused-monitor", "unfocused-monitor"]++focusedMonitorClass :: Bool -> T.Text+focusedMonitorClass True = "focused-monitor"+focusedMonitorClass False = "unfocused-monitor"++getBarMonitor :: Gtk.Window -> Maybe Int32 -> IO (Maybe Gdk.Monitor)+getBarMonitor window maybeMonitorNumber = do+  display <- Gtk.widgetGetDisplay window+  maybe+    (Gdk.displayGetPrimaryMonitor display)+    (Gdk.displayGetMonitor display)+    maybeMonitorNumber++monitorsMatch :: Gdk.Monitor -> Gdk.Monitor -> IO Bool+monitorsMatch left right = do+  leftGeometry <- Gdk.getMonitorGeometry left+  rightGeometry <- Gdk.getMonitorGeometry right+  case (leftGeometry, rightGeometry) of+    (Nothing, Nothing) -> return True+    (Just leftRect, Just rightRect) -> Gdk.rectangleEqual leftRect rightRect+    _ -> return False++updateFocusedMonitorClass ::+  IO (Maybe Gdk.Monitor) ->+  Gtk.Window ->+  Maybe Int32 ->+  IO ()+updateFocusedMonitorClass resolveFocusedMonitor window maybeBarMonitorNumber = do+  maybeFocusedMonitor <- resolveFocusedMonitor+  maybeBarMonitor <- getBarMonitor window maybeBarMonitorNumber+  isFocused <- case (maybeFocusedMonitor, maybeBarMonitor) of+    (Just focusedMonitor, Just barMonitor) ->+      monitorsMatch focusedMonitor barMonitor+    _ -> return False+  updateWidgetClasses+    window+    [focusedMonitorClass isFocused]+    focusedMonitorClasses++isRelevantFocusedMonitorHyprlandEvent :: T.Text -> Bool+isRelevantFocusedMonitorHyprlandEvent eventLine =+  let hyprEventName = T.takeWhile (/= '>') eventLine+   in hyprEventName+        `elem` [ "workspace",+                 "workspacev2",+                 "focusedmon",+                 "activewindow",+                 "activewindowv2",+                 "monitoradded",+                 "monitorremoved",+                 "taffybar-hyprland-connected"+               ]++setupFocusedMonitorClassUpdates ::+  FocusedMonitorHooks ->+  Gtk.Window ->+  Maybe Int32 ->+  IO ()+setupFocusedMonitorClassUpdates hooks window maybeBarMonitorNumber = do+  let resolveFocusedMonitor = case hooks of+        FocusedMonitorHooksX11 {resolveFocusedMonitorX11 = resolve} -> resolve+        FocusedMonitorHooksWayland {resolveFocusedMonitorWayland = resolve} -> resolve+      refresh =+        postGUIASync $+          updateFocusedMonitorClass+            resolveFocusedMonitor+            window+            maybeBarMonitorNumber+  case hooks of+    FocusedMonitorHooksX11+      { subscribeToFocusedMonitorX11Events = subscribe,+        unsubscribeFromFocusedMonitorX11Events = unsubscribe+      } -> do+        subscription <- subscribe refresh+        _ <- Gtk.onWidgetUnrealize window $ unsubscribe subscription+        return ()+    FocusedMonitorHooksWayland+      { getFocusedMonitorHyprlandEvents = getEvents+      } -> do+        events <- getEvents+        tid <- forkIO $ forever $ do+          eventLine <- atomically $ readTChan events+          when (isRelevantFocusedMonitorHyprlandEvent eventLine) refresh+        _ <- Gtk.onWidgetUnrealize window $ killThread tid+        return ()+  refresh
src/System/Taffybar/WindowIcon.hs view
@@ -1,44 +1,129 @@+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE LambdaCase #-}++-- | Helpers for resolving and constructing window icons from EWMH metadata,+-- desktop entries, icon themes, and browser tab image hooks. module System.Taffybar.WindowIcon where -import           Control.Concurrent-import           Control.Monad-import           Control.Monad.IO.Class-import           Control.Monad.Trans.Class-import           Control.Monad.Trans.Maybe-import           Data.Bits-import           Data.Int-import           Data.List+import Control.Concurrent+import qualified Control.Concurrent.MVar as MV+import Control.Monad+import Control.Monad.IO.Class+import Control.Monad.Trans.Reader (ask, runReaderT)+import Control.Monad.Trans.Class+import Control.Monad.Trans.Maybe+import Data.Bits+import Data.Data (Typeable)+import Data.Int+import Data.List import qualified Data.Map as M-import           Data.Maybe+import Data.Maybe import qualified Data.MultiMap as MM-import           Data.Ord+import Data.Ord import qualified Data.Text as T-import           Data.Word-import           Foreign.Marshal.Alloc-import           Foreign.Marshal.Array-import           Foreign.Ptr-import           Foreign.Storable+import Data.Word+import Foreign.Marshal.Alloc+import Foreign.Marshal.Array+import Foreign.Ptr+import Foreign.Storable import qualified GI.GdkPixbuf.Enums as Gdk import qualified GI.GdkPixbuf.Objects.Pixbuf as Gdk-import           System.Log.Logger-import           System.Taffybar.Context-import           System.Taffybar.Hooks-import           System.Taffybar.Information.Chrome-import           System.Taffybar.Information.EWMHDesktopInfo-import           System.Taffybar.Information.X11DesktopInfo-import           System.Environment.XDG.DesktopEntry-import           System.Taffybar.Util-import           System.Taffybar.Widget.Util-import           Text.Printf+import qualified GI.Gtk as Gtk+import System.Environment.XDG.DesktopEntry+import System.Log.Logger+import System.Taffybar.Context+import System.Taffybar.Hooks+import System.Taffybar.Information.Chrome+import System.Taffybar.Information.EWMHDesktopInfo+import System.Taffybar.Information.SafeX11 (Event (PropertyEvent))+import System.Taffybar.Information.X11DesktopInfo+import System.Taffybar.Util+import System.Taffybar.Widget.Util+import Text.Printf +-- | Packed 32-bit RGBA color value used by 'pixBufFromColor'. type ColorRGBA = Word32 +data WindowIconCacheKey+  = DesktopEntryIconCacheKey Int32 String+  | ClassIconCacheKey Int32 String+  | EWMHIconCacheKey Int32 X11Window+  deriving (Eq, Ord, Show)++newtype WindowIconCache = WindowIconCache+  { windowIconCacheEntries :: MV.MVar (M.Map WindowIconCacheKey (Maybe Gdk.Pixbuf))+  }+  deriving (Typeable)++getWindowIconCache :: TaffyIO WindowIconCache+getWindowIconCache = getStateDefault buildWindowIconCache++buildWindowIconCache :: TaffyIO WindowIconCache+buildWindowIconCache = do+  cacheEntries <- liftIO $ MV.newMVar M.empty+  let cache = WindowIconCache {windowIconCacheEntries = cacheEntries}+  context <- ask+  iconTheme <- liftIO Gtk.iconThemeGetDefault+  _ <- liftIO $ Gtk.onIconThemeChanged iconTheme $ do+    invalidateThemeWindowIconCacheEntries cacheEntries+    void $ runReaderT refreshTaffyWindows context+  _ <-+    subscribeToPropertyEvents [ewmhWMIcon] $ \case+      PropertyEvent _ _ _ _ windowId' _ _ _ ->+        liftIO $ invalidateEWMHWindowIconCacheEntriesForWindow cacheEntries windowId'+      _ -> return ()+  return cache++getCachedWindowIcon ::+  WindowIconCacheKey ->+  TaffyIO (Maybe Gdk.Pixbuf) ->+  TaffyIO (Maybe Gdk.Pixbuf)+getCachedWindowIcon cacheKey buildIcon = do+  WindowIconCache {windowIconCacheEntries = entriesVar} <- getWindowIconCache+  cached <- liftIO $ M.lookup cacheKey <$> MV.readMVar entriesVar+  case cached of+    Just icon -> return icon+    Nothing -> do+      icon <- buildIcon+      liftIO $ MV.modifyMVar_ entriesVar (return . M.insert cacheKey icon)+      return icon++isThemeIconCacheKey :: WindowIconCacheKey -> Bool+isThemeIconCacheKey (DesktopEntryIconCacheKey _ _) = True+isThemeIconCacheKey (ClassIconCacheKey _ _) = True+isThemeIconCacheKey (EWMHIconCacheKey _ _) = False++invalidateThemeWindowIconCacheEntries ::+  MV.MVar (M.Map WindowIconCacheKey (Maybe Gdk.Pixbuf)) ->+  IO ()+invalidateThemeWindowIconCacheEntries entriesVar =+  MV.modifyMVar_ entriesVar $+    return . M.filterWithKey (\k _ -> not (isThemeIconCacheKey k))++invalidateEWMHWindowIconCacheEntriesForWindow ::+  MV.MVar (M.Map WindowIconCacheKey (Maybe Gdk.Pixbuf)) ->+  X11Window ->+  IO ()+invalidateEWMHWindowIconCacheEntriesForWindow entriesVar changedWindow =+  MV.modifyMVar_ entriesVar $+    return . M.filterWithKey keepEntry+  where+    keepEntry (EWMHIconCacheKey _ cachedWindow) _ = cachedWindow /= changedWindow+    keepEntry _ _ = True++invalidateWindowIconCacheForWindow ::+  X11Window ->+  TaffyIO ()+invalidateWindowIconCacheForWindow windowId' = do+  WindowIconCache {windowIconCacheEntries = entriesVar} <- getWindowIconCache+  liftIO $ invalidateEWMHWindowIconCacheEntriesForWindow entriesVar windowId'+ -- | Convert a C array of integer pixels in the ARGB format to the ABGR format. -- Returns an unmanged Ptr that points to a block of memory that must be freed -- manually.-pixelsARGBToBytesABGR-  :: (Storable a, Bits a, Num a, Integral a)-  => Ptr a -> Int -> IO (Ptr Word8)+pixelsARGBToBytesABGR ::+  (Storable a, Bits a, Num a, Integral a) =>+  Ptr a -> Int -> IO (Ptr Word8) pixelsARGBToBytesABGR ptr size = do   target <- mallocArray (size * 4)   let writeIndex i = do@@ -60,6 +145,7 @@   writeIndexAndNext 0   return target +-- | Pick the best icon candidate for a target size from EWMH icon variants. selectEWMHIcon :: Int32 -> [EWMHIcon] -> Maybe EWMHIcon selectEWMHIcon imgSize icons = listToMaybe prefIcon   where@@ -69,6 +155,7 @@     largestIcon = take 1 $ reverse sortedIcons     prefIcon = smallestLargerIcon ++ largestIcon +-- | Create a pixbuf from the best matching EWMH icon for the requested size. getPixbufFromEWMHIcons :: Int32 -> [EWMHIcon] -> IO (Maybe Gdk.Pixbuf) getPixbufFromEWMHIcons size = traverse pixBufFromEWMHIcon . selectEWMHIcon size @@ -79,60 +166,104 @@       height = fromIntegral h       rowStride = width * 4   wPtr <- pixelsARGBToBytesABGR px (w * h)-  Gdk.pixbufNewFromData wPtr Gdk.ColorspaceRgb True 8-     width height rowStride (Just free)+  Gdk.pixbufNewFromData+    wPtr+    Gdk.ColorspaceRgb+    True+    8+    width+    height+    rowStride+    (Just free) +-- | Read EWMH icon data from an X11 window and convert it into a pixbuf. getIconPixBufFromEWMH :: Int32 -> X11Window -> X11Property (Maybe Gdk.Pixbuf) getIconPixBufFromEWMH size x11WindowId = runMaybeT $ do   ewmhData <- MaybeT $ getWindowIconsData x11WindowId   MaybeT $ lift $ withEWMHIcons ewmhData (getPixbufFromEWMHIcons size) +-- | Resolve and cache the EWMH icon for an X11 window.+getCachedIconPixBufFromEWMH :: Int32 -> X11Window -> TaffyIO (Maybe Gdk.Pixbuf)+getCachedIconPixBufFromEWMH size x11WindowId =+  getCachedWindowIcon+    (EWMHIconCacheKey size x11WindowId)+    (runX11Def Nothing $ getIconPixBufFromEWMH size x11WindowId)+ -- | Create a pixbuf with the indicated RGBA color.-pixBufFromColor-  :: MonadIO m-  => Int32 -> Word32 -> m Gdk.Pixbuf+pixBufFromColor ::+  (MonadIO m) =>+  Int32 -> Word32 -> m Gdk.Pixbuf pixBufFromColor imgSize c = do   pixbuf <- fromJust <$> Gdk.pixbufNew Gdk.ColorspaceRgb True 8 imgSize imgSize   Gdk.pixbufFill pixbuf c   return pixbuf -getDirectoryEntryByClass-  :: String-  -> TaffyIO (Maybe DesktopEntry)+-- | Resolve a desktop entry by X11 class name.+getDirectoryEntryByClass ::+  String ->+  TaffyIO (Maybe DesktopEntry) getDirectoryEntryByClass klass = do   entries <- MM.lookup klass <$> getDirectoryEntriesByClassName-  when (length entries > 1) $ liftIO $-       logM "System.Taffybar.WindowIcon" DEBUG $ printf-         "Class \"%s\" has multiple desktop entries: %s"-         klass (intercalate ", " $ map deFilename entries)+  when (length entries > 1) $+    liftIO $+      logM "System.Taffybar.WindowIcon" DEBUG $+        printf+          "Class \"%s\" has multiple desktop entries: %s"+          klass+          (intercalate ", " $ map deFilename entries)   return $ listToMaybe entries -getWindowIconForAllClasses-  :: Monad m-  => (p -> String -> m (Maybe a)) -> p -> String -> m (Maybe a)+-- | Try icon lookup for each parsed class component until one succeeds.+getWindowIconForAllClasses ::+  (Monad m) =>+  (p -> String -> m (Maybe a)) -> p -> String -> m (Maybe a) getWindowIconForAllClasses doOnClass size klass =   foldl combine (return Nothing) $ parseWindowClasses klass   where     combine soFar theClass =       maybeTCombine soFar (doOnClass size theClass) +-- | Resolve a window icon through desktop-entry icon metadata. getWindowIconFromDesktopEntryByClasses ::-     Int32 -> String -> TaffyIO (Maybe Gdk.Pixbuf)+  Int32 -> String -> TaffyIO (Maybe Gdk.Pixbuf) getWindowIconFromDesktopEntryByClasses =   getWindowIconForAllClasses getWindowIconFromDesktopEntryByClass-  where getWindowIconFromDesktopEntryByClass size klass =-          runMaybeT $ do-            entry <- MaybeT $ getDirectoryEntryByClass klass-            lift $ logPrintF "System.Taffybar.WindowIcon" DEBUG-                   "Using desktop entry for icon %s"-                   (deFilename entry, klass)-            MaybeT $ lift $ getImageForDesktopEntry size entry+  where+    getWindowIconFromDesktopEntryByClass size klass =+      runMaybeT $ do+        entry <- MaybeT $ getDirectoryEntryByClass klass+        lift $+          logPrintF+            "System.Taffybar.WindowIcon"+            DEBUG+            "Using desktop entry for icon %s"+            (deFilename entry, klass)+        MaybeT $ lift $ getImageForDesktopEntry size entry +-- | Resolve and cache a window icon through desktop-entry icon metadata.+getCachedWindowIconFromDesktopEntryByClasses ::+  Int32 -> String -> TaffyIO (Maybe Gdk.Pixbuf)+getCachedWindowIconFromDesktopEntryByClasses size klass =+  getCachedWindowIcon+    (DesktopEntryIconCacheKey size klass)+    (getWindowIconFromDesktopEntryByClasses size klass)++-- | Resolve a window icon directly by class names in the icon theme. getWindowIconFromClasses :: Int32 -> String -> IO (Maybe Gdk.Pixbuf) getWindowIconFromClasses =   getWindowIconForAllClasses getWindowIconFromClass-  where getWindowIconFromClass size klass = loadPixbufByName size (T.pack klass)+  where+    getWindowIconFromClass size klass = loadPixbufByName size (T.pack klass) +-- | Resolve and cache a window icon directly by class names in the icon theme.+getCachedWindowIconFromClasses ::+  Int32 -> String -> TaffyIO (Maybe Gdk.Pixbuf)+getCachedWindowIconFromClasses size klass =+  getCachedWindowIcon+    (ClassIconCacheKey size klass)+    (liftIO $ getWindowIconFromClasses size klass)++-- | Resolve a window icon from cached Chrome tab image data. getPixBufFromChromeData :: X11Window -> TaffyIO (Maybe Gdk.Pixbuf) getPixBufFromChromeData window = do   imageData <- getChromeTabImageDataTable >>= lift . readMVar
taffybar.cabal view
@@ -1,6 +1,6 @@ cabal-version: 3.4 name: taffybar-version: 5.1.3+version: 5.2.0 synopsis: A desktop bar similar to xmobar, but with more GUI license: BSD-3-Clause license-file: LICENSE@@ -17,6 +17,7 @@   dbus-xml/org.PulseAudio.ServerLookup1.xml   dbus-xml/org.PulseAudio.Core1.xml   dbus-xml/org.PulseAudio.Core1.Device.xml+  dbus-xml/org.freedesktop.login1.Manager.xml   dbus-xml/org.freedesktop.UPower.Device.xml   dbus-xml/org.freedesktop.UPower.xml   dbus-xml/org.mpris.MediaPlayer2.Player.xml@@ -66,7 +67,7 @@                , data-default                , dbus >= 1.2.11 && < 2.0.0                , dbus-hslogger >= 0.1.1.0 && < 0.2.0.0-               , dbus-menu >= 0.1.3.2+               , dbus-menu >= 0.1.3.0                , directory                , disk-free-space >= 0.1.0.1                , dyre >= 0.9.0 && < 0.10@@ -85,7 +86,7 @@                , gi-gtk3 >= 3.0.44 && < 4                , gi-gtk-hs >= 0.3.17 && < 0.4                , gi-pango-               , gtk-sni-tray >= 0.1.14.2+               , gtk-sni-tray >= 0.2.0.0                , gtk-strut >= 0.1.2.1                , haskell-gi-base >= 0.24                , hslogger@@ -102,7 +103,7 @@                , safe >= 0.3 && < 1                , scotty >= 0.20 && < 0.31                , split >= 0.1.4.2-               , status-notifier-item >= 0.3.1.0+               , status-notifier-item >= 0.3.2.6                , stm                , template-haskell                , text@@ -136,6 +137,7 @@                  , System.Taffybar.Information.PulseAudio                  , System.Taffybar.Information.WirePlumber                  , System.Taffybar.Information.Backlight+                 , System.Taffybar.Information.ASUS                  , System.Taffybar.Information.Battery                  , System.Taffybar.Information.Bluetooth                  , System.Taffybar.Information.CPU@@ -158,6 +160,10 @@                  , System.Taffybar.Information.SafeX11                  , System.Taffybar.Information.Systemd                  , System.Taffybar.Information.StreamInfo+                 , System.Taffybar.Information.Workspaces.EWMH+                 , System.Taffybar.Information.Workspaces.Hyprland+                 , System.Taffybar.Information.Workspaces.Model+                 , System.Taffybar.Information.Wakeup                  , System.Taffybar.Information.Wlsunset                  , System.Taffybar.Information.X11DesktopInfo                  , System.Taffybar.Information.XDG.Protocol@@ -167,6 +173,7 @@                  , System.Taffybar.Util                  , System.Taffybar.Widget                  , System.Taffybar.Widget.PulseAudio+                 , System.Taffybar.Widget.ASUS                  , System.Taffybar.Widget.Backlight                  , System.Taffybar.Widget.Battery                  , System.Taffybar.Widget.BatteryDonut@@ -175,10 +182,12 @@                  , System.Taffybar.Widget.CPUMonitor                  , System.Taffybar.Widget.CommandRunner                  , System.Taffybar.Widget.Crypto+                 , System.Taffybar.Widget.ChannelWorkspaces                  , System.Taffybar.Widget.DiskIOMonitor                  , System.Taffybar.Widget.DiskUsage                  , System.Taffybar.Widget.FSMonitor                  , System.Taffybar.Widget.FreedesktopNotifications+                 , System.Taffybar.Widget.ImageCommandButton                  , System.Taffybar.Widget.Generic.AutoFillImage                  , System.Taffybar.Widget.Generic.AutoSizeImage                  , System.Taffybar.Widget.Generic.ChannelGraph@@ -192,7 +201,6 @@                  , 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@@ -204,18 +212,28 @@                  , System.Taffybar.Widget.ScreenLock                  , System.Taffybar.Widget.SNIMenu                  , System.Taffybar.Widget.SNITray+                 , System.Taffybar.Widget.SNITray.PrioritizedCollapsible                  , System.Taffybar.Widget.SimpleClock                  , System.Taffybar.Widget.SimpleCommandButton                  , System.Taffybar.Widget.Systemd                  , System.Taffybar.Widget.Temperature+                 , System.Taffybar.Widget.WakeupDebug                  , 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.Workspaces.Hyprland                  , System.Taffybar.Widget.Windows                  , System.Taffybar.Widget.Workspaces+                 , System.Taffybar.Widget.Workspaces.Config+                 , System.Taffybar.Widget.Workspaces.Common+                 , System.Taffybar.Widget.Workspaces.EWMH+                 , System.Taffybar.Widget.Workspaces.EWMH.Compat+                 , System.Taffybar.Widget.Workspaces.X11+                 , System.Taffybar.Widget.Workspaces.Hyprland.Compat+                 , System.Taffybar.Widget.Workspaces.Channel                  , System.Taffybar.Widget.Workspaces.Shared                  , System.Taffybar.Widget.WirePlumber                  , System.Taffybar.Widget.Wlsunset@@ -229,6 +247,7 @@     exposed-modules: System.Taffybar.Support.PagerHints    other-modules: Paths_taffybar+               , System.Taffybar.DBus.Client.Login1Manager                , System.Taffybar.DBus.Client.MPRIS2                , System.Taffybar.DBus.Client.NetworkManager                , System.Taffybar.DBus.Client.NetworkManagerAccessPoint@@ -240,7 +259,11 @@                , System.Taffybar.DBus.Client.UPower                , System.Taffybar.DBus.Client.UPowerDevice                , System.Taffybar.DBus.Client.Util+               , System.Taffybar.Information.Hyprland.API+               , System.Taffybar.Information.Hyprland.Types+               , System.Taffybar.Information.Wakeup.Manager                , System.Taffybar.Information.Udev+               , System.Taffybar.Window.FocusedMonitor    autogen-modules: Paths_taffybar @@ -250,12 +273,16 @@ executable taffybar   import: haskell, exe   build-depends: data-default+               , dhall                , directory+               , gi-gtk3                , hslogger                , optparse-applicative                , taffybar+               , text -  other-modules: Paths_taffybar+  other-modules: DhallConfig+               , Paths_taffybar   autogen-modules: Paths_taffybar    hs-source-dirs: app@@ -351,9 +378,13 @@                , System.Taffybar.AuthSpec                , System.Taffybar.AppearanceSpec                , System.Taffybar.ContextSpec+               , System.Taffybar.Information.CryptoSpec                , System.Taffybar.Information.X11DesktopInfoSpec+               , System.Taffybar.Information.WakeupSpec                , System.Taffybar.SimpleConfigSpec                , System.Taffybar.Widget.HyprlandWorkspacesSpec+               , System.Taffybar.Widget.Workspaces.ChannelSpec+               , System.Taffybar.Widget.WindowsSpec   build-depends: data-default                , bytestring                , directory
taffybar.css view
@@ -73,6 +73,37 @@ 	padding-bottom: 3px; } +.sni-tray-expand-toggle,+.sni-tray-edit-toggle,+.sni-tray-settings-toggle,+.sni-tray-overflow-indicator,+.sni-tray-priority-mode-toggle {+	background-color: rgba(255, 255, 255, 0.08);+	border: 1px solid rgba(255, 255, 255, 0.18);+	border-radius: 6px;+	padding-left: 4px;+	padding-right: 4px;+	margin-left: 3px;+}++.sni-tray-expand-toggle:hover,+.sni-tray-edit-toggle:hover,+.sni-tray-settings-toggle:hover {+	background-color: rgba(255, 255, 255, 0.15);+	border-color: rgba(255, 255, 255, 0.30);+}++.sni-tray-overflow-count-label {+	min-width: 12px;+}++.sni-tray-edit-toggle-active,+.sni-tray-priority-mode-toggle-active {+	background-color: rgba(120, 190, 130, 0.40);+	border-color: rgba(120, 190, 130, 0.90);+	border-radius: 4px;+}+ .window-icon-container.active { 	box-shadow: inset 0 -3px @white; }
+ test/data/appearance-ewmh-bar-levels.png view

binary file changed (absent → 2033 bytes)

test/data/appearance-test.css view
@@ -53,6 +53,21 @@   border-radius: 5px; } +.test-level2-left {+  background-color: #7a3a5a;+  border-radius: 5px;+}++.test-level2-center {+  background-color: #3a7a5a;+  border-radius: 5px;+}++.test-level2-right {+  background-color: #7a6a3a;+  border-radius: 5px;+}+ .test-pill {   background-color: rgba(255, 255, 255, 0.08);   color: #f0f0f0;
test/lib/System/Taffybar/Test/DBusSpec.hs view
@@ -1,40 +1,45 @@ module System.Taffybar.Test.DBusSpec-  ( spec-  -- * Start private D-Busses for testing-  , withTestDBus-  , withTestDBusInDir-  , Bus(..)-  , withDBusDaemon_-  , withConnectDBusDaemon-  , withConnectDBusDaemon'-  -- ** Using the private D-Bus-  , setDBusEnv-  , withBusEnv-  -- ** @python-dbusmock@ Services-  , withPythonDBusMock-  , withTaffyMocks-  -- * Utils-  , withMatch-  , withClient-  ) where+  ( spec, +    -- * Start private D-Busses for testing+    withTestDBus,+    withTestDBusInDir,+    Bus (..),+    withDBusDaemon_,+    withConnectDBusDaemon,+    withConnectDBusDaemon',++    -- ** Using the private D-Bus+    setDBusEnv,+    withBusEnv,++    -- ** @python-dbusmock@ Services+    withPythonDBusMock,+    withTaffyMocks,++    -- * Utils+    withMatch,+    withClient,+  )+where+ import Control.Monad (forM_, void, when) import Control.Monad.IO.Unlift (MonadUnliftIO (..))+import DBus+import DBus.Client import Data.Function ((&))+import Data.Int (Int64) import Data.Map qualified as Map import Data.Maybe (fromMaybe)-import Data.Int (Int64)-import DBus-import DBus.Client-import Test.Hspec-import System.FilePath ((</>), (<.>), takeFileName)-import System.IO (hGetLine, hClose)+import System.FilePath (takeFileName, (<.>), (</>))+import System.IO (hClose, hGetLine) import System.Process.Typed-import System.Taffybar.Test.UtilSpec (withSetEnv, logSetup, specLog, withService, getSpecLogPriority, setServiceDefaults, laxTimeout')-import UnliftIO.Directory (makeAbsolute, createDirectoryIfMissing, createFileLink)-import UnliftIO.Temporary (withSystemTempDirectory)-import UnliftIO.Exception (bracket, throwString, finally, throwIO)+import System.Taffybar.Test.UtilSpec (getSpecLogPriority, laxTimeout', logSetup, setServiceDefaults, specLog, withService, withSetEnv)+import Test.Hspec+import UnliftIO.Directory (createDirectoryIfMissing, createFileLink, makeAbsolute)+import UnliftIO.Exception (bracket, finally, throwIO, throwString) import UnliftIO.MVar qualified as MV+import UnliftIO.Temporary (withSystemTempDirectory)  -- | Uses 'withDBusDaemon_' to provide both a private session bus and -- a private system bus while the given action is running.@@ -48,12 +53,14 @@ -- -- __Note__: Environment variables are global to the process, so be -- careful using this with 'parallel' unit tests.-withTestDBusInDir-  :: FilePath -- ^ Directory for config files and sockets.-  -> IO a -> IO a-withTestDBusInDir socketDir-  = withDBusDaemon_ System socketDir-  . withDBusDaemon_ Session socketDir+withTestDBusInDir ::+  -- | Directory for config files and sockets.+  FilePath ->+  IO a ->+  IO a+withTestDBusInDir socketDir =+  withDBusDaemon_ System socketDir+    . withDBusDaemon_ Session socketDir  -- | Same as 'withTestDBusInDir', except that it creates and removes the -- temporary directory for you.@@ -92,7 +99,8 @@      makeDBusDaemon configFile logLevel =       proc "dbus-daemon" ["--print-address", "--config-file", configFile]-        & setServiceDefaults logLevel & setStdout createPipe+        & setServiceDefaults logLevel+        & setStdout createPipe  -- | Start a D-Bus daemon of the given 'Bus' type, and set the -- corresponding environment variable while running the given action.@@ -108,10 +116,10 @@ withConnectDBusDaemon' :: Bus -> FilePath -> (Address -> Client -> IO a) -> IO a withConnectDBusDaemon' bus socketDir action =   withDBusDaemon bus socketDir $ \addr ->-  withClient addr $ \c -> action addr c+    withClient addr $ \c -> action addr c  withConnectDBusDaemon :: Bus -> FilePath -> (Client -> IO a) -> IO a-withConnectDBusDaemon bus socketDir = withConnectDBusDaemon' bus socketDir. const+withConnectDBusDaemon bus socketDir = withConnectDBusDaemon' bus socketDir . const  setupBusDir :: Bus -> FilePath -> IO FilePath setupBusDir bus socketDir = do@@ -124,20 +132,21 @@   -- createFileLink "/nix/store/ygd600kkc1h3p5dgw9vjm5xnfci43v0k-upower-1.90.4/share/dbus-1/system-services/org.freedesktop.UPower.service" (serviceDir </> "org.freedesktop.UPower.service")    addr <- mkAddress (socketDir </> busName bus <.> "socket")-  writeFile configFile $ unlines-    [ "<!DOCTYPE busconfig PUBLIC \"-//freedesktop//DTD D-Bus Bus Configuration 1.0//EN\" \"http://www.freedesktop.org/standards/dbus/1.0/busconfig.dtd\">"-    , "<busconfig>"-    , "  <type>" ++ busName bus ++ "</type>"-    , "  <keep_umask/>"-    , "  <listen>" ++ addr ++ "</listen>"-    , "  <servicedir>" ++ serviceDir ++ "</servicedir>"-    , "  <policy context=\"default\">"-    , "    <allow send_destination=\"*\" eavesdrop=\"true\"/>"-    , "    <allow eavesdrop=\"true\"/>"-    , "    <allow own=\"*\"/>"-    , "  </policy>"-    , "</busconfig>"-    ]+  writeFile configFile $+    unlines+      [ "<!DOCTYPE busconfig PUBLIC \"-//freedesktop//DTD D-Bus Bus Configuration 1.0//EN\" \"http://www.freedesktop.org/standards/dbus/1.0/busconfig.dtd\">",+        "<busconfig>",+        "  <type>" ++ busName bus ++ "</type>",+        "  <keep_umask/>",+        "  <listen>" ++ addr ++ "</listen>",+        "  <servicedir>" ++ serviceDir ++ "</servicedir>",+        "  <policy context=\"default\">",+        "    <allow send_destination=\"*\" eavesdrop=\"true\"/>",+        "    <allow eavesdrop=\"true\"/>",+        "    <allow own=\"*\"/>",+        "  </policy>",+        "</busconfig>"+      ]   pure configFile  mkAddress :: FilePath -> IO String@@ -159,11 +168,12 @@ withClient :: Address -> (Client -> IO a) -> IO a withClient addr = bracket (connect addr) disconnect -withMatch :: MonadUnliftIO m => Client -> MatchRule -> (Signal -> m ()) -> m a -> m a-withMatch client rule cb action = withRunInIO $ \run -> bracket-  (addMatch client rule (run . cb))-  (removeMatch client)-  (const $ run action)+withMatch :: (MonadUnliftIO m) => Client -> MatchRule -> (Signal -> m ()) -> m a -> m a+withMatch client rule cb action = withRunInIO $ \run ->+  bracket+    (addMatch client rule (run . cb))+    (removeMatch client)+    (const $ run action)  makeBusNameWaiter :: Client -> (BusName -> Bool) -> IO (IO ()) makeBusNameWaiter client p = do@@ -176,10 +186,12 @@   MV.putMVar h =<< addMatch client rule cb   pure (MV.takeMVar v)   where-    rule = matchAny { matchMember = Just "NameOwnerChanged"-                    , matchInterface = Just "org.freedesktop.DBus"-                    , matchSender = Just "org.freedesktop.DBus"-                    }+    rule =+      matchAny+        { matchMember = Just "NameOwnerChanged",+          matchInterface = Just "org.freedesktop.DBus",+          matchSender = Just "org.freedesktop.DBus"+        }     isMatch = maybe False p . fromVariant     isOwned = not . null . fromMaybe ("" :: String) . fromVariant @@ -189,39 +201,54 @@  -- | Starts up [@python-dbusmock@](https://martinpitt.github.io/python-dbusmock/). -- The given action will be run once the mock is ready.-withPythonDBusMock-  :: Bus -- ^ @python-dbusmock@ wants to know which bus.-  -> (Address, Client) -- ^ Connection to the 'Bus'-  -> BusName -- ^ Name of mock service.-  -> ObjectPath -- ^ Path of mock service.-  -> InterfaceName -- ^ Interface of mock service.-  -> IO a -> IO a+withPythonDBusMock ::+  -- | @python-dbusmock@ wants to know which bus.+  Bus ->+  -- | Connection to the 'Bus'+  (Address, Client) ->+  -- | Name of mock service.+  BusName ->+  -- | Path of mock service.+  ObjectPath ->+  -- | Interface of mock service.+  InterfaceName ->+  IO a ->+  IO a withPythonDBusMock bus (addr, client) name path interface action = do   waiter <- makeBusNameWaiter client (== name)   logLevel <- getSpecLogPriority-  withService (cfg & setServiceDefaults logLevel) $ const $-    waiter *> action+  withService (cfg & setServiceDefaults logLevel) $+    const $+      waiter *> action   where     cfg = proc "python3" args & setDBusEnv bus addr-    args = ["-m", "dbusmock", busArg bus-           , formatBusName name-           , formatObjectPath path-           , formatInterfaceName interface]+    args =+      [ "-m",+        "dbusmock",+        busArg bus,+        formatBusName name,+        formatObjectPath path,+        formatInterfaceName interface+      ]  mockAddTemplate :: Client -> BusName -> ObjectPath -> String -> [(String, Variant)] -> IO () mockAddTemplate client dest path templ params = do-  void $ call_ client (addTemplate templ params) { methodCallDestination = Just dest }+  void $ call_ client (addTemplate templ params) {methodCallDestination = Just dest}   where-    addTemplate t p = (methodCall path "org.freedesktop.DBus.Mock" "AddTemplate")-      { methodCallBody = [toVariant t, toVariant (Map.fromList p)] }+    addTemplate t p =+      (methodCall path "org.freedesktop.DBus.Mock" "AddTemplate")+        { methodCallBody = [toVariant t, toVariant (Map.fromList p)]+        }  ------------------------------------------------------------------------  upName :: BusName upName = "org.freedesktop.UPower"+ upPath, upDisplayDevicePath :: ObjectPath upPath = "/org/freedesktop/UPower" upDisplayDevicePath = objectPath_ (formatObjectPath upPath ++ "/devices/DisplayDevice")+ upIface, upDeviceIface :: InterfaceName upIface = "org.freedesktop.UPower" upDeviceIface = interfaceName_ (formatInterfaceName upIface ++ ".Device")@@ -233,9 +260,9 @@ mockUPower client = do   -- oh dbus, so ugly.   mockAddTemplate client upName upPath "upower" [("OnBattery", toVariant True)]-  void $ call_ client (methodCall upPath "org.freedesktop.DBus.Mock" "AddAC") { methodCallBody = map toVariant ["mock_AC" :: String, "Mock AC"], methodCallDestination = Just upName }-  void $ call_ client (methodCall upPath "org.freedesktop.DBus.Mock" "AddChargingBattery") { methodCallBody = map toVariant ["mock_BAT" :: String, "Mock Battery"] ++ [toVariant (30.0 :: Double), toVariant (1200 :: Int64)] , methodCallDestination = Just upName }-  void $ setPropertyValue client (methodCall upDisplayDevicePath upDeviceIface "IconName") { methodCallDestination = Just upName } mockIconName+  void $ call_ client (methodCall upPath "org.freedesktop.DBus.Mock" "AddAC") {methodCallBody = map toVariant ["mock_AC" :: String, "Mock AC"], methodCallDestination = Just upName}+  void $ call_ client (methodCall upPath "org.freedesktop.DBus.Mock" "AddChargingBattery") {methodCallBody = map toVariant ["mock_BAT" :: String, "Mock Battery"] ++ [toVariant (30.0 :: Double), toVariant (1200 :: Int64)], methodCallDestination = Just upName}+  void $ setPropertyValue client (methodCall upDisplayDevicePath upDeviceIface "IconName") {methodCallDestination = Just upName} mockIconName  withTaffyMocks :: IO a -> IO a withTaffyMocks action = do@@ -263,16 +290,18 @@    forM_ [System] $ \bus ->     aroundWith (flip (withConnectDBusDaemon' bus) . curry) $-    describe ("python-dbusmock " ++ show bus ++ " services") $ do-      -- 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"+      describe ("python-dbusmock " ++ show bus ++ " services") $ do+        -- 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" -      it "UPower" $ \_ -> pendingWith "python-dbusmock fails to start in CI"+        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"]  ping :: MethodCall-ping = (methodCall "/org/freedesktop/DBus" "org.freedesktop.DBus.Peer" "Ping")-  { methodCallDestination = Just "org.freedesktop.DBus" }+ping =+  (methodCall "/org/freedesktop/DBus" "org.freedesktop.DBus.Peer" "Ping")+    { methodCallDestination = Just "org.freedesktop.DBus"+    }
test/lib/System/Taffybar/Test/UtilSpec.hs view
@@ -1,49 +1,57 @@+{-# LANGUAGE CPP #-} {-# LANGUAGE DerivingVia #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ViewPatterns #-}-{-# LANGUAGE CPP #-}  module System.Taffybar.Test.UtilSpec-  ( spec-  -- * Mock commands-  , withMockCommand-  , writeScript-  -- * Environment setup-  , withEnv-  , withSetEnv-  , prependPath-  -- ** Running subprocesses-  , withService-  , setStdoutCond-  , setStderrCond-  , setServiceDefaults-  , makeServiceDefaults-  -- * Concurrency-  , listLiveThreads-  , diffLiveThreads-  -- * OS Resources-  , listFds-  -- * Other test helpers-  , tryIOMaybe-  , laxTimeout-  , laxTimeout'-  , DodgyEq(..)-  -- ** Logging for tests-  , logSetup-  , specLogSetup-  , specLogSetupPrio-  , specLog-  , specLogAt-  , getSpecLogPriority-  , Priority(..)-  ) where+  ( spec, +    -- * Mock commands+    withMockCommand,+    writeScript,++    -- * Environment setup+    withEnv,+    withSetEnv,+    prependPath,++    -- ** Running subprocesses+    withService,+    setStdoutCond,+    setStderrCond,+    setServiceDefaults,+    makeServiceDefaults,++    -- * Concurrency+    listLiveThreads,+    diffLiveThreads,++    -- * OS Resources+    listFds,++    -- * Other test helpers+    tryIOMaybe,+    laxTimeout,+    laxTimeout',+    DodgyEq (..),++    -- ** Logging for tests+    logSetup,+    specLogSetup,+    specLogSetupPrio,+    specLog,+    specLogAt,+    getSpecLogPriority,+    Priority (..),+  )+where+ import Control.Applicative ((<|>)) import Control.Monad (guard, join, void, (<=<)) import Control.Monad.IO.Unlift import Data.Bifunctor (second)-import qualified Data.ByteString.Char8 as B8+import Data.ByteString.Char8 qualified as B8 import Data.Either.Extra (eitherToMaybe, isLeft) import Data.Function (on, (&)) import Data.List (deleteFirstsBy, uncons)@@ -53,35 +61,37 @@ #else import GHC.Conc.Sync (ThreadId(..), ThreadStatus(..)) #endif-import System.Exit (ExitCode(..))+import System.Exit (ExitCode (..)) import System.FilePath (isRelative, takeFileName, (</>))-import System.IO (Handle, BufferMode(..), hSetBuffering, stderr, hClose)-import System.Log.Logger (Priority(..), updateGlobalLogger, setLevel, logM, getLevel, getLogger, removeHandler, setHandlers)-import System.Log.Handler.Simple (GenericHandler(..))-import System.Process.Typed (readProcess, proc, ProcessConfig, Process, withProcessTerm, waitExitCode, ExitCodeException (..), setStdin, nullStream, setStdout, setStderr, StreamSpec, setCloseFds, inherit, createPipe, getStdin)+import System.IO (BufferMode (..), Handle, hClose, hSetBuffering, stderr)+import System.Log.Handler.Simple (GenericHandler (..))+import System.Log.Logger (Priority (..), getLevel, getLogger, logM, removeHandler, setHandlers, setLevel, updateGlobalLogger) import System.Posix.Files (readSymbolicLink)+import System.Process.Typed (ExitCodeException (..), Process, ProcessConfig, StreamSpec, createPipe, getStdin, inherit, nullStream, proc, readProcess, setCloseFds, setStderr, setStdin, setStdout, waitExitCode, withProcessTerm)+import System.Taffybar.LogFormatter (taffyLogHandler) import Test.Hspec import Text.Printf (printf) import Text.Read (readMaybe) import UnliftIO.Async (race) import UnliftIO.Concurrent (forkFinally, threadDelay)-import UnliftIO.Directory (Permissions (..), findExecutable, getPermissions, setPermissions, listDirectory)+import UnliftIO.Directory (Permissions (..), findExecutable, getPermissions, listDirectory, setPermissions) import UnliftIO.Environment (lookupEnv, setEnv, unsetEnv)-import UnliftIO.Exception (bracket, evaluateDeep, throwIO, throwString, tryIO, StringException (..), try)-import qualified UnliftIO.MVar as MV+import UnliftIO.Exception (StringException (..), bracket, evaluateDeep, throwIO, throwString, try, tryIO)+import UnliftIO.MVar qualified as MV import UnliftIO.Temporary (withSystemTempDirectory) import UnliftIO.Timeout (timeout) -import System.Taffybar.LogFormatter (taffyLogHandler)- -- | Run the given 'IO' action with the @PATH@ environment variable -- set up so that executing the given command name will run a -- script.-withMockCommand-  :: FilePath -- ^ Name of command - should not contain slashes-  -> String -- ^ Contents of script-  -> IO a -- ^ Action to run with command available in search path-  -> IO a+withMockCommand ::+  -- | Name of command - should not contain slashes+  FilePath ->+  -- | Contents of script+  String ->+  -- | Action to run with command available in search path+  IO a ->+  IO a withMockCommand name content action =   withSystemTempDirectory "specutil" $ \dir -> do     writeScript (dir </> takeFileName name) content@@ -94,7 +104,7 @@   content' <- patchShebangs content   writeFile scriptFile content'   p <- getPermissions scriptFile-  setPermissions scriptFile (p { executable = True })+  setPermissions scriptFile (p {executable = True})  -- | Given the text of a shell script, this replaces any relative path -- in the shebang with an absolute path, according to the current@@ -112,7 +122,7 @@     takeRelativeFileName :: FilePath -> Maybe FilePath     takeRelativeFileName fp = guard (isRelative fp) >> pure (takeFileName fp) -patchShebangs' :: Applicative m => (FilePath -> m (Maybe FilePath)) -> String -> m String+patchShebangs' :: (Applicative m) => (FilePath -> m (Maybe FilePath)) -> String -> m String patchShebangs' replaceExe script = case parseInterpreter script of   Just (interpreter, rest) -> do     let unparse exe = "#! " ++ exe ++ rest@@ -123,13 +133,12 @@ parseInterpreter (lines -> content) = do   (header, rest) <- uncons content   (interpreter, args) <- parseShebang header-  pure (interpreter, unlines (args:rest))-+  pure (interpreter, unlines (args : rest))   where     parseShebang :: String -> Maybe (String, String)-    parseShebang ('#':'!':(findInterpreter -> shebang)) =-      let catArgs args = unwords ("":args)-      in second catArgs <$> shebang+    parseShebang ('#' : '!' : (findInterpreter -> shebang)) =+      let catArgs args = unwords ("" : args)+       in second catArgs <$> shebang     parseShebang _ = Nothing      findInterpreter = uncons . dropWhile ((== "env") . takeFileName) . words@@ -160,12 +169,12 @@ prependPath :: FilePath -> Maybe String -> Maybe String prependPath p = Just . (++ ":/usr/bin") . (p ++) . maybe "" (":" ++) -listFds :: MonadIO m => m [(Int, FilePath)]+listFds :: (MonadIO m) => m [(Int, FilePath)] listFds = catMaybes <$> (listDirectory fdPath >>= mapM readEntry)   where     fdPath = "/proc/self/fd" -    readEntry :: MonadIO m => FilePath -> m (Maybe (Int, FilePath))+    readEntry :: (MonadIO m) => FilePath -> m (Maybe (Int, FilePath))     readEntry fd = do       t <- liftIO $ tryIOMaybe $ readSymbolicLink (fdPath </> fd)       pure $ (,) <$> readMaybe fd <*> t@@ -182,16 +191,17 @@ listLiveThreads = pure [] #endif -diffLiveThreads :: Eq a => [(a, b)] -> [(a, b)] -> [(a, b)]+diffLiveThreads :: (Eq a) => [(a, b)] -> [(a, b)] -> [(a, b)] diffLiveThreads = deleteFirstsBy ((==) `on` fst) -tryIOMaybe :: MonadUnliftIO m => m a -> m (Maybe a)+tryIOMaybe :: (MonadUnliftIO m) => m a -> m (Maybe a) tryIOMaybe = fmap eitherToMaybe . tryIO  laxTimeout' :: (HasCallStack, MonadUnliftIO m) => Int -> m a -> m a-laxTimeout' n action = laxTimeout n action >>= \case-  Just a -> pure a-  Nothing -> expectationFailure' $ printf "Timed out after %dusec" n+laxTimeout' n action =+  laxTimeout n action >>= \case+    Just a -> pure a+    Nothing -> expectationFailure' $ printf "Timed out after %dusec" n  expectationFailure' :: (HasCallStack, MonadIO m) => String -> m a expectationFailure' msg = liftIO (expectationFailure msg) >> throwString msg@@ -203,8 +213,8 @@   join <$> timeout n (MV.takeMVar result >>= either throwIO pure)  -- | A wrapper to provide 'Eq' for types which only have 'Show'.-newtype DodgyEq a = DodgyEq { unDodgyEq :: a }-  deriving Show via (DodgyEq a)+newtype DodgyEq a = DodgyEq {unDodgyEq :: a}+  deriving (Show) via (DodgyEq a)  instance Eq (DodgyEq a) where   a == b = show a == show b@@ -216,15 +226,15 @@ specLoggerName = "Test"  -- | Log a test message.-specLog :: MonadIO m => String -> m ()+specLog :: (MonadIO m) => String -> m () specLog = specLogAt INFO  -- | Log a test message at the given level.-specLogAt :: MonadIO m => Priority -> String -> m ()+specLogAt :: (MonadIO m) => Priority -> String -> m () specLogAt level = liftIO . logM specLoggerName level  -- | Setup logging before running the specs.-logSetup :: HasCallStack => SpecWith a -> SpecWith a+logSetup :: (HasCallStack) => SpecWith a -> SpecWith a logSetup = beforeAll_ specLogSetup  -- | Get log levels from environment variables and set up formatters.@@ -246,16 +256,17 @@  -- | A plain looking log handler, to contrast with 'taffyLogFormatter'. specLogHandler :: GenericHandler Handle-specLogHandler = GenericHandler-  { priority = DEBUG-  , formatter =  \_ (level, msg) _name -> return (show level ++ ": " ++ msg)-  , privData = stderr-  , writeFunc = \h -> B8.hPutStrLn h . B8.pack <=< evaluateDeep-  , closeFunc = \_ -> return ()-  }+specLogHandler =+  GenericHandler+    { priority = DEBUG,+      formatter = \_ (level, msg) _name -> return (show level ++ ": " ++ msg),+      privData = stderr,+      writeFunc = \h -> B8.hPutStrLn h . B8.pack <=< evaluateDeep,+      closeFunc = \_ -> return ()+    }  -- | Find out the configured log level for specs.-getSpecLogPriority :: MonadIO m => m Priority+getSpecLogPriority :: (MonadIO m) => m Priority getSpecLogPriority = fromMaybe WARNING . getLevel <$> liftIO (getLogger specLoggerName)  -- | Converts an environment variable value to a 'Priority'.@@ -266,15 +277,16 @@     toPriority s = readMaybe s <|> fmap fromInt (readMaybe s)      fromInt :: Int -> Priority-    fromInt n | n >= 2 = DEBUG-              | n <= 0 = WARNING-              | otherwise = INFO+    fromInt n+      | n >= 2 = DEBUG+      | n <= 0 = WARNING+      | otherwise = INFO  -- | Like 'withProcessTerm_', except that if the process exits -- for -- whatever reason -- before the action completes, then it's an -- error. It will immediately cancel the action and throw an -- 'ExitCodeException'.-withService :: MonadUnliftIO m => ProcessConfig stdin stdout stderr -> (Process stdin stdout stderr -> m a) -> m a+withService :: (MonadUnliftIO m) => ProcessConfig stdin stdout stderr -> (Process stdin stdout stderr -> m a) -> m a withService cfg action = withProcessTerm cfg $ \p -> do   either throwEarlyExitException pure =<< race (waitExitCode p) (action p)   where@@ -295,21 +307,23 @@   flip setServiceDefaults (proc prog args) <$> getSpecLogPriority  setServiceDefaults :: Priority -> ProcessConfig i o e -> ProcessConfig () () ()-setServiceDefaults logLevel = setCloseFds True-  . setStdin nullStream-  . setStdoutCond logLevel-  . setStderrCond logLevel+setServiceDefaults logLevel =+  setCloseFds True+    . setStdin nullStream+    . setStdoutCond logLevel+    . setStderrCond logLevel  ------------------------------------------------------------------------  spec :: Spec spec = do-  it "withMockCommand" $ example $-    withMockCommand "blah" "#!/usr/bin/env bash\necho hello \"$@\"\n" $ do-      (code, out, err) <- readProcess (proc "blah" ["arstd"])-      code `shouldBe` ExitSuccess-      out `shouldBe` "hello arstd\n"-      err `shouldBe` ""+  it "withMockCommand" $+    example $+      withMockCommand "blah" "#!/usr/bin/env bash\necho hello \"$@\"\n" $ do+        (code, out, err) <- readProcess (proc "blah" ["arstd"])+        code `shouldBe` ExitSuccess+        out `shouldBe` "hello arstd\n"+        err `shouldBe` ""    it "laxTimeout" $ example $ do     let t = 50_000@@ -317,23 +331,28 @@    describe "withService" $ around_ (laxTimeout' 100_000) $ do     let wait = const $ threadDelay maxBound-    it "normal" $ example $-      withService (proc "sleep" ["60"]) (const $ pure ())-        `shouldReturn` ()-    it "exc" $ example $-      withService (proc "sleep" ["60"]) (const $ throwString "hello")-        `shouldThrow` \(StringException msg _) -> msg == "hello"-    it "early exit" $ example $-      withService "true" wait `shouldThrow`-        \exc -> eceExitCode exc == ExitSuccess-    it "manual exit" $ example $-      withService-        (proc "cat" [] & setStdin createPipe)-        (\p -> hClose (getStdin p) >> wait p)-        `shouldThrow` \exc -> eceExitCode exc == ExitSuccess-    it "failure" $ example $-      withService "false" wait `shouldThrow`-        \exc -> eceExitCode exc /= ExitSuccess+    it "normal" $+      example $+        withService (proc "sleep" ["60"]) (const $ pure ())+          `shouldReturn` ()+    it "exc" $+      example $+        withService (proc "sleep" ["60"]) (const $ throwString "hello")+          `shouldThrow` \(StringException msg _) -> msg == "hello"+    it "early exit" $+      example $+        withService "true" wait+          `shouldThrow` \exc -> eceExitCode exc == ExitSuccess+    it "manual exit" $+      example $+        withService+          (proc "cat" [] & setStdin createPipe)+          (\p -> hClose (getStdin p) >> wait p)+          `shouldThrow` \exc -> eceExitCode exc == ExitSuccess+    it "failure" $+      example $+        withService "false" wait+          `shouldThrow` \exc -> eceExitCode exc /= ExitSuccess     it "error message" $ example $ do       res <- try (withService (proc "false" ["arg1", "arg2"]) wait)       res `shouldSatisfy` isLeft
test/lib/System/Taffybar/Test/XvfbSpec.hs view
@@ -2,72 +2,76 @@ {-# LANGUAGE OverloadedRecordDot #-}  module System.Taffybar.Test.XvfbSpec-  ( spec-  -- * Virtual X11 server for unit testing-  , withXvfb-  , withXdummy-  , displayArg-  , displayEnv-  , setDefaultDisplay_-  , setDefaultDisplay-  -- ** Randr-  , withRandrSetup-  , randrSetup-  , randrTeardown-  -- *** RANDR config-  , RRSetup(..)-  , RROutput(..)-  , RROutputSettings(..)-  , RRExistingMode(..)-  , RRMode(..)-  , RRModeName(..)-  , RRModeLine(..)-  , RRPosition(..)-  , RRRotation(..)-  , ListIndex(..)-  -- ** Clients-  , withXTerm-  -- * Wrappers around @xprop@ command-  , XPropName(..)-  , xpropName-  , XPropValue(..)-  , xpropValue-  , xpropGet-  , xpropSet-  , xpropRemove-  , xpropList-  ) where+  ( spec, +    -- * Virtual X11 server for unit testing+    withXvfb,+    withXdummy,+    displayArg,+    displayEnv,+    setDefaultDisplay_,+    setDefaultDisplay,++    -- ** Randr+    withRandrSetup,+    randrSetup,+    randrTeardown,++    -- *** RANDR config+    RRSetup (..),+    RROutput (..),+    RROutputSettings (..),+    RRExistingMode (..),+    RRMode (..),+    RRModeName (..),+    RRModeLine (..),+    RRPosition (..),+    RRRotation (..),+    ListIndex (..),++    -- ** Clients+    withXTerm,++    -- * Wrappers around @xprop@ command+    XPropName (..),+    xpropName,+    XPropValue (..),+    xpropValue,+    xpropGet,+    xpropSet,+    xpropRemove,+    xpropList,+  )+where+ import Control.Applicative ((<|>))-import Control.Monad ((<=<), void, forM_, guard)-import Control.Monad.IO.Class (MonadIO(..))-import Data.Attoparsec.Text.Lazy hiding (takeWhile, take)-import qualified Data.Attoparsec.Text.Lazy as P-import qualified Data.ByteString.Lazy.Char8 as BL+import Control.Monad (forM_, guard, void, (<=<))+import Control.Monad.IO.Class (MonadIO (..))+import Data.Attoparsec.Text.Lazy hiding (take, takeWhile)+import Data.Attoparsec.Text.Lazy qualified as P import Data.Bifunctor (bimap, second)+import Data.ByteString.Lazy.Char8 qualified as BL import Data.Char (isPrint, isSpace) import Data.Coerce (coerce)-import Data.Default (Default(..))-import Data.List (findIndex, uncons, dropWhileEnd)-import Data.String (IsString(..))-import Data.Text.Lazy.Encoding (decodeUtf8')-import qualified Data.Text.Lazy as TL-import qualified Data.Text as T+import Data.Default (Default (..)) import Data.Function ((&))-import Data.Maybe (maybeToList, mapMaybe, isJust, isNothing)+import Data.List (dropWhileEnd, findIndex, uncons)+import Data.Maybe (isJust, isNothing, mapMaybe, maybeToList)+import Data.String (IsString (..))+import Data.Text qualified as T+import Data.Text.Lazy qualified as TL+import Data.Text.Lazy.Encoding (decodeUtf8') import GHC.Generics (Generic)-import System.Process.Typed import System.IO (Handle, hClose, hGetLine)-import Text.Read (readMaybe)-import UnliftIO.Concurrent (threadDelay)-import UnliftIO.Exception (fromEitherM, throwString, bracket_)-+import System.Process.Typed+import System.Taffybar.Information.X11DesktopInfo (DisplayName (..))+import System.Taffybar.Test.UtilSpec (Priority (..), getSpecLogPriority, logSetup, setServiceDefaults, setStderrCond, specLog, specLogAt, withService, withSetEnv) import Test.Hspec import Test.QuickCheck import Test.QuickCheck.Monadic--import System.Taffybar.Test.UtilSpec (withSetEnv, logSetup, specLog, specLogAt, getSpecLogPriority, Priority(..), setStderrCond, setServiceDefaults, withService)-import System.Taffybar.Information.X11DesktopInfo (DisplayName(..))+import Text.Read (readMaybe)+import UnliftIO.Concurrent (threadDelay)+import UnliftIO.Exception (bracket_, fromEitherM, throwString)  ------------------------------------------------------------------------ @@ -90,27 +94,28 @@  ------------------------------------------------------------------------ -newtype XPropName = XPropName { unXPropName :: String }+newtype XPropName = XPropName {unXPropName :: String}   deriving (Show, Read, Eq, Ord, Generic)  -- | Construct a valid 'XPropName' from a 'String'. Any names which -- cause problems when parsing @xprop@ output are not allowed. xpropName :: String -> Maybe XPropName-xpropName n@(c:cs)-  | c `elem` propNameStartChars &&-    all isPrint cs &&-    not (any propNameBadChars cs) = Just (XPropName n)+xpropName n@(c : cs)+  | c `elem` propNameStartChars+      && all isPrint cs+      && not (any propNameBadChars cs) =+      Just (XPropName n) xpropName _ = Nothing  -- | List of characters which are valid first characters of a property -- name. propNameStartChars :: [Char]-propNameStartChars = ['a'..'z'] <> ['A'..'Z'] <> ['_']+propNameStartChars = ['a' .. 'z'] <> ['A' .. 'Z'] <> ['_']  propNameBadChars :: Char -> Bool propNameBadChars c = isSpace c || c `elem` ['(', ')', ':'] -newtype XPropValue = XPropValue { unXPropValue :: String }+newtype XPropValue = XPropValue {unXPropValue :: String}   deriving (Show, Read, Eq, Ord, Semigroup, Monoid, Generic)  -- | Construct a valid 'XPropValue' from a 'String'. Any values which@@ -121,7 +126,7 @@ -- | Predicate on characters which cause difficulties when parsing -- @xprop@ output. propValueBadChars :: Char -> Bool-propValueBadChars c = c `elem` ['"','\n','\r'] || not (isPrint c)+propValueBadChars c = c `elem` ['"', '\n', '\r'] || not (isPrint c)  ------------------------------------------------------------------------ @@ -136,7 +141,7 @@   either throwString pure $ parseXProp1 p txt   where     cfg = xpropProc d ["-root", unXPropName p]-    decoded :: MonadIO m => m BL.ByteString -> m TL.Text+    decoded :: (MonadIO m) => m BL.ByteString -> m TL.Text     decoded = fromEitherM . fmap decodeUtf8'  parseXProp1 :: XPropName -> TL.Text -> Either String [XPropValue]@@ -175,7 +180,7 @@     parsePropValue "UTF8_STRING" = quotedString     parsePropValue t = fail $ "Can't parse format \"" ++ T.unpack t ++ "\"" -xpropSet :: MonadIO m => DisplayName -> XPropName -> XPropValue -> m ()+xpropSet :: (MonadIO m) => DisplayName -> XPropName -> XPropValue -> m () xpropSet d (XPropName p) (XPropValue v) = liftIO $ do   specLog $ "xpropSet running: " ++ show cfg   runProcess_ cfg@@ -183,14 +188,14 @@     cfg = xpropProc d args     args = ["-root", "-format", p, "8u", "-set", p, v] -xpropRemove :: MonadIO m => DisplayName -> XPropName -> m ()+xpropRemove :: (MonadIO m) => DisplayName -> XPropName -> m () xpropRemove d p = do   specLog $ "xpropRemove running: " ++ show cfg   runProcess_ cfg   where     cfg = xpropProc d ["-root", "-remove", unXPropName p] -xpropList :: MonadIO m => DisplayName -> m ()+xpropList :: (MonadIO m) => DisplayName -> m () xpropList d = liftIO $ do   specLog $ "xpropList running: " ++ show cfg   runProcess_ cfg@@ -228,9 +233,10 @@     action d   where     args' = displayArgMaybe ++ ["-displayfd", "1", "-terminate", "60"] ++ args-    makeXvfb logLevel = proc prog args'-      & setServiceDefaults logLevel-      & setStdout createPipe+    makeXvfb logLevel =+      proc prog args'+        & setServiceDefaults logLevel+        & setStdout createPipe      displayArgMaybe = maybeToList (fmap displaySpec display) @@ -257,13 +263,13 @@  -- | Adds a guiding phantom type annotation for indices into lists. -- fixme: zipper rather than indices-newtype ListIndex a = ListIndex { unListIndex :: Int }+newtype ListIndex a = ListIndex {unListIndex :: Int}   deriving (Show, Read, Eq, Ord, Enum, Num, Real, Integral, Generic)  enumerate :: [a] -> [(ListIndex a, a)]-enumerate = zip [0..]+enumerate = zip [0 ..] -bounds' :: Integral n => (n, n) -> (ListIndex a, ListIndex a)+bounds' :: (Integral n) => (n, n) -> (ListIndex a, ListIndex a) bounds' = let f = ListIndex . fromIntegral in bimap f f  bounds :: [a] -> (ListIndex a, ListIndex a)@@ -281,36 +287,39 @@ ------------------------------------------------------------------------  data RRSetup = RRSetup-  { outputs :: [RROutput]-  , primary :: Maybe (ListIndex RROutput)-  , newModes :: [RRMode] -- unused by outputs-  } deriving (Show, Read, Eq, Generic)+  { outputs :: [RROutput],+    primary :: Maybe (ListIndex RROutput),+    newModes :: [RRMode] -- unused by outputs+  }+  deriving (Show, Read, Eq, Generic)  instance Default RRSetup where-  def = RRSetup { outputs = [def], primary = Just 0, newModes = [] }+  def = RRSetup {outputs = [def], primary = Just 0, newModes = []}  data RROutput = RROutput-  { mode :: Maybe RRExistingMode-  , settings :: RROutputSettings-  , position :: RRPosition-  } deriving (Show, Read, Eq, Generic)+  { mode :: Maybe RRExistingMode,+    settings :: RROutputSettings,+    position :: RRPosition+  }+  deriving (Show, Read, Eq, Generic)  instance Default RROutput where-  def = RROutput { mode = def, settings = def, position = def }+  def = RROutput {mode = def, settings = def, position = def}  rrOutputOff :: RROutput-rrOutputOff = def { settings = def { disabled = True } }+rrOutputOff = def {settings = def {disabled = True}}  data RROutputSettings = RROutputSettings-  { disabled :: Bool-  , rotate :: RRRotation-  } deriving (Show, Read, Eq, Generic)+  { disabled :: Bool,+    rotate :: RRRotation+  }+  deriving (Show, Read, Eq, Generic)  instance Default RROutputSettings where-  def = RROutputSettings { disabled = False, rotate = def }+  def = RROutputSettings {disabled = False, rotate = def}  -- | This is an index into 'modeLines'.-newtype RRExistingMode = RRExistingMode { unRRExistingMode :: ListIndex RRMode }+newtype RRExistingMode = RRExistingMode {unRRExistingMode :: ListIndex RRMode}   deriving (Show, Read, Eq, Ord, Enum, Generic)  instance Bounded RRExistingMode where@@ -321,9 +330,10 @@   def = minBound  data RRMode = RRMode-  { name :: RRModeName-  , modeLine :: RRModeLine-  } deriving (Show, Read, Eq, Generic)+  { name :: RRModeName,+    modeLine :: RRModeLine+  }+  deriving (Show, Read, Eq, Generic)  instance IsString RRMode where   fromString = uncurry RRMode . bimap (RRModeName . unquote) RRModeLine . split@@ -331,10 +341,10 @@       split = second (dropWhile isSpace) . break isSpace       unquote = takeWhile (/= '"') . dropWhile (== '"') -newtype RRModeName = RRModeName { unRRModeName :: String }+newtype RRModeName = RRModeName {unRRModeName :: String}   deriving (Show, Read, Eq, IsString, Generic) -newtype RRModeLine = RRModeLine { unRRModeLine :: String }+newtype RRModeLine = RRModeLine {unRRModeLine :: String}   deriving (Show, Read, Eq, IsString, Generic)  data RRPosition = SameAs | RightOf | LeftOf | Below | Above@@ -354,34 +364,34 @@ -- instances to generate new modelines. modeLines :: [RRMode] modeLines =-  [ "1280x1024 157.500 1280 1344 1504 1728 1024 1025 1028 1072 +HSync +VSync +preferred"-  , "1280x1024 135.000 1280 1296 1440 1688 1024 1025 1028 1066 +HSync +VSync"-  , "1280x1024 108.000 1280 1328 1440 1688 1024 1025 1028 1066 +HSync +VSync"-  , "1280x960 148.500 1280 1344 1504 1728 960 961 964 1011 +HSync +VSync"-  , "1280x960 108.000 1280 1376 1488 1800 960 961 964 1000 +HSync +VSync"-  , "1280x800 83.500 1280 1352 1480 1680 800 803 809 831 -HSync +VSync"-  , "1152x864 108.000 1152 1216 1344 1600 864 865 868 900 +HSync +VSync"-  , "1280x720 74.500 1280 1344 1472 1664 720 723 728 748 -HSync +VSync"-  , "1024x768 94.500 1024 1072 1168 1376 768 769 772 808 +HSync +VSync"-  , "1024x768 78.750 1024 1040 1136 1312 768 769 772 800 +HSync +VSync"-  , "1024x768 75.000 1024 1048 1184 1328 768 771 777 806 -HSync -VSync"-  , "1024x768 65.000 1024 1048 1184 1344 768 771 777 806 -HSync -VSync"-  , "1024x576 46.500 1024 1064 1160 1296 576 579 584 599 -HSync +VSync"-  , "832x624 57.284 832 864 928 1152 624 625 628 667 -HSync -VSync"-  , "960x540 40.750 960 992 1088 1216 540 543 548 562 -HSync +VSync"-  , "800x600 56.300 800 832 896 1048 600 601 604 631 +HSync +VSync"-  , "800x600 50.000 800 856 976 1040 600 637 643 666 +HSync +VSync"-  , "800x600 49.500 800 816 896 1056 600 601 604 625 +HSync +VSync"-  , "800x600 40.000 800 840 968 1056 600 601 605 628 +HSync +VSync"-  , "800x600 36.000 800 824 896 1024 600 601 603 625 +HSync +VSync"-  , "864x486 32.500 864 888 968 1072 486 489 494 506 -HSync +VSync"-  , "640x480 36.000 640 696 752 832 480 481 484 509 -HSync -VSync"-  , "640x480 31.500 640 656 720 840 480 481 484 500 -HSync -VSync"-  , "640x480 31.500 640 664 704 832 480 489 492 520 -HSync -VSync"-  , "640x480 25.175 640 656 752 800 480 490 492 525 -HSync -VSync"-  , "720x400 35.500 720 756 828 936 400 401 404 446 -HSync +VSync"-  , "640x400 31.500 640 672 736 832 400 401 404 445 -HSync +VSync"-  , "640x350 31.500 640 672 736 832 350 382 385 445 +HSync -VSync"+  [ "1280x1024 157.500 1280 1344 1504 1728 1024 1025 1028 1072 +HSync +VSync +preferred",+    "1280x1024 135.000 1280 1296 1440 1688 1024 1025 1028 1066 +HSync +VSync",+    "1280x1024 108.000 1280 1328 1440 1688 1024 1025 1028 1066 +HSync +VSync",+    "1280x960 148.500 1280 1344 1504 1728 960 961 964 1011 +HSync +VSync",+    "1280x960 108.000 1280 1376 1488 1800 960 961 964 1000 +HSync +VSync",+    "1280x800 83.500 1280 1352 1480 1680 800 803 809 831 -HSync +VSync",+    "1152x864 108.000 1152 1216 1344 1600 864 865 868 900 +HSync +VSync",+    "1280x720 74.500 1280 1344 1472 1664 720 723 728 748 -HSync +VSync",+    "1024x768 94.500 1024 1072 1168 1376 768 769 772 808 +HSync +VSync",+    "1024x768 78.750 1024 1040 1136 1312 768 769 772 800 +HSync +VSync",+    "1024x768 75.000 1024 1048 1184 1328 768 771 777 806 -HSync -VSync",+    "1024x768 65.000 1024 1048 1184 1344 768 771 777 806 -HSync -VSync",+    "1024x576 46.500 1024 1064 1160 1296 576 579 584 599 -HSync +VSync",+    "832x624 57.284 832 864 928 1152 624 625 628 667 -HSync -VSync",+    "960x540 40.750 960 992 1088 1216 540 543 548 562 -HSync +VSync",+    "800x600 56.300 800 832 896 1048 600 601 604 631 +HSync +VSync",+    "800x600 50.000 800 856 976 1040 600 637 643 666 +HSync +VSync",+    "800x600 49.500 800 816 896 1056 600 601 604 625 +HSync +VSync",+    "800x600 40.000 800 840 968 1056 600 601 605 628 +HSync +VSync",+    "800x600 36.000 800 824 896 1024 600 601 603 625 +HSync +VSync",+    "864x486 32.500 864 888 968 1072 486 489 494 506 -HSync +VSync",+    "640x480 36.000 640 696 752 832 480 481 484 509 -HSync -VSync",+    "640x480 31.500 640 656 720 840 480 481 484 500 -HSync -VSync",+    "640x480 31.500 640 664 704 832 480 489 492 520 -HSync -VSync",+    "640x480 25.175 640 656 752 800 480 490 492 525 -HSync -VSync",+    "720x400 35.500 720 756 828 936 400 401 404 446 -HSync +VSync",+    "640x400 31.500 640 672 736 832 400 401 404 445 -HSync +VSync",+    "640x350 31.500 640 672 736 832 350 382 385 445 +HSync -VSync"   ]  xrandr :: DisplayName -> [String] -> ProcessConfig () () ()@@ -415,26 +425,29 @@     Nothing -> pure ()    runXrandr d args-   where     args = concat (globalArgs ++ givenArgs ++ switchOffOthers rr.outputs)-    globalArgs = [ ["--noprimary" | isNothing rr.primary ] ]+    globalArgs = [["--noprimary" | isNothing rr.primary]] -    givenArgs = zipWith outputArgs [0..] rr.outputs+    givenArgs = zipWith outputArgs [0 ..] rr.outputs      outputArgs :: ListIndex RROutput -> RROutput -> [String]     outputArgs i output =-      [ "--output", outputName i-      , "--rotate", rrRotation output.settings.rotate-      ] ++-      maybe ["--preferred"] (\m -> ["--mode", modeName m]) output.mode ++-      ["--off" | output.settings.disabled ] ++-      ["--primary" | rr.primary == Just i] ++-      (if i > 0 then ["--" ++ rrPosition output.position, outputName (i - 1)] else [])+      [ "--output",+        outputName i,+        "--rotate",+        rrRotation output.settings.rotate+      ]+        ++ maybe ["--preferred"] (\m -> ["--mode", modeName m]) output.mode+        ++ ["--off" | output.settings.disabled]+        ++ ["--primary" | rr.primary == Just i]+        ++ (if i > 0 then ["--" ++ rrPosition output.position, outputName (i - 1)] else [])      switchOffOthers :: [RROutput] -> [[String]]-    switchOffOthers os = [ ["--output", outputName i, "--off"]-                         | i <- [ListIndex (length os)..15] ]+    switchOffOthers os =+      [ ["--output", outputName i, "--off"]+      | i <- [ListIndex (length os) .. 15]+      ]  randrTeardown :: DisplayName -> RRSetup -> IO () randrTeardown d rr = do@@ -488,14 +501,15 @@  ------------------------------------------------------------------------ -prop_xprop :: HasCallStack => DisplayName -> XPropName -> XPropValue -> Property+prop_xprop :: (HasCallStack) => DisplayName -> XPropName -> XPropValue -> Property prop_xprop d name value = monadicIO $ do   xpropSet d name value   value' <- xpropGet d name   xpropRemove d name-  pure $ if value /= mempty-    then value' === [value]-    else value' === []+  pure $+    if value /= mempty+      then value' === [value]+      else value' === []  instance Arbitrary XPropName where   arbitrary = ((:) <$> elements propNameStartChars <*> listOf arbitraryASCIIChar) `suchThatMap` xpropName@@ -507,29 +521,32 @@  ------------------------------------------------------------------------ -prop_xrandr :: HasCallStack => DisplayName -> RRSetup -> Property+prop_xrandr :: (HasCallStack) => DisplayName -> RRSetup -> Property prop_xrandr d rr = decorate $ monadicIO $ do-    qrr <- run $ withRandrSetup d rr (randrQuery d)-    let (rr', qrr') = reformat rr qrr-    pure $ qrr' === rr'+  qrr <- run $ withRandrSetup d rr (randrQuery d)+  let (rr', qrr') = reformat rr qrr+  pure $ qrr' === rr'   where     decorate =-      tabulate "Outputs" [outputName i | (i, o) <- enumerate rr.outputs, not o.settings.disabled] .-      (if any ((/= Unrotated) . rotate . settings) rr.outputs then label "rotation" else id) .-      (if any (isNothing . mode) rr.outputs then label "using preferred mode" else id) .-      cover 50 (length rr.outputs > 1) "non-trivial"+      tabulate "Outputs" [outputName i | (i, o) <- enumerate rr.outputs, not o.settings.disabled]+        . (if any ((/= Unrotated) . rotate . settings) rr.outputs then label "rotation" else id)+        . (if any (isNothing . mode) rr.outputs then label "using preferred mode" else id)+        . cover 50 (length rr.outputs > 1) "non-trivial" -    reformat rrs = unzip-      . map (bimap snd snd)-      . dropWhileEnd (not . uncurry (||) . bimap fst fst)-      . zip (tuplify (backfill 16 rrs))+    reformat rrs =+      unzip+        . map (bimap snd snd)+        . dropWhileEnd (not . uncurry (||) . bimap fst fst)+        . zip (tuplify (backfill 16 rrs)) -    tuplify RRSetup{..} =+    tuplify RRSetup {..} =       [ (not o.settings.disabled, (i, Just (ListIndex i) == primary))-      | (i, o) <- zip [0..] outputs ]+      | (i, o) <- zip [0 ..] outputs+      ] -    backfill n rrs = rrs { outputs = rr.outputs ++ extras }-      where extras = replicate (max 0 (n - length rr.outputs)) rrOutputOff+    backfill n rrs = rrs {outputs = rr.outputs ++ extras}+      where+        extras = replicate (max 0 (n - length rr.outputs)) rrOutputOff  -- | Scans output of @xrandr --query@ and returns values relevant to -- test assertions.@@ -553,37 +570,40 @@     nNewModes <- chooseInt (1, nOutputs)     newModeLines <- vectorOf nNewModes (elements (map modeLine modeLines)) -    let newModes = [ RRMode (newModeName i) m | (i, m) <- enumerate newModeLines ]+    let newModes = [RRMode (newModeName i) m | (i, m) <- enumerate newModeLines]      -- TODO: also use new modes for outputs     -- mode <- chooseListIndex newModes      outputs <- vector nOutputs-    primary <- frequency [ (5, Just <$> chooseListIndex outputs)-                         , (1, pure Nothing) ]-    pure $ RRSetup{..}+    primary <-+      frequency+        [ (5, Just <$> chooseListIndex outputs),+          (1, pure Nothing)+        ]+    pure $ RRSetup {..}    shrink rr = do     (primary, outputs) <- shrinkOutputs     guard $ not $ null outputs     pure $ RRSetup {newModes = [], ..}-     where       shrinkOutputs = case rr.primary of         Just p -> shrinkListIx shrink (p, rr.outputs)         Nothing -> map (Nothing,) (shrinkList shrink rr.outputs) -      -- fixme: shrink modes properly too, and adjust mode within outputs-      -- shrinkModes ms = do-      --   ms' <- shrinkListP shrink ms-      --   pure ms'+-- fixme: shrink modes properly too, and adjust mode within outputs+-- shrinkModes ms = do+--   ms' <- shrinkListP shrink ms+--   pure ms'  shrinkListIx :: (a -> [a]) -> (ListIndex a, [a]) -> [(Maybe (ListIndex a), [a])] shrinkListIx shr (ix, xs) = map unwrap $ shrinkList (shrinkSecond shr) (wrap xs)   where-    wrap = zip [0..]-    unwrap ixs = let ix' = findIndex ((== ix) . fst) ixs-                 in (fmap ListIndex ix', map snd ixs)+    wrap = zip [0 ..]+    unwrap ixs =+      let ix' = findIndex ((== ix) . fst) ixs+       in (fmap ListIndex ix', map snd ixs)      shrinkSecond :: (a -> [a]) -> (b, a) -> [(b, a)]     shrinkSecond f (b, a) = map (b,) (f a)@@ -591,16 +611,18 @@ instance Arbitrary RROutput where   -- Always set a mode because "--preferred" option seems dodgy   arbitrary = RROutput <$> fmap Just arbitrary <*> arbitrary <*> arbitrary-  shrink o = [ RROutput m s p-             | (m, s, p) <- shrink (o.mode, o.settings, o.position)-             , isJust m-             ]+  shrink o =+    [ RROutput m s p+    | (m, s, p) <- shrink (o.mode, o.settings, o.position),+      isJust m+    ]  instance Arbitrary RROutputSettings where   -- Rotation and reflection don't seem to work for xdummy-  arbitrary = RROutputSettings-    <$> frequency [(5, pure False), (1, pure True)]-    <*> pure Unrotated+  arbitrary =+    RROutputSettings+      <$> frequency [(5, pure False), (1, pure True)]+      <*> pure Unrotated   shrink = genericShrink  instance Arbitrary RRExistingMode where@@ -608,20 +630,26 @@   shrink = shrinkMap (RRExistingMode . ListIndex . getPositive) (Positive . unListIndex . unRRExistingMode)  instance Arbitrary RRPosition where-  arbitrary = frequency $ map (second pure)-    [ (2, SameAs)-    , (1, LeftOf)-    , (4, RightOf)-    , (1, Above)-    , (2, Below)-    ]+  arbitrary =+    frequency $+      map+        (second pure)+        [ (2, SameAs),+          (1, LeftOf),+          (4, RightOf),+          (1, Above),+          (2, Below)+        ]   shrink = shrinkBoundedEnum  instance Arbitrary RRRotation where-  arbitrary = frequency $ map (second pure)-    [ (4, Unrotated)-    , (2, Inverted)-    , (1, RotateLeft)-    , (1, RotateRight)-    ]+  arbitrary =+    frequency $+      map+        (second pure)+        [ (4, Unrotated),+          (2, Inverted),+          (1, RotateLeft),+          (1, RotateRight)+        ]   shrink = shrinkBoundedEnum
test/unit/System/Taffybar/AppearanceSpec.hs view
@@ -1,57 +1,97 @@ module System.Taffybar.AppearanceSpec (spec) where -import Control.Monad (when)+import Codec.Picture qualified as JP+import Control.Monad (unless, when)+import Data.ByteString.Lazy qualified as BL+import Data.Maybe (isJust) import System.Directory (doesFileExist, findExecutable, makeAbsolute) import System.Exit (ExitCode (..)) import System.FilePath ((</>))+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) 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)+appearanceSnapProcessTimeoutUsec :: Int+appearanceSnapProcessTimeoutUsec = 120_000_000  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+spec = do+  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 LegacyLayout LegacyWidget+      assertGolden "appearance" goldenFile actualPng -    shouldUpdate <- lookupEnv "TAFFYBAR_UPDATE_GOLDENS"-    case shouldUpdate of-      Just _ -> do-        BL.writeFile goldenFile actualPng+    it "renders a two-level bar under an EWMH window manager" $ \env -> do+      goldenFile <- makeAbsolute "test/data/appearance-ewmh-bar-levels.png"+      actualPng <- renderBarScreenshot env LevelsLayout LegacyWidget+      assertGolden "appearance-levels" goldenFile actualPng++    it "renders the channel workspaces widget under an EWMH window manager" $ \env -> do+      actualPng <- renderBarScreenshot env LegacyLayout ChannelWidget+      assertPngLooksRendered "ewmh-channel-workspaces" actualPng++    it "keeps configured bar height when the windows title has oversized glyph metrics" $ \env -> do+      actualPng <- renderBarScreenshot env WindowsTitleStressLayout LegacyWidget+      let actualImg = decodePngRGBA8 "stress" actualPng+      JP.imageHeight actualImg `shouldBe` 55++    it "sets an appropriately scaled top strut under EWMH when GDK_SCALE=2" $ \env ->+      withSetEnv [("GDK_SCALE", "2"), ("GDK_DPI_SCALE", "1")] $ do+        actualPng <-+          renderBarScreenshotWithArgs+            env+            LegacyLayout+            LegacyWidget+            ["--expect-top-strut", "80"]+        assertPngLooksRendered "ewmh-hidpi-strut" actualPng++  it "renders the channel workspaces widget under Hyprland when available" $ do+    available <- hyprlandTestAvailable+    unless available $+      pendingWith+        "Hyprland integration environment unavailable (needs WAYLAND_DISPLAY, HYPRLAND_INSTANCE_SIGNATURE and grim)"+    actualPng <- renderHyprlandScreenshot LegacyLayout ChannelWidget+    assertPngLooksRendered "hyprland-channel-workspaces" actualPng++assertGolden :: String -> FilePath -> BL.ByteString -> IO ()+assertGolden label goldenFile actualPng = do+  shouldUpdate <- lookupEnv "TAFFYBAR_UPDATE_GOLDENS"+  case shouldUpdate of+    Just _ -> do+      BL.writeFile goldenFile actualPng+      createDirectoryIfMissing True "dist"+      BL.writeFile ("dist/" ++ label ++ "-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-      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)"+        BL.writeFile ("dist/" ++ label ++ "-actual.png") actualPng+        BL.writeFile ("dist/" ++ label ++ "-golden.png") goldenPng+        expectationFailure $+          "Appearance golden mismatch: "+            ++ goldenFile+            ++ " (wrote dist/"+            ++ label+            ++ "-actual.png and dist/"+            ++ label+            ++ "-golden.png)"  newtype Env = Env   { envTmpDir :: FilePath@@ -68,28 +108,36 @@            -- 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 })+            [ ("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+data LayoutKind = LegacyLayout | LevelsLayout | WindowsTitleStressLayout++data WidgetKind = LegacyWidget | ChannelWidget++renderBarScreenshot :: Env -> LayoutKind -> WidgetKind -> IO BL.ByteString+renderBarScreenshot env layout widgetKind =+  renderBarScreenshotWithArgs env layout widgetKind []++renderBarScreenshotWithArgs :: Env -> LayoutKind -> WidgetKind -> [String] -> IO BL.ByteString+renderBarScreenshotWithArgs Env {envTmpDir = tmp} layout widgetKind extraArgs = do   exePath <-     findComponentExecutable       "taffybar-appearance-snap"@@ -99,13 +147,22 @@   cssPath <- makeAbsolute "test/data/appearance-test.css"   outPath <- makeAbsolute (tmp </> "appearance-actual.png") -  let pc =+  let levelArgs =+        case layout of+          LegacyLayout -> []+          LevelsLayout -> ["--levels"]+          WindowsTitleStressLayout -> ["--windows-title-stress"]+      widgetArgs =+        case widgetKind of+          LegacyWidget -> []+          ChannelWidget -> ["--channel-workspaces"]+      pc =         setStdout inherit $           setStderr inherit $-            proc exePath ["--out", outPath, "--css", cssPath]+            proc exePath (["--out", outPath, "--css", cssPath] ++ levelArgs ++ widgetArgs ++ extraArgs)    withProcessTerm pc $ \p -> do-    mEc <- timeout 60_000_000 (waitExitCode p)+    mEc <- timeout appearanceSnapProcessTimeoutUsec (waitExitCode p)     case mEc of       Nothing -> do         stopProcess p@@ -116,6 +173,65 @@    BL.readFile outPath +renderHyprlandScreenshot :: LayoutKind -> WidgetKind -> IO BL.ByteString+renderHyprlandScreenshot layout widgetKind =+  withSystemTempDirectory "taffybar-appearance-hyprland" $ \tmp -> do+    exePath <-+      findComponentExecutable+        "taffybar-appearance-snap-hyprland"+        [ "dist/build/taffybar-appearance-snap-hyprland/taffybar-appearance-snap-hyprland"+        ]+    cssPath <- makeAbsolute "test/data/appearance-test.css"+    outPath <- makeAbsolute (tmp </> "appearance-hyprland-actual.png")+    let levelArgs =+          case layout of+            LegacyLayout -> []+            LevelsLayout -> ["--levels"]+            WindowsTitleStressLayout -> []+        widgetArgs =+          case widgetKind of+            LegacyWidget -> []+            ChannelWidget -> ["--channel-workspaces"]+        pc =+          setStdout inherit $+            setStderr inherit $+              proc exePath (["--out", outPath, "--css", cssPath] ++ levelArgs ++ widgetArgs)+    withProcessTerm pc $ \p -> do+      mEc <- timeout appearanceSnapProcessTimeoutUsec (waitExitCode p)+      case mEc of+        Nothing -> do+          stopProcess p+          expectationFailure "Timed out running taffybar-appearance-snap-hyprland"+        Just ExitSuccess -> pure ()+        Just (ExitFailure n) ->+          expectationFailure ("taffybar-appearance-snap-hyprland exited with " ++ show n)+    BL.readFile outPath++assertPngLooksRendered :: String -> BL.ByteString -> IO ()+assertPngLooksRendered label actualPng = do+  let img = decodePngRGBA8 label actualPng+      w = JP.imageWidth img+      h = JP.imageHeight img+      opaquePixelCount =+        length+          [ ()+          | y <- [0 .. h - 1],+            x <- [0 .. w - 1],+            let JP.PixelRGBA8 _ _ _ a = JP.pixelAt img x y,+            a > 200+          ]+  when (w <= 0 || h <= 0) $+    expectationFailure ("Rendered PNG has invalid dimensions for " ++ label)+  when (opaquePixelCount <= 4000) $+    expectationFailure ("Rendered PNG seems empty for " ++ label)++hyprlandTestAvailable :: IO Bool+hyprlandTestAvailable = do+  waylandDisplay <- lookupEnv "WAYLAND_DISPLAY"+  hyprSig <- lookupEnv "HYPRLAND_INSTANCE_SIGNATURE"+  grimExe <- findExecutable "grim"+  pure (isJust waylandDisplay && isJust hyprSig && isJust grimExe)+ findComponentExecutable :: String -> [FilePath] -> IO FilePath findComponentExecutable name localCandidates = do   mexe <- findExecutable name@@ -124,7 +240,7 @@     Nothing -> go localCandidates   where     go [] = fail (name ++ " not found on PATH")-    go (p:ps) = do+    go (p : ps) = do       exists <- doesFileExist p       if exists then makeAbsolute p else go ps
test/unit/System/Taffybar/AuthSpec.hs view
@@ -1,15 +1,13 @@ module System.Taffybar.AuthSpec (spec) where  import Data.List (intercalate)-import System.FilePath ((</>), (<.>))-import Text.Printf (printf)-+import System.FilePath ((<.>), (</>))+import System.Taffybar.Auth+import System.Taffybar.Test.UtilSpec (withMockCommand) import Test.Hspec import Test.Hspec.Core.Spec (getSpecDescriptionPath) import Test.Hspec.Golden hiding (golden)--import System.Taffybar.Auth-import System.Taffybar.Test.UtilSpec (withMockCommand)+import Text.Printf (printf)  spec :: Spec spec = aroundAll_ (withMockPass mockDb) $ describe "passGet" $ do@@ -24,51 +22,55 @@     taffybarGolden (intercalate "-" path) <$> runAction  taffybarGolden :: String -> String -> Golden String-taffybarGolden name output = Golden-  { output-  , encodePretty = show-  , writeToFile = writeFile-  , readFromFile = readFile-  , goldenFile = "test/data/" </> name <.> "golden"-  , actualFile = Nothing-  , failFirstTime = True-  }+taffybarGolden name output =+  Golden+    { output,+      encodePretty = show,+      writeToFile = writeFile,+      readFromFile = readFile,+      goldenFile = "test/data/" </> name <.> "golden",+      actualFile = Nothing,+      failFirstTime = True+    }  mockDb :: [MockEntry]-mockDb = [ mockEntry "hello" "xyzzy" []-         , mockEntry "multiline" "secret" [("Username", "fred"), ("silly", "")]-         , fallbackEntry "" "Error: is not in the password store.\n" 1-         ]+mockDb =+  [ mockEntry "hello" "xyzzy" [],+    mockEntry "multiline" "secret" [("Username", "fred"), ("silly", "")],+    fallbackEntry "" "Error: is not in the password store.\n" 1+  ]  withMockPass :: [MockEntry] -> IO a -> IO a withMockPass db = withMockCommand "pass" (mockScript db)  data MockEntry = MockEntry-  { passName :: String-  , out :: String-  , err :: String-  , status :: Int-  } deriving (Show, Read, Eq)+  { passName :: String,+    out :: String,+    err :: String,+    status :: Int+  }+  deriving (Show, Read, Eq)  mockEntry :: String -> String -> [(String, String)] -> MockEntry mockEntry passName key info =-  MockEntry { passName, out = passFile key info, err = "", status = 0 }+  MockEntry {passName, out = passFile key info, err = "", status = 0}  passFile :: String -> [(String, String)] -> String-passFile key info = unlines (key:[k ++ ": " ++ v | (k, v) <- info])+passFile key info = unlines (key : [k ++ ": " ++ v | (k, v) <- info])  fallbackEntry :: String -> String -> Int -> MockEntry-fallbackEntry out err status = MockEntry { passName = "", .. }+fallbackEntry out err status = MockEntry {passName = "", ..}  mockScript :: [MockEntry] -> String-mockScript db = unlines ("#!/usr/bin/env bash":map makeEntry db)+mockScript db = unlines ("#!/usr/bin/env bash" : map makeEntry db)   where-    makeEntry MockEntry{..} = printf template passName out err status-    template = unlines-      [ "pass_name='%s'"-      , "if [ -z \"$pass_name\" -o \"$2\" = \"$pass_name\" ]; then"-      , "  echo -n '%s'"-      , "  >&2 echo '%s'"-      , "  exit %d"-      , "fi"-      ]+    makeEntry MockEntry {..} = printf template passName out err status+    template =+      unlines+        [ "pass_name='%s'",+          "if [ -z \"$pass_name\" -o \"$2\" = \"$pass_name\" ]; then",+          "  echo -n '%s'",+          "  >&2 echo '%s'",+          "  exit %d",+          "fi"+        ]
test/unit/System/Taffybar/ContextSpec.hs view
@@ -2,46 +2,47 @@ {-# LANGUAGE LambdaCase #-} {-# LANGUAGE NumericUnderscores #-} {-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE TypeSynonymInstances #-} {-# OPTIONS_GHC -Wno-orphans #-}  module System.Taffybar.ContextSpec-  ( spec-  -- * Utils-  , runTaffyDefault-  -- * Abstract Config-  , GenSimpleConfig(..)-  , toSimpleConfig-  , GenWidget(..)-  , toTaffyWidget-  , GenSpace(..)-  , GenCssPath(..)-  , toCssPaths-  , GenMonitorsAction(..)-  , toMonitorsAction-  ) where+  ( spec, -import Control.Monad.Trans.Reader (runReaderT)+    -- * Utils+    runTaffyDefault,++    -- * Abstract Config+    GenSimpleConfig (..),+    toSimpleConfig,+    GenWidget (..),+    toTaffyWidget,+    GenSpace (..),+    GenCssPath (..),+    toCssPaths,+    GenMonitorsAction (..),+    toMonitorsAction,+  )+where+ import Control.Exception (SomeException, catch)+import Control.Monad.Trans.Reader (runReaderT) 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-import Test.QuickCheck-import Test.QuickCheck.Monadic- import System.Taffybar.Context import System.Taffybar.SimpleConfig-import System.Taffybar.Widget.SimpleClock (textClockNewWith)-import System.Taffybar.Widget.Workspaces (workspacesNew)- import System.Taffybar.Test.DBusSpec (withTestDBus) import System.Taffybar.Test.UtilSpec (logSetup, withSetEnv)-import System.Taffybar.Test.XvfbSpec (withXdummy, setDefaultDisplay_)+import System.Taffybar.Test.XvfbSpec (setDefaultDisplay_, withXdummy)+import System.Taffybar.Widget.SimpleClock (textClockNewWith)+import System.Taffybar.Widget.Workspaces (workspacesNew)+import Test.Hspec hiding (context)+import Test.Hspec.QuickCheck+import Test.QuickCheck+import Test.QuickCheck.Monadic  spec :: Spec spec = logSetup $ sequential $ aroundAll_ withTestDBus $ aroundAll_ (withXdummy . flip setDefaultDisplay_) $ do@@ -53,10 +54,11 @@       removePathForcibly runtime `catch` (\(_ :: SomeException) -> pure ())       createDirectoryIfMissing True runtime       withSetEnv-        [ ("XDG_RUNTIME_DIR", runtime)-        , ("WAYLAND_DISPLAY", wl)-        , ("XDG_SESSION_TYPE", "wayland")-        ] $ do+        [ ("XDG_RUNTIME_DIR", runtime),+          ("WAYLAND_DISPLAY", wl),+          ("XDG_SESSION_TYPE", "wayland")+        ]+        $ do           detectBackend `shouldReturn` BackendX11       removePathForcibly runtime `catch` (\(_ :: SomeException) -> pure ()) @@ -69,10 +71,11 @@       createDirectoryIfMissing True runtime       writeFile wlPath "" -- exists but is not a socket       withSetEnv-        [ ("XDG_RUNTIME_DIR", runtime)-        , ("WAYLAND_DISPLAY", wl)-        , ("XDG_SESSION_TYPE", "wayland")-        ] $ do+        [ ("XDG_RUNTIME_DIR", runtime),+          ("WAYLAND_DISPLAY", wl),+          ("XDG_SESSION_TYPE", "wayland")+        ]+        $ do           detectBackend `shouldReturn` BackendX11       removePathForcibly runtime `catch` (\(_ :: SomeException) -> pure ()) @@ -90,31 +93,34 @@ -- | Represents 'SimpleTaffyConfig' in a more abstract way, so that -- it's easier to 'show', 'shrink', 'assert', etc. data GenSimpleConfig = GenSimpleConfig-  { monitors :: GenMonitorsAction-  , size :: StrutSize-  , padding :: GenSpace-  , position :: Position-  , spacing :: GenSpace-  , start :: [GenWidget]-  , center :: [GenWidget]-  , end :: [GenWidget]-  , css :: [GenCssPath]-  } deriving (Show, Eq, Generic)+  { monitors :: GenMonitorsAction,+    size :: StrutSize,+    padding :: GenSpace,+    position :: Position,+    spacing :: GenSpace,+    start :: [GenWidget],+    center :: [GenWidget],+    end :: [GenWidget],+    css :: [GenCssPath]+  }+  deriving (Show, Eq, Generic)  -- | Build an actual taffy config from the abstract form. toSimpleConfig :: GenSimpleConfig -> SimpleTaffyConfig-toSimpleConfig GenSimpleConfig{..} = SimpleTaffyConfig-  { monitorsAction = toMonitorsAction monitors-  , barHeight = size-  , barPadding = unGenSpace padding-  , barPosition = position-  , widgetSpacing = unGenSpace spacing-  , startWidgets = map toTaffyWidget start-  , centerWidgets = map toTaffyWidget center-  , endWidgets = map toTaffyWidget end-  , cssPaths = toCssPaths css-  , startupHook = pure () -- TODO: add something-  }+toSimpleConfig GenSimpleConfig {..} =+  SimpleTaffyConfig+    { monitorsAction = toMonitorsAction monitors,+      barHeight = size,+      barPadding = unGenSpace padding,+      barPosition = position,+      widgetSpacing = unGenSpace spacing,+      startWidgets = map toTaffyWidget start,+      centerWidgets = map toTaffyWidget center,+      endWidgets = map toTaffyWidget end,+      barLevels = Nothing,+      cssPaths = toCssPaths css,+      startupHook = pure () -- TODO: add something+    }  toTaffyWidget :: GenWidget -> TaffyIO Widget toTaffyWidget = \case@@ -131,14 +137,15 @@   UseTheseMonitors xs -> pure xs  instance Arbitrary GenSimpleConfig where-  arbitrary = GenSimpleConfig <$> arbitrary <*>  arbitrary <*>  arbitrary <*>  arbitrary <*>  arbitrary <*>  arbitrary <*>  arbitrary <*>  arbitrary <*>  arbitrary+  arbitrary = GenSimpleConfig <$> arbitrary <*> arbitrary <*> arbitrary <*> arbitrary <*> arbitrary <*> arbitrary <*> arbitrary <*> arbitrary <*> arbitrary   shrink = genericShrink  instance Arbitrary StrutSize where-  arbitrary = oneof-    [ ExactSize . getSmall . getPositive <$> arbitrary-    , ScreenRatio <$> elements [ 1 % 27, 1 % 50, 1 % 2 ] -- TODO: more arbitrary-    ]+  arbitrary =+    oneof+      [ ExactSize . getSmall . getPositive <$> arbitrary,+        ScreenRatio <$> elements [1 % 27, 1 % 50, 1 % 2] -- TODO: more arbitrary+      ]   shrink (ExactSize s) = ExactSize . getPositive <$> shrink (Positive (fromIntegral s))   shrink (ScreenRatio r) = ScreenRatio <$> shrink r @@ -147,7 +154,7 @@   shrink Top = []   shrink Bottom = [Top] -newtype GenSpace = GenSpace { unGenSpace :: Int }+newtype GenSpace = GenSpace {unGenSpace :: Int}   deriving (Show, Read, Eq, Generic)  instance Arbitrary GenSpace where@@ -168,39 +175,46 @@   arbitrary = arbitraryBoundedEnum   shrink = genericShrink -data GenMonitorsAction = UsePrimaryMonitor-                       | UseAllMonitors-                       | UseTheseMonitors [Int]+data GenMonitorsAction+  = UsePrimaryMonitor+  | UseAllMonitors+  | UseTheseMonitors [Int]   deriving (Show, Read, Eq, Generic)  instance Arbitrary GenMonitorsAction where-  arbitrary = oneof-    [ pure UsePrimaryMonitor-    , pure UseAllMonitors-    , wild ]+  arbitrary =+    oneof+      [ pure UsePrimaryMonitor,+        pure UseAllMonitors,+        wild+      ]     where       -- This could be a lot meaner.       wild = do         NonNegative (Small n) <- arbitrary-        pure (UseTheseMonitors [0..n])+        pure (UseTheseMonitors [0 .. n])   shrink = genericShrink  ------------------------------------------------------------------------  prop_genSimpleConfig :: GenSimpleConfig -> Property-prop_genSimpleConfig cfg = checkCoverage $-  cover 25 (monitors cfg == UsePrimaryMonitor) "Primary monitor only" $-  cfg === cfg+prop_genSimpleConfig cfg =+  checkCoverage $+    cover 25 (monitors cfg == UsePrimaryMonitor) "Primary monitor only" $+      cfg === cfg  prop_taffybarConfig :: GenSimpleConfig -> Property-prop_taffybarConfig cfg = within 1_000_000 $ monadicIO $-  pure (cfg =/= cfg)-  -- Some possible assertions:-  --   startupHook executed exactly once-  --   css rules are applied-  --   css files later in list have precedence-  --   missing css => exception-  --   error in css => warning and continue-  --   widgets are visible-  --   spacing/height/position/padding are observed-  --   appears on the correct monitor+prop_taffybarConfig cfg =+  within 1_000_000 $+    monadicIO $+      pure (cfg =/= cfg)++-- Some possible assertions:+--   startupHook executed exactly once+--   css rules are applied+--   css files later in list have precedence+--   missing css => exception+--   error in css => warning and continue+--   widgets are visible+--   spacing/height/position/padding are observed+--   appears on the correct monitor
+ test/unit/System/Taffybar/Information/CryptoSpec.hs view
@@ -0,0 +1,15 @@+module System.Taffybar.Information.CryptoSpec (spec) where++import System.Taffybar.Information.Crypto+import Test.Hspec++spec :: Spec+spec = describe "Crypto backoff" $ do+  it "caps exponential growth at the configured maximum" $+    nextCryptoBackoff 960 960 `shouldBe` (960, 960)++  it "doubles the current backoff delay when under the maximum" $+    nextCryptoBackoff 960 120 `shouldBe` (240, 120)++  it "sets max backoff to 16x the nominal polling delay" $+    maxCryptoBackoffForDelay 60 `shouldBe` 960
+ test/unit/System/Taffybar/Information/WakeupSpec.hs view
@@ -0,0 +1,80 @@+{-# LANGUAGE NumericUnderscores #-}++module System.Taffybar.Information.WakeupSpec (spec) where++import Data.Word (Word64)+import System.Taffybar.Information.Wakeup+import Test.Hspec+import Test.Hspec.QuickCheck+import Test.QuickCheck++spec :: Spec+spec = do+  describe "nextWallAlignedWakeupNs" $ do+    it "aligns 1-second intervals to top-of-second boundaries" $ do+      let realtimeOffset = 0+          interval = 1_000_000_000+          now = 1_250_000_000+      nextWallAlignedWakeupNs realtimeOffset interval now+        `shouldBe` 2_000_000_000++    prop "returns a strict future boundary aligned to wall-clock phase" $+      \(Positive (Small intervalSeconds :: Small Int))+       (NonNegative (Small nowOffsetMicros :: Small Int))+       (Small offsetMicros :: Small Int) ->+          let anchor :: Word64+              anchor = 1_000_000_000+              interval :: Word64+              interval = fromIntegral intervalSeconds * 1_000_000_000+              now :: Word64+              now = anchor + fromIntegral nowOffsetMicros * 1_000+              realtimeOffsetNs :: Integer+              realtimeOffsetNs = fromIntegral offsetMicros * 1_000+              due = nextWallAlignedWakeupNs realtimeOffsetNs interval now+           in due > now+                && (toInteger due + realtimeOffsetNs) `mod` toInteger interval == 0++  describe "nextAlignedWakeupNs" $ do+    it "returns the next boundary when now is exactly on a boundary" $ do+      let anchor = 1_000_000_000+          interval = 5_000_000_000+          now = 6_000_000_000+      nextAlignedWakeupNs anchor interval now+        `shouldBe` 11_000_000_000++    prop "returns a strict future boundary aligned to the interval" $+      \(Positive (Small intervalSeconds :: Small Int)) (NonNegative (Small nowOffsetMicros :: Small Int)) ->+        let anchor :: Word64+            anchor = 1_000_000_000+            interval :: Word64+            interval = fromIntegral intervalSeconds * 1_000_000_000+            now :: Word64+            now = anchor + fromIntegral nowOffsetMicros * 1_000+            due = nextAlignedWakeupNs anchor interval now+         in due > now+              && (due - anchor) `mod` interval == 0++  describe "divisibility alignment" $ do+    it "keeps 10s wakeups synchronized to every other 5s wakeup" $ do+      let anchor :: Word64+          anchor = 0+          fiveSeconds :: Word64+          fiveSeconds = 5_000_000_000+          tenSeconds :: Word64+          tenSeconds = 10_000_000_000+          fiveSchedule = map (intervalDueAtStepNs anchor fiveSeconds) [1 .. 10]+          tenSchedule = map (intervalDueAtStepNs anchor tenSeconds) [1 .. 5]+          everyOtherFive = [fiveSchedule !! 1, fiveSchedule !! 3, fiveSchedule !! 5, fiveSchedule !! 7, fiveSchedule !! 9]+      tenSchedule `shouldBe` everyOtherFive++  describe "minute alignment" $ do+    it "lands on exact minute boundaries for intervals that divide 60 seconds" $ do+      let minuteNs :: Word64+          minuteNs = 60_000_000_000+          divisorIntervalsSeconds :: [Word64]+          divisorIntervalsSeconds = [1, 2, 3, 4, 5, 6, 10, 12, 15, 20, 30, 60]+          checkInterval intervalSeconds =+            let intervalNs = intervalSeconds * 1_000_000_000+                stepAtMinute = 60 `div` intervalSeconds+             in intervalDueAtStepNs 0 intervalNs stepAtMinute == minuteNs+      map checkInterval divisorIntervalsSeconds `shouldBe` replicate (length divisorIntervalsSeconds) True
test/unit/System/Taffybar/Information/X11DesktopInfoSpec.hs view
@@ -2,18 +2,19 @@  module System.Taffybar.Information.X11DesktopInfoSpec (spec) where -import Test.Hspec hiding (context)--import System.Taffybar.Test.XvfbSpec (withXdummy, xpropSet, XPropName(..), XPropValue(..)) import System.Taffybar.Information.X11DesktopInfo+import System.Taffybar.Test.XvfbSpec (XPropName (..), XPropValue (..), withXdummy, xpropSet)+import Test.Hspec hiding (context)  spec :: Spec spec = around withXdummy $ describe "withX11Context" $ do-  it "trivial" $ \dn -> example $-    withX11Context dn (pure ()) `shouldReturn` ()+  it "trivial" $ \dn ->+    example $+      withX11Context dn (pure ()) `shouldReturn` () -  it "getPrimaryOutputNumber" $ \dn -> example $-    withX11Context dn getPrimaryOutputNumber `shouldReturn` Just 0+  it "getPrimaryOutputNumber" $ \dn ->+    example $+      withX11Context dn getPrimaryOutputNumber `shouldReturn` Just 0    it "read property of root window" $ \dn -> do     xpropSet dn (XPropName "_XMONAD_VISIBLE_WORKSPACES") (XPropValue "hello")
test/unit/System/Taffybar/SimpleConfigSpec.hs view
@@ -3,18 +3,15 @@ module System.Taffybar.SimpleConfigSpec (spec) where  import Data.Maybe (maybeToList)-+import System.Taffybar.ContextSpec (runTaffyDefault)+import System.Taffybar.Information.X11DesktopInfo (DisplayName (..))+import System.Taffybar.SimpleConfig+import System.Taffybar.Test.XvfbSpec (RROutput (..), RROutputSettings (..), RRSetup (..), setDefaultDisplay_, withRandrSetup, withXdummy) import Test.Hspec import Test.Hspec.QuickCheck import Test.QuickCheck import Test.QuickCheck.Monadic -import System.Taffybar.ContextSpec (runTaffyDefault)-import System.Taffybar.Test.XvfbSpec (RRSetup(..), RROutput(..), RROutputSettings(..), withXdummy, setDefaultDisplay_, withRandrSetup)--import System.Taffybar.Information.X11DesktopInfo (DisplayName(..))-import System.Taffybar.SimpleConfig- spec :: Spec spec = aroundAll_ (withXdummy . flip setDefaultDisplay_) $ do   -- Pending: Can't run properties without cleaning up buildContext@@ -23,18 +20,25 @@  prop_useAllMonitors :: RRSetup -> Property prop_useAllMonitors rr = monadicIO $ do-  allMonitors <- run $ withRandrSetup DefaultDisplay rr $-    runTaffyDefault useAllMonitors+  allMonitors <-+    run $+      withRandrSetup DefaultDisplay rr $+        runTaffyDefault useAllMonitors -  let rrOutputNumbers = [ i | (i, o) <- zip [0..] rr.outputs-                            , not o.settings.disabled ]+  let rrOutputNumbers =+        [ i+        | (i, o) <- zip [0 ..] rr.outputs,+          not o.settings.disabled+        ]    pure $ allMonitors === rrOutputNumbers  prop_usePrimaryMonitor :: RRSetup -> Property prop_usePrimaryMonitor rr = monadicIO $ do-  primaryMonitor <- run $ withRandrSetup DefaultDisplay rr $-    runTaffyDefault usePrimaryMonitor+  primaryMonitor <-+    run $+      withRandrSetup DefaultDisplay rr $+        runTaffyDefault usePrimaryMonitor    let rrPrimaryMonitor = fromIntegral <$> maybeToList rr.primary
test/unit/System/Taffybar/Widget/HyprlandWorkspacesSpec.hs view
@@ -1,25 +1,23 @@ module System.Taffybar.Widget.HyprlandWorkspacesSpec where -import Test.Hspec--import qualified Data.Text as T--import System.Taffybar.Widget.HyprlandWorkspaces-  ( HyprlandWindow(..)-  , sortHyprlandWindowsByPosition+import Data.Text qualified as T+import System.Taffybar.Widget.Workspaces.Hyprland+  ( HyprlandWindow (..),+    sortHyprlandWindowsByPosition,   )+import Test.Hspec  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+    { windowAddress = T.pack addr,+      windowTitle = addr,+      windowClass = Nothing,+      windowInitialClass = Nothing,+      windowAt = atPos,+      windowUrgent = False,+      windowActive = False,+      windowMinimized = minimized     }  spec :: Spec@@ -28,11 +26,10 @@     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))+          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]-
+ test/unit/System/Taffybar/Widget/WindowsSpec.hs view
@@ -0,0 +1,14 @@+module System.Taffybar.Widget.WindowsSpec (spec) where++import Data.Text qualified as T+import System.Taffybar.Util (truncateText)+import Test.Hspec++spec :: Spec+spec = describe "Windows active label truncation" $ do+  it "truncates raw labels without introducing escaped entities" $ do+    let rawLabel = "Escape &apples"+        truncated = truncateText 8 rawLabel++    truncated `shouldBe` "Escape &…"+    T.isInfixOf "&amp;" truncated `shouldBe` False
+ test/unit/System/Taffybar/Widget/Workspaces/ChannelSpec.hs view
@@ -0,0 +1,78 @@+module System.Taffybar.Widget.Workspaces.ChannelSpec (spec) where++import Data.Text qualified as T+import Data.Word (Word64)+import System.Taffybar.Information.Workspaces.Model+import System.Taffybar.Widget.Workspaces (sortWindowsByPosition)+import Test.Hspec++mkX11Window :: Word64 -> Bool -> Maybe (Int, Int) -> WindowInfo+mkX11Window wid minimized pos =+  WindowInfo+    { windowIdentity = X11WindowIdentity wid,+      windowTitle = T.pack (show wid),+      windowClassHints = [],+      windowPosition = pos,+      windowUrgent = False,+      windowActive = False,+      windowMinimized = minimized+    }++mkWorkspace :: Int -> String -> WorkspaceViewState -> [WindowInfo] -> WorkspaceInfo+mkWorkspace idx name state windows =+  WorkspaceInfo+    { workspaceIdentity =+        WorkspaceIdentity+          { workspaceNumericId = Just idx,+            workspaceName = T.pack name+          },+      workspaceState = state,+      workspaceHasUrgentWindow = any windowUrgent windows,+      workspaceIsSpecial = False,+      workspaceWindows = windows+    }++mkSnapshot :: Word64 -> [WorkspaceInfo] -> WorkspaceSnapshot+mkSnapshot rev workspaces =+  WorkspaceSnapshot+    { snapshotBackend = WorkspaceBackendHyprland,+      snapshotRevision = rev,+      snapshotWindowDataComplete = True,+      snapshotWorkspaces = workspaces+    }++spec :: Spec+spec = do+  describe "sortWindowsByPosition" $ do+    it "orders non-minimized windows first, then by (x, y), then unknown positions" $ do+      let a = mkX11Window 1 False (Just (10, 0))+          b = mkX11Window 2 False (Just (0, 100))+          c = mkX11Window 3 True (Just (0, 0))+          d = mkX11Window 4 False Nothing+      sortWindowsByPosition [a, b, c, d] `shouldBe` [b, a, d, c]++  describe "diffWorkspaceSnapshots" $ do+    it "returns no events for identical snapshots" $ do+      let w1 = mkX11Window 1 False (Just (0, 0))+          ws1 = mkWorkspace 1 "1" WorkspaceActive [w1]+          snap = mkSnapshot 7 [ws1]+      diffWorkspaceSnapshots snap snap `shouldBe` []++    it "emits order/add/change/window events for meaningful updates" $ do+      let oldW1 = mkX11Window 1 False (Just (0, 0))+          newW1 = oldW1 {windowTitle = "updated"}+          newW2 = mkX11Window 2 False (Just (50, 50))+          oldWs1 = mkWorkspace 1 "1" WorkspaceActive [oldW1]+          newWs1 = mkWorkspace 1 "1" WorkspaceHidden [newW1, newW2]+          newWs2 = mkWorkspace 2 "2" WorkspaceVisible []+          oldSnap = mkSnapshot 10 [oldWs1]+          newSnap = mkSnapshot 11 [newWs2, newWs1]+          expectedEvents =+            [ WorkspaceOrderChanged [workspaceIdentity newWs2, workspaceIdentity newWs1],+              WorkspaceAdded newWs2,+              WorkspaceChanged newWs1,+              WorkspaceWindowsChanged+                (workspaceIdentity newWs1)+                [WindowAdded newW2, WindowChanged newW1]+            ]+      diffWorkspaceSnapshots oldSnap newSnap `shouldBe` expectedEvents
test/unit/unit-tests.hs view
@@ -2,9 +2,8 @@  import Test.Hspec import Test.Hspec.Runner--import qualified UnitSpec-import qualified TestLibSpec+import TestLibSpec qualified+import UnitSpec qualified  main :: IO () main = hspecWith defaultConfig $ do