tv xmonad: XMonad.Hooks.EwmhDesktops.Extra

This commit is contained in:
tv 2023-02-07 21:03:36 +01:00
parent 7f012e96af
commit fd90f35fd9
3 changed files with 122 additions and 3 deletions

View File

@ -1,5 +1,5 @@
{ mkDerivation, aeson, base, bytestring, containers, directory { mkDerivation, aeson, base, bytestring, containers, directory
, extra, filepath, lib, unix, X11, xmonad, xmonad-contrib , extra, filepath, lib, pager, unix, X11, xmonad, xmonad-contrib
}: }:
mkDerivation { mkDerivation {
pname = "xmonad-tv"; pname = "xmonad-tv";
@ -8,8 +8,8 @@ mkDerivation {
isLibrary = false; isLibrary = false;
isExecutable = true; isExecutable = true;
executableHaskellDepends = [ executableHaskellDepends = [
aeson base bytestring containers directory extra filepath unix X11 aeson base bytestring containers directory extra filepath pager
xmonad xmonad-contrib unix X11 xmonad xmonad-contrib
]; ];
license = lib.licenses.mit; license = lib.licenses.mit;
mainProgram = "xmonad"; mainProgram = "xmonad";

View File

@ -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

View File

@ -17,10 +17,12 @@ executable xmonad
, directory , directory
, extra , extra
, filepath , filepath
, pager
, unix , unix
, xmonad , xmonad
, xmonad-contrib , xmonad-contrib
other-modules: other-modules:
Shutdown Shutdown
XMonad.Hooks.EwmhDesktops.Extra
default-language: Haskell2010 default-language: Haskell2010
ghc-options: -O2 -Wall ghc-options: -O2 -Wall