1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
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
|
