From fd90f35fd94ab949daf73e7253a2b0133311057c Mon Sep 17 00:00:00 2001 From: tv Date: Tue, 7 Feb 2023 21:03:36 +0100 Subject: tv xmonad: XMonad.Hooks.EwmhDesktops.Extra --- tv/5pkgs/haskell/xmonad-tv/default.nix | 6 +- .../src/XMonad/Hooks/EwmhDesktops/Extra.hs | 117 +++++++++++++++++++++ tv/5pkgs/haskell/xmonad-tv/src/xmonad-tv.cabal | 2 + 3 files changed, 122 insertions(+), 3 deletions(-) create mode 100644 tv/5pkgs/haskell/xmonad-tv/src/XMonad/Hooks/EwmhDesktops/Extra.hs (limited to 'tv') diff --git a/tv/5pkgs/haskell/xmonad-tv/default.nix b/tv/5pkgs/haskell/xmonad-tv/default.nix index 60e9d3b43..f42f97c2a 100644 --- a/tv/5pkgs/haskell/xmonad-tv/default.nix +++ b/tv/5pkgs/haskell/xmonad-tv/default.nix @@ -1,5 +1,5 @@ { mkDerivation, aeson, base, bytestring, containers, directory -, extra, filepath, lib, unix, X11, xmonad, xmonad-contrib +, extra, filepath, lib, pager, unix, X11, xmonad, xmonad-contrib }: mkDerivation { pname = "xmonad-tv"; @@ -8,8 +8,8 @@ mkDerivation { isLibrary = false; isExecutable = true; executableHaskellDepends = [ - aeson base bytestring containers directory extra filepath unix X11 - xmonad xmonad-contrib + aeson base bytestring containers directory extra filepath pager + unix X11 xmonad xmonad-contrib ]; license = lib.licenses.mit; mainProgram = "xmonad"; diff --git a/tv/5pkgs/haskell/xmonad-tv/src/XMonad/Hooks/EwmhDesktops/Extra.hs b/tv/5pkgs/haskell/xmonad-tv/src/XMonad/Hooks/EwmhDesktops/Extra.hs new file mode 100644 index 000000000..bf8431446 --- /dev/null +++ b/tv/5pkgs/haskell/xmonad-tv/src/XMonad/Hooks/EwmhDesktops/Extra.hs @@ -0,0 +1,117 @@ +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE MultiWayIf #-} +{-# LANGUAGE NamedFieldPuns #-} + +module XMonad.Hooks.EwmhDesktops.Extra where + +import Control.Monad (when) +import Data.Maybe (fromMaybe) +import Data.Monoid (All) +import Data.Tuple.Extra (both) +import Graphics.X11.EWMH (getDesktopNames, setDesktopNames) +import Graphics.X11.EWMH.Atom (_NET_DESKTOP_NAMES) +import Graphics.X11.Xlib.Display.Extra (withDefaultDisplay) +import XMonad hiding (workspaces) +import XMonad.Actions.DynamicWorkspaces (addHiddenWorkspace, removeEmptyWorkspaceByTag) +import XMonad.StackSet (mapWorkspace, tag, workspaces) +import XMonad.Util.WorkspaceCompare (getSortByIndex) +import qualified Data.Map.Strict as Map +import qualified Data.Set as Set +import qualified XMonad + + +ewmhExtra :: XConfig a -> IO (XConfig a) +ewmhExtra c = do + -- XMonad.Hooks.EwmhDesktops.setDesktopViewport uses _NET_DESKTOP_VIEWPORT + -- only if it exists. This seems to be a harmless issue, but by creating + -- the atom here, we suppress the error message: + -- + -- xmonad: X11 error: BadAtom (invalid Atom parameter), + -- request code=18, error code=5 + -- + _ <- + withDefaultDisplay $ \dpy -> internAtom dpy "_NET_DESKTOP_VIEWPORT" False + + initialWorkspaces <- + Data.Maybe.fromMaybe (XMonad.workspaces def) + <$> withDefaultDisplay getDesktopNames + + return + c { handleEventHook = ewmhDesktopsExtraEventHook <> handleEventHook c + , rootMask = rootMask c .|. propertyChangeMask + , XMonad.workspaces = initialWorkspaces + } + +ewmhDesktopsExtraEventHook :: Event -> X All +ewmhDesktopsExtraEventHook = \case + PropertyEvent{ev_window, ev_atom} -> do + r <- asks theRoot + when (ev_window == r && ev_atom == _NET_DESKTOP_NAMES) $ + withDisplay $ \dpy -> do + sort <- getSortByIndex + + oldNames <- gets $ map tag . sort . workspaces . windowset + newNames <- fromMaybe oldNames <$> io (getDesktopNames dpy) + + let + (renamesFrom, renamesTo) = both Set.fromList $ unzip renames + + renames = go oldNames newNames where + go old@(headOld : tailOld) new@(headNew : tailNew) = do + let + deleteOld = Set.member headOld deleteNameSet + createNew = Set.member headNew createNameSet + + if + | headOld == headNew -> + -- assert (not deleteOld && not createNew) + go tailOld tailNew + + | deleteOld && createNew -> + (headOld, headNew) : + go tailOld tailNew + + | deleteOld -> + go tailOld new + + | createNew -> + go old tailNew + + | otherwise -> + -- assert (headOld == headNew) + go tailOld tailNew + + go _ _ = [] + + oldNameSet = Set.fromList oldNames + newNameSet = Set.fromList newNames + deleteNameSet = Set.difference oldNameSet newNameSet + createNameSet = Set.difference newNameSet oldNameSet + + deleteNames = Set.toAscList $ + Set.difference deleteNameSet renamesFrom + createNames = Set.toAscList $ + Set.difference createNameSet renamesTo + + mapM_ addHiddenWorkspace createNames + mapM_ removeEmptyWorkspaceByTag deleteNames + when (not (null renames)) $ do + let + renameMap = Map.fromList renames + rename w = + case Map.lookup (tag w) renameMap of + Just newName -> w { tag = newName } + Nothing -> w + + modifyWindowSet $ mapWorkspace rename + + names <- gets $ map tag . sort . workspaces . windowset + + when (names /= newNames) $ do + trace $ "setDesktopNames " <> show names + io (setDesktopNames names dpy) + + mempty + + _ -> + mempty diff --git a/tv/5pkgs/haskell/xmonad-tv/src/xmonad-tv.cabal b/tv/5pkgs/haskell/xmonad-tv/src/xmonad-tv.cabal index 94aecd75f..0f61ba659 100644 --- a/tv/5pkgs/haskell/xmonad-tv/src/xmonad-tv.cabal +++ b/tv/5pkgs/haskell/xmonad-tv/src/xmonad-tv.cabal @@ -17,10 +17,12 @@ executable xmonad , directory , extra , filepath + , pager , unix , xmonad , xmonad-contrib other-modules: Shutdown + XMonad.Hooks.EwmhDesktops.Extra default-language: Haskell2010 ghc-options: -O2 -Wall -- cgit v1.2.3