From b6df5196d445ad1dc307f4ad2090baa8a0844ff7 Mon Sep 17 00:00:00 2001 From: Tomas Janousek Date: Sun, 17 Oct 2021 16:41:46 +0100 Subject: [PATCH 1/7] X.H.EwmhDesktops: Simplify whenChanged --- XMonad/Hooks/EwmhDesktops.hs | 7 +------ 1 file changed, 1 insertion(+), 6 deletions(-) diff --git a/XMonad/Hooks/EwmhDesktops.hs b/XMonad/Hooks/EwmhDesktops.hs index 295850348c..6a9f8f11ab 100644 --- a/XMonad/Hooks/EwmhDesktops.hs +++ b/XMonad/Hooks/EwmhDesktops.hs @@ -42,7 +42,6 @@ import XMonad.Prelude import qualified XMonad.StackSet as W import XMonad.Hooks.SetWMName -import qualified XMonad.Util.ExtensibleState as E import XMonad.Util.WorkspaceCompare import XMonad.Util.WindowProperties (getProp32) import qualified XMonad.Util.ExtensibleState as XS @@ -160,11 +159,7 @@ instance ExtensionClass ActiveWindow where -- | Compare the given value against the value in the extensible state. Run the -- action if it has changed. whenChanged :: (Eq a, ExtensionClass a) => a -> X () -> X () -whenChanged v action = do - v0 <- E.get - unless (v == v0) $ do - action - E.put v +whenChanged = whenX . XS.modified . const -- | -- Generalized version of ewmhDesktopsLogHook that allows an arbitrary From 63f3b52b5270d94701bd82c6457635190c0fbf6f Mon Sep 17 00:00:00 2001 From: Tomas Janousek Date: Sun, 17 Oct 2021 22:01:26 +0100 Subject: [PATCH 2/7] X.U.ExtensibleConf: Perform 'add' before modifying in once(M) This better matches the documentation. It is still, however, considered bad practice to rely on the order of these operations. `f` isn't meant to touch any extensible configuration. If it happens to do so anyway, it no longer loops. :-) --- XMonad/Util/ExtensibleConf.hs | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/XMonad/Util/ExtensibleConf.hs b/XMonad/Util/ExtensibleConf.hs index e51b9c478c..e64832e080 100644 --- a/XMonad/Util/ExtensibleConf.hs +++ b/XMonad/Util/ExtensibleConf.hs @@ -117,7 +117,7 @@ once :: forall a l. (Semigroup a, Typeable a) => (XConfig l -> XConfig l) -- ^ 'XConfig' modification done only once -> a -- ^ configuration to add -> XConfig l -> XConfig l -once f x c = add x $ maybe f (const id) (lookup @a c) c +once f x c = maybe f (const id) (lookup @a c) $ add x c -- | Config-time: Applicative (monadic) variant of 'once', useful if the -- 'XConfig' modification needs to do some 'IO' (e.g. create an @@ -126,4 +126,4 @@ onceM :: forall a l m. (Applicative m, Semigroup a, Typeable a) => (XConfig l -> m (XConfig l)) -- ^ 'XConfig' modification done only once -> a -- ^ configuration to add -> XConfig l -> m (XConfig l) -onceM f x c = add x <$> maybe f (const pure) (lookup @a c) c +onceM f x c = maybe f (const pure) (lookup @a c) $ add x c From 72095a878d77f7fe884adc7448e5508266db22ed Mon Sep 17 00:00:00 2001 From: Tomas Janousek Date: Sun, 17 Oct 2021 22:47:58 +0100 Subject: [PATCH 3/7] X.U.ExtensibleConf: Add high-level idioms for non-Semigroup types Sometimes it may be better to provide an interface not based on Semigroup. Users may need the option to completely override a value; to choose between prepending/appending, etc. --- XMonad/Util/ExtensibleConf.hs | 63 ++++++++++++++++++++++++++++++++++- tests/ExtensibleConf.hs | 32 +++++++++++++++--- 2 files changed, 89 insertions(+), 6 deletions(-) diff --git a/XMonad/Util/ExtensibleConf.hs b/XMonad/Util/ExtensibleConf.hs index e64832e080..e706789de6 100644 --- a/XMonad/Util/ExtensibleConf.hs +++ b/XMonad/Util/ExtensibleConf.hs @@ -23,9 +23,14 @@ module XMonad.Util.ExtensibleConf ( -- * High-level idioms with, + withDef, add, once, onceM, + modify, + modifyDef, + onceIni, + onceIniM, -- * Low-level primitivies ask, @@ -34,9 +39,11 @@ module XMonad.Util.ExtensibleConf ( ) where import Prelude hiding (lookup) -import XMonad hiding (ask) +import XMonad hiding (ask, modify, trace) +import XMonad.Prelude ((<|>), fromMaybe) import Data.Typeable +import Debug.Trace import qualified Data.Map as M @@ -101,6 +108,11 @@ mapConfExt f = fmap ConfExtension . f . (>>= fromConfExt) with :: (MonadReader XConf m, Typeable a, Monoid b) => (a -> m b) -> m b with a = ask >>= maybe (pure mempty) a +-- | Run-time: Run a monadic action with the value of the custom +-- configuration, or the 'Default' value thereof, if absent. +withDef :: (MonadReader XConf m, Typeable a, Default a) => (a -> m b) -> m b +withDef a = ask >>= a . fromMaybe def + -- | Config-time: Add (append) a piece of custom configuration to an 'XConfig' -- using the 'Semigroup' instance of the configuration type. add :: (Semigroup a, Typeable a) @@ -113,6 +125,9 @@ add x = alter (<> Just x) -- -- This can be used to implement a composable interface for modules that must -- only hook into xmonad core once. +-- +-- (The piece of custom configuration is the last argument as it's expected to +-- come from the user.) once :: forall a l. (Semigroup a, Typeable a) => (XConfig l -> XConfig l) -- ^ 'XConfig' modification done only once -> a -- ^ configuration to add @@ -127,3 +142,49 @@ onceM :: forall a l m. (Applicative m, Semigroup a, Typeable a) -> a -- ^ configuration to add -> XConfig l -> m (XConfig l) onceM f x c = maybe f (const pure) (lookup @a c) $ add x c + +-- | Config-time: Modify a configuration value in 'XConfig', or print a +-- warning to stderr if there's no value to be modified. This is an +-- alternative to 'add' for when a 'Semigroup' instance is unavailable or +-- unsuitable. +-- +-- Note that this must be used /after/ 'once' or any of its variants for the +-- warning to not be printed. +modify :: forall a l. (Typeable a) + => (a -> a) -- ^ modification of configuration + -> XConfig l -> XConfig l +modify f c = maybe (trace missing) (const (alter (f <$>))) (lookup @a c) c + where + missing = "X.U.ExtensibleConf.modify: no value of type " <> show (typeRep (Proxy @a)) + -- TODO: xmessage in startupHook instead + +-- | Config-time: Modify a configuration value in 'XConfig', initializing it +-- to its 'Default' value first if absent. This is an alternative to 'add' for +-- when a 'Semigroup' instance is unavailable or unsuitable. +-- +-- Note that this must /not/ be used together with any variant of 'once'! +modifyDef :: forall a l. (Typeable a, Default a) + => (a -> a) -- ^ modification of configuration + -> XConfig l -> XConfig l +modifyDef f = alter ((f <$>) . (<|> Just def)) + +-- | Config-time: Apply a modification to 'XConfig' only once, guarded by the +-- absence of a configuration value. This is an alternative to 'once' for when +-- a 'Semigroup' instance is unavailable or unsuitable. +-- +-- (The configuration value is the first argument as it's expected to be +-- supplied by the contrib module.) +onceIni :: forall a l. (Typeable a) + => a -- ^ initial (default, empty, …) configuration + -> (XConfig l -> XConfig l) -- ^ 'XConfig' modification done only once + -> XConfig l -> XConfig l +onceIni x f c = maybe f (const id) (lookup @a c) $ alter (<|> Just x) c + +-- | Config-time: Applicative (monadic) variant of 'once'', useful if the +-- 'XConfig' modification needs to do some 'IO' (e.g. create an +-- 'Data.IORef.IORef'). +onceIniM :: forall a l m. (Applicative m, Typeable a) + => a -- ^ initial (default, empty, …) configuration + -> (XConfig l -> m (XConfig l)) -- ^ 'XConfig' modification done only once + -> XConfig l -> m (XConfig l) +onceIniM x f c = maybe f (const pure) (lookup @a c) $ alter (<|> Just x) c diff --git a/tests/ExtensibleConf.hs b/tests/ExtensibleConf.hs index bfb55560c8..412cb9371a 100644 --- a/tests/ExtensibleConf.hs +++ b/tests/ExtensibleConf.hs @@ -21,11 +21,33 @@ spec = do specify "lookup @() . add @String . add @[Int]" $ XC.lookup (XC.add "a" (XC.add [1 :: Int] def)) `shouldBe` (Nothing :: Maybe ()) - specify "once" $ - borderWidth (XC.once incBorderWidth "a" def) `shouldBe` succ (borderWidth def) - specify "once . once" $ - borderWidth (XC.once incBorderWidth "b" (XC.once incBorderWidth "a" def)) - `shouldBe` succ (borderWidth def) + specify "once" $ do + let c = XC.once incBorderWidth "a" def + borderWidth c `shouldBe` succ (borderWidth def) + XC.lookup c `shouldBe` Just "a" + specify "once . once" $ do + let c = XC.once incBorderWidth "b" (XC.once incBorderWidth "a" def) + borderWidth c `shouldBe` succ (borderWidth def) + XC.lookup c `shouldBe` Just "ab" + + specify "onceIni" $ do + let c = XC.onceIni "a" incBorderWidth def + borderWidth c `shouldBe` succ (borderWidth def) + XC.lookup c `shouldBe` Just "a" + specify "onceIni . onceIni" $ do + let c = XC.onceIni "b" incBorderWidth (XC.onceIni "a" incBorderWidth def) + borderWidth c `shouldBe` succ (borderWidth def) + XC.lookup c `shouldBe` Just "a" + specify "modify . onceIni" $ do + let c = XC.modify (<> "b") (XC.onceIni "a" incBorderWidth def) + borderWidth c `shouldBe` succ (borderWidth def) + XC.lookup c `shouldBe` Just "ab" + specify "modifyDef" $ do + let c = XC.modifyDef (<> "a") def + XC.lookup c `shouldBe` Just "a" + specify "modifyDef . modifyDef" $ do + let c = XC.modifyDef (<> "b") (XC.modifyDef (<> "a") def) + XC.lookup c `shouldBe` Just "ab" incBorderWidth :: XConfig l -> XConfig l incBorderWidth c = c{ borderWidth = succ (borderWidth c) } From bcd8fa1ea81cfcdf465c793ae7ee50afe453db6d Mon Sep 17 00:00:00 2001 From: Tomas Janousek Date: Sun, 17 Oct 2021 14:29:47 +0100 Subject: [PATCH 4/7] X.U.EWMH: New module; implement _NET_SUPPORTED abstraction --- XMonad/Util/EWMH.hs | 67 ++++++++++++++++++++++++++++++++++++++++++++ xmonad-contrib.cabal | 1 + 2 files changed, 68 insertions(+) create mode 100644 XMonad/Util/EWMH.hs diff --git a/XMonad/Util/EWMH.hs b/XMonad/Util/EWMH.hs new file mode 100644 index 0000000000..0c0765e047 --- /dev/null +++ b/XMonad/Util/EWMH.hs @@ -0,0 +1,67 @@ +{-# LANGUAGE GeneralizedNewtypeDeriving #-} + +-- | +-- Module : XMonad.Util.EWMH +-- Description : Utilities for modules implementing Extended Window Manager Hints (EWMH). +-- Copyright : (c) 2021 Tomáš Janoušek +-- License : BSD3 +-- Maintainer : Tomáš Janoušek +-- +-- The common bits of of xmonad's implementation of the EWMH specification +-- (). +-- +module XMonad.Util.EWMH ( + -- * Usage + -- $usage + + -- * @_NET_SUPPORTED@ abstraction + ewmhSupported, + ) where + +import XMonad +import XMonad.Prelude +import qualified XMonad.Util.ExtensibleConf as XC + +-- --------------------------------------------------------------------- +-- $usage +-- +-- This module is not intended to be used in user configurations. +-- +-- Contrib modules implementing parts of the EWMH specification should export +-- an 'XConfig' combinator which applies 'ewmhSupported' to advertise the +-- hints it implements, and uses 'XMonad.Util.ExtensibleConf.once' to attach +-- its hooks to the user's 'XConfig'. +-- +-- A very simple example: +-- +-- > import XMonad.Util.EWMH +-- > import qualified XMonad.Util.ExtensibleConf as XC +-- > +-- > data EwmhDesktopsConfig = EwmhDesktopsConfig{…} +-- > instance Semigroup EwmhDesktopsConfig where … +-- > +-- > ewmhDesktops :: EwmhDesktopsConfig -> XConfig a -> XConfig a +-- > ewmhDesktops = ewmhSupported hints .: XC.once hooks +-- > where +-- > hints = ["_NET_CURRENT_DESKTOP", "_NET_NUMBER_OF_DESKTOPS", "_NET_DESKTOP_NAMES", "_NET_WM_DESKTOP"] +-- > hooks c = c{ handleEventHook = handleEventHook c <> ewmhDesktopsEventHook } + +-- --------------------------------------------------------------------- +-- @_NET_SUPPORTED@ abstraction + +newtype EwmhSupported = EwmhSupported{ getSupported :: [String] } deriving (Semigroup) + +-- | Add given atoms to the @_NET_SUPPORTED@ list of supported hints. +-- +-- The property is set once, as the very first 'startupHook' when xmonad +-- starts. +ewmhSupported :: [String] -> XConfig l -> XConfig l +ewmhSupported = XC.once (\c -> c{ startupHook = setSupported <> startupHook c }) . EwmhSupported + +setSupported :: X () +setSupported = XC.with $ \supported -> + withDisplay $ \dpy -> do + r <- asks theRoot + a <- getAtom "_NET_SUPPORTED" + atoms <- mapM getAtom $ nub $ getSupported supported + io $ changeProperty32 dpy r a aTOM propModeReplace $ map fi atoms diff --git a/xmonad-contrib.cabal b/xmonad-contrib.cabal index f6c0a8db82..791ed8b5c7 100644 --- a/xmonad-contrib.cabal +++ b/xmonad-contrib.cabal @@ -334,6 +334,7 @@ library XMonad.Util.Dmenu XMonad.Util.DynamicScratchpads XMonad.Util.Dzen + XMonad.Util.EWMH XMonad.Util.EZConfig XMonad.Util.ExclusiveScratchpads XMonad.Util.ExtensibleConf From e72e6633e24111e74a34129800239479bb56901b Mon Sep 17 00:00:00 2001 From: Tomas Janousek Date: Sun, 17 Oct 2021 16:40:59 +0100 Subject: [PATCH 5/7] X.H.EWMH.Desktops: New module; implement desktops/windows EWMH hints This is almost functionally equivalent to X.H.EwmhDesktops except for the logHook window activation (will be replaced by a configurable activateHook) and full-screen handling (will go into its own module). --- XMonad/Hooks/EWMH/Desktops.hs | 231 ++++++++++++++++++++++++++++++++++ xmonad-contrib.cabal | 1 + 2 files changed, 232 insertions(+) create mode 100644 XMonad/Hooks/EWMH/Desktops.hs diff --git a/XMonad/Hooks/EWMH/Desktops.hs b/XMonad/Hooks/EWMH/Desktops.hs new file mode 100644 index 0000000000..41752820db --- /dev/null +++ b/XMonad/Hooks/EWMH/Desktops.hs @@ -0,0 +1,231 @@ +{-# LANGUAGE MultiWayIf #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE PatternGuards #-} + +-- | +-- Module : XMonad.Hooks.EWMH.Desktops +-- Description : Extended Window Manager Hints (EWMH) support for workspaces (virtual desktops). +-- Copyright : (c) 2021 Tomáš Janoušek +-- License : BSD3 +-- Maintainer : Tomáš Janoušek +-- +-- Makes xmonad use the EWMH hints to tell panel applications about its +-- workspaces and the windows therein. It also allows the user to interact +-- with xmonad by clicking on panels and window lists. +-- + +module XMonad.Hooks.EWMH.Desktops ( + -- * Usage + -- $usage + ewmhDesktops, + setEwmhWorkspaceListTransform, + addEwmhWorkspaceListTransform, + ) where + +import Codec.Binary.UTF8.String (encode) +import Data.Bits (complement) +import XMonad +import XMonad.Prelude +import XMonad.Util.EWMH +import XMonad.Util.WorkspaceCompare (getSortByIndex) +import qualified Data.Map as M +import qualified XMonad.StackSet as W +import qualified XMonad.Util.ExtensibleConf as XC +import qualified XMonad.Util.ExtensibleState as XS + +-- --------------------------------------------------------------------- +-- $usage +-- You can use this module with the following in your @~\/.xmonad\/xmonad.hs@: +-- +-- > main = xmonad $ … . ewmhDesktops . … $ def{…} + +newtype EwmhDesktopsConfig = + EwmhDesktopsConfig + { workspaceListTransform :: [WindowSpace] -> [WindowSpace] + } + +instance Default EwmhDesktopsConfig where + def = EwmhDesktopsConfig + { workspaceListTransform = id + } + +data EwmhDesktops = EwmhDesktops + +-- | Add EWMH support for workspaces (virtual desktops) to 'XConfig'. +ewmhDesktops :: XConfig l -> XConfig l +ewmhDesktops = ewmhSupported hints . XC.onceIni EwmhDesktops hooks + where + hints = [ "_NET_DESKTOP_NAMES" + , "_NET_NUMBER_OF_DESKTOPS" + , "_NET_CLIENT_LIST" + , "_NET_CLIENT_LIST_STACKING" + , "_NET_CURRENT_DESKTOP" + , "_NET_WM_DESKTOP" + , "_NET_ACTIVE_WINDOW" + , "_NET_CLOSE_WINDOW" + ] + hooks c = c{ handleEventHook = handleEventHook c <> ewmhDesktopsEventHook + , logHook = logHook c <> ewmhDesktopsLogHook } + +-- | Set an arbitrary user-specified function to transform the workspace list +-- (post-sorting). This can be used to e.g. filter out scratchpad workspaces. +setEwmhWorkspaceListTransform :: ([WindowSpace] -> [WindowSpace]) -> XConfig l -> XConfig l +setEwmhWorkspaceListTransform f = XC.modifyDef $ \c -> c{ workspaceListTransform = f } + +-- | Like 'setEwmhWorkspaceListTransform', but compose (after) with the +-- existing instead of replacing it. +addEwmhWorkspaceListTransform :: ([WindowSpace] -> [WindowSpace]) -> XConfig l -> XConfig l +addEwmhWorkspaceListTransform f = XC.modifyDef $ \c -> + c{ workspaceListTransform = workspaceListTransform c <> f } + +ewmhDesktopsLogHook :: X () +ewmhDesktopsLogHook = XC.withDef $ \EwmhDesktopsConfig{workspaceListTransform} -> do + withWindowSet $ \s -> do + sort' <- getSortByIndex + let ws = workspaceListTransform $ sort' $ W.workspaces s + + -- Set number of workspaces and names thereof + let desktopNames = map W.tag ws + whenModified (NetDesktopNames desktopNames) $ do + setNumberOfDesktops (length desktopNames) + setDesktopNames desktopNames + + -- Set client list which should be sorted by window age. We just + -- guess that StackSet contains windows list in this order which + -- isn't true but at least gives consistency with windows cycling + let clientList = nub . concatMap (W.integrate' . W.stack) $ ws + whenModified (NetClientList clientList) $ do + setClientList clientList + + -- Set stacking client list which should have bottom-to-top + -- stacking order, i.e. focused window should be last + let clientListStacking = nub . concatMap (maybe [] (\(W.Stack x l r) -> reverse l ++ r ++ [x]) . W.stack) $ ws + whenModified (NetClientListStacking clientListStacking) $ do + setClientListStacking clientListStacking + + -- Set current desktop (remap the current workspace to handle any + -- renames that workspaceListTransform might be doing). + let maybeCurrent' = W.tag <$> listToMaybe (workspaceListTransform [W.workspace $ W.current s]) + current = flip elemIndex (map W.tag ws) =<< maybeCurrent' + whenModified (NetCurrentDesktop $ fromMaybe 0 current) $ + mapM_ setCurrentDesktop current + + -- Set window-desktop mapping + let windowDesktops = + let f wsId workspace = M.fromList [ (winId, wsId) | winId <- W.integrate' $ W.stack workspace ] + in M.unions $ zipWith f [0..] ws + whenModified (NetWmDesktop windowDesktops) $ + mapM_ (uncurry setWindowDesktop) (M.toList windowDesktops) + + -- Set active window + let activeWindow = fromMaybe none (W.peek s) + whenModified (NetActiveWindow activeWindow) $ do + setActiveWindow activeWindow + +ewmhDesktopsEventHook :: Event -> X All +ewmhDesktopsEventHook ClientMessageEvent{ev_window = w, ev_message_type = mt, ev_data = d} = + XC.withDef $ \EwmhDesktopsConfig{workspaceListTransform} -> + withWindowSet $ \s -> do + sort' <- getSortByIndex + let ws = workspaceListTransform $ sort' $ W.workspaces s + + a_cd <- getAtom "_NET_CURRENT_DESKTOP" + a_d <- getAtom "_NET_WM_DESKTOP" + a_aw <- getAtom "_NET_ACTIVE_WINDOW" + a_cw <- getAtom "_NET_CLOSE_WINDOW" + + if | mt == a_cd, n : _ <- d, Just ww <- ws !? fi n -> + if W.currentTag s == W.tag ww then mempty else windows $ W.view (W.tag ww) + | mt == a_cd -> + trace $ "Bad _NET_CURRENT_DESKTOP with data=" ++ show d + | mt == a_d, n : _ <- d, Just ww <- ws !? fi n -> + if W.findTag w s == Just (W.tag ww) then mempty else windows $ W.shiftWin (W.tag ww) w + | mt == a_d -> + trace $ "Bad _NET_WM_DESKTOP with data=" ++ show d + | mt == a_aw, 2 : _ <- d -> + -- when the request comes from a pager, honor it unconditionally + -- https://specifications.freedesktop.org/wm-spec/wm-spec-1.3.html#sourceindication + windows $ W.focusWindow w + | mt == a_aw, W.peek s /= Just w -> do + -- TODO: activateHook + windows $ W.focusWindow w + | mt == a_cw -> + killWindow w + | otherwise -> + -- The Message is unknown to us, but that is ok, not all are meant + -- to be handled by the window manager + mempty + + mempty +ewmhDesktopsEventHook _ = mempty + +-- | Cached @_NET_DESKTOP_NAMES@, @_NET_NUMBER_OF_DESKTOPS@ +newtype NetDesktopNames = NetDesktopNames [String] deriving Eq +instance ExtensionClass NetDesktopNames where initialValue = NetDesktopNames [] + +-- | Cached @_NET_CLIENT_LIST@ +newtype NetClientList = NetClientList [Window] deriving Eq +instance ExtensionClass NetClientList where initialValue = NetClientList [none] + +-- | Cached @_NET_CLIENT_LIST_STACKING@ +newtype NetClientListStacking = NetClientListStacking [Window] deriving Eq +instance ExtensionClass NetClientListStacking where initialValue = NetClientListStacking [none] + +-- | Cached @_NET_CURRENT_DESKTOP@ +newtype NetCurrentDesktop = NetCurrentDesktop Int deriving Eq +instance ExtensionClass NetCurrentDesktop where initialValue = NetCurrentDesktop (complement 0) + +-- | Cached @_NET_WM_DESKTOP@ +newtype NetWmDesktop = NetWmDesktop (M.Map Window Int) deriving Eq +instance ExtensionClass NetWmDesktop where initialValue = NetWmDesktop (M.singleton none (complement 0)) + +-- | Cached @_NET_ACTIVE_WINDOW@ +newtype NetActiveWindow = NetActiveWindow Window deriving Eq +instance ExtensionClass NetActiveWindow where initialValue = NetActiveWindow (complement none) + +-- | Update value in extensible state, run action if it changed. +whenModified :: (Eq a, ExtensionClass a) => a -> X () -> X () +whenModified = whenX . XS.modified . const + +setNumberOfDesktops :: Int -> X () +setNumberOfDesktops n = withDisplay $ \dpy -> do + a <- getAtom "_NET_NUMBER_OF_DESKTOPS" + r <- asks theRoot + io $ changeProperty32 dpy r a cARDINAL propModeReplace [fi n] + +setDesktopNames :: [String] -> X () +setDesktopNames names = withDisplay $ \dpy -> do + r <- asks theRoot + a <- getAtom "_NET_DESKTOP_NAMES" + c <- getAtom "UTF8_STRING" + let enc = map fi . concatMap ((++[0]) . encode) + io $ changeProperty8 dpy r a c propModeReplace $ enc names + +setClientList :: [Window] -> X () +setClientList wins = withDisplay $ \dpy -> do + r <- asks theRoot + a <- getAtom "_NET_CLIENT_LIST" + io $ changeProperty32 dpy r a wINDOW propModeReplace (fmap fi wins) + +setClientListStacking :: [Window] -> X () +setClientListStacking wins = withDisplay $ \dpy -> do + r <- asks theRoot + a <- getAtom "_NET_CLIENT_LIST_STACKING" + io $ changeProperty32 dpy r a wINDOW propModeReplace (fmap fi wins) + +setCurrentDesktop :: Int -> X () +setCurrentDesktop i = withDisplay $ \dpy -> do + a <- getAtom "_NET_CURRENT_DESKTOP" + r <- asks theRoot + io $ changeProperty32 dpy r a cARDINAL propModeReplace [fi i] + +setWindowDesktop :: Window -> Int -> X () +setWindowDesktop win i = withDisplay $ \dpy -> do + a <- getAtom "_NET_WM_DESKTOP" + io $ changeProperty32 dpy win a cARDINAL propModeReplace [fi i] + +setActiveWindow :: Window -> X () +setActiveWindow w = withDisplay $ \dpy -> do + r <- asks theRoot + a <- getAtom "_NET_ACTIVE_WINDOW" + io $ changeProperty32 dpy r a wINDOW propModeReplace [fi w] diff --git a/xmonad-contrib.cabal b/xmonad-contrib.cabal index 791ed8b5c7..28eaa1de30 100644 --- a/xmonad-contrib.cabal +++ b/xmonad-contrib.cabal @@ -170,6 +170,7 @@ library XMonad.Hooks.DynamicIcons XMonad.Hooks.DynamicLog XMonad.Hooks.DynamicProperty + XMonad.Hooks.EWMH.Desktops XMonad.Hooks.EwmhDesktops XMonad.Hooks.FadeInactive XMonad.Hooks.FadeWindows From 8df5bd90a5aadb799baa02805cc431533eed6c60 Mon Sep 17 00:00:00 2001 From: Tomas Janousek Date: Fri, 6 Nov 2020 20:37:17 +0000 Subject: [PATCH 6/7] X.H.UrgencyHook: Add askUrgent and doAskUrgent These are useful when one blocks some _NET_ACTIVE_WINDOW requests but still wants to somehow show that a window requested focus. Related: https://github.com/xmonad/xmonad-contrib/pull/110 Related: https://github.com/xmonad/xmonad-contrib/pull/128 Related: https://github.com/xmonad/xmonad-contrib/pull/192 --- CHANGES.md | 4 ++++ XMonad/Hooks/UrgencyHook.hs | 28 +++++++++++++++++++++++++++- 2 files changed, 31 insertions(+), 1 deletion(-) diff --git a/CHANGES.md b/CHANGES.md index 3579d151be..dfa11acc4f 100644 --- a/CHANGES.md +++ b/CHANGES.md @@ -634,6 +634,10 @@ - Added a variant of `filterUrgencyHook` that takes a generic `Query Bool` to select which windows should never be marked urgent. + - Added `askUrgent` and a `doAskUrgent` manage hook helper for marking + windows as urgent from inside of xmonad. This can be used as a less + intrusive action for windows requesting focus. + * `XMonad.Hooks.ServerMode` - To make it easier to use, the `xmonadctl` client is now included in diff --git a/XMonad/Hooks/UrgencyHook.hs b/XMonad/Hooks/UrgencyHook.hs index c133c2fc89..b004f33eda 100644 --- a/XMonad/Hooks/UrgencyHook.hs +++ b/XMonad/Hooks/UrgencyHook.hs @@ -60,6 +60,7 @@ module XMonad.Hooks.UrgencyHook ( FocusHook(..), filterUrgencyHook, filterUrgencyHook', minutes, seconds, + askUrgent, doAskUrgent, -- * Stuff for developers: readUrgents, withUrgents, clearUrgents', StdoutUrgencyHook(..), @@ -70,7 +71,7 @@ module XMonad.Hooks.UrgencyHook ( ) where import XMonad -import XMonad.Prelude (delete, fromMaybe, listToMaybe, maybeToList, when, (\\)) +import XMonad.Prelude (fi, delete, fromMaybe, listToMaybe, maybeToList, when, (\\)) import qualified XMonad.StackSet as W import XMonad.Hooks.ManageHelpers (windowTag) @@ -542,3 +543,28 @@ filterUrgencyHook skips = filterUrgencyHook' $ maybe False (`elem` skips) <$> wi -- should never be marked urgent. filterUrgencyHook' :: Query Bool -> Window -> X () filterUrgencyHook' q w = whenX (runQuery q w) (clearUrgents' [w]) + +-- | Mark the given window urgent. +-- +-- (The implementation is a bit hacky: send a _NET_WM_STATE ClientMessage to +-- ourselves. This is so that we respect the 'SuppressWhen' of the configured +-- urgency hooks. If this module if ever migrated to the ExtensibleConf +-- infrastrcture, we'll then invoke markUrgent directly.) +askUrgent :: Window -> X () +askUrgent w = withDisplay $ \dpy -> do + rw <- asks theRoot + a_wmstate <- getAtom "_NET_WM_STATE" + a_da <- getAtom "_NET_WM_STATE_DEMANDS_ATTENTION" + let state_add = 1 + let source_pager = 2 + io $ allocaXEvent $ \e -> do + setEventType e clientMessage + setClientMessageEvent' e w a_wmstate 32 [state_add, fi a_da, 0, source_pager] + sendEvent dpy rw False (substructureRedirectMask .|. substructureNotifyMask) e + +-- | Helper for 'ManageHook' that marks the window as urgent (unless +-- suppressed, see 'SuppressWhen'). Useful in +-- 'XMonad.Hooks.EwmhDesktops.activateLogHook' and also in combination with +-- "XMonad.Hooks.InsertPosition", "XMonad.Hooks.Focus". +doAskUrgent :: ManageHook +doAskUrgent = ask >>= \w -> liftX (askUrgent w) >> return mempty From 071adfda8b9ff0b44e0d33fc5b583af07b999593 Mon Sep 17 00:00:00 2001 From: Tomas Janousek Date: Mon, 18 Oct 2021 14:49:16 +0100 Subject: [PATCH 7/7] fixup! X.H.EWMH.Desktops: New module; implement desktops/windows EWMH hints --- XMonad/Hooks/EWMH/Desktops.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/XMonad/Hooks/EWMH/Desktops.hs b/XMonad/Hooks/EWMH/Desktops.hs index 41752820db..c60f01ef49 100644 --- a/XMonad/Hooks/EWMH/Desktops.hs +++ b/XMonad/Hooks/EWMH/Desktops.hs @@ -76,7 +76,7 @@ setEwmhWorkspaceListTransform f = XC.modifyDef $ \c -> c{ workspaceListTransform -- existing instead of replacing it. addEwmhWorkspaceListTransform :: ([WindowSpace] -> [WindowSpace]) -> XConfig l -> XConfig l addEwmhWorkspaceListTransform f = XC.modifyDef $ \c -> - c{ workspaceListTransform = workspaceListTransform c <> f } + c{ workspaceListTransform = f . workspaceListTransform c } ewmhDesktopsLogHook :: X () ewmhDesktopsLogHook = XC.withDef $ \EwmhDesktopsConfig{workspaceListTransform} -> do