(wip) Refactor EWMH support

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

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 <tomi@nomi.cz>
+-- License     :  BSD3
+-- Maintainer  :  Tomáš Janoušek <tomi@nomi.cz>
+--
+-- 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 = f . workspaceListTransform c }
+
+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]

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

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

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 <tomi@nomi.cz>
+-- License     :  BSD3
+-- Maintainer  :  Tomáš Janoušek <tomi@nomi.cz>
+--
+-- The common bits of of xmonad's implementation of the EWMH specification
+-- (<https://specifications.freedesktop.org/wm-spec/latest/>).
+--
+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