ENH use features for all dynamic workspaces
This commit is contained in:
parent
6aa4dfde3e
commit
851f034c3f
133
bin/xmonad.hs
133
bin/xmonad.hs
|
@ -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
|
||||||
|
|
Loading…
Reference in New Issue