xmonad-config/bin/xmonad.hs

831 lines
30 KiB
Haskell
Raw Normal View History

2022-12-30 14:58:23 -05:00
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
2020-03-28 19:58:26 -04:00
{-# LANGUAGE MultiParamTypeClasses #-}
2022-12-30 14:58:23 -05:00
{-# LANGUAGE OverloadedStrings #-}
2020-04-01 22:06:00 -04:00
--------------------------------------------------------------------------------
2022-12-30 14:58:23 -05:00
-- XMonad binary
2020-04-01 22:06:00 -04:00
module Main (main) where
2022-12-30 14:58:23 -05:00
import Data.Internal.DBus
import Data.Internal.Dependency
import Data.Monoid
import Data.Text.IO (hPutStrLn)
import Graphics.X11.Types
import Graphics.X11.Xlib.Atom
import Graphics.X11.Xlib.Extras
import RIO
import RIO.Directory
2022-12-31 19:47:02 -05:00
import RIO.List
2022-12-30 14:58:23 -05:00
import RIO.Process
import qualified RIO.Text as T
import System.Posix.Signals
import System.Process
( getPid
, getProcessExitCode
)
2022-12-31 19:47:02 -05:00
import UnliftIO.Environment
2022-12-30 14:58:23 -05:00
import XMonad
import XMonad.Actions.CopyWindow
import XMonad.Actions.CycleWS
import XMonad.Actions.PhysicalScreens
import XMonad.Actions.Warp
import XMonad.Hooks.DynamicLog
import XMonad.Hooks.EwmhDesktops
import XMonad.Hooks.ManageDocks
import XMonad.Hooks.ManageHelpers
import XMonad.Internal.Command.DMenu
import XMonad.Internal.Command.Desktop
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
import XMonad.Internal.DBus.Brightness.ClevoKeyboard
import XMonad.Internal.DBus.Brightness.Common
import XMonad.Internal.DBus.Brightness.IntelBacklight
import XMonad.Internal.DBus.Control
import XMonad.Internal.DBus.Removable
import XMonad.Internal.DBus.Screensaver
import XMonad.Internal.Shell hiding (proc)
import qualified XMonad.Internal.Theme as XT
import XMonad.Layout.MultiToggle
import XMonad.Layout.NoBorders
import XMonad.Layout.NoFrillsDecoration
import XMonad.Layout.PerWorkspace
import XMonad.Layout.Renamed
import XMonad.Layout.Tabbed
import qualified XMonad.Operations as O
import qualified XMonad.StackSet as W
import XMonad.Util.Cursor
import XMonad.Util.EZConfig
import qualified XMonad.Util.ExtensibleState as E
import XMonad.Util.NamedActions
import XMonad.Util.WorkspaceCompare
2020-03-20 01:15:22 -04:00
main :: IO ()
main = getArgs >>= parse
parse :: [String] -> IO ()
2022-12-30 14:58:23 -05:00
parse [] = run
parse ["--deps"] = withCache printDeps
2022-12-28 00:46:48 -05:00
-- parse ["--test"] = void $ withCache . evalConf =<< connectDBusX
2022-12-30 14:58:23 -05:00
parse _ = usage
run :: IO ()
run = do
-- These first two commands are only significant when xmonad is restarted.
-- The 'launch' function below this will turn off buffering (so flushes are
-- required to see stdout) and will also install xmonad's silly signal
-- handlers (which set the handlers for sigCHLD and sigPIPE to SIG_IGN).
-- Ignoring sigCHLD is particularly bad since most of my setup entails
-- spawning processes and waiting for their exit code, which totally breaks
-- when sigCHLD is ignored (since children are killed immediately without
-- the parent invoking 'wait'). Since the 'launch' function is called last
-- here, everything before should be fine except for the case where xmonad
-- is restarted, which uses 'exec' and thus should cause the buffering and
-- signal handlers to carry over to the top.
uninstallSignalHandlers
hSetBuffering stdout LineBuffering
2022-12-28 00:46:48 -05:00
withCache $ do
withDBusX_ $ \db -> do
2022-12-31 22:49:46 -05:00
let fs = features $ dbSysClient db
2022-12-28 00:46:48 -05:00
startDBusInterfaces db fs
withXmobar $ \xmobarP -> do
withChildDaemons fs $ \ds -> do
let ts = ThreadState ds (Just xmobarP)
startRemovableMon db fs
startPowerMon fs
dws <- startDynWorkspaces fs
kbs <- filterExternal <$> evalExternal (fsKeys fs ts db)
sk <- evalAlways $ fsShowKeys fs
ha <- evalAlways $ fsACPIHandler fs
tt <- evalAlways $ fsTabbedTheme fs
2022-12-30 14:58:23 -05:00
let conf =
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 xmobarP
, clickJustFocuses = False
, focusFollowsMouse = False
, normalBorderColor = T.unpack XT.bordersColor
, focusedBorderColor = T.unpack XT.selectedBordersColor
}
io $ runXMonad conf
2022-12-28 00:46:48 -05:00
where
2022-12-30 14:58:23 -05:00
startRemovableMon db fs =
void $
executeSometimes $
fsRemovableMon fs $
dbSysClient db
2022-12-28 00:46:48 -05:00
startPowerMon fs = void $ async $ void $ executeSometimes $ fsPowerMon fs
startDynWorkspaces fs = do
dws <- catMaybes <$> mapM evalSometimes (fsDynWorkspaces fs)
void $ io $ async $ runWorkspaceMon dws
return dws
runXMonad :: (LayoutClass l Window, Read (l Window)) => XConfig l -> IO ()
runXMonad conf = do
dirs <- getCreateDirectories
launch conf dirs
2022-12-28 00:46:48 -05:00
startDBusInterfaces :: DBusState -> FeatureSet -> FIO ()
2022-12-30 14:58:23 -05:00
startDBusInterfaces db fs =
mapM_ (\f -> executeSometimes $ f $ dbSesClient db) $
fsDBusExporters fs
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 <- tryIO $ createDirectoryIfMissing True d
case r of
(Left e) -> print e
2022-12-30 14:58:23 -05:00
_ -> return ()
2022-07-03 18:23:32 -04:00
data FeatureSet = FeatureSet
2022-12-30 14:58:23 -05:00
{ fsKeys :: ThreadState -> DBusState -> [KeyGroup FeatureX]
2022-07-09 17:08:10 -04:00
, fsDBusExporters :: [Maybe SesClient -> SometimesIO]
2022-12-30 14:58:23 -05:00
, fsPowerMon :: SometimesIO
, fsRemovableMon :: Maybe SysClient -> SometimesIO
, fsDaemons :: [Sometimes (FIO (Process () () ()))]
, fsACPIHandler :: Always (String -> X ())
, fsTabbedTheme :: Always Theme
2022-07-03 18:23:32 -04:00
, fsDynWorkspaces :: [Sometimes DynWorkspace]
2022-12-30 14:58:23 -05:00
, fsShowKeys :: Always ([((KeyMask, KeySym), NamedAction)] -> X ())
2022-07-03 18:23:32 -04:00
}
tabbedFeature :: Always Theme
tabbedFeature = Always "theme for tabbed windows" $ Option sf fallback
where
sf = Subfeature niceTheme "theme with nice font"
niceTheme = IORoot XT.tabbedTheme $ fontTree XT.defFontFamily defFontPkgs
fallback = Always_ $ FallbackAlone $ XT.tabbedTheme XT.fallbackFont
2022-07-09 17:08:10 -04:00
features :: Maybe SysClient -> FeatureSet
2022-12-30 14:58:23 -05:00
features cl =
FeatureSet
{ fsKeys = externalBindings
, fsDBusExporters = dbusExporters
, fsPowerMon = runPowermon
, fsRemovableMon = runRemovableMon
, fsACPIHandler = runHandleACPI
, fsDynWorkspaces = allDWs'
, fsTabbedTheme = tabbedFeature
, fsShowKeys = runShowKeys
, fsDaemons = [runNetAppDaemon cl, runAutolock]
}
2022-07-03 18:23:32 -04:00
2022-12-28 00:46:48 -05:00
startXmobar :: FIO (Process Handle () ())
startXmobar = do
p <- proc "xmobar" [] start
2022-12-28 00:46:48 -05:00
io $ hSetBuffering (getStdin p) LineBuffering
return p
where
2022-12-30 14:58:23 -05:00
start =
startProcess
. setStdin createPipe
. setCreateGroup True
2022-12-28 00:46:48 -05:00
startChildDaemons :: FeatureSet -> FIO [Process () () ()]
2022-12-28 00:46:48 -05:00
startChildDaemons fs = catMaybes <$> mapM executeSometimes (fsDaemons fs)
withChildDaemons :: FeatureSet -> ([Process () () ()] -> FIO a) -> FIO a
withChildDaemons fs = bracket (startChildDaemons fs) cleanup
where
cleanup ps = do
logInfo "stopping child processes"
mapM_ (io . killNoWait) ps
2022-12-28 00:46:48 -05:00
withXmobar :: (Process Handle () () -> FIO a) -> FIO a
withXmobar = bracket startXmobar cleanup
where
cleanup p = do
logInfo "stopping xmobar child process"
io $ killNoWait p
printDeps :: FIO ()
printDeps = withDBus_ $ \db -> do
2022-07-02 20:08:37 -04:00
(i, f, d) <- allFeatures db
mapM_ (liftIO . putStrLn . T.unpack) $
fmap showFulfillment $
sort $
nub $
concat $
fmap dumpFeature f ++ fmap dumpSometimes i ++ fmap dumpSometimes d
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
2022-12-30 14:58:23 -05:00
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-12-30 14:58:23 -05:00
return (dbus ++ others, Left runScreenLock : bfs, allDWs')
2022-06-28 21:24:21 -04:00
where
2022-12-30 14:58:23 -05:00
ts = ThreadState {tsChildPIDs = [], tsXmobar = Nothing}
usage :: IO ()
2022-12-30 14:58:23 -05:00
usage =
putStrLn $
intercalate
"\n"
[ "xmonad: run greatest window manager"
, "xmonad --deps: print dependencies"
]
2020-04-01 22:06:00 -04:00
--------------------------------------------------------------------------------
2022-12-30 14:58:23 -05:00
-- Concurrency configuration
2020-03-28 18:38:38 -04:00
data ThreadState = ThreadState
2022-12-30 14:58:23 -05:00
{ tsChildPIDs :: [Process () () ()]
, tsXmobar :: Maybe (Process Handle () ())
}
runCleanup :: ThreadState -> DBusState -> X ()
runCleanup ts db = io $ do
mapM_ killNoWait $ tsXmobar ts
mapM_ killNoWait $ tsChildPIDs ts
disconnectDBusX db
-- | Kill a process (group) after xmonad has already started
-- This is necessary (as opposed to 'stopProcess' from rio) because a) xmonad
-- sets the handler for sigCHLD to Ignore which breaks 'waitForProcess' (which
-- in turn will break 'stopProcess') and b) because I want to kill off entire
-- process groups since they may spawn child processes themselves. NOTE:
-- for reasons unknown I cannot just turn off/on the signal handlers here.
killNoWait :: Process a () () -> IO ()
killNoWait p = do
-- this strategy is outlined/sanctioned in RIO.Process under
-- 'unsafeProcessHandle':
--
-- get the handle (unsafely, since it breaks the semantics of RIO)
let ph = unsafeProcessHandle p
-- check if the process has already exited (if so, do nothing since trying
-- to kill it will open wormholes
ec <- getProcessExitCode ph
unless (isJust ec) $ do
-- send SIGTERM to the entire group (NOTE: 'System.Process.terminateProcess'
-- does not actually do this despite what the docs say)
i <- getPid ph
forM_ i $ signalProcessGroup sigTERM
-- actually call 'stopProcess' which will clean up associated data and
-- then try to wait for the exit, which will fail because we are assuming
-- this function is called when the handler for SIGCHLD is Ignore. Ignore
-- the failure and move on with life.
handleIO (\_ -> return ()) $ stopProcess p
2020-03-28 18:38:38 -04:00
2020-04-01 22:06:00 -04:00
--------------------------------------------------------------------------------
2022-12-30 14:58:23 -05:00
-- Startuphook configuration
-- TODO add _NET_DESKTOP_VIEWPORTS to _NET_SUPPORTED?
myStartupHook :: X ()
2022-12-30 14:58:23 -05:00
myStartupHook =
setDefaultCursor xC_left_ptr
<+> startupHook def
2020-04-01 22:06:00 -04:00
--------------------------------------------------------------------------------
2022-12-30 14:58:23 -05:00
-- Workspace configuration
myWorkspaces :: [WorkspaceId]
2022-12-30 14:58:23 -05:00
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
2022-12-30 14:58:23 -05:00
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'
, dwCmd = Just $ spawnCmd exe []
}
2022-07-09 01:11:02 -04:00
exe = "gimp-2.10"
2022-12-30 14:58:23 -05:00
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
2022-12-30 14:58:23 -05:00
vmDynamicWorkspace =
Sometimes
"virtualbox workspace"
xpfVirtualBox
[Subfeature root "windows 8 VM"]
where
2022-12-30 14:58:23 -05:00
root =
IORoot_ dw $
toAnd_ (sysExe [Package Official "virtualbox"] "VBoxManage") $
IOTest_ name [] $
io $
vmExists vm
name = T.unwords ["test if", vm, "exists"]
c = "VirtualBoxVM"
vm = "win8raw"
2022-12-30 14:58:23 -05:00
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
2022-12-30 14:58:23 -05:00
xsaneDynamicWorkspace =
Sometimes
"scanner workspace"
xpfXSANE
[Subfeature (IORoot_ dw tree) "xsane"]
where
tree = Only_ $ sysExe [Package Official "xsane"] "xsane"
2022-12-30 14:58:23 -05:00
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-12-30 14:58:23 -05:00
f5vpnDynamicWorkspace =
Sometimes
"F5 VPN workspace"
xpfF5VPN
[Subfeature (IORoot_ dw tree) "f5vpn"]
where
tree = Only_ $ sysExe [Package AUR "f5vpn"] "f5vpn"
2022-12-30 14:58:23 -05:00
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]
2022-12-30 14:58:23 -05:00
allDWs' =
[ xsaneDynamicWorkspace
, vmDynamicWorkspace
, gimpDynamicWorkspace
, f5vpnDynamicWorkspace
]
2022-07-02 20:08:37 -04:00
2020-04-01 22:06:00 -04:00
--------------------------------------------------------------------------------
2022-12-30 14:58:23 -05: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-12-30 14:58:23 -05:00
myLayouts tt =
onWorkspace vmTag vmLayout $
onWorkspace gimpTag gimpLayout $
mkToggle (single HIDE) $
tall ||| fulltab ||| full
where
2022-07-03 18:23:32 -04:00
addTopBar = noFrillsDeco shrinkText tt
2022-12-30 14:58:23 -05:00
tall =
renamed [Replace "Tall"] $
avoidStruts $
addTopBar $
noBorders $
Tall 1 0.03 0.5
fulltab =
renamed [Replace "Tabbed"] $
avoidStruts $
noBorders $
tabbedAlways shrinkText tt
full =
renamed [Replace "Full"] $
noBorders Full
vmLayout = noBorders Full
-- TODO use a tabbed layout for multiple master windows
2022-12-30 14:58:23 -05:00
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
2022-12-30 14:58:23 -05:00
deriving (Show, Read)
2020-03-28 19:58:26 -04:00
instance LayoutClass EmptyLayout a where
doLayout a b _ = emptyLayout a b
description _ = "Desktop"
data HIDE = HIDE
2022-12-30 14:58:23 -05:00
deriving (Read, Show, Eq, Typeable)
2020-03-28 19:58:26 -04:00
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
--------------------------------------------------------------------------------
2022-12-30 14:58:23 -05:00
-- Loghook configuration
2022-12-27 22:09:23 -05:00
myLoghook :: Process 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]
2022-12-30 14:58:23 -05:00
deriving (Eq)
instance ExtensionClass DesktopViewports where
2022-12-30 14:58:23 -05:00
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) $
2022-12-30 14:58:23 -05:00
setDesktopViewports desktopViewports
where
2022-12-30 14:58:23 -05:00
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
2022-12-30 14:58:23 -05:00
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
2022-12-30 14:58:23 -05:00
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.
2022-12-27 22:09:23 -05:00
logXinerama :: Process Handle () () -> X ()
2022-12-30 14:58:23 -05:00
logXinerama p = withWindowSet $ \ws ->
io $
hPutStrLn (getStdin p) $
T.unwords $
filter (not . T.null) [onScreen ws, offScreen ws, sep, layout ws, nWindows ws]
where
2022-12-30 14:58:23 -05:00
onScreen ws =
xmobarColor_ hilightFgColor hilightBgColor $
(T.pack . pad . T.unpack) $
T.unwords $
map (fmtTags ws . W.tag . W.workspace) $
sortBy compareXCoord $
W.current ws : W.visible ws
offScreen =
xmobarColor_ XT.backdropFgColor ""
. T.unwords
. fmap (T.pack . W.tag)
. filter (isJust . W.stack)
. sortOn W.tag
. W.hidden
sep = xmobarColor_ XT.backdropFgColor "" ":"
layout = T.pack . description . W.layout . W.workspace . W.current
2022-12-30 14:58:23 -05:00
nWindows =
(\x -> T.concat ["(", x, ")"])
. T.pack
. show
. length
. W.integrate'
. W.stack
. W.workspace
. W.current
2021-09-06 00:30:06 -04:00
hilightBgColor = "#A6D3FF"
hilightFgColor = XT.blend' 0.4 hilightBgColor XT.fgColor
2022-12-30 14:58:23 -05:00
fmtTags ws t =
let t_ = T.pack t
in if t == W.currentTag ws
then xmobarColor_ XT.fgColor hilightBgColor t_
else t_
xmobarColor_ a b c = T.pack $ xmobarColor (T.unpack a) (T.unpack b) (T.unpack c)
2020-04-01 18:51:30 -04:00
compareXCoord
:: W.Screen i1 l1 a1 ScreenId ScreenDetail
2022-12-30 14:58:23 -05:00
-> 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
--------------------------------------------------------------------------------
2022-12-30 14:58:23 -05:00
-- Managehook configuration
myManageHook :: [DynWorkspace] -> ManageHook
myManageHook dws = manageApps dws <+> manageHook def
manageApps :: [DynWorkspace] -> ManageHook
2022-12-30 14:58:23 -05:00
manageApps dws =
composeOne $
concatMap dwHook dws
++ [ isDialog -?> doCenterFloat
, -- the seafile applet
className =? "Seafile Client" -?> doFloat
, -- gnucash
(className =? "Gnucash" <&&> title =? "Transaction Import Assistant") -?> doFloat
, -- plots and graphics
className =? "R_x11" -?> doFloat
, className =? "Matplotlib" -?> doFloat
, className =? "mpv" -?> doFloat
, -- the floating windows created by the brave browser
stringProperty "WM_NAME" =? "Brave" -?> doFloat
, -- , (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
--------------------------------------------------------------------------------
2022-12-30 14:58:23 -05: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
2022-12-30 14:58:23 -05:00
xMsgEventHook handler ClientMessageEvent {ev_message_type = t, ev_data = d}
| t == bITMAP = do
2022-12-30 14:58:23 -05:00
let (xtype, tag) = splitXMsg d
case xtype of
Workspace -> removeDynamicWorkspace tag
ACPI -> handler tag
Unknown -> io $ putStrLn "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
--------------------------------------------------------------------------------
2022-12-30 14:58:23 -05:00
-- Keymap configuration
myModMask :: KeyMask
myModMask = mod4Mask
2022-12-30 14:58:23 -05:00
addKeymap
:: [DynWorkspace]
-> ([((KeyMask, KeySym), NamedAction)] -> X ())
-> [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 =
2022-12-30 14:58:23 -05: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'
)
]
2021-06-19 00:17:47 -04:00
]
2022-12-30 14:58:23 -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)
]
)
, KeyGroup
"Dynamic Workspaces"
[ KeyBinding ("M-C-" ++ [k]) ("launch/switch to " ++ n) cmd
| DynWorkspace {dwTag = t, dwKey = k, dwCmd = a, dwName = n} <- dws
, 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
]
]
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
2022-12-30 14:58:23 -05:00
mkNamedSubmap :: XConfig Layout -> KeyGroup (X ()) -> [((KeyMask, KeySym), NamedAction)]
mkNamedSubmap c KeyGroup {kgHeader = h, kgBindings = b} =
(subtitle h :) $
mkNamedKeymap c $
(\KeyBinding {kbSyms = s, kbDesc = d, kbMaybeAction = a} -> (s, addName d a))
<$> b
2021-06-19 00:17:47 -04:00
data KeyBinding a = KeyBinding
2022-12-30 14:58:23 -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
2022-12-30 14:58:23 -05: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
2022-12-30 14:58:23 -05:00
go k@KeyGroup {kgBindings = bs} =
(\bs' -> k {kgBindings = bs'}) <$> mapM evalKeyBinding bs
2021-06-19 00:17:47 -04:00
evalKeyBinding :: KeyBinding FeatureX -> FIO (KeyBinding MaybeX)
2022-12-30 14:58:23 -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-12-30 14:58:23 -05:00
go k@KeyGroup {kgBindings = bs} =
k
{ kgBindings =
[ kb {kbMaybeAction = x}
| kb@KeyBinding {kbMaybeAction = Just x} <- bs
]
2022-07-08 20:08:17 -04:00
}
externalBindings :: ThreadState -> DBusState -> [KeyGroup FeatureX]
externalBindings ts db =
2022-12-30 14:58:23 -05:00
[ KeyGroup
"Launchers"
[ KeyBinding "<XF86Search>" "select/launch app" $ Left runAppMenu
, KeyBinding "M-g" "launch clipboard manager" $ Left runClipMenu
, 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
, 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
]
, KeyGroup
"Actions"
[ KeyBinding "M-q" "close window" $ ftrAlways "kill window function" kill1
, KeyBinding "M-r" "run program" $ Left runCmdMenu
, 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
-- , ("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
]
, 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
]
, KeyGroup
"System"
[ 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
, KeyBinding "M-<End>" "power menu" $ Left runPowerPrompt
, KeyBinding "M-<Home>" "quit xmonad" $ Left runQuitPrompt
, KeyBinding "M-<Delete>" "lock screen" $ Left runScreenLock
, -- M-<F1> reserved for showing the keymap
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 $ 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 = (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 ())