diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,5 +1,20 @@ # Unreleased +# 6.0.0 + +## Breaking Changes + +* Remove legacy workspace widget implementations. + +## Fixes + +* Fix workspace filter visibility after bar recreation. +* Fix window icon cache poisoning on failed lookups. + +## Tests + +* Refresh appearance golden images. + # 5.2.1 ## Fixes diff --git a/app/DhallConfig.hs b/app/DhallConfig.hs --- a/app/DhallConfig.hs +++ b/app/DhallConfig.hs @@ -3,7 +3,6 @@ {-# LANGUAGE DerivingStrategies #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE NamedFieldPuns #-} -{-# LANGUAGE OverloadedStrings #-} module DhallConfig ( runDhallConfigFromFile, @@ -23,6 +22,7 @@ import System.Taffybar.DBus (withLogServer, withToggleServer) import System.Taffybar.Hooks (withBatteryRefresh, withLogLevels) import qualified System.Taffybar.Information.Wlsunset as WlsunsetInfo +import qualified System.Taffybar.Information.Workspaces.Model as WorkspaceModel import System.Taffybar.SimpleConfig import System.Taffybar.Widget import qualified System.Taffybar.Widget.Backlight as Backlight @@ -32,10 +32,6 @@ 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 @@ -292,8 +288,8 @@ 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) + WorkspacesEWMH maybeSpec -> workspacesNew (ewmhConfigFromSpec maybeSpec) + WorkspacesHyprland maybeSpec -> workspacesNew (hyprlandConfigFromSpec maybeSpec) ScreenLock maybeSpec -> ScreenLock.screenLockNewWithConfig (screenLockConfigFromSpec maybeSpec) Wlsunset maybeSpec -> Wlsunset.wlsunsetNewWithConfig (wlsunsetConfigFromSpec maybeSpec) Layout -> layoutNew defaultLayoutConfig @@ -424,23 +420,16 @@ ewmhUpdateRateLimitMicroseconds = 100000 } -ewmhConfigFromSpec :: Maybe EWMHWorkspacesSpec -> EWMHWorkspaces.WorkspacesConfig +ewmhConfigFromSpec :: Maybe EWMHWorkspacesSpec -> 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) + base = defaultEWMHWorkspacesConfig + in base + { minIcons = naturalToInt (ewmhMinIcons spec), + maxIcons = fmap naturalToInt (ewmhMaxIcons spec), + widgetGap = naturalToInt (ewmhWidgetGap spec), + showWorkspaceFn = if ewmhShowEmpty spec then const True else hideEmpty, + urgentWorkspaceState = ewmhUrgentWorkspaceState spec } defaultHyprlandWorkspacesSpec :: HyprlandWorkspacesSpec @@ -456,31 +445,23 @@ hyprlandIconSize = 16 } -hyprlandConfigFromSpec :: Maybe HyprlandWorkspacesSpec -> HyprlandWorkspaces.HyprlandWorkspacesConfig +hyprlandConfigFromSpec :: Maybe HyprlandWorkspacesSpec -> WorkspacesConfig hyprlandConfigFromSpec maybeSpec = let spec = fromMaybe defaultHyprlandWorkspacesSpec maybeSpec - base = HyprlandWorkspaces.defaultHyprlandWorkspacesConfig - common = HyprlandWorkspaces.hyprlandWorkspacesCommonConfig base + base = defaultWorkspacesConfig 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 + let isEmpty = WorkspaceModel.workspaceState ws == WorkspaceModel.WorkspaceEmpty + isSpecial = WorkspaceModel.workspaceIsSpecial ws 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) + in base + { minIcons = naturalToInt (hyprlandMinIcons spec), + maxIcons = fmap naturalToInt (hyprlandMaxIcons spec), + widgetGap = naturalToInt (hyprlandWidgetGap spec), + showWorkspaceFn = shouldShowWorkspace, + urgentWorkspaceState = hyprlandUrgentWorkspaceState spec, + iconSize = Just (fromIntegral (hyprlandIconSize spec)) } screenLockConfigFromSpec :: Maybe ScreenLockSpec -> ScreenLock.ScreenLockConfig 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 @@ -30,8 +30,7 @@ import System.Taffybar.SimpleConfig import System.Taffybar.Widget import System.Taffybar.Widget.Generic.PollingGraph -import qualified System.Taffybar.Widget.Workspaces.Config as WorkspaceConfig -import qualified System.Taffybar.Widget.Workspaces.EWMH as Workspaces +import qualified System.Taffybar.Widget.Workspaces as Workspaces -- | Fully transparent RGBA color. transparent :: (Double, Double, Double, Double) @@ -102,15 +101,11 @@ exampleTaffybarConfig = let myWorkspacesConfig :: Workspaces.WorkspacesConfig myWorkspacesConfig = - let cfg = def - in cfg - { Workspaces.workspacesConfig = - (Workspaces.workspacesConfig cfg) - { WorkspaceConfig.minIcons = 1, - WorkspaceConfig.widgetGap = 0, - WorkspaceConfig.showWorkspaceFn = Workspaces.hideEmpty - } - } + def + { Workspaces.minIcons = 1, + Workspaces.widgetGap = 0, + Workspaces.showWorkspaceFn = Workspaces.hideEmpty + } workspaces = Workspaces.workspacesNew myWorkspacesConfig cpu = cpuMonitorNew cpuCfg 0.5 "cpu" mem = pollingGraphNew memCfg 1 memCallback 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 @@ -101,38 +101,6 @@ -- * "System.Taffybar.Widget.Windows" , module System.Taffybar.Widget.Windows - -- * "System.Taffybar.Widget.ChannelWorkspaces" - , ChannelWorkspacesConfig - , defaultChannelWorkspacesConfig - , defaultChannelEWMHWorkspacesConfig - , channelWorkspacesNew - - -- * "System.Taffybar.Widget.HyprlandWorkspaces" - , HyprlandWorkspacesConfig(..) - , defaultHyprlandWorkspacesConfig - , hyprlandWorkspacesNew - , HyprlandWorkspace(..) - , HyprlandWindow(..) - , HyprlandWindowIconPixbufGetter - , HyprlandWorkspaceWidgetController(..) - , HyprlandWWC(..) - , HyprlandControllerConstructor - , HyprlandParentControllerConstructor - , hyprlandBuildLabelController - , hyprlandBuildIconController - , hyprlandBuildContentsController - , hyprlandBuildLabelOverlayController - , hyprlandBuildCustomOverlayController - , hyprlandBuildButtonController - , defaultHyprlandWidgetBuilder - , defaultHyprlandGetWindowIconPixbuf - , getHyprlandWorkspaces - , hyprlandSwitchToWorkspace - , getActiveWindowAddress - , runHyprctlJson - , HyprlandClient(..) - , windowFromClient - -- * "System.Taffybar.Widget.Workspaces" , module System.Taffybar.Widget.Workspaces @@ -140,8 +108,6 @@ , 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 @@ -174,40 +140,5 @@ import System.Taffybar.Widget.Backlight import System.Taffybar.Widget.Weather import System.Taffybar.Widget.Windows -import System.Taffybar.Widget.Workspaces.Hyprland hiding - ( HyprlandWorkspacesConfig(..) - , defaultHyprlandWorkspacesConfig - , hyprlandBuildButtonController - , hyprlandBuildContentsController - , hyprlandBuildCustomOverlayController - , hyprlandBuildIconController - , hyprlandBuildLabelController - , hyprlandBuildLabelOverlayController - , hyprlandWorkspacesNew - , defaultHyprlandWidgetBuilder - ) -import System.Taffybar.Widget.Workspaces.Hyprland.Compat - ( HyprlandWorkspacesConfig(..) - , defaultHyprlandWorkspacesConfig - , hyprlandWorkspacesNew - , hyprlandBuildLabelController - , hyprlandBuildIconController - , hyprlandBuildContentsController - , hyprlandBuildLabelOverlayController - , hyprlandBuildCustomOverlayController - , hyprlandBuildButtonController - , defaultHyprlandWidgetBuilder - ) 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/ChannelWorkspaces.hs b/src/System/Taffybar/Widget/ChannelWorkspaces.hs deleted file mode 100644 --- a/src/System/Taffybar/Widget/ChannelWorkspaces.hs +++ /dev/null @@ -1,42 +0,0 @@ ------------------------------------------------------------------------------ - ------------------------------------------------------------------------------ - --- | --- 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/HyprlandWorkspaces.hs b/src/System/Taffybar/Widget/HyprlandWorkspaces.hs deleted file mode 100644 --- a/src/System/Taffybar/Widget/HyprlandWorkspaces.hs +++ /dev/null @@ -1,67 +0,0 @@ ------------------------------------------------------------------------------ - ------------------------------------------------------------------------------ - --- | --- Module : System.Taffybar.Widget.HyprlandWorkspaces --- Copyright : (c) Ivan A. Malison --- License : BSD3-style (see LICENSE) --- --- Maintainer : Ivan A. Malison --- Stability : unstable --- Portability : unportable -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, - ) -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.Workspaces.Hyprland.Compat - ( HyprlandWorkspacesConfig (..), - applyCommonHyprlandWorkspacesConfig, - applyUrgentState, - buildIconWidget, - defaultHyprlandWidgetBuilder, - defaultHyprlandWorkspacesConfig, - hyprlandBuildButtonController, - hyprlandBuildContentsController, - hyprlandBuildCustomOverlayController, - hyprlandBuildIconController, - hyprlandBuildLabelController, - hyprlandBuildLabelOverlayController, - hyprlandWorkspacesCommonConfig, - hyprlandWorkspacesNew, - refreshWorkspaces, - ) 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 @@ -448,8 +448,15 @@ forceIconRefresh = snapshotBackend snapshot == WorkspaceBackendEWMH && snapshotRevision snapshot /= cacheLastRevision oldCache + applyVisibility wsInfo entry = + if showWorkspaceFn cfg wsInfo + then liftIO $ Gtk.widgetShow (entryButton entry) + else liftIO $ Gtk.widgetHide (entryButton entry) if workspaces == cacheLastWorkspaces oldCache && not forceIconRefresh - then return oldCache + then do + forM_ (M.elems $ cacheEntries oldCache) $ \entry -> + applyVisibility (entryLastWorkspace entry) entry + return oldCache else do let oldEntries = cacheEntries oldCache buildOrUpdate (cacheAcc, entriesAcc) wsInfo = do @@ -482,10 +489,7 @@ 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) + forM_ orderedEntries $ uncurry applyVisibility return WorkspaceCache { cacheEntries = newEntries, diff --git a/src/System/Taffybar/Widget/Workspaces/Channel.hs b/src/System/Taffybar/Widget/Workspaces/Channel.hs deleted file mode 100644 --- a/src/System/Taffybar/Widget/Workspaces/Channel.hs +++ /dev/null @@ -1,21 +0,0 @@ -{-# 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 deleted file mode 100644 --- a/src/System/Taffybar/Widget/Workspaces/Common.hs +++ /dev/null @@ -1,19 +0,0 @@ ------------------------------------------------------------------------------ - ------------------------------------------------------------------------------ - --- | --- 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 deleted file mode 100644 --- a/src/System/Taffybar/Widget/Workspaces/Config.hs +++ /dev/null @@ -1,41 +0,0 @@ -{-# 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 deleted file mode 100644 --- a/src/System/Taffybar/Widget/Workspaces/EWMH.hs +++ /dev/null @@ -1,884 +0,0 @@ -{-# 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 deleted file mode 100644 --- a/src/System/Taffybar/Widget/Workspaces/EWMH/Compat.hs +++ /dev/null @@ -1,171 +0,0 @@ -{-# 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 deleted file mode 100644 --- a/src/System/Taffybar/Widget/Workspaces/Hyprland.hs +++ /dev/null @@ -1,963 +0,0 @@ -{-# 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 deleted file mode 100644 --- a/src/System/Taffybar/Widget/Workspaces/Hyprland/Compat.hs +++ /dev/null @@ -1,253 +0,0 @@ -{-# 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/X11.hs b/src/System/Taffybar/Widget/Workspaces/X11.hs deleted file mode 100644 --- a/src/System/Taffybar/Widget/Workspaces/X11.hs +++ /dev/null @@ -1,18 +0,0 @@ ------------------------------------------------------------------------------ - ------------------------------------------------------------------------------ - --- | --- 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/WindowIcon.hs b/src/System/Taffybar/WindowIcon.hs --- a/src/System/Taffybar/WindowIcon.hs +++ b/src/System/Taffybar/WindowIcon.hs @@ -51,7 +51,7 @@ deriving (Eq, Ord, Show) newtype WindowIconCache = WindowIconCache - { windowIconCacheEntries :: MV.MVar (M.Map WindowIconCacheKey (Maybe Gdk.Pixbuf)) + { windowIconCacheEntries :: MV.MVar (M.Map WindowIconCacheKey Gdk.Pixbuf) } deriving (Typeable) @@ -85,10 +85,13 @@ WindowIconCache {windowIconCacheEntries = entriesVar} <- getWindowIconCache cached <- liftIO $ M.lookup cacheKey <$> MV.readMVar entriesVar case cached of - Just icon -> return icon + Just icon -> return $ Just icon Nothing -> do icon <- buildIcon - liftIO $ MV.modifyMVar_ entriesVar (return . M.insert cacheKey icon) + liftIO $ + forM_ icon $ + \resolvedIcon -> + MV.modifyMVar_ entriesVar (return . M.insert cacheKey resolvedIcon) return icon isThemeIconCacheKey :: WindowIconCacheKey -> Bool @@ -97,14 +100,14 @@ isThemeIconCacheKey (EWMHIconCacheKey _ _) = False invalidateThemeWindowIconCacheEntries :: - MV.MVar (M.Map WindowIconCacheKey (Maybe Gdk.Pixbuf)) -> + MV.MVar (M.Map WindowIconCacheKey Gdk.Pixbuf) -> IO () invalidateThemeWindowIconCacheEntries entriesVar = MV.modifyMVar_ entriesVar $ return . M.filterWithKey (\k _ -> not (isThemeIconCacheKey k)) invalidateEWMHWindowIconCacheEntriesForWindow :: - MV.MVar (M.Map WindowIconCacheKey (Maybe Gdk.Pixbuf)) -> + MV.MVar (M.Map WindowIconCacheKey Gdk.Pixbuf) -> X11Window -> IO () invalidateEWMHWindowIconCacheEntriesForWindow entriesVar changedWindow = 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.1 +version: 6.0.0 synopsis: A desktop bar similar to xmobar, but with more GUI license: BSD-3-Clause license-file: LICENSE @@ -182,7 +182,6 @@ , 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 @@ -223,17 +222,8 @@ , 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 @@ -382,7 +372,6 @@ , 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 diff --git a/test/data/appearance-ewmh-bar-levels.png b/test/data/appearance-ewmh-bar-levels.png Binary files a/test/data/appearance-ewmh-bar-levels.png and b/test/data/appearance-ewmh-bar-levels.png differ diff --git a/test/data/appearance-ewmh-bar.png b/test/data/appearance-ewmh-bar.png Binary files a/test/data/appearance-ewmh-bar.png and b/test/data/appearance-ewmh-bar.png differ diff --git a/test/data/appearance-hyprland-bar.png b/test/data/appearance-hyprland-bar.png Binary files a/test/data/appearance-hyprland-bar.png and b/test/data/appearance-hyprland-bar.png differ diff --git a/test/unit/System/Taffybar/Widget/HyprlandWorkspacesSpec.hs b/test/unit/System/Taffybar/Widget/HyprlandWorkspacesSpec.hs deleted file mode 100644 --- a/test/unit/System/Taffybar/Widget/HyprlandWorkspacesSpec.hs +++ /dev/null @@ -1,35 +0,0 @@ -module System.Taffybar.Widget.HyprlandWorkspacesSpec where - -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 - } - -spec :: Spec -spec = do - describe "sortHyprlandWindowsByPosition" $ do - it "orders non-minimized windows first, then by (x, y) position" $ do - let a = mkWin "a" False (Just (10, 0)) - b = mkWin "b" False (Just (0, 100)) - c = mkWin "c" True (Just (0, 0)) - sortHyprlandWindowsByPosition [a, b, c] `shouldBe` [b, a, c] - - it "puts windows without a position at the end" $ do - let a = mkWin "a" False Nothing - b = mkWin "b" False (Just (0, 0)) - sortHyprlandWindowsByPosition [a, b] `shouldBe` [b, a]