xmonad-config/bin/xmonad.hs

708 lines
26 KiB
Haskell
Raw Normal View History

2020-03-28 19:58:26 -04:00
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE MultiParamTypeClasses #-}
2020-04-01 22:06:00 -04:00
--------------------------------------------------------------------------------
-- | XMonad binary
module Main (main) where
2020-03-22 23:23:02 -04:00
import Control.Concurrent
2021-11-20 15:20:22 -05:00
import Control.Monad
2022-07-09 17:44:14 -04:00
import Data.Internal.DBus
import Data.Internal.Dependency
2020-04-01 20:17:47 -04:00
import Data.List
import Data.Maybe
2022-07-09 17:48:07 -04:00
import Data.Monoid
2020-03-22 23:23:02 -04:00
import Graphics.X11.Types
import Graphics.X11.Xlib.Atom
import Graphics.X11.Xlib.Extras
2022-12-26 09:44:49 -05:00
import RIO (async)
import System.Directory
import System.Environment
2020-03-22 23:23:02 -04:00
import System.IO
import System.IO.Error
import System.Process
2020-03-22 23:23:02 -04:00
import XMonad
import XMonad.Actions.CopyWindow
import XMonad.Actions.CycleWS
import XMonad.Actions.PhysicalScreens
2020-03-27 21:09:40 -04:00
import XMonad.Actions.Warp
2020-04-01 20:17:47 -04:00
import XMonad.Hooks.DynamicLog
2020-03-22 23:23:02 -04:00
import XMonad.Hooks.EwmhDesktops
import XMonad.Hooks.ManageDocks
import XMonad.Hooks.ManageHelpers
2020-04-01 20:17:47 -04:00
import XMonad.Internal.Command.DMenu
2021-06-19 00:54:01 -04:00
import XMonad.Internal.Command.Desktop
2020-04-01 20:17:47 -04:00
import XMonad.Internal.Command.Power
import XMonad.Internal.Concurrent.ACPIEvent
import XMonad.Internal.Concurrent.ClientMessage
import XMonad.Internal.Concurrent.DynamicWorkspaces
import XMonad.Internal.Concurrent.VirtualBox
2021-11-21 00:42:40 -05:00
import XMonad.Internal.DBus.Brightness.ClevoKeyboard
import XMonad.Internal.DBus.Brightness.Common
import XMonad.Internal.DBus.Brightness.IntelBacklight
2020-04-01 20:17:47 -04:00
import XMonad.Internal.DBus.Control
import XMonad.Internal.DBus.Removable
2021-11-29 00:56:16 -05:00
import XMonad.Internal.DBus.Screensaver
2020-04-01 20:17:47 -04:00
import XMonad.Internal.Process
import XMonad.Internal.Shell
import qualified XMonad.Internal.Theme as T
2020-03-28 19:58:26 -04:00
import XMonad.Layout.MultiToggle
2020-03-22 23:23:02 -04:00
import XMonad.Layout.NoBorders
import XMonad.Layout.NoFrillsDecoration
import XMonad.Layout.PerWorkspace
import XMonad.Layout.Renamed
2020-03-22 23:23:02 -04:00
import XMonad.Layout.Tabbed
import qualified XMonad.Operations as O
import qualified XMonad.StackSet as W
2020-04-05 00:48:44 -04:00
import XMonad.Util.Cursor
2020-03-22 23:23:02 -04:00
import XMonad.Util.EZConfig
import qualified XMonad.Util.ExtensibleState as E
2020-03-22 23:23:02 -04:00
import XMonad.Util.NamedActions
import XMonad.Util.WorkspaceCompare
2020-03-20 01:15:22 -04:00
main :: IO ()
main = getArgs >>= parse
parse :: [String] -> IO ()
parse [] = run
parse ["--deps"] = withCache printDeps
parse ["--test"] = void $ withCache . evalConf =<< connectDBusX
parse _ = usage
run :: IO ()
run = do
db <- connectDBusX
conf <- withCache $ evalConf db
ds <- getCreateDirectories
2022-07-03 18:23:32 -04:00
-- IDK why this is necessary; nothing prior to this will print if missing
hFlush stdout
2022-03-05 18:18:16 -05:00
launch conf ds
2022-07-03 18:23:32 -04:00
getCreateDirectories :: IO Directories
getCreateDirectories = do
ds <- getDirectories
mapM_ (createIfMissing ds) [dataDir, cfgDir, cacheDir]
return ds
where
createIfMissing ds f = do
let d = f ds
r <- tryIOError $ createDirectoryIfMissing True d
case r of
(Left e) -> print e
_ -> return ()
2022-07-03 18:23:32 -04:00
data FeatureSet = FeatureSet
{ fsKeys :: ThreadState -> DBusState -> [KeyGroup FeatureX]
2022-07-09 17:08:10 -04:00
, fsDBusExporters :: [Maybe SesClient -> SometimesIO]
2022-07-03 18:23:32 -04:00
, fsPowerMon :: SometimesIO
2022-07-09 17:08:10 -04:00
, fsRemovableMon :: Maybe SysClient -> SometimesIO
2022-07-03 18:23:32 -04:00
, fsDaemons :: [Sometimes (IO ProcessHandle)]
, fsACPIHandler :: Always (String -> X ())
, fsTabbedTheme :: Always Theme
, fsDynWorkspaces :: [Sometimes DynWorkspace]
, fsShowKeys :: Always ([((KeyMask, KeySym), NamedAction)] -> X ())
}
tabbedFeature :: Always Theme
tabbedFeature = Always "theme for tabbed windows" $ Option sf fallback
where
sf = Subfeature niceTheme "theme with nice font"
niceTheme = IORoot T.tabbedTheme $ fontTree T.defFontFamily defFontPkgs
fallback = Always_ $ FallbackAlone $ T.tabbedTheme T.fallbackFont
2022-07-09 17:08:10 -04:00
features :: Maybe SysClient -> FeatureSet
2022-07-08 00:21:05 -04:00
features cl = FeatureSet
2022-07-03 18:23:32 -04:00
{ fsKeys = externalBindings
, fsDBusExporters = dbusExporters
, fsPowerMon = runPowermon
, fsRemovableMon = runRemovableMon
, fsACPIHandler = runHandleACPI
, fsDynWorkspaces = allDWs'
, fsTabbedTheme = tabbedFeature
2022-07-03 18:23:32 -04:00
, fsShowKeys = runShowKeys
2022-07-08 00:21:05 -04:00
, fsDaemons = [runNetAppDaemon cl, runAutolock]
2022-07-03 18:23:32 -04:00
}
2022-07-08 00:21:05 -04:00
evalConf db@DBusState { dbSysClient = cl } = do
2022-07-03 18:23:32 -04:00
-- start DBus interfaces first since many features after this test these
-- interfaces as dependencies
2022-07-08 00:21:05 -04:00
let fs = features cl
startDBusInterfaces fs
(xmobarHandle, ts) <- startChildDaemons fs
startRemovableMon fs
startPowerMon fs
dws <- startDynWorkspaces fs
tt <- evalAlways $ fsTabbedTheme fs
2022-07-03 18:23:32 -04:00
-- fb <- evalAlways $ fsFontBuilder features
2022-07-08 00:21:05 -04:00
kbs <- filterExternal <$> evalExternal (fsKeys fs ts db)
sk <- evalAlways $ fsShowKeys fs
ha <- evalAlways $ fsACPIHandler fs
2022-07-03 18:23:32 -04:00
return $ ewmh
$ addKeymap dws sk kbs
$ docks
$ def { terminal = myTerm
, modMask = myModMask
, layoutHook = myLayouts tt
, manageHook = myManageHook dws
, handleEventHook = myEventHook ha
, startupHook = myStartupHook
, workspaces = myWorkspaces
, logHook = myLoghook xmobarHandle
, clickJustFocuses = False
, focusFollowsMouse = False
, normalBorderColor = T.bordersColor
, focusedBorderColor = T.selectedBordersColor
}
2021-11-20 15:20:22 -05:00
where
forkIO_ = void . forkIO
2022-07-08 00:21:05 -04:00
startDBusInterfaces fs = mapM_ (\f -> executeSometimes $ f $ dbSesClient db)
$ fsDBusExporters fs
startChildDaemons fs = do
(h, p) <- io $ spawnPipe "xmobar"
2022-07-08 00:21:05 -04:00
ps <- catMaybes <$> mapM executeSometimes (fsDaemons fs)
2022-07-03 18:23:32 -04:00
return (h, ThreadState (p:ps) [h])
2022-07-08 00:21:05 -04:00
startRemovableMon fs = void $ executeSometimes $ fsRemovableMon fs
2022-07-03 18:23:32 -04:00
$ dbSysClient db
2022-12-26 09:44:49 -05:00
startPowerMon fs = void $ async $ void $ executeSometimes $ fsPowerMon fs
2022-07-08 00:21:05 -04:00
startDynWorkspaces fs = do
dws <- catMaybes <$> mapM evalSometimes (fsDynWorkspaces fs)
io $ forkIO_ $ runWorkspaceMon dws
2022-07-03 18:23:32 -04:00
return dws
printDeps :: FIO ()
2022-06-28 21:24:21 -04:00
printDeps = do
db <- io connectDBus
2022-07-02 20:08:37 -04:00
(i, f, d) <- allFeatures db
2022-12-25 18:07:03 -05:00
let is = concatMap dumpSometimes i
let fs = concatMap dumpFeature f
let ds = concatMap dumpSometimes d
let ps = fmap showFulfillment $ sort $ nub $ is ++ fs ++ ds
io $ mapM_ putStrLn ps
io $ disconnectDBus db
2022-06-28 21:24:21 -04:00
allFeatures :: DBusState -> FIO ([SometimesIO], [FeatureX], [Sometimes DynWorkspace])
2022-06-28 21:24:21 -04:00
allFeatures db = do
let bfs = concatMap (fmap kbMaybeAction . kgBindings)
$ externalBindings ts db
2022-07-03 18:23:32 -04:00
let dbus = fmap (\f -> f $ dbSesClient db) dbusExporters
let others = [runRemovableMon $ dbSysClient db, runPowermon]
2022-07-02 20:08:37 -04:00
return (dbus ++ others, Left runScreenLock:bfs, allDWs')
2022-06-28 21:24:21 -04:00
where
ts = ThreadState { tsChildPIDs = [], tsChildHandles = [] }
usage :: IO ()
usage = putStrLn $ intercalate "\n"
[ "xmonad: run greatest window manager"
, "xmonad --deps: print dependencies"
]
2020-04-01 22:06:00 -04:00
--------------------------------------------------------------------------------
-- | Concurrency configuration
2020-03-28 18:38:38 -04:00
data ThreadState = ThreadState
{ tsChildPIDs :: [ProcessHandle]
, tsChildHandles :: [Handle]
}
2020-03-28 18:38:38 -04:00
-- TODO shouldn't this be run by a signal handler?
runCleanup :: ThreadState -> DBusState -> X ()
runCleanup ts db = io $ do
2021-11-20 15:20:22 -05:00
mapM_ killHandle $ tsChildPIDs ts
2022-07-03 18:23:32 -04:00
disconnectDBusX db
2020-03-28 18:38:38 -04:00
2020-04-01 22:06:00 -04:00
--------------------------------------------------------------------------------
-- | Startuphook configuration
-- TODO add _NET_DESKTOP_VIEWPORTS to _NET_SUPPORTED?
myStartupHook :: X ()
myStartupHook = setDefaultCursor xC_left_ptr
2020-04-05 00:48:44 -04:00
<+> startupHook def
2020-04-01 22:06:00 -04:00
--------------------------------------------------------------------------------
-- | Workspace configuration
myWorkspaces :: [WorkspaceId]
myWorkspaces = map show [1..10 :: Int]
gimpTag :: String
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 [Package Official "gimp"] exe
dw = DynWorkspace
{ dwName = "Gimp"
, dwTag = gimpTag
, dwClass = c
, dwHook =
[ matchGimpRole "gimp-image-window" -?> appendViewShift gimpTag
, matchGimpRole "gimp-dock" -?> doF W.swapDown
, matchGimpRole "gimp-toolbox" -?> doF W.swapDown
, className =? c -?> appendViewShift gimpTag
]
, dwKey = 'g'
2022-07-09 01:11:02 -04:00
, dwCmd = Just $ spawnCmd exe []
}
2022-07-09 01:11:02 -04:00
exe = "gimp-2.10"
matchGimpRole role = isPrefixOf role <$> stringProperty "WM_WINDOW_ROLE"
<&&> className =? c
c = "Gimp-2.10" -- TODO I don't feel like changing the version long term
2022-08-30 00:21:21 -04:00
-- TODO don't hardcode the VM name/title/shortcut
vmDynamicWorkspace :: Sometimes DynWorkspace
vmDynamicWorkspace = Sometimes "virtualbox workspace" xpfVirtualBox
[Subfeature root "windows 8 VM"]
where
root = IORoot_ dw $ toAnd_ (sysExe [Package Official "virtualbox"] "VBoxManage")
$ IOTest_ name [] $ vmExists vm
name = unwords ["test if", vm, "exists"]
c = "VirtualBoxVM"
vm = "win8raw"
dw = DynWorkspace
{ dwName = "Windows VirtualBox"
, dwTag = vmTag
, dwClass = c
, dwHook = [ className =? c -?> appendViewShift vmTag ]
, dwKey = 'v'
, dwCmd = Just $ spawnCmd "vbox-start" [vm]
}
xsaneDynamicWorkspace :: Sometimes DynWorkspace
xsaneDynamicWorkspace = Sometimes "scanner workspace" xpfXSANE
[Subfeature (IORoot_ dw tree) "xsane"]
where
tree = Only_ $ sysExe [Package Official "xsane"] "xsane"
dw = DynWorkspace
{ dwName = "XSane"
, dwTag = xsaneTag
, dwClass = c
, dwHook = [ className =? c -?> appendViewShift xsaneTag >> doFloat ]
, dwKey = 'x'
, dwCmd = Just $ spawnCmd "xsane" []
}
c = "Xsane"
f5vpnDynamicWorkspace :: Sometimes DynWorkspace
2022-07-09 01:07:41 -04:00
f5vpnDynamicWorkspace = Sometimes "F5 VPN workspace" xpfF5VPN
[Subfeature (IORoot_ dw tree) "f5vpn"]
where
tree = Only_ $ sysExe [Package AUR "f5vpn"] "f5vpn"
dw = DynWorkspace
{ dwName = "F5Vpn"
, dwTag = f5Tag
, dwClass = c
, dwHook = [ className =? c -?> appendShift f5Tag ]
, dwKey = 'i'
, dwCmd = Just skip
}
c = "F5 VPN"
2022-07-02 20:08:37 -04:00
allDWs' :: [Sometimes DynWorkspace]
allDWs' = [xsaneDynamicWorkspace
, vmDynamicWorkspace
, gimpDynamicWorkspace
, f5vpnDynamicWorkspace
]
2020-04-01 22:06:00 -04:00
--------------------------------------------------------------------------------
-- | Layout configuration
-- NOTE this will have all available layouts, even those that may be for
-- features that failed. Trying to dynamically take out a layout seems to
-- make a new type :/
2022-07-03 18:23:32 -04:00
myLayouts tt = onWorkspace vmTag vmLayout
$ onWorkspace gimpTag gimpLayout
2020-03-28 19:58:26 -04:00
$ mkToggle (single HIDE)
$ tall ||| fulltab ||| full
where
2022-07-03 18:23:32 -04:00
addTopBar = noFrillsDeco shrinkText tt
tall = renamed [Replace "Tall"]
$ avoidStruts
$ addTopBar
$ noBorders
$ Tall 1 0.03 0.5
2020-03-28 19:58:26 -04:00
fulltab = renamed [Replace "Tabbed"]
$ avoidStruts
$ noBorders
2022-07-03 18:23:32 -04:00
$ tabbedAlways shrinkText tt
full = renamed [Replace "Full"]
$ noBorders Full
vmLayout = noBorders Full
-- TODO use a tabbed layout for multiple master windows
gimpLayout = renamed [Replace "Gimp Layout"]
$ avoidStruts
$ noBorders
$ addTopBar
$ Tall 1 0.025 0.8
2020-04-01 22:06:00 -04:00
-- | Make a new empty layout and add a message to show/hide it. This is useful
-- for quickly showing conky.
2020-03-28 19:58:26 -04:00
data EmptyLayout a = EmptyLayout
deriving (Show, Read)
instance LayoutClass EmptyLayout a where
doLayout a b _ = emptyLayout a b
description _ = "Desktop"
data HIDE = HIDE
deriving (Read, Show, Eq, Typeable)
instance Transformer HIDE Window where
transform _ x k = k EmptyLayout (\EmptyLayout -> x)
-- TODO toggle back to normal when a new window is opened
2020-03-28 19:58:26 -04:00
runHide :: X ()
runHide = sendMessage $ Toggle HIDE
2020-04-01 22:06:00 -04:00
--------------------------------------------------------------------------------
-- | Loghook configuration
2020-04-01 22:06:00 -04:00
--
myLoghook :: Handle -> X ()
myLoghook h = do
logXinerama h
logViewports
-- | Viewports loghook
-- This is all stuff that should probably be added to the EVMH contrib module.
-- Basically, this will send the workspace "viewport" positions to
-- _NET_DESKTOP_VIEWPORT which can be further processed by tools such as
-- 'wmctrl' to figure out which workspaces are on what monitor outside of
-- xmomad. This is more or less the way i3 does this, where the current
-- workspace has a valid position and everything else is just (0, 0). Also, I
-- probably should set the _NET_SUPPORT atom to reflect the existance of
-- _NET_DESKTOP_VIEWPORT, but for now there seems to be no ill effects so why
-- bother...(if that were necessary it would go in the startup hook)
newtype DesktopViewports = DesktopViewports [Int]
deriving Eq
instance ExtensionClass DesktopViewports where
initialValue = DesktopViewports []
logViewports :: X ()
logViewports = withWindowSet $ \s -> do
sort' <- getSortByIndex
let ws = sort' $ W.workspaces s
let desktopViewports = concatMap (wsToViewports s) ws
whenChanged (DesktopViewports desktopViewports) $
setDesktopViewports desktopViewports
where
wsToViewports s w = let cur = W.current s in
if W.tag w == currentTag cur then currentPos cur else [0, 0]
currentTag = W.tag . W.workspace
currentPos = rectXY . screenRect . W.screenDetail
rectXY (Rectangle x y _ _) = [fromIntegral x, fromIntegral y]
setDesktopViewports :: [Int] -> X ()
setDesktopViewports vps = withDisplay $ \dpy -> do
r <- asks theRoot
a <- getAtom "_NET_DESKTOP_VIEWPORT"
c <- getAtom "CARDINAL"
io $ changeProperty32 dpy r a c propModeReplace $ map fromIntegral vps
-- stolen from XMonad.Hooks.EwmhDesktops
whenChanged :: (Eq a, ExtensionClass a) => a -> X () -> X ()
whenChanged v action = do
v0 <- E.get
unless (v == v0) $ do
action
E.put v
-- | Xinerama loghook (for xmobar)
2020-04-01 22:06:00 -04:00
-- The format will be like "[<1> 2 3] 4 5 | LAYOUT (N)" where each digit is the
-- workspace and LAYOUT is the current layout. Each workspace in the brackets is
-- currently visible and the order reflects the physical location of each
-- screen. The "<>" is the workspace that currently has focus. N is the number
-- of windows on the current workspace.
logXinerama :: Handle -> X ()
logXinerama h = withWindowSet $ \ws -> io
$ hPutStrLn h
$ unwords
$ filter (not . null) [onScreen ws, offScreen ws, sep, layout ws, nWindows ws]
where
onScreen ws = xmobarColor hilightFgColor hilightBgColor
2020-04-01 20:17:47 -04:00
$ pad
$ unwords
$ map (fmtTags ws . W.tag . W.workspace)
2020-04-01 18:51:30 -04:00
$ sortBy compareXCoord
$ W.current ws : W.visible ws
offScreen ws = xmobarColor T.backdropFgColor ""
2020-04-01 18:51:30 -04:00
$ unwords
$ map W.tag
2020-04-01 18:51:30 -04:00
$ filter (isJust . W.stack)
$ sortOn W.tag
$ W.hidden ws
2020-04-01 20:17:47 -04:00
sep = xmobarColor T.backdropFgColor "" ":"
layout ws = description $ W.layout $ W.workspace $ W.current ws
nWindows ws = wrap "(" ")"
2020-04-01 18:51:30 -04:00
$ show
$ length
$ W.integrate'
$ W.stack
$ W.workspace
$ W.current ws
2021-09-06 00:30:06 -04:00
hilightBgColor = "#A6D3FF"
2021-07-06 12:26:14 -04:00
hilightFgColor = T.blend' 0.4 hilightBgColor T.fgColor
fmtTags ws t = if t == W.currentTag ws
2020-04-01 20:17:47 -04:00
then xmobarColor T.fgColor hilightBgColor t
2020-04-01 18:51:30 -04:00
else t
compareXCoord
:: W.Screen i1 l1 a1 ScreenId ScreenDetail
-> W.Screen i2 l2 a2 ScreenId ScreenDetail -> Ordering
2022-08-06 00:10:29 -04:00
compareXCoord s0 s1 = compare (go s0) (go s1)
2020-04-01 18:51:30 -04:00
where
2022-08-06 00:10:29 -04:00
go = (\(Rectangle x _ _ _) -> x) . snd . getScreenIdAndRectangle
2020-04-01 22:06:00 -04:00
--------------------------------------------------------------------------------
-- | Managehook configuration
myManageHook :: [DynWorkspace] -> ManageHook
myManageHook dws = manageApps dws <+> manageHook def
manageApps :: [DynWorkspace] -> ManageHook
manageApps dws = composeOne $ concatMap dwHook dws ++
[ isDialog -?> doCenterFloat
-- the seafile applet
, className =? "Seafile Client" -?> doFloat
-- gnucash
, (className =? "Gnucash" <&&> title =? "Transaction Import Assistant") -?> doFloat
2020-04-08 23:16:34 -04:00
-- plots and graphics
, className =? "R_x11" -?> doFloat
2020-04-08 23:16:34 -04:00
, className =? "Matplotlib" -?> doFloat
, className =? "mpv" -?> doFloat
-- the floating windows created by the brave browser
, stringProperty "WM_NAME" =? "Brave" -?> doFloat
2020-05-02 00:19:54 -04:00
-- , (stringProperty "WM_WINDOW_ROLE" =? "pop-up"
-- <&&> className =? "Brave-browser") -?> doFloat
-- the dialog windows created by the zotero addon in Google Docs
, (className =? "Zotero" <&&> resource =? "Toplevel") -?> doFloat
]
2020-04-01 22:06:00 -04:00
--------------------------------------------------------------------------------
-- | Eventhook configuration
myEventHook :: (String -> X ()) -> Event -> X All
myEventHook handler = xMsgEventHook handler <+> handleEventHook def
2020-04-01 22:06:00 -04:00
-- | React to ClientMessage events from concurrent threads
xMsgEventHook :: (String -> X ()) -> Event -> X All
xMsgEventHook handler ClientMessageEvent { ev_message_type = t, ev_data = d }
| t == bITMAP = do
2020-03-25 14:45:21 -04:00
let (xtype, tag) = splitXMsg d
case xtype of
Workspace -> removeDynamicWorkspace tag
ACPI -> handler tag
Unknown -> io $ print "WARNING: unknown concurrent message"
return (All True)
2021-11-19 22:42:19 -05:00
xMsgEventHook _ _ = return (All True)
2020-04-01 22:06:00 -04:00
--------------------------------------------------------------------------------
-- | Keymap configuration
myModMask :: KeyMask
myModMask = mod4Mask
addKeymap :: [DynWorkspace] -> ([((KeyMask, KeySym), NamedAction)] -> X ())
2022-06-26 19:27:04 -04:00
-> [KeyGroup (X ())] -> XConfig l -> XConfig l
addKeymap dws showKeys external = addDescrKeys' ((myModMask, xK_F1), showKeys)
(\c -> concatMap (mkNamedSubmap c) $ internalBindings dws c ++ external)
2021-06-19 00:17:47 -04:00
internalBindings :: [DynWorkspace] -> XConfig Layout -> [KeyGroup (X ())]
internalBindings dws c =
2021-06-19 00:17:47 -04:00
[ KeyGroup "Window Layouts"
[ KeyBinding "M-j" "focus down" $ windows W.focusDown
, KeyBinding "M-k" "focus up" $ windows W.focusUp
, KeyBinding "M-m" "focus master" $ windows W.focusMaster
, KeyBinding "M-d" "focus master" runHide
, KeyBinding "M-S-j" "swap down" $ windows W.swapDown
, KeyBinding "M-S-k" "swap up" $ windows W.swapUp
, KeyBinding "M-S-m" "swap master" $ windows W.swapMaster
, KeyBinding "M-<Return>" "next layout" $ sendMessage NextLayout
, KeyBinding "M-S-<Return>" "reset layout" $ setLayout $ layoutHook c
, KeyBinding "M-t" "sink tiling" $ withFocused $ windows . W.sink
, KeyBinding "M-S-t" "float tiling" $ withFocused O.float
, KeyBinding "M--" "shrink" $ sendMessage Shrink
, KeyBinding "M-=" "expand" $ sendMessage Expand
, KeyBinding "M-S--" "remove master window" $ sendMessage $ IncMasterN (-1)
, KeyBinding "M-S-=" "add master window" $ sendMessage $ IncMasterN 1
]
, KeyGroup "Workspaces"
-- ASSUME standard workspaces only use numbers 0-9 (otherwise we won't get
-- valid keysyms)
([ KeyBinding (mods ++ n) (msg ++ n) (f n) | n <- myWorkspaces
, (mods, msg, f) <-
[ ("M-", "switch to workspace ", windows . W.view)
, ("M-S-", "move client to workspace ", windows . W.shift)
, ("M-C-", "follow client to workspace ", \n' -> do
windows $ W.shift n'
windows $ W.view n')
]
] ++
2022-03-05 18:18:16 -05:00
[ KeyBinding "M-M1-l" "move up workspace" $ moveTo Next (hiddenWS :&: Not emptyWS)
, KeyBinding "M-M1-h" "move down workspace" $ moveTo Prev (hiddenWS :&: Not emptyWS)
2021-06-19 00:17:47 -04:00
])
, KeyGroup "Dynamic Workspaces"
[ KeyBinding ("M-C-" ++ [k]) ("launch/switch to " ++ n) cmd
| DynWorkspace { dwTag = t, dwKey = k, dwCmd = a, dwName = n } <- dws,
2021-06-19 00:17:47 -04:00
let cmd = case a of
Just a' -> spawnOrSwitch t a'
Nothing -> windows $ W.view t
]
, KeyGroup "Screens"
[ KeyBinding "M-l" "move up screen" nextScr
, KeyBinding "M-h" "move down screen" prevScr
, KeyBinding "M-C-l" "follow client up screen" $ nextScr' W.shift
, KeyBinding "M-C-h" "follow client down screen" $ prevScr' W.shift
, KeyBinding "M-S-l" "shift workspace up screen" $ nextScr' W.greedyView
, KeyBinding "M-S-h" "shift workspace down screen" $ prevScr' W.greedyView
2021-06-19 00:17:47 -04:00
]
]
where
prev = onPrevNeighbour horizontalScreenOrderer
next = onNextNeighbour horizontalScreenOrderer
prevScr = prev W.view
nextScr = next W.view
prevScr' f = prev f >> prevScr
nextScr' f = next f >> nextScr
2021-06-19 00:17:47 -04:00
mkNamedSubmap :: XConfig Layout -> KeyGroup (X ()) -> [((KeyMask, KeySym), NamedAction)]
mkNamedSubmap c KeyGroup { kgHeader = h, kgBindings = b } =
(subtitle h:) $ mkNamedKeymap c
2021-11-21 10:26:28 -05:00
$ (\KeyBinding{kbSyms = s, kbDesc = d, kbMaybeAction = a} -> (s, addName d a))
2021-06-19 00:17:47 -04:00
<$> b
data KeyBinding a = KeyBinding
2021-11-21 17:54:00 -05:00
{ kbSyms :: String
, kbDesc :: String
2021-11-21 10:26:28 -05:00
, kbMaybeAction :: a
2021-06-19 00:17:47 -04:00
}
data KeyGroup a = KeyGroup
2021-06-19 00:54:01 -04:00
{ kgHeader :: String
2021-06-19 00:17:47 -04:00
, kgBindings :: [KeyBinding a]
}
evalExternal :: [KeyGroup FeatureX] -> FIO [KeyGroup MaybeX]
2021-06-19 00:17:47 -04:00
evalExternal = mapM go
where
go k@KeyGroup { kgBindings = bs } =
(\bs' -> k { kgBindings = bs' }) <$> mapM evalKeyBinding bs
evalKeyBinding :: KeyBinding FeatureX -> FIO (KeyBinding MaybeX)
2021-11-21 10:26:28 -05:00
evalKeyBinding k@KeyBinding { kbMaybeAction = a } =
(\f -> k { kbMaybeAction = f }) <$> evalFeature a
2021-06-19 00:17:47 -04:00
filterExternal :: [KeyGroup MaybeX] -> [KeyGroup (X ())]
filterExternal = fmap go
where
2022-07-08 20:08:17 -04:00
go k@KeyGroup { kgBindings = bs } =
k { kgBindings = [ kb { kbMaybeAction = x }
| kb@KeyBinding { kbMaybeAction = Just x } <- bs
]
}
externalBindings :: ThreadState -> DBusState -> [KeyGroup FeatureX]
externalBindings ts db =
2021-06-19 00:17:47 -04:00
[ KeyGroup "Launchers"
[ KeyBinding "<XF86Search>" "select/launch app" $ Left runAppMenu
, KeyBinding "M-g" "launch clipboard manager" $ Left runClipMenu
2022-07-08 00:21:05 -04:00
, KeyBinding "M-a" "launch network selector" $ Left $ runNetMenu sys
, KeyBinding "M-w" "launch window selector" $ Left runWinMenu
, KeyBinding "M-u" "launch device selector" $ Left runDevMenu
2022-07-08 00:21:05 -04:00
, KeyBinding "M-b" "launch bitwarden selector" $ Left $ runBwMenu ses
, KeyBinding "M-v" "launch ExpressVPN selector" $ Left runVPNMenu
, KeyBinding "M-e" "launch bluetooth selector" $ Left runBTMenu
, KeyBinding "M-C-e" "launch editor" $ Left runEditor
, KeyBinding "M-C-w" "launch browser" $ Left runBrowser
, KeyBinding "M-C-t" "launch terminal with tmux" $ Left runTMux
, KeyBinding "M-C-S-t" "launch terminal" $ Left runTerm
, KeyBinding "M-C-q" "launch calc" $ Left runCalc
, KeyBinding "M-C-f" "launch file manager" $ Left runFileManager
2021-06-19 00:17:47 -04:00
]
, KeyGroup "Actions"
2022-06-28 23:27:55 -04:00
[ KeyBinding "M-q" "close window" $ ftrAlways "kill window function" kill1
, KeyBinding "M-r" "run program" $ Left runCmdMenu
2022-06-28 23:27:55 -04:00
, KeyBinding "M-<Space>" "warp pointer" $ ftrAlways "warp function" $ warpToWindow 0.5 0.5
, KeyBinding "M-C-s" "capture area" $ Left $ runAreaCapture ses
, KeyBinding "M-C-S-s" "capture screen" $ Left $ runScreenCapture ses
, KeyBinding "M-C-d" "capture desktop" $ Left $ runDesktopCapture ses
, KeyBinding "M-C-b" "browse captures" $ Left runCaptureBrowser
2021-06-19 00:17:47 -04:00
-- , ("M-C-S-s", "capture focused window", spawn myWindowCap)
]
, KeyGroup "Multimedia"
[ KeyBinding "<XF86AudioPlay>" "toggle play/pause" $ Left runTogglePlay
, KeyBinding "<XF86AudioPrev>" "previous track" $ Left runPrevTrack
, KeyBinding "<XF86AudioNext>" "next track" $ Left runNextTrack
, KeyBinding "<XF86AudioStop>" "stop" $ Left runStopPlay
, KeyBinding "<XF86AudioLowerVolume>" "volume down" $ Left runVolumeDown
, KeyBinding "<XF86AudioRaiseVolume>" "volume up" $ Left runVolumeUp
, KeyBinding "<XF86AudioMute>" "volume mute" $ Left runVolumeMute
2021-06-19 00:17:47 -04:00
]
2021-06-19 00:54:01 -04:00
2021-10-24 13:30:30 -04:00
, KeyGroup "Dunst"
[ KeyBinding "M-`" "dunst history" $ Left $ runNotificationHistory ses
, KeyBinding "M-S-`" "dunst close" $ Left $ runNotificationClose ses
, KeyBinding "M-M1-`" "dunst context menu" $ Left $ runNotificationContext ses
, KeyBinding "M-C-`" "dunst close all" $ Left $ runNotificationCloseAll ses
2021-10-24 13:30:30 -04:00
]
2021-06-19 00:17:47 -04:00
, KeyGroup "System"
2021-11-21 17:54:00 -05:00
[ KeyBinding "M-." "backlight up" $ ib bctlInc
, KeyBinding "M-," "backlight down" $ ib bctlDec
, KeyBinding "M-M1-," "backlight min" $ ib bctlMin
, KeyBinding "M-M1-." "backlight max" $ ib bctlMax
, KeyBinding "M-S-." "keyboard up" $ ck bctlInc
, KeyBinding "M-S-," "keyboard down" $ ck bctlDec
, KeyBinding "M-S-M1-," "keyboard min" $ ck bctlMin
, KeyBinding "M-S-M1-." "keyboard max" $ ck bctlMax
2022-07-03 18:23:32 -04:00
, KeyBinding "M-<End>" "power menu" $ Left runPowerPrompt
2022-07-02 17:09:21 -04:00
, KeyBinding "M-<Home>" "quit xmonad" $ Left runQuitPrompt
, KeyBinding "M-<Delete>" "lock screen" $ Left runScreenLock
2021-06-19 00:17:47 -04:00
-- M-<F1> reserved for showing the keymap
2022-06-28 23:27:55 -04:00
, KeyBinding "M-<F2>" "restart xmonad" restartf
, KeyBinding "M-<F3>" "recompile xmonad" recompilef
, KeyBinding "M-<F8>" "select autorandr profile" $ Left runAutorandrMenu
, KeyBinding "M-<F9>" "toggle ethernet" $ Left runToggleEthernet
, KeyBinding "M-<F10>" "toggle bluetooth" $ Left $ runToggleBluetooth sys
, KeyBinding "M-<F11>" "toggle screensaver" $ Left $ ioSometimes $ callToggle ses
, KeyBinding "M-<F12>" "switch gpu" $ Left runOptimusPrompt
2021-06-19 00:17:47 -04:00
]
]
2021-11-21 17:54:00 -05:00
where
ses = dbSesClient db
sys = dbSysClient db
brightessControls ctl getter = (ioSometimes . getter . ctl) ses
ib = Left . brightessControls intelBacklightControls
ck = Left . brightessControls clevoKeyboardControls
ftrAlways n = Right . Always n . Always_ . FallbackAlone
2022-06-28 23:27:55 -04:00
restartf = ftrAlways "restart function" (runCleanup ts db >> runRestart)
recompilef = ftrAlways "recompile function" runRecompile
type MaybeX = Maybe (X ())
type FeatureX = Feature (X ())