diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,5 +1,17 @@ # Unreleased +# 5.2.1 + +## Fixes + +* Guard EWMH window-icon property subscriptions behind X11 context presence to + avoid non-X11 build/runtime failures. + +## Tests + +* Simplify appearance snapshot apps/tests to a single workspaces mode by + removing legacy channel-workspaces snapshot wiring and flags. + # 5.2.0 ## New Features diff --git a/app/AppearanceSnap.hs b/app/AppearanceSnap.hs --- a/app/AppearanceSnap.hs +++ b/app/AppearanceSnap.hs @@ -76,15 +76,7 @@ ) import System.Taffybar.Util (postGUIASync) 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 qualified System.Taffybar.Widget.Workspaces as Workspaces import Text.Read (readMaybe) import UnliftIO.Temporary (withSystemTempDirectory) @@ -92,18 +84,12 @@ { 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 @@ -113,7 +99,6 @@ { outFile = outPath, cssFile = cssPath, layoutMode = mode, - workspaceWidgetMode = wsMode, expectedTopStrut = mExpectedTopStrut } <- parseArgs =<< getArgs @@ -156,7 +141,7 @@ -- -- If this fails, the parent Xvfb teardown will still kill the X server, -- which causes the WM to exit. - res <- runUnderWm wmProc outPath cssPath mode wsMode mExpectedTopStrut + res <- runUnderWm wmProc outPath cssPath mode mExpectedTopStrut killProcessNoWait wmProc pure res @@ -167,10 +152,9 @@ FilePath -> FilePath -> LayoutMode -> - WorkspaceWidgetMode -> Maybe Int -> IO ExitCode -runUnderWm wmProc outPath cssPath mode wsMode mExpectedTopStrut = do +runUnderWm wmProc outPath cssPath mode mExpectedTopStrut = do ctxVar <- (newEmptyMVar :: IO (MVar Context)) resultVar <- (newEmptyMVar :: IO (MVar (Either String BL.ByteString))) doneVar <- (newEmptyMVar :: IO (MVar ExitCode)) @@ -185,38 +169,25 @@ void $ forkIO $ watchdogThread wmProc ctxVar resultVar doneVar snapshotWatchdogTimeoutUsec barUnique <- newUnique - 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 - } - } - channelWsCfg = - ChannelWorkspaces.defaultEWMHWorkspacesConfig - { ChannelWorkspaces.labelSetter = const (pure ""), - ChannelWorkspaces.maxIcons = Just 1, - ChannelWorkspaces.minIcons = 1, - ChannelWorkspaces.showWorkspaceFn = const True + let wsCfg = + Workspaces.defaultEWMHWorkspacesConfig + { -- Avoid font-dependent output in the appearance golden: we only care + -- that icons/layout render deterministically. + Workspaces.labelSetter = const (pure ""), + Workspaces.maxIcons = Just 1, + Workspaces.minIcons = 1, + Workspaces.getWindowIconPixbuf = Workspaces.getWindowIconPixbufFromEWMH, + Workspaces.iconSort = Workspaces.sortWindowsByStackIndex, + Workspaces.showWorkspaceFn = const True } - workspaceWidget = - case wsMode of - UseLegacyWorkspaces -> workspacesNew legacyWsCfg - UseChannelWorkspaces -> ChannelWorkspaces.workspacesNew channelWsCfg + workspaceWidget = Workspaces.workspacesNew wsCfg barCfg = buildBarConfig workspaceWidget barUnique mode cfg = def { dbusClientParam = Nothing, cssPaths = [cssPath], getBarConfigsParam = pure [barCfg], - startupHook = scheduleSnapshot ctxVar resultVar wsMode mExpectedTopStrut, + startupHook = scheduleSnapshot ctxVar resultVar mExpectedTopStrut, errorMsg = Nothing } @@ -360,10 +331,9 @@ scheduleSnapshot :: MVar Context -> MVar (Either String BL.ByteString) -> - WorkspaceWidgetMode -> Maybe Int -> TaffyIO () -scheduleSnapshot ctxVar resultVar wsMode mExpectedTopStrut = do +scheduleSnapshot ctxVar resultVar mExpectedTopStrut = do ctx <- ask liftIO $ void (tryPutMVar ctxVar ctx) liftIO $ void $ forkIO (pollLoop ctx) @@ -373,7 +343,7 @@ case done of Just _ -> pure () Nothing -> do - postGUIASync (trySnapshotOnGuiThread ctx' resultVar wsMode mExpectedTopStrut) + postGUIASync (trySnapshotOnGuiThread ctx' resultVar mExpectedTopStrut) threadDelay 50_000 pollLoop ctx' @@ -467,10 +437,9 @@ trySnapshotOnGuiThread :: Context -> MVar (Either String BL.ByteString) -> - WorkspaceWidgetMode -> Maybe Int -> IO () -trySnapshotOnGuiThread ctx resultVar wsMode mExpectedTopStrut = do +trySnapshotOnGuiThread ctx resultVar mExpectedTopStrut = do -- Read the windows list and snapshot the first bar window. ws <- readMVar (existingWindows ctx) case listToMaybe ws of @@ -486,9 +455,7 @@ 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) $ + when (strutReady && isSnapshotReady img) $ void (tryPutMVar resultVar (Right (JP.encodePng img))) getDockTopStrut :: IO (Maybe Int) @@ -518,44 +485,8 @@ (_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 - tol = 40 - opaqueThreshold :: Int - opaqueThreshold = 5000 - near (JP.PixelRGBA8 r g b a) (tr, tg, tb) = - a > 200 - && abs (fromIntegral r - tr) <= tol - && abs (fromIntegral g - tg) <= tol - && abs (fromIntegral b - tb) <= tol - redTarget :: (Int, Int, Int) - redTarget = (224, 58, 58) - greenTarget :: (Int, Int, Int) - greenTarget = (58, 224, 106) - w = JP.imageWidth img - h = JP.imageHeight img - go y seenR seenG opaqueCount - | y >= h = seenR && seenG && opaqueCount > opaqueThreshold - | otherwise = - let goX x sr sg oc - | x >= w = go (y + 1) sr sg oc - | otherwise = - let px = JP.pixelAt img x y - sr1 = sr || near px redTarget - sg1 = sg || near px greenTarget - oc1 = - oc - + (case px of JP.PixelRGBA8 _ _ _ a -> if a > 200 then 1 else 0) - in (sr1 && sg1 && oc1 > opaqueThreshold) || goX (x + 1) sr1 sg1 oc1 - in goX 0 seenR seenG opaqueCount - in go 0 False False (0 :: Int) +isSnapshotReady :: JP.Image JP.PixelRGBA8 -> Bool +isSnapshotReady = imageHasOpaqueContent imageHasOpaqueContent :: JP.Image JP.PixelRGBA8 -> Bool imageHasOpaqueContent img = @@ -628,14 +559,10 @@ | "--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"]) + (`notElem` ["--levels", "--windows-title-stress"]) argsSansTopStrutFlag in case argsSansFlags of ["--out", outPath, "--css", cssPath] -> @@ -644,7 +571,6 @@ { outFile = outPath, cssFile = cssPath, layoutMode = selectedLayoutMode, - workspaceWidgetMode = selectedWorkspaceWidgetMode, expectedTopStrut = mExpectedTopStrut } ["--css", cssPath, "--out", outPath] -> @@ -653,11 +579,10 @@ { 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]" + die "usage: taffybar-appearance-snap --out OUT.png --css appearance-test.css [--levels|--windows-title-stress] [--expect-top-strut N]" where parseTopStrutFlag :: [String] -> (Maybe Int, [String]) parseTopStrutFlag [] = (Nothing, []) diff --git a/app/AppearanceSnapHyprland.hs b/app/AppearanceSnapHyprland.hs --- a/app/AppearanceSnapHyprland.hs +++ b/app/AppearanceSnapHyprland.hs @@ -51,24 +51,18 @@ TaffybarConfig (..), exitTaffybar, ) -import qualified System.Taffybar.Widget.Workspaces as ChannelWorkspaces +import qualified System.Taffybar.Widget.Workspaces as Workspaces import UnliftIO.Temporary (withSystemTempDirectory) data Args = Args { outFile :: FilePath, cssFile :: FilePath, - layoutMode :: LayoutMode, - workspaceWidgetMode :: WorkspaceWidgetMode + layoutMode :: LayoutMode } data LayoutMode = LayoutLegacy | LayoutLevels deriving (Eq, Show) -data WorkspaceWidgetMode - = UseLegacyWorkspaces - | UseChannelWorkspaces - deriving (Eq, Show) - snapshotWatchdogTimeoutUsec :: Int snapshotWatchdogTimeoutUsec = 60_000_000 @@ -77,8 +71,7 @@ Args { outFile = outPath, cssFile = cssPath, - layoutMode = mode, - workspaceWidgetMode = wsMode + layoutMode = mode } <- parseArgs =<< getArgs @@ -117,7 +110,7 @@ createDirectoryIfMissing True (takeDirectory outPath) - runUnderHyprland outPath cssPath mode wsMode + runUnderHyprland outPath cssPath mode exitWith ec @@ -125,9 +118,8 @@ FilePath -> FilePath -> LayoutMode -> - WorkspaceWidgetMode -> IO ExitCode -runUnderHyprland outPath cssPath mode wsMode = do +runUnderHyprland outPath cssPath mode = do ctxVar :: MVar Context <- newEmptyMVar resultVar :: MVar (Either String BL.ByteString) <- newEmptyMVar doneVar :: MVar ExitCode <- newEmptyMVar @@ -141,7 +133,7 @@ barUnique <- newUnique - let barCfg = buildBarConfig barUnique mode wsMode + let barCfg = buildBarConfig barUnique mode cfg = def @@ -178,8 +170,8 @@ Gtk.widgetShowAll widget pure widget -buildBarConfig :: Unique -> LayoutMode -> WorkspaceWidgetMode -> BarConfig -buildBarConfig barUnique mode wsMode = +buildBarConfig :: Unique -> LayoutMode -> BarConfig +buildBarConfig barUnique mode = case mode of LayoutLegacy -> BarConfig @@ -228,16 +220,13 @@ 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 - } + Workspaces.workspacesNew $ + Workspaces.defaultWorkspacesConfig + { Workspaces.labelSetter = const (pure ""), + Workspaces.maxIcons = Just 1, + Workspaces.minIcons = 1, + Workspaces.showWorkspaceFn = const True + } scheduleSnapshot :: MVar Context -> MVar (Either String BL.ByteString) -> IORef (Maybe BL.ByteString) -> LayoutMode -> TaffyIO () scheduleSnapshot ctxVar resultVar lastShotRef mode = do @@ -393,13 +382,9 @@ if "--levels" `elem` args then LayoutLevels else LayoutLegacy - selectedWorkspaceWidgetMode = - if "--channel-workspaces" `elem` args - then UseChannelWorkspaces - else UseLegacyWorkspaces argsSansFlags = filter - (`notElem` ["--levels", "--channel-workspaces"]) + (`notElem` ["--levels"]) args in case argsSansFlags of ["--out", outPath, "--css", cssPath] -> @@ -407,20 +392,18 @@ Args { outFile = outPath, cssFile = cssPath, - layoutMode = selectedLayoutMode, - workspaceWidgetMode = selectedWorkspaceWidgetMode + layoutMode = selectedLayoutMode } ["--css", cssPath, "--out", outPath] -> pure Args { outFile = outPath, cssFile = cssPath, - layoutMode = selectedLayoutMode, - workspaceWidgetMode = selectedWorkspaceWidgetMode + layoutMode = selectedLayoutMode } _ -> fail - "usage: taffybar-appearance-snap-hyprland --out OUT.png --css appearance-test.css [--levels] [--channel-workspaces]" + "usage: taffybar-appearance-snap-hyprland --out OUT.png --css appearance-test.css [--levels]" die :: String -> IO a die msg = do 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 @@ -9,9 +9,9 @@ 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 Control.Monad.Trans.Reader (ask, asks, runReaderT) import Data.Bits import Data.Data (Typeable) import Data.Int @@ -67,11 +67,14 @@ _ <- liftIO $ Gtk.onIconThemeChanged iconTheme $ do invalidateThemeWindowIconCacheEntries cacheEntries void $ runReaderT refreshTaffyWindows context - _ <- - subscribeToPropertyEvents [ewmhWMIcon] $ \case - PropertyEvent _ _ _ _ windowId' _ _ _ -> - liftIO $ invalidateEWMHWindowIconCacheEntriesForWindow cacheEntries windowId' - _ -> return () + maybeX11Context <- asks x11ContextVar + forM_ maybeX11Context $ + const $ + void $ + subscribeToPropertyEvents [ewmhWMIcon] $ \case + PropertyEvent _ _ _ _ windowId' _ _ _ -> + liftIO $ invalidateEWMHWindowIconCacheEntriesForWindow cacheEntries windowId' + _ -> return () return cache getCachedWindowIcon :: 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.2.0 +version: 5.2.1 synopsis: A desktop bar similar to xmobar, but with more GUI license: BSD-3-Clause license-file: LICENSE 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 @@ -33,20 +33,20 @@ 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 + actualPng <- renderBarScreenshot env LegacyLayout assertGolden "appearance" 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 + actualPng <- renderBarScreenshot env LevelsLayout 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 "renders the workspaces widget under an EWMH window manager" $ \env -> do + actualPng <- renderBarScreenshot env LegacyLayout + assertPngLooksRendered "ewmh-workspaces" actualPng it "keeps configured bar height when the windows title has oversized glyph metrics" $ \env -> do - actualPng <- renderBarScreenshot env WindowsTitleStressLayout LegacyWidget + actualPng <- renderBarScreenshot env WindowsTitleStressLayout let actualImg = decodePngRGBA8 "stress" actualPng JP.imageHeight actualImg `shouldBe` 55 @@ -56,17 +56,16 @@ renderBarScreenshotWithArgs env LegacyLayout - LegacyWidget ["--expect-top-strut", "80"] assertPngLooksRendered "ewmh-hidpi-strut" actualPng - it "renders the channel workspaces widget under Hyprland when available" $ do + it "renders the 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 + actualPng <- renderHyprlandScreenshot LegacyLayout + assertPngLooksRendered "hyprland-workspaces" actualPng assertGolden :: String -> FilePath -> BL.ByteString -> IO () assertGolden label goldenFile actualPng = do @@ -130,14 +129,12 @@ data LayoutKind = LegacyLayout | LevelsLayout | WindowsTitleStressLayout -data WidgetKind = LegacyWidget | ChannelWidget - -renderBarScreenshot :: Env -> LayoutKind -> WidgetKind -> IO BL.ByteString -renderBarScreenshot env layout widgetKind = - renderBarScreenshotWithArgs env layout widgetKind [] +renderBarScreenshot :: Env -> LayoutKind -> IO BL.ByteString +renderBarScreenshot env layout = + renderBarScreenshotWithArgs env layout [] -renderBarScreenshotWithArgs :: Env -> LayoutKind -> WidgetKind -> [String] -> IO BL.ByteString -renderBarScreenshotWithArgs Env {envTmpDir = tmp} layout widgetKind extraArgs = do +renderBarScreenshotWithArgs :: Env -> LayoutKind -> [String] -> IO BL.ByteString +renderBarScreenshotWithArgs Env {envTmpDir = tmp} layout extraArgs = do exePath <- findComponentExecutable "taffybar-appearance-snap" @@ -152,14 +149,10 @@ 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] ++ levelArgs ++ widgetArgs ++ extraArgs) + proc exePath (["--out", outPath, "--css", cssPath] ++ levelArgs ++ extraArgs) withProcessTerm pc $ \p -> do mEc <- timeout appearanceSnapProcessTimeoutUsec (waitExitCode p) @@ -173,8 +166,8 @@ BL.readFile outPath -renderHyprlandScreenshot :: LayoutKind -> WidgetKind -> IO BL.ByteString -renderHyprlandScreenshot layout widgetKind = +renderHyprlandScreenshot :: LayoutKind -> IO BL.ByteString +renderHyprlandScreenshot layout = withSystemTempDirectory "taffybar-appearance-hyprland" $ \tmp -> do exePath <- findComponentExecutable @@ -188,14 +181,10 @@ 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) + proc exePath (["--out", outPath, "--css", cssPath] ++ levelArgs) withProcessTerm pc $ \p -> do mEc <- timeout appearanceSnapProcessTimeoutUsec (waitExitCode p) case mEc of