diff --git a/CHANGELOG.md b/CHANGELOG.md
--- a/CHANGELOG.md
+++ b/CHANGELOG.md
@@ -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
diff --git a/app/AppearanceSnap.hs b/app/AppearanceSnap.hs
--- a/app/AppearanceSnap.hs
+++ b/app/AppearanceSnap.hs
@@ -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
diff --git a/app/AppearanceSnapHyprland.hs b/app/AppearanceSnapHyprland.hs
--- a/app/AppearanceSnapHyprland.hs
+++ b/app/AppearanceSnapHyprland.hs
@@ -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
diff --git a/app/DhallConfig.hs b/app/DhallConfig.hs
new file mode 100644
--- /dev/null
+++ b/app/DhallConfig.hs
@@ -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
diff --git a/app/Main.hs b/app/Main.hs
--- a/app/Main.hs
+++ b/app/Main.hs
@@ -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
diff --git a/app/TestWM.hs b/app/TestWM.hs
--- a/app/TestWM.hs
+++ b/app/TestWM.hs
@@ -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
}
diff --git a/dbus-xml/org.freedesktop.login1.Manager.xml b/dbus-xml/org.freedesktop.login1.Manager.xml
new file mode 100644
--- /dev/null
+++ b/dbus-xml/org.freedesktop.login1.Manager.xml
@@ -0,0 +1,10 @@
+
+
+
+
+
+
+
+
+
diff --git a/doc/config.md b/doc/config.md
--- a/doc/config.md
+++ b/doc/config.md
@@ -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
diff --git a/doc/custom.md b/doc/custom.md
--- a/doc/custom.md
+++ b/doc/custom.md
@@ -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`
diff --git a/doc/dhall-config-proposal.md b/doc/dhall-config-proposal.md
new file mode 100644
--- /dev/null
+++ b/doc/dhall-config-proposal.md
@@ -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?
diff --git a/doc/dhall-config.md b/doc/dhall-config.md
new file mode 100644
--- /dev/null
+++ b/doc/dhall-config.md
@@ -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`
diff --git a/doc/faq.md b/doc/faq.md
--- a/doc/faq.md
+++ b/doc/faq.md
@@ -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:
+
+
+### 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:
+
+-
+
+## 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:
+
+-
+-
+-
+
+## 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:
+
+-
+-
+-
+
+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:
+
+-
+
+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
+```
diff --git a/src/System/Taffybar.hs b/src/System/Taffybar.hs
--- a/src/System/Taffybar.hs
+++ b/src/System/Taffybar.hs
@@ -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
- -- .
+ -- ** 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
+ -- .
- -- * 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"
diff --git a/src/System/Taffybar/Auth.hs b/src/System/Taffybar/Auth.hs
--- a/src/System/Taffybar/Auth.hs
+++ b/src/System/Taffybar/Auth.hs
@@ -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
diff --git a/src/System/Taffybar/Context.hs b/src/System/Taffybar/Context.hs
--- a/src/System/Taffybar/Context.hs
+++ b/src/System/Taffybar/Context.hs
@@ -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)
diff --git a/src/System/Taffybar/Context/Backend.hs b/src/System/Taffybar/Context/Backend.hs
--- a/src/System/Taffybar/Context/Backend.hs
+++ b/src/System/Taffybar/Context/Backend.hs
@@ -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
diff --git a/src/System/Taffybar/DBus.hs b/src/System/Taffybar/DBus.hs
--- a/src/System/Taffybar/DBus.hs
+++ b/src/System/Taffybar/DBus.hs
@@ -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
diff --git a/src/System/Taffybar/DBus/Client/Login1Manager.hs b/src/System/Taffybar/DBus/Client/Login1Manager.hs
new file mode 100644
--- /dev/null
+++ b/src/System/Taffybar/DBus/Client/Login1Manager.hs
@@ -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"
diff --git a/src/System/Taffybar/DBus/Client/MPRIS2.hs b/src/System/Taffybar/DBus/Client/MPRIS2.hs
--- a/src/System/Taffybar/DBus/Client/MPRIS2.hs
+++ b/src/System/Taffybar/DBus/Client/MPRIS2.hs
@@ -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"
diff --git a/src/System/Taffybar/DBus/Client/NetworkManager.hs b/src/System/Taffybar/DBus/Client/NetworkManager.hs
--- a/src/System/Taffybar/DBus/Client/NetworkManager.hs
+++ b/src/System/Taffybar/DBus/Client/NetworkManager.hs
@@ -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"
diff --git a/src/System/Taffybar/DBus/Client/NetworkManagerAccessPoint.hs b/src/System/Taffybar/DBus/Client/NetworkManagerAccessPoint.hs
--- a/src/System/Taffybar/DBus/Client/NetworkManagerAccessPoint.hs
+++ b/src/System/Taffybar/DBus/Client/NetworkManagerAccessPoint.hs
@@ -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"
diff --git a/src/System/Taffybar/DBus/Client/NetworkManagerActiveConnection.hs b/src/System/Taffybar/DBus/Client/NetworkManagerActiveConnection.hs
--- a/src/System/Taffybar/DBus/Client/NetworkManagerActiveConnection.hs
+++ b/src/System/Taffybar/DBus/Client/NetworkManagerActiveConnection.hs
@@ -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"
diff --git a/src/System/Taffybar/DBus/Client/Params.hs b/src/System/Taffybar/DBus/Client/Params.hs
--- a/src/System/Taffybar/DBus/Client/Params.hs
+++ b/src/System/Taffybar/DBus/Client/Params.hs
@@ -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
diff --git a/src/System/Taffybar/DBus/Client/PulseAudioCore.hs b/src/System/Taffybar/DBus/Client/PulseAudioCore.hs
--- a/src/System/Taffybar/DBus/Client/PulseAudioCore.hs
+++ b/src/System/Taffybar/DBus/Client/PulseAudioCore.hs
@@ -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"
diff --git a/src/System/Taffybar/DBus/Client/PulseAudioDevice.hs b/src/System/Taffybar/DBus/Client/PulseAudioDevice.hs
--- a/src/System/Taffybar/DBus/Client/PulseAudioDevice.hs
+++ b/src/System/Taffybar/DBus/Client/PulseAudioDevice.hs
@@ -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"
diff --git a/src/System/Taffybar/DBus/Client/PulseAudioServerLookup.hs b/src/System/Taffybar/DBus/Client/PulseAudioServerLookup.hs
--- a/src/System/Taffybar/DBus/Client/PulseAudioServerLookup.hs
+++ b/src/System/Taffybar/DBus/Client/PulseAudioServerLookup.hs
@@ -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"
diff --git a/src/System/Taffybar/DBus/Client/UPower.hs b/src/System/Taffybar/DBus/Client/UPower.hs
--- a/src/System/Taffybar/DBus/Client/UPower.hs
+++ b/src/System/Taffybar/DBus/Client/UPower.hs
@@ -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"
diff --git a/src/System/Taffybar/DBus/Client/UPowerDevice.hs b/src/System/Taffybar/DBus/Client/UPowerDevice.hs
--- a/src/System/Taffybar/DBus/Client/UPowerDevice.hs
+++ b/src/System/Taffybar/DBus/Client/UPowerDevice.hs
@@ -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"
diff --git a/src/System/Taffybar/DBus/Client/Util.hs b/src/System/Taffybar/DBus/Client/Util.hs
--- a/src/System/Taffybar/DBus/Client/Util.hs
+++ b/src/System/Taffybar/DBus/Client/Util.hs
@@ -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
diff --git a/src/System/Taffybar/DBus/Toggle.hs b/src/System/Taffybar/DBus/Toggle.hs
--- a/src/System/Taffybar/DBus/Toggle.hs
+++ b/src/System/Taffybar/DBus/Toggle.hs
@@ -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
+ }
diff --git a/src/System/Taffybar/Example.hs b/src/System/Taffybar/Example.hs
--- a/src/System/Taffybar/Example.hs
+++ b/src/System/Taffybar/Example.hs
@@ -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
diff --git a/src/System/Taffybar/Hooks.hs b/src/System/Taffybar/Hooks.hs
--- a/src/System/Taffybar/Hooks.hs
+++ b/src/System/Taffybar/Hooks.hs
@@ -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
diff --git a/src/System/Taffybar/Hyprland.hs b/src/System/Taffybar/Hyprland.hs
--- a/src/System/Taffybar/Hyprland.hs
+++ b/src/System/Taffybar/Hyprland.hs
@@ -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
diff --git a/src/System/Taffybar/Information/ASUS.hs b/src/System/Taffybar/Information/ASUS.hs
new file mode 100644
--- /dev/null
+++ b/src/System/Taffybar/Information/ASUS.hs
@@ -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
diff --git a/src/System/Taffybar/Information/Backlight.hs b/src/System/Taffybar/Information/Backlight.hs
--- a/src/System/Taffybar/Information/Backlight.hs
+++ b/src/System/Taffybar/Information/Backlight.hs
@@ -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
diff --git a/src/System/Taffybar/Information/Battery.hs b/src/System/Taffybar/Information/Battery.hs
--- a/src/System/Taffybar/Information/Battery.hs
+++ b/src/System/Taffybar/Information/Battery.hs
@@ -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
diff --git a/src/System/Taffybar/Information/Bluetooth.hs b/src/System/Taffybar/Information/Bluetooth.hs
--- a/src/System/Taffybar/Information/Bluetooth.hs
+++ b/src/System/Taffybar/Information/Bluetooth.hs
@@ -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
+ }
diff --git a/src/System/Taffybar/Information/CPU.hs b/src/System/Taffybar/Information/CPU.hs
--- a/src/System/Taffybar/Information/CPU.hs
+++ b/src/System/Taffybar/Information/CPU.hs
@@ -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)
diff --git a/src/System/Taffybar/Information/CPU2.hs b/src/System/Taffybar/Information/CPU2.hs
--- a/src/System/Taffybar/Information/CPU2.hs
+++ b/src/System/Taffybar/Information/CPU2.hs
@@ -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
diff --git a/src/System/Taffybar/Information/Chrome.hs b/src/System/Taffybar/Information/Chrome.hs
--- a/src/System/Taffybar/Information/Chrome.hs
+++ b/src/System/Taffybar/Information/Chrome.hs
@@ -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
diff --git a/src/System/Taffybar/Information/Crypto.hs b/src/System/Taffybar/Information/Crypto.hs
--- a/src/System/Taffybar/Information/Crypto.hs
+++ b/src/System/Taffybar/Information/Crypto.hs
@@ -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
diff --git a/src/System/Taffybar/Information/DiskIO.hs b/src/System/Taffybar/Information/DiskIO.hs
--- a/src/System/Taffybar/Information/DiskIO.hs
+++ b/src/System/Taffybar/Information/DiskIO.hs
@@ -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])
-
diff --git a/src/System/Taffybar/Information/DiskUsage.hs b/src/System/Taffybar/Information/DiskUsage.hs
--- a/src/System/Taffybar/Information/DiskUsage.hs
+++ b/src/System/Taffybar/Information/DiskUsage.hs
@@ -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
diff --git a/src/System/Taffybar/Information/EWMHDesktopInfo.hs b/src/System/Taffybar/Information/EWMHDesktopInfo.hs
--- a/src/System/Taffybar/Information/EWMHDesktopInfo.hs
+++ b/src/System/Taffybar/Information/EWMHDesktopInfo.hs
@@ -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)
diff --git a/src/System/Taffybar/Information/Hyprland.hs b/src/System/Taffybar/Information/Hyprland.hs
--- a/src/System/Taffybar/Information/Hyprland.hs
+++ b/src/System/Taffybar/Information/Hyprland.hs
@@ -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
diff --git a/src/System/Taffybar/Information/Hyprland/API.hs b/src/System/Taffybar/Information/Hyprland/API.hs
new file mode 100644
--- /dev/null
+++ b/src/System/Taffybar/Information/Hyprland/API.hs
@@ -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 @
+ DispatchWorkspace HyprlandWorkspaceTarget
+ | -- | @hyprctl dispatch focuswindow address:@
+ 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)]
diff --git a/src/System/Taffybar/Information/Hyprland/Types.hs b/src/System/Taffybar/Information/Hyprland/Types.hs
new file mode 100644
--- /dev/null
+++ b/src/System/Taffybar/Information/Hyprland/Types.hs
@@ -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"
diff --git a/src/System/Taffybar/Information/Inhibitor.hs b/src/System/Taffybar/Information/Inhibitor.hs
--- a/src/System/Taffybar/Information/Inhibitor.hs
+++ b/src/System/Taffybar/Information/Inhibitor.hs
@@ -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"
diff --git a/src/System/Taffybar/Information/KeyboardState.hs b/src/System/Taffybar/Information/KeyboardState.hs
--- a/src/System/Taffybar/Information/KeyboardState.hs
+++ b/src/System/Taffybar/Information/KeyboardState.hs
@@ -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
+ }
diff --git a/src/System/Taffybar/Information/MPRIS2.hs b/src/System/Taffybar/Information/MPRIS2.hs
--- a/src/System/Taffybar/Information/MPRIS2.hs
+++ b/src/System/Taffybar/Information/MPRIS2.hs
@@ -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
diff --git a/src/System/Taffybar/Information/Memory.hs b/src/System/Taffybar/Information/Memory.hs
--- a/src/System/Taffybar/Information/Memory.hs
+++ b/src/System/Taffybar/Information/Memory.hs
@@ -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
+ }
diff --git a/src/System/Taffybar/Information/Network.hs b/src/System/Taffybar/Information/Network.hs
--- a/src/System/Taffybar/Information/Network.hs
+++ b/src/System/Taffybar/Information/Network.hs
@@ -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
diff --git a/src/System/Taffybar/Information/NetworkManager.hs b/src/System/Taffybar/Information/NetworkManager.hs
--- a/src/System/Taffybar/Information/NetworkManager.hs
+++ b/src/System/Taffybar/Information/NetworkManager.hs
@@ -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
diff --git a/src/System/Taffybar/Information/PowerProfiles.hs b/src/System/Taffybar/Information/PowerProfiles.hs
--- a/src/System/Taffybar/Information/PowerProfiles.hs
+++ b/src/System/Taffybar/Information/PowerProfiles.hs
@@ -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
diff --git a/src/System/Taffybar/Information/Privacy.hs b/src/System/Taffybar/Information/Privacy.hs
--- a/src/System/Taffybar/Information/Privacy.hs
+++ b/src/System/Taffybar/Information/Privacy.hs
@@ -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
diff --git a/src/System/Taffybar/Information/PulseAudio.hs b/src/System/Taffybar/Information/PulseAudio.hs
--- a/src/System/Taffybar/Information/PulseAudio.hs
+++ b/src/System/Taffybar/Information/PulseAudio.hs
@@ -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
diff --git a/src/System/Taffybar/Information/SafeX11.hs b/src/System/Taffybar/Information/SafeX11.hs
--- a/src/System/Taffybar/Information/SafeX11.hs
+++ b/src/System/Taffybar/Information/SafeX11.hs
@@ -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
diff --git a/src/System/Taffybar/Information/ScreenLock.hs b/src/System/Taffybar/Information/ScreenLock.hs
--- a/src/System/Taffybar/Information/ScreenLock.hs
+++ b/src/System/Taffybar/Information/ScreenLock.hs
@@ -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"
diff --git a/src/System/Taffybar/Information/StreamInfo.hs b/src/System/Taffybar/Information/StreamInfo.hs
--- a/src/System/Taffybar/Information/StreamInfo.hs
+++ b/src/System/Taffybar/Information/StreamInfo.hs
@@ -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
diff --git a/src/System/Taffybar/Information/Systemd.hs b/src/System/Taffybar/Information/Systemd.hs
--- a/src/System/Taffybar/Information/Systemd.hs
+++ b/src/System/Taffybar/Information/Systemd.hs
@@ -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")
diff --git a/src/System/Taffybar/Information/Temperature.hs b/src/System/Taffybar/Information/Temperature.hs
--- a/src/System/Taffybar/Information/Temperature.hs
+++ b/src/System/Taffybar/Information/Temperature.hs
@@ -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 (== ' ')
diff --git a/src/System/Taffybar/Information/Udev.hs b/src/System/Taffybar/Information/Udev.hs
--- a/src/System/Taffybar/Information/Udev.hs
+++ b/src/System/Taffybar/Information/Udev.hs
@@ -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)
diff --git a/src/System/Taffybar/Information/Wakeup.hs b/src/System/Taffybar/Information/Wakeup.hs
new file mode 100644
--- /dev/null
+++ b/src/System/Taffybar/Information/Wakeup.hs
@@ -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"
diff --git a/src/System/Taffybar/Information/Wakeup/Manager.hs b/src/System/Taffybar/Information/Wakeup/Manager.hs
new file mode 100644
--- /dev/null
+++ b/src/System/Taffybar/Information/Wakeup/Manager.hs
@@ -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"
diff --git a/src/System/Taffybar/Information/WirePlumber.hs b/src/System/Taffybar/Information/WirePlumber.hs
--- a/src/System/Taffybar/Information/WirePlumber.hs
+++ b/src/System/Taffybar/Information/WirePlumber.hs
@@ -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.
--
diff --git a/src/System/Taffybar/Information/Wlsunset.hs b/src/System/Taffybar/Information/Wlsunset.hs
--- a/src/System/Taffybar/Information/Wlsunset.hs
+++ b/src/System/Taffybar/Information/Wlsunset.hs
@@ -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 \@ and @-T \@ 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
diff --git a/src/System/Taffybar/Information/Workspaces/EWMH.hs b/src/System/Taffybar/Information/Workspaces/EWMH.hs
new file mode 100644
--- /dev/null
+++ b/src/System/Taffybar/Information/Workspaces/EWMH.hs
@@ -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)
diff --git a/src/System/Taffybar/Information/Workspaces/Hyprland.hs b/src/System/Taffybar/Information/Workspaces/Hyprland.hs
new file mode 100644
--- /dev/null
+++ b/src/System/Taffybar/Information/Workspaces/Hyprland.hs
@@ -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
+ }
diff --git a/src/System/Taffybar/Information/Workspaces/Model.hs b/src/System/Taffybar/Information/Workspaces/Model.hs
new file mode 100644
--- /dev/null
+++ b/src/System/Taffybar/Information/Workspaces/Model.hs
@@ -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
+ ]
diff --git a/src/System/Taffybar/Information/X11DesktopInfo.hs b/src/System/Taffybar/Information/X11DesktopInfo.hs
--- a/src/System/Taffybar/Information/X11DesktopInfo.hs
+++ b/src/System/Taffybar/Information/X11DesktopInfo.hs
@@ -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
diff --git a/src/System/Taffybar/Information/XDG/Protocol.hs b/src/System/Taffybar/Information/XDG/Protocol.hs
--- a/src/System/Taffybar/Information/XDG/Protocol.hs
+++ b/src/System/Taffybar/Information/XDG/Protocol.hs
@@ -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
+ )
diff --git a/src/System/Taffybar/LogFormatter.hs b/src/System/Taffybar/LogFormatter.hs
--- a/src/System/Taffybar/LogFormatter.hs
+++ b/src/System/Taffybar/LogFormatter.hs
@@ -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}
diff --git a/src/System/Taffybar/LogLevels.hs b/src/System/Taffybar/LogLevels.hs
--- a/src/System/Taffybar/LogLevels.hs
+++ b/src/System/Taffybar/LogLevels.hs
@@ -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
diff --git a/src/System/Taffybar/SimpleConfig.hs b/src/System/Taffybar/SimpleConfig.hs
--- a/src/System/Taffybar/SimpleConfig.hs
+++ b/src/System/Taffybar/SimpleConfig.hs
@@ -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)
diff --git a/src/System/Taffybar/Support/PagerHints.hs b/src/System/Taffybar/Support/PagerHints.hs
--- a/src/System/Taffybar/Support/PagerHints.hs
+++ b/src/System/Taffybar/Support/PagerHints.hs
@@ -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
diff --git a/src/System/Taffybar/Util.hs b/src/System/Taffybar/Util.hs
--- a/src/System/Taffybar/Util.hs
+++ b/src/System/Taffybar/Util.hs
@@ -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)
diff --git a/src/System/Taffybar/Widget.hs b/src/System/Taffybar/Widget.hs
--- a/src/System/Taffybar/Widget.hs
+++ b/src/System/Taffybar/Widget.hs
@@ -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
diff --git a/src/System/Taffybar/Widget/ASUS.hs b/src/System/Taffybar/Widget/ASUS.hs
new file mode 100644
--- /dev/null
+++ b/src/System/Taffybar/Widget/ASUS.hs
@@ -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: @\ \ \@, 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
diff --git a/src/System/Taffybar/Widget/Backlight.hs b/src/System/Taffybar/Widget/Backlight.hs
--- a/src/System/Taffybar/Widget/Backlight.hs
+++ b/src/System/Taffybar/Widget/Backlight.hs
@@ -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 =
diff --git a/src/System/Taffybar/Widget/Battery.hs b/src/System/Taffybar/Widget/Battery.hs
--- a/src/System/Taffybar/Widget/Battery.hs
+++ b/src/System/Taffybar/Widget/Battery.hs
@@ -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
diff --git a/src/System/Taffybar/Widget/BatteryDonut.hs b/src/System/Taffybar/Widget/BatteryDonut.hs
--- a/src/System/Taffybar/Widget/BatteryDonut.hs
+++ b/src/System/Taffybar/Widget/BatteryDonut.hs
@@ -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
diff --git a/src/System/Taffybar/Widget/BatteryTextIcon.hs b/src/System/Taffybar/Widget/BatteryTextIcon.hs
--- a/src/System/Taffybar/Widget/BatteryTextIcon.hs
+++ b/src/System/Taffybar/Widget/BatteryTextIcon.hs
@@ -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
diff --git a/src/System/Taffybar/Widget/Bluetooth.hs b/src/System/Taffybar/Widget/Bluetooth.hs
--- a/src/System/Taffybar/Widget/Bluetooth.hs
+++ b/src/System/Taffybar/Widget/Bluetooth.hs
@@ -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.
diff --git a/src/System/Taffybar/Widget/CPUMonitor.hs b/src/System/Taffybar/Widget/CPUMonitor.hs
--- a/src/System/Taffybar/Widget/CPUMonitor.hs
+++ b/src/System/Taffybar/Widget/CPUMonitor.hs
@@ -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]
diff --git a/src/System/Taffybar/Widget/ChannelWorkspaces.hs b/src/System/Taffybar/Widget/ChannelWorkspaces.hs
new file mode 100644
--- /dev/null
+++ b/src/System/Taffybar/Widget/ChannelWorkspaces.hs
@@ -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
diff --git a/src/System/Taffybar/Widget/CommandRunner.hs b/src/System/Taffybar/Widget/CommandRunner.hs
--- a/src/System/Taffybar/Widget/CommandRunner.hs
+++ b/src/System/Taffybar/Widget/CommandRunner.hs
@@ -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
diff --git a/src/System/Taffybar/Widget/Crypto.hs b/src/System/Taffybar/Widget/Crypto.hs
--- a/src/System/Taffybar/Widget/Crypto.hs
+++ b/src/System/Taffybar/Widget/Crypto.hs
@@ -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"))
diff --git a/src/System/Taffybar/Widget/DiskIOMonitor.hs b/src/System/Taffybar/Widget/DiskIOMonitor.hs
--- a/src/System/Taffybar/Widget/DiskIOMonitor.hs
+++ b/src/System/Taffybar/Widget/DiskIOMonitor.hs
@@ -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
diff --git a/src/System/Taffybar/Widget/DiskUsage.hs b/src/System/Taffybar/Widget/DiskUsage.hs
--- a/src/System/Taffybar/Widget/DiskUsage.hs
+++ b/src/System/Taffybar/Widget/DiskUsage.hs
@@ -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
diff --git a/src/System/Taffybar/Widget/FSMonitor.hs b/src/System/Taffybar/Widget/FSMonitor.hs
--- a/src/System/Taffybar/Widget/FSMonitor.hs
+++ b/src/System/Taffybar/Widget/FSMonitor.hs
@@ -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
diff --git a/src/System/Taffybar/Widget/FreedesktopNotifications.hs b/src/System/Taffybar/Widget/FreedesktopNotifications.hs
--- a/src/System/Taffybar/Widget/FreedesktopNotifications.hs
+++ b/src/System/Taffybar/Widget/FreedesktopNotifications.hs
@@ -2,6 +2,7 @@
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE ScopedTypeVariables #-}
+
-- | This widget listens on DBus for freedesktop notifications
-- (). 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 "" <> prefix <> "" <> 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 "" <> prefix <> "" <> 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
diff --git a/src/System/Taffybar/Widget/Generic/AutoFillImage.hs b/src/System/Taffybar/Widget/Generic/AutoFillImage.hs
--- a/src/System/Taffybar/Widget/Generic/AutoFillImage.hs
+++ b/src/System/Taffybar/Widget/Generic/AutoFillImage.hs
@@ -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
diff --git a/src/System/Taffybar/Widget/Generic/AutoSizeImage.hs b/src/System/Taffybar/Widget/Generic/AutoSizeImage.hs
--- a/src/System/Taffybar/Widget/Generic/AutoSizeImage.hs
+++ b/src/System/Taffybar/Widget/Generic/AutoSizeImage.hs
@@ -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
diff --git a/src/System/Taffybar/Widget/Generic/ChannelGraph.hs b/src/System/Taffybar/Widget/Generic/ChannelGraph.hs
--- a/src/System/Taffybar/Widget/Generic/ChannelGraph.hs
+++ b/src/System/Taffybar/Widget/Generic/ChannelGraph.hs
@@ -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
diff --git a/src/System/Taffybar/Widget/Generic/ChannelWidget.hs b/src/System/Taffybar/Widget/Generic/ChannelWidget.hs
--- a/src/System/Taffybar/Widget/Generic/ChannelWidget.hs
+++ b/src/System/Taffybar/Widget/Generic/ChannelWidget.hs
@@ -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
diff --git a/src/System/Taffybar/Widget/Generic/DynamicMenu.hs b/src/System/Taffybar/Widget/Generic/DynamicMenu.hs
--- a/src/System/Taffybar/Widget/Generic/DynamicMenu.hs
+++ b/src/System/Taffybar/Widget/Generic/DynamicMenu.hs
@@ -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 ->
diff --git a/src/System/Taffybar/Widget/Generic/Graph.hs b/src/System/Taffybar/Widget/Generic/Graph.hs
--- a/src/System/Taffybar/Widget/Generic/Graph.hs
+++ b/src/System/Taffybar/Widget/Generic/Graph.hs
@@ -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
diff --git a/src/System/Taffybar/Widget/Generic/Icon.hs b/src/System/Taffybar/Widget/Generic/Icon.hs
--- a/src/System/Taffybar/Widget/Generic/Icon.hs
+++ b/src/System/Taffybar/Widget/Generic/Icon.hs
@@ -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
diff --git a/src/System/Taffybar/Widget/Generic/PollingBar.hs b/src/System/Taffybar/Widget/Generic/PollingBar.hs
--- a/src/System/Taffybar/Widget/Generic/PollingBar.hs
+++ b/src/System/Taffybar/Widget/Generic/PollingBar.hs
@@ -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
diff --git a/src/System/Taffybar/Widget/Generic/PollingGraph.hs b/src/System/Taffybar/Widget/Generic/PollingGraph.hs
--- a/src/System/Taffybar/Widget/Generic/PollingGraph.hs
+++ b/src/System/Taffybar/Widget/Generic/PollingGraph.hs
@@ -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
diff --git a/src/System/Taffybar/Widget/Generic/PollingLabel.hs b/src/System/Taffybar/Widget/Generic/PollingLabel.hs
--- a/src/System/Taffybar/Widget/Generic/PollingLabel.hs
+++ b/src/System/Taffybar/Widget/Generic/PollingLabel.hs
@@ -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
diff --git a/src/System/Taffybar/Widget/Generic/ScalingImage.hs b/src/System/Taffybar/Widget/Generic/ScalingImage.hs
--- a/src/System/Taffybar/Widget/Generic/ScalingImage.hs
+++ b/src/System/Taffybar/Widget/Generic/ScalingImage.hs
@@ -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
diff --git a/src/System/Taffybar/Widget/Generic/VerticalBar.hs b/src/System/Taffybar/Widget/Generic/VerticalBar.hs
--- a/src/System/Taffybar/Widget/Generic/VerticalBar.hs
+++ b/src/System/Taffybar/Widget/Generic/VerticalBar.hs
@@ -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
diff --git a/src/System/Taffybar/Widget/HyprlandLayout.hs b/src/System/Taffybar/Widget/HyprlandLayout.hs
--- a/src/System/Taffybar/Widget/HyprlandLayout.hs
+++ b/src/System/Taffybar/Widget/HyprlandLayout.hs
@@ -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
diff --git a/src/System/Taffybar/Widget/HyprlandWindows.hs b/src/System/Taffybar/Widget/HyprlandWindows.hs
deleted file mode 100644
--- a/src/System/Taffybar/Widget/HyprlandWindows.hs
+++ /dev/null
@@ -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 ()
diff --git a/src/System/Taffybar/Widget/HyprlandWorkspaces.hs b/src/System/Taffybar/Widget/HyprlandWorkspaces.hs
--- a/src/System/Taffybar/Widget/HyprlandWorkspaces.hs
+++ b/src/System/Taffybar/Widget/HyprlandWorkspaces.hs
@@ -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
- }
diff --git a/src/System/Taffybar/Widget/ImageCommandButton.hs b/src/System/Taffybar/Widget/ImageCommandButton.hs
new file mode 100644
--- /dev/null
+++ b/src/System/Taffybar/Widget/ImageCommandButton.hs
@@ -0,0 +1,80 @@
+--------------------------------------------------------------------------------
+
+--------------------------------------------------------------------------------
+
+-- |
+-- Module : System.Taffybar.Widget.ImageCommandButton
+-- Copyright : (c) Ulf Jasper
+-- License : BSD3-style (see LICENSE)
+--
+-- Maintainer : Ulf Jasper
+-- 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
diff --git a/src/System/Taffybar/Widget/Inhibitor.hs b/src/System/Taffybar/Widget/Inhibitor.hs
--- a/src/System/Taffybar/Widget/Inhibitor.hs
+++ b/src/System/Taffybar/Widget/Inhibitor.hs
@@ -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
diff --git a/src/System/Taffybar/Widget/KeyboardState.hs b/src/System/Taffybar/Widget/KeyboardState.hs
--- a/src/System/Taffybar/Widget/KeyboardState.hs
+++ b/src/System/Taffybar/Widget/KeyboardState.hs
@@ -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
diff --git a/src/System/Taffybar/Widget/Layout.hs b/src/System/Taffybar/Widget/Layout.hs
--- a/src/System/Taffybar/Widget/Layout.hs
+++ b/src/System/Taffybar/Widget/Layout.hs
@@ -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
diff --git a/src/System/Taffybar/Widget/MPRIS2.hs b/src/System/Taffybar/Widget/MPRIS2.hs
--- a/src/System/Taffybar/Widget/MPRIS2.hs
+++ b/src/System/Taffybar/Widget/MPRIS2.hs
@@ -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
-- ().
------------------------------------------------------------------------------
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
diff --git a/src/System/Taffybar/Widget/NetworkGraph.hs b/src/System/Taffybar/Widget/NetworkGraph.hs
--- a/src/System/Taffybar/Widget/NetworkGraph.hs
+++ b/src/System/Taffybar/Widget/NetworkGraph.hs
@@ -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
diff --git a/src/System/Taffybar/Widget/NetworkManager.hs b/src/System/Taffybar/Widget/NetworkManager.hs
--- a/src/System/Taffybar/Widget/NetworkManager.hs
+++ b/src/System/Taffybar/Widget/NetworkManager.hs
@@ -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")
diff --git a/src/System/Taffybar/Widget/PowerProfiles.hs b/src/System/Taffybar/Widget/PowerProfiles.hs
--- a/src/System/Taffybar/Widget/PowerProfiles.hs
+++ b/src/System/Taffybar/Widget/PowerProfiles.hs
@@ -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
diff --git a/src/System/Taffybar/Widget/Privacy.hs b/src/System/Taffybar/Widget/Privacy.hs
--- a/src/System/Taffybar/Widget/Privacy.hs
+++ b/src/System/Taffybar/Widget/Privacy.hs
@@ -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
diff --git a/src/System/Taffybar/Widget/PulseAudio.hs b/src/System/Taffybar/Widget/PulseAudio.hs
--- a/src/System/Taffybar/Widget/PulseAudio.hs
+++ b/src/System/Taffybar/Widget/PulseAudio.hs
@@ -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
diff --git a/src/System/Taffybar/Widget/SNIMenu.hs b/src/System/Taffybar/Widget/SNIMenu.hs
--- a/src/System/Taffybar/Widget/SNIMenu.hs
+++ b/src/System/Taffybar/Widget/SNIMenu.hs
@@ -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"
diff --git a/src/System/Taffybar/Widget/SNITray.hs b/src/System/Taffybar/Widget/SNITray.hs
--- a/src/System/Taffybar/Widget/SNITray.hs
+++ b/src/System/Taffybar/Widget/SNITray.hs
@@ -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
-
diff --git a/src/System/Taffybar/Widget/SNITray/PrioritizedCollapsible.hs b/src/System/Taffybar/Widget/SNITray/PrioritizedCollapsible.hs
new file mode 100644
--- /dev/null
+++ b/src/System/Taffybar/Widget/SNITray/PrioritizedCollapsible.hs
@@ -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
diff --git a/src/System/Taffybar/Widget/ScreenLock.hs b/src/System/Taffybar/Widget/ScreenLock.hs
--- a/src/System/Taffybar/Widget/ScreenLock.hs
+++ b/src/System/Taffybar/Widget/ScreenLock.hs
@@ -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
diff --git a/src/System/Taffybar/Widget/SimpleClock.hs b/src/System/Taffybar/Widget/SimpleClock.hs
--- a/src/System/Taffybar/Widget/SimpleClock.hs
+++ b/src/System/Taffybar/Widget/SimpleClock.hs
@@ -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
-- ().
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
diff --git a/src/System/Taffybar/Widget/SimpleCommandButton.hs b/src/System/Taffybar/Widget/SimpleCommandButton.hs
--- a/src/System/Taffybar/Widget/SimpleCommandButton.hs
+++ b/src/System/Taffybar/Widget/SimpleCommandButton.hs
@@ -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
diff --git a/src/System/Taffybar/Widget/Systemd.hs b/src/System/Taffybar/Widget/Systemd.hs
--- a/src/System/Taffybar/Widget/Systemd.hs
+++ b/src/System/Taffybar/Widget/Systemd.hs
@@ -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.
diff --git a/src/System/Taffybar/Widget/Temperature.hs b/src/System/Taffybar/Widget/Temperature.hs
--- a/src/System/Taffybar/Widget/Temperature.hs
+++ b/src/System/Taffybar/Widget/Temperature.hs
@@ -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"
diff --git a/src/System/Taffybar/Widget/Text/CPUMonitor.hs b/src/System/Taffybar/Widget/Text/CPUMonitor.hs
--- a/src/System/Taffybar/Widget/Text/CPUMonitor.hs
+++ b/src/System/Taffybar/Widget/Text/CPUMonitor.hs
@@ -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"
diff --git a/src/System/Taffybar/Widget/Text/MemoryMonitor.hs b/src/System/Taffybar/Widget/Text/MemoryMonitor.hs
--- a/src/System/Taffybar/Widget/Text/MemoryMonitor.hs
+++ b/src/System/Taffybar/Widget/Text/MemoryMonitor.hs
@@ -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
diff --git a/src/System/Taffybar/Widget/Text/NetworkMonitor.hs b/src/System/Taffybar/Widget/Text/NetworkMonitor.hs
--- a/src/System/Taffybar/Widget/Text/NetworkMonitor.hs
+++ b/src/System/Taffybar/Widget/Text/NetworkMonitor.hs
@@ -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
diff --git a/src/System/Taffybar/Widget/Util.hs b/src/System/Taffybar/Widget/Util.hs
--- a/src/System/Taffybar/Widget/Util.hs
+++ b/src/System/Taffybar/Widget/Util.hs
@@ -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 "%s" (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.
--
diff --git a/src/System/Taffybar/Widget/WakeupDebug.hs b/src/System/Taffybar/Widget/WakeupDebug.hs
new file mode 100644
--- /dev/null
+++ b/src/System/Taffybar/Widget/WakeupDebug.hs
@@ -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
diff --git a/src/System/Taffybar/Widget/Weather.hs b/src/System/Taffybar/Widget/Weather.hs
--- a/src/System/Taffybar/Widget/Weather.hs
+++ b/src/System/Taffybar/Widget/Weather.hs
@@ -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
diff --git a/src/System/Taffybar/Widget/Windows.hs b/src/System/Taffybar/Widget/Windows.hs
--- a/src/System/Taffybar/Widget/Windows.hs
+++ b/src/System/Taffybar/Widget/Windows.hs
@@ -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
+ ]
diff --git a/src/System/Taffybar/Widget/WirePlumber.hs b/src/System/Taffybar/Widget/WirePlumber.hs
--- a/src/System/Taffybar/Widget/WirePlumber.hs
+++ b/src/System/Taffybar/Widget/WirePlumber.hs
@@ -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 ->
diff --git a/src/System/Taffybar/Widget/Wlsunset.hs b/src/System/Taffybar/Widget/Wlsunset.hs
--- a/src/System/Taffybar/Widget/Wlsunset.hs
+++ b/src/System/Taffybar/Widget/Wlsunset.hs
@@ -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
diff --git a/src/System/Taffybar/Widget/Workspaces.hs b/src/System/Taffybar/Widget/Workspaces.hs
--- a/src/System/Taffybar/Widget/Workspaces.hs
+++ b/src/System/Taffybar/Widget/Workspaces.hs
@@ -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
diff --git a/src/System/Taffybar/Widget/Workspaces/Channel.hs b/src/System/Taffybar/Widget/Workspaces/Channel.hs
new file mode 100644
--- /dev/null
+++ b/src/System/Taffybar/Widget/Workspaces/Channel.hs
@@ -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
diff --git a/src/System/Taffybar/Widget/Workspaces/Common.hs b/src/System/Taffybar/Widget/Workspaces/Common.hs
new file mode 100644
--- /dev/null
+++ b/src/System/Taffybar/Widget/Workspaces/Common.hs
@@ -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
diff --git a/src/System/Taffybar/Widget/Workspaces/Config.hs b/src/System/Taffybar/Widget/Workspaces/Config.hs
new file mode 100644
--- /dev/null
+++ b/src/System/Taffybar/Widget/Workspaces/Config.hs
@@ -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
+ }
diff --git a/src/System/Taffybar/Widget/Workspaces/EWMH.hs b/src/System/Taffybar/Widget/Workspaces/EWMH.hs
new file mode 100644
--- /dev/null
+++ b/src/System/Taffybar/Widget/Workspaces/EWMH.hs
@@ -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}
diff --git a/src/System/Taffybar/Widget/Workspaces/EWMH/Compat.hs b/src/System/Taffybar/Widget/Workspaces/EWMH/Compat.hs
new file mode 100644
--- /dev/null
+++ b/src/System/Taffybar/Widget/Workspaces/EWMH/Compat.hs
@@ -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
diff --git a/src/System/Taffybar/Widget/Workspaces/Hyprland.hs b/src/System/Taffybar/Widget/Workspaces/Hyprland.hs
new file mode 100644
--- /dev/null
+++ b/src/System/Taffybar/Widget/Workspaces/Hyprland.hs
@@ -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
+ }
diff --git a/src/System/Taffybar/Widget/Workspaces/Hyprland/Compat.hs b/src/System/Taffybar/Widget/Workspaces/Hyprland/Compat.hs
new file mode 100644
--- /dev/null
+++ b/src/System/Taffybar/Widget/Workspaces/Hyprland/Compat.hs
@@ -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
diff --git a/src/System/Taffybar/Widget/Workspaces/Shared.hs b/src/System/Taffybar/Widget/Workspaces/Shared.hs
--- a/src/System/Taffybar/Widget/Workspaces/Shared.hs
+++ b/src/System/Taffybar/Widget/Workspaces/Shared.hs
@@ -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}
diff --git a/src/System/Taffybar/Widget/Workspaces/X11.hs b/src/System/Taffybar/Widget/Workspaces/X11.hs
new file mode 100644
--- /dev/null
+++ b/src/System/Taffybar/Widget/Workspaces/X11.hs
@@ -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
diff --git a/src/System/Taffybar/Widget/WttrIn.hs b/src/System/Taffybar/Widget/WttrIn.hs
--- a/src/System/Taffybar/Widget/WttrIn.hs
+++ b/src/System/Taffybar/Widget/WttrIn.hs
@@ -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
diff --git a/src/System/Taffybar/Widget/XDGMenu/Menu.hs b/src/System/Taffybar/Widget/XDGMenu/Menu.hs
--- a/src/System/Taffybar/Widget/XDGMenu/Menu.hs
+++ b/src/System/Taffybar/Widget/XDGMenu/Menu.hs
@@ -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
diff --git a/src/System/Taffybar/Widget/XDGMenu/MenuWidget.hs b/src/System/Taffybar/Widget/XDGMenu/MenuWidget.hs
--- a/src/System/Taffybar/Widget/XDGMenu/MenuWidget.hs
+++ b/src/System/Taffybar/Widget/XDGMenu/MenuWidget.hs
@@ -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
diff --git a/src/System/Taffybar/Window/FocusedMonitor.hs b/src/System/Taffybar/Window/FocusedMonitor.hs
new file mode 100644
--- /dev/null
+++ b/src/System/Taffybar/Window/FocusedMonitor.hs
@@ -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
diff --git a/src/System/Taffybar/WindowIcon.hs b/src/System/Taffybar/WindowIcon.hs
--- a/src/System/Taffybar/WindowIcon.hs
+++ b/src/System/Taffybar/WindowIcon.hs
@@ -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
diff --git a/taffybar.cabal b/taffybar.cabal
--- a/taffybar.cabal
+++ b/taffybar.cabal
@@ -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
diff --git a/taffybar.css b/taffybar.css
--- a/taffybar.css
+++ b/taffybar.css
@@ -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;
}
diff --git a/test/data/appearance-ewmh-bar-levels.png b/test/data/appearance-ewmh-bar-levels.png
new file mode 100644
Binary files /dev/null and b/test/data/appearance-ewmh-bar-levels.png differ
diff --git a/test/data/appearance-test.css b/test/data/appearance-test.css
--- a/test/data/appearance-test.css
+++ b/test/data/appearance-test.css
@@ -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;
diff --git a/test/lib/System/Taffybar/Test/DBusSpec.hs b/test/lib/System/Taffybar/Test/DBusSpec.hs
--- a/test/lib/System/Taffybar/Test/DBusSpec.hs
+++ b/test/lib/System/Taffybar/Test/DBusSpec.hs
@@ -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
- [ ""
- , ""
- , " " ++ busName bus ++ ""
- , " "
- , " " ++ addr ++ ""
- , " " ++ serviceDir ++ ""
- , " "
- , " "
- , " "
- , " "
- , " "
- , ""
- ]
+ writeFile configFile $
+ unlines
+ [ "",
+ "",
+ " " ++ busName bus ++ "",
+ " ",
+ " " ++ addr ++ "",
+ " " ++ serviceDir ++ "",
+ " ",
+ " ",
+ " ",
+ " ",
+ " ",
+ ""
+ ]
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"
+ }
diff --git a/test/lib/System/Taffybar/Test/UtilSpec.hs b/test/lib/System/Taffybar/Test/UtilSpec.hs
--- a/test/lib/System/Taffybar/Test/UtilSpec.hs
+++ b/test/lib/System/Taffybar/Test/UtilSpec.hs
@@ -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
diff --git a/test/lib/System/Taffybar/Test/XvfbSpec.hs b/test/lib/System/Taffybar/Test/XvfbSpec.hs
--- a/test/lib/System/Taffybar/Test/XvfbSpec.hs
+++ b/test/lib/System/Taffybar/Test/XvfbSpec.hs
@@ -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
diff --git a/test/unit/System/Taffybar/AppearanceSpec.hs b/test/unit/System/Taffybar/AppearanceSpec.hs
--- a/test/unit/System/Taffybar/AppearanceSpec.hs
+++ b/test/unit/System/Taffybar/AppearanceSpec.hs
@@ -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
diff --git a/test/unit/System/Taffybar/AuthSpec.hs b/test/unit/System/Taffybar/AuthSpec.hs
--- a/test/unit/System/Taffybar/AuthSpec.hs
+++ b/test/unit/System/Taffybar/AuthSpec.hs
@@ -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"
+ ]
diff --git a/test/unit/System/Taffybar/ContextSpec.hs b/test/unit/System/Taffybar/ContextSpec.hs
--- a/test/unit/System/Taffybar/ContextSpec.hs
+++ b/test/unit/System/Taffybar/ContextSpec.hs
@@ -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
diff --git a/test/unit/System/Taffybar/Information/CryptoSpec.hs b/test/unit/System/Taffybar/Information/CryptoSpec.hs
new file mode 100644
--- /dev/null
+++ b/test/unit/System/Taffybar/Information/CryptoSpec.hs
@@ -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
diff --git a/test/unit/System/Taffybar/Information/WakeupSpec.hs b/test/unit/System/Taffybar/Information/WakeupSpec.hs
new file mode 100644
--- /dev/null
+++ b/test/unit/System/Taffybar/Information/WakeupSpec.hs
@@ -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
diff --git a/test/unit/System/Taffybar/Information/X11DesktopInfoSpec.hs b/test/unit/System/Taffybar/Information/X11DesktopInfoSpec.hs
--- a/test/unit/System/Taffybar/Information/X11DesktopInfoSpec.hs
+++ b/test/unit/System/Taffybar/Information/X11DesktopInfoSpec.hs
@@ -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")
diff --git a/test/unit/System/Taffybar/SimpleConfigSpec.hs b/test/unit/System/Taffybar/SimpleConfigSpec.hs
--- a/test/unit/System/Taffybar/SimpleConfigSpec.hs
+++ b/test/unit/System/Taffybar/SimpleConfigSpec.hs
@@ -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
diff --git a/test/unit/System/Taffybar/Widget/HyprlandWorkspacesSpec.hs b/test/unit/System/Taffybar/Widget/HyprlandWorkspacesSpec.hs
--- a/test/unit/System/Taffybar/Widget/HyprlandWorkspacesSpec.hs
+++ b/test/unit/System/Taffybar/Widget/HyprlandWorkspacesSpec.hs
@@ -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]
-
diff --git a/test/unit/System/Taffybar/Widget/WindowsSpec.hs b/test/unit/System/Taffybar/Widget/WindowsSpec.hs
new file mode 100644
--- /dev/null
+++ b/test/unit/System/Taffybar/Widget/WindowsSpec.hs
@@ -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 "&" truncated `shouldBe` False
diff --git a/test/unit/System/Taffybar/Widget/Workspaces/ChannelSpec.hs b/test/unit/System/Taffybar/Widget/Workspaces/ChannelSpec.hs
new file mode 100644
--- /dev/null
+++ b/test/unit/System/Taffybar/Widget/Workspaces/ChannelSpec.hs
@@ -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
diff --git a/test/unit/unit-tests.hs b/test/unit/unit-tests.hs
--- a/test/unit/unit-tests.hs
+++ b/test/unit/unit-tests.hs
@@ -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