ndwarshuis
/
xmonad-config
1
0
Fork 0
Code Issues Pull Requests Packages Projects Releases Wiki Activity

ENH use features for all dynamic workspaces

This commit is contained in:
Nathan Dwarshuis 2022-07-02 20:02:26 -04:00
parent 6aa4dfde3e
commit 851f034c3f
1 changed files with 101 additions and 66 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

133
bin/xmonad.hs
View File

@ -27,7 +27,9 @@ import Graphics.X11.Xlib.Atom
import Graphics.X11.Xlib.Extras import Graphics.X11.Xlib.Extras
import System.Environment import System.Environment
import System.Exit
import System.IO import System.IO
import System.IO.Error
import System.Process import System.Process
import XMonad import XMonad
@ -86,8 +88,9 @@ run = do
db <- connectXDBus db <- connectXDBus
(h, p) <- spawnPipe "xmobar" (h, p) <- spawnPipe "xmobar"
void $ executeSometimes $ runRemovableMon $ dbSystemClient db void $ executeSometimes $ runRemovableMon $ dbSystemClient db
dws <- allDWs
forkIO_ $ void $ executeSometimes runPowermon forkIO_ $ void $ executeSometimes runPowermon
forkIO_ $ runWorkspaceMon allDWs forkIO_ $ runWorkspaceMon dws
let ts = ThreadState let ts = ThreadState
{ tsChildPIDs = [p] { tsChildPIDs = [p]
, tsChildHandles = [h] , tsChildHandles = [h]
@ -100,12 +103,12 @@ run = do
hFlush stdout hFlush stdout
ds <- getDirectories ds <- getDirectories
let conf = ewmh let conf = ewmh
$ addKeymap sk (filterExternal ext) $ addKeymap dws sk (filterExternal ext)
$ docks $ docks
$ def { terminal = myTerm $ def { terminal = myTerm
, modMask = myModMask , modMask = myModMask
, layoutHook = myLayouts fb , layoutHook = myLayouts fb
, manageHook = myManageHook , manageHook = myManageHook dws
, handleEventHook = myEventHook ha , handleEventHook = myEventHook ha
, startupHook = myStartupHook , startupHook = myStartupHook
, workspaces = myWorkspaces , workspaces = myWorkspaces
@ -194,68 +197,97 @@ myStartupHook = setDefaultCursor xC_left_ptr
myWorkspaces :: [WorkspaceId] myWorkspaces :: [WorkspaceId]
myWorkspaces = map show [1..10 :: Int] myWorkspaces = map show [1..10 :: Int]
gimpDynamicWorkspace :: DynWorkspace gimpTag :: String
gimpDynamicWorkspace = DynWorkspace gimpTag = "GIMP"
vmTag :: String
vmTag = "VM"
xsaneTag :: String
xsaneTag = "XSANE"
f5Tag :: String
f5Tag = "F5VPN"
gimpDynamicWorkspace :: Sometimes DynWorkspace
gimpDynamicWorkspace = sometimesIO_ "gimp workspace" "gimp" tree dw
where
tree = Only_ $ sysExe "gimp"
dw = DynWorkspace
{ dwName = "Gimp" { dwName = "Gimp"
, dwTag = t , dwTag = gimpTag
, dwClass = c , dwClass = c
, dwHook = , dwHook =
[ matchGimpRole "gimp-image-window" -?> appendViewShift t [ matchGimpRole "gimp-image-window" -?> appendViewShift gimpTag
, matchGimpRole "gimp-dock" -?> doF W.swapDown , matchGimpRole "gimp-dock" -?> doF W.swapDown
, matchGimpRole "gimp-toolbox" -?> doF W.swapDown , matchGimpRole "gimp-toolbox" -?> doF W.swapDown
, className =? c -?> appendViewShift t , className =? c -?> appendViewShift gimpTag
] ]
, dwKey = 'g' , dwKey = 'g'
, dwCmd = Just $ spawnCmd "gimp-2.10" [] , dwCmd = Just $ spawnCmd "gimp-2.10" []
} }
where
matchGimpRole role = isPrefixOf role <$> stringProperty "WM_WINDOW_ROLE" matchGimpRole role = isPrefixOf role <$> stringProperty "WM_WINDOW_ROLE"
<&&> className =? c <&&> className =? c
t = "GIMP"
c = "Gimp-2.10" -- TODO I don't feel like changing the version long term c = "Gimp-2.10" -- TODO I don't feel like changing the version long term
wmDynamicWorkspace :: DynWorkspace vmDynamicWorkspace :: Sometimes DynWorkspace
wmDynamicWorkspace = DynWorkspace vmDynamicWorkspace = sometimes1 "virtualbox workspace" "windows 8 VM" root
{ dwName = "Windows VirtualBox"
, dwTag = t
, dwClass = c
, dwHook = [ className =? c -?> appendViewShift t ]
, dwKey = 'v'
, dwCmd = Just $ spawnCmd "vbox-start" ["win8raw"]
}
where where
t = "VM" root = IORoot_ dw $ And_ (Only_ $ sysExe "VBoxManage")
$ Only_ $ sysTest name $ vmExists vm
name = unwords ["test if", vm, "exists"]
c = "VirtualBoxVM" c = "VirtualBoxVM"
vm = "win8raw"
xsaneDynamicWorkspace :: DynWorkspace dw = DynWorkspace
xsaneDynamicWorkspace = DynWorkspace { dwName = "Windows VirtualBox"
{ dwName = "XSane" , dwTag = vmTag
, dwTag = t
, dwClass = c , dwClass = c
, dwHook = [ className =? c -?> appendViewShift t >> doFloat ] , dwHook = [ className =? c -?> appendViewShift vmTag ]
, dwKey = 'v'
, dwCmd = Just $ spawnCmd "vbox-start" [vm]
}
-- TODO this shell command is hilariously slow and kills my fast startup time
vmExists :: String -> IO (Maybe String)
vmExists vm =
go <$> tryIOError (readCreateProcessWithExitCode' pr "")
where
pr = proc' "VBoxManage" ["showvminfo", vm]
go (Right (ExitSuccess, _, _)) = Nothing
go (Right (ExitFailure _, _, _)) = Just $ "VM not found: " ++ vm
go (Left e) = Just $ show e
xsaneDynamicWorkspace :: Sometimes DynWorkspace
xsaneDynamicWorkspace = sometimesIO_ "scanner workspace" "xsane" tree dw
where
tree = Only_ $ sysExe "xsane"
dw = DynWorkspace
{ dwName = "XSane"
, dwTag = xsaneTag
, dwClass = c
, dwHook = [ className =? c -?> appendViewShift xsaneTag >> doFloat ]
, dwKey = 'x' , dwKey = 'x'
, dwCmd = Just $ spawnCmd "xsane" [] , dwCmd = Just $ spawnCmd "xsane" []
} }
where
t = "XSANE"
c = "Xsane" c = "Xsane"
f5vpnDynamicWorkspace :: DynWorkspace f5vpnDynamicWorkspace :: Sometimes DynWorkspace
f5vpnDynamicWorkspace = DynWorkspace f5vpnDynamicWorkspace = sometimesIO_ "F5 VPN workspace" "f5vpn" tree dw
where
tree = Only_ $ sysExe "f5vpn"
dw = DynWorkspace
{ dwName = "F5Vpn" { dwName = "F5Vpn"
, dwTag = t , dwTag = f5Tag
, dwClass = c , dwClass = c
, dwHook = [ className =? c -?> appendShift t ] , dwHook = [ className =? c -?> appendShift f5Tag ]
, dwKey = 'i' , dwKey = 'i'
, dwCmd = Just skip , dwCmd = Just skip
} }
where
t = "F5VPN"
c = "F5 VPN" c = "F5 VPN"
allDWs :: [DynWorkspace] allDWs :: IO [DynWorkspace]
allDWs = [ xsaneDynamicWorkspace allDWs = catMaybes <$> mapM evalSometimes [ xsaneDynamicWorkspace
, wmDynamicWorkspace , vmDynamicWorkspace
, gimpDynamicWorkspace , gimpDynamicWorkspace
, f5vpnDynamicWorkspace , f5vpnDynamicWorkspace
] ]
@ -263,8 +295,11 @@ allDWs = [ xsaneDynamicWorkspace
-------------------------------------------------------------------------------- --------------------------------------------------------------------------------
-- | Layout configuration -- | Layout configuration
myLayouts fb = onWorkspace (dwTag wmDynamicWorkspace) vmLayout -- NOTE this will have all available layouts, even those that may be for
$ onWorkspace (dwTag gimpDynamicWorkspace) gimpLayout -- features that failed. Trying to dynamically take out a layout seems to
-- make a new type :/
myLayouts fb = onWorkspace vmTag vmLayout
$ onWorkspace gimpTag gimpLayout
$ mkToggle (single HIDE) $ mkToggle (single HIDE)
$ tall ||| fulltab ||| full $ tall ||| fulltab ||| full
where where
@ -412,11 +447,11 @@ compareXCoord s0 s1 = compare x0 x1
-------------------------------------------------------------------------------- --------------------------------------------------------------------------------
-- | Managehook configuration -- | Managehook configuration
myManageHook :: ManageHook myManageHook :: [DynWorkspace] -> ManageHook
myManageHook = manageApps <+> manageHook def myManageHook dws = manageApps dws <+> manageHook def
manageApps :: ManageHook manageApps :: [DynWorkspace] -> ManageHook
manageApps = composeOne $ concatMap dwHook allDWs ++ manageApps dws = composeOne $ concatMap dwHook dws ++
[ isDialog -?> doCenterFloat [ isDialog -?> doCenterFloat
-- the seafile applet -- the seafile applet
, className =? "Seafile Client" -?> doFloat , className =? "Seafile Client" -?> doFloat
@ -458,13 +493,13 @@ xMsgEventHook _ _ = return (All True)
myModMask :: KeyMask myModMask :: KeyMask
myModMask = mod4Mask myModMask = mod4Mask
addKeymap :: ([((KeyMask, KeySym), NamedAction)] -> X ()) addKeymap :: [DynWorkspace] -> ([((KeyMask, KeySym), NamedAction)] -> X ())
-> [KeyGroup (X ())] -> XConfig l -> XConfig l -> [KeyGroup (X ())] -> XConfig l -> XConfig l
addKeymap showKeys external = addDescrKeys' ((myModMask, xK_F1), showKeys) addKeymap dws showKeys external = addDescrKeys' ((myModMask, xK_F1), showKeys)
(\c -> concatMap (mkNamedSubmap c) $ internalBindings c ++ external) (\c -> concatMap (mkNamedSubmap c) $ internalBindings dws c ++ external)
internalBindings :: XConfig Layout -> [KeyGroup (X ())] internalBindings :: [DynWorkspace] -> XConfig Layout -> [KeyGroup (X ())]
internalBindings c = internalBindings dws c =
[ KeyGroup "Window Layouts" [ KeyGroup "Window Layouts"
[ KeyBinding "M-j" "focus down" $ windows W.focusDown [ KeyBinding "M-j" "focus down" $ windows W.focusDown
, KeyBinding "M-k" "focus up" $ windows W.focusUp , KeyBinding "M-k" "focus up" $ windows W.focusUp
@ -501,7 +536,7 @@ internalBindings c =
, KeyGroup "Dynamic Workspaces" , KeyGroup "Dynamic Workspaces"
[ KeyBinding ("M-C-" ++ [k]) ("launch/switch to " ++ n) cmd [ KeyBinding ("M-C-" ++ [k]) ("launch/switch to " ++ n) cmd
| DynWorkspace { dwTag = t, dwKey = k, dwCmd = a, dwName = n } <- allDWs, | DynWorkspace { dwTag = t, dwKey = k, dwCmd = a, dwName = n } <- dws,
let cmd = case a of let cmd = case a of
Just a' -> spawnOrSwitch t a' Just a' -> spawnOrSwitch t a'
Nothing -> windows $ W.view t Nothing -> windows $ W.view t