tv xmonad: XMonad.Hooks.EwmhDesktops.Extra
This commit is contained in:
parent
7f012e96af
commit
fd90f35fd9
@ -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";
|
||||||
|
@ -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
|
@ -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
|
||||||
|
Loading…
Reference in New Issue
Block a user