xmonad-config/bin/xmonad.hs

584 lines
21 KiB
Haskell

{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE MultiParamTypeClasses #-}
--------------------------------------------------------------------------------
-- | XMonad binary
module Main (main) where
import Control.Concurrent
import Control.Monad
( forM_
, unless
, void
)
import Data.List
( isPrefixOf
, sortBy
, sortOn
)
import Data.Maybe
( isJust
, mapMaybe
)
import Data.Monoid (All (..))
import Graphics.X11.Types
import Graphics.X11.Xlib.Atom
import Graphics.X11.Xlib.Extras
import System.IO
import System.Process
import XMonad
import XMonad.Actions.CopyWindow
import XMonad.Actions.CycleWS
import XMonad.Actions.PhysicalScreens
import XMonad.Actions.Warp
import XMonad.Hooks.DynamicLog
( pad
, wrap
, xmobarColor
)
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.Removable
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.Screensaver
import XMonad.Internal.Dependency
import XMonad.Internal.Process
import XMonad.Internal.Shell
import qualified XMonad.Internal.Theme as T
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
main :: IO ()
main = do
sesClient <- startXMonadService
sysClient <- getDBusClient True
(h, p) <- spawnPipe "xmobar"
mapM_ (applyFeature_ forkIO_) [runPowermon, runRemovableMon sysClient]
forkIO_ $ runWorkspaceMon allDWs
let ts = ThreadState
{ tsSessionClient = sesClient
, tsSystemClient = sysClient
, tsChildPIDs = [p]
, tsChildHandles = [h]
}
lockRes <- evalFeature runScreenLock
let lock = whenSatisfied lockRes
ext <- evalExternal $ externalBindings ts lock
warnMissing $ externalToMissing ext
-- IDK why this is necessary; nothing prior to this line will print if missing
hFlush stdout
launch
$ ewmh
$ addKeymap (filterExternal ext)
$ def { terminal = myTerm
, modMask = myModMask
, layoutHook = myLayouts
, manageHook = myManageHook
, handleEventHook = myEventHook lock
, startupHook = myStartupHook
, workspaces = myWorkspaces
, logHook = myLoghook h
, clickJustFocuses = False
, focusFollowsMouse = False
, normalBorderColor = T.bordersColor
, focusedBorderColor = T.selectedBordersColor
}
where
forkIO_ = void . forkIO
--------------------------------------------------------------------------------
-- | Concurrency configuration
data ThreadState = ThreadState
{ tsSessionClient :: Maybe Client
, tsSystemClient :: Maybe Client
, tsChildPIDs :: [ProcessHandle]
, tsChildHandles :: [Handle]
}
-- TODO shouldn't this be run by a signal handler?
runCleanup :: ThreadState -> X ()
runCleanup ts = io $ do
mapM_ killHandle $ tsChildPIDs ts
forM_ (tsSessionClient ts) stopXMonadService
forM_ (tsSystemClient ts) disconnect
--------------------------------------------------------------------------------
-- | Startuphook configuration
-- TODO add _NET_DESKTOP_VIEWPORTS to _NET_SUPPORTED?
myStartupHook :: X ()
myStartupHook = setDefaultCursor xC_left_ptr
<+> docksStartupHook
<+> startupHook def
--------------------------------------------------------------------------------
-- | Workspace configuration
myWorkspaces :: [WorkspaceId]
myWorkspaces = map show [1..10 :: Int]
gimpDynamicWorkspace :: DynWorkspace
gimpDynamicWorkspace = DynWorkspace
{ dwName = "Gimp"
, dwTag = t
, dwClass = c
, dwHook =
[ matchGimpRole "gimp-image-window" -?> appendViewShift t
, matchGimpRole "gimp-dock" -?> doF W.swapDown
, matchGimpRole "gimp-toolbox" -?> doF W.swapDown
, className =? c -?> appendViewShift t
]
, dwKey = 'g'
, dwCmd = Just $ spawnCmd "gimp-2.10" []
}
where
matchGimpRole role = isPrefixOf role <$> stringProperty "WM_WINDOW_ROLE"
<&&> className =? c
t = "GIMP"
c = "Gimp-2.10" -- TODO I don't feel like changing the version long term
wmDynamicWorkspace :: DynWorkspace
wmDynamicWorkspace = DynWorkspace
{ dwName = "Windows VirtualBox"
, dwTag = t
, dwClass = c
, dwHook = [ className =? c -?> appendViewShift t ]
, dwKey = 'v'
, dwCmd = Just $ spawnCmd "vbox-start" ["win8raw"]
}
where
t = "VM"
c = "VirtualBoxVM"
xsaneDynamicWorkspace :: DynWorkspace
xsaneDynamicWorkspace = DynWorkspace
{ dwName = "XSane"
, dwTag = t
, dwClass = c
, dwHook = [ className =? c -?> appendViewShift t >> doFloat ]
, dwKey = 'x'
, dwCmd = Just $ spawnCmd "xsane" []
}
where
t = "XSANE"
c = "Xsane"
f5vpnDynamicWorkspace :: DynWorkspace
f5vpnDynamicWorkspace = DynWorkspace
{ dwName = "F5Vpn"
, dwTag = t
, dwClass = c
, dwHook = [ className =? c -?> appendShift t ]
, dwKey = 'i'
, dwCmd = Just skip
}
where
t = "F5VPN"
c = "F5 VPN"
allDWs :: [DynWorkspace]
allDWs = [ xsaneDynamicWorkspace
, wmDynamicWorkspace
, gimpDynamicWorkspace
, f5vpnDynamicWorkspace
]
--------------------------------------------------------------------------------
-- | Layout configuration
myLayouts = onWorkspace (dwTag wmDynamicWorkspace) vmLayout
$ onWorkspace (dwTag gimpDynamicWorkspace) gimpLayout
$ mkToggle (single HIDE)
$ tall ||| fulltab ||| full
where
addTopBar = noFrillsDeco shrinkText T.tabbedTheme
tall = renamed [Replace "Tall"]
$ avoidStruts
$ addTopBar
$ noBorders
$ Tall 1 0.03 0.5
fulltab = renamed [Replace "Tabbed"]
$ avoidStruts
$ noBorders
$ tabbedAlways shrinkText T.tabbedTheme
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
-- | Make a new empty layout and add a message to show/hide it. This is useful
-- for quickly showing conky.
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
runHide :: X ()
runHide = sendMessage $ Toggle HIDE
--------------------------------------------------------------------------------
-- | Loghook configuration
--
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)
-- 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
$ pad
$ unwords
$ map (fmtTags ws . W.tag . W.workspace)
$ sortBy compareXCoord
$ W.current ws : W.visible ws
offScreen ws = xmobarColor T.backdropFgColor ""
$ unwords
$ map W.tag
$ filter (isJust . W.stack)
$ sortOn W.tag
$ W.hidden ws
sep = xmobarColor T.backdropFgColor "" ":"
layout ws = description $ W.layout $ W.workspace $ W.current ws
nWindows ws = wrap "(" ")"
$ show
$ length
$ W.integrate'
$ W.stack
$ W.workspace
$ W.current ws
hilightBgColor = "#A6D3FF"
hilightFgColor = T.blend' 0.4 hilightBgColor T.fgColor
fmtTags ws t = if t == W.currentTag ws
then xmobarColor T.fgColor hilightBgColor t
else t
compareXCoord
:: W.Screen i1 l1 a1 ScreenId ScreenDetail
-> W.Screen i2 l2 a2 ScreenId ScreenDetail -> Ordering
compareXCoord s0 s1 = compare x0 x1
where
(_, Rectangle x0 _ _ _) = getScreenIdAndRectangle s0
(_, Rectangle x1 _ _ _) = getScreenIdAndRectangle s1
--------------------------------------------------------------------------------
-- | Managehook configuration
myManageHook :: ManageHook
myManageHook = manageApps <+> manageDocks <+> manageHook def
manageApps :: ManageHook
manageApps = composeOne $ concatMap dwHook allDWs ++
[ 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
]
--------------------------------------------------------------------------------
-- | Eventhook configuration
myEventHook :: X () -> Event -> X All
myEventHook lock = xMsgEventHook lock <+> docksEventHook <+> handleEventHook def
-- | React to ClientMessage events from concurrent threads
xMsgEventHook :: X () -> Event -> X All
xMsgEventHook lock ClientMessageEvent { ev_message_type = t, ev_data = d }
| t == bITMAP = do
let (xtype, tag) = splitXMsg d
case xtype of
Workspace -> removeDynamicWorkspace tag
ACPI -> handleACPI lock tag
return (All True)
xMsgEventHook _ _ = return (All True)
--------------------------------------------------------------------------------
-- | Keymap configuration
myModMask :: KeyMask
myModMask = mod4Mask
addKeymap :: [KeyGroup (X ())] -> XConfig l -> XConfig l
addKeymap external = addDescrKeys' ((myModMask, xK_F1), runShowKeys)
(\c -> concatMap (mkNamedSubmap c) $ internalBindings c ++ external)
internalBindings :: XConfig Layout -> [KeyGroup (X ())]
internalBindings c =
[ 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')
]
] ++
[ KeyBinding "M-M1-l" "move up workspace" $ moveTo Next HiddenNonEmptyWS
, KeyBinding "M-M1-h" "move down workspace" $ moveTo Prev HiddenNonEmptyWS
])
, KeyGroup "Dynamic Workspaces"
[ KeyBinding ("M-C-" ++ [k]) ("launch/switch to " ++ n) cmd
| DynWorkspace { dwTag = t, dwKey = k, dwCmd = a, dwName = n } <- allDWs,
let cmd = case a of
Just a' -> spawnOrSwitch t a'
Nothing -> windows $ W.view t
]
, KeyGroup "Screens"
[ KeyBinding "M-l" "move up screen" nextScreen
, KeyBinding "M-h" "move down screen" prevScreen
, KeyBinding "M-C-l" "follow client up screen" $ shiftNextScreen >> nextScreen
, KeyBinding "M-C-h" "follow client down screen" $ shiftPrevScreen >> prevScreen
, KeyBinding "M-S-l" "shift workspace up screen" $ swapNextScreen >> nextScreen
, KeyBinding "M-S-h" "shift workspace down screen" $ swapPrevScreen >> prevScreen
]
]
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
data KeyBinding a = KeyBinding
{ kbSyms :: String
, kbDesc :: String
, kbMaybeAction :: a
}
data KeyGroup a = KeyGroup
{ kgHeader :: String
, kgBindings :: [KeyBinding a]
}
evalExternal :: [KeyGroup FeatureX] -> IO [KeyGroup MaybeX]
evalExternal = mapM go
where
go k@KeyGroup { kgBindings = bs } =
(\bs' -> k { kgBindings = bs' }) <$> mapM evalKeyBinding bs
evalKeyBinding :: KeyBinding FeatureX -> IO (KeyBinding MaybeX)
evalKeyBinding k@KeyBinding { kbMaybeAction = a } =
(\f -> k { kbMaybeAction = f }) <$> evalFeature a
filterExternal :: [KeyGroup MaybeX] -> [KeyGroup (X ())]
filterExternal = fmap go
where
go k@KeyGroup { kgBindings = bs } = k { kgBindings = mapMaybe flagKeyBinding bs }
externalToMissing :: [KeyGroup (MaybeAction a)] -> [MaybeAction a]
externalToMissing = concatMap go
where
go KeyGroup { kgBindings = bs } = fmap kbMaybeAction bs
flagKeyBinding :: KeyBinding MaybeX -> Maybe (KeyBinding (X ()))
flagKeyBinding k@KeyBinding{ kbDesc = d, kbMaybeAction = a } = case a of
(Right x) -> Just $ k{ kbMaybeAction = x }
(Left _) -> Just $ k{ kbDesc = "[!!!]" ++ d, kbMaybeAction = skip }
externalBindings :: ThreadState -> X () -> [KeyGroup FeatureX]
externalBindings ts lock =
[ KeyGroup "Launchers"
[ KeyBinding "<XF86Search>" "select/launch app" runAppMenu
, KeyBinding "M-g" "launch clipboard manager" runClipMenu
, KeyBinding "M-a" "launch network selector" runNetMenu
, KeyBinding "M-w" "launch window selector" runWinMenu
, KeyBinding "M-u" "launch device selector" runDevMenu
, KeyBinding "M-b" "launch bitwarden selector" runBwMenu
, KeyBinding "M-C-e" "launch editor" runEditor
, KeyBinding "M-C-w" "launch browser" runBrowser
, KeyBinding "M-C-t" "launch terminal with tmux" runTMux
, KeyBinding "M-C-S-t" "launch terminal" runTerm
, KeyBinding "M-C-q" "launch calc" runCalc
, KeyBinding "M-C-f" "launch file manager" runFileManager
]
, KeyGroup "Actions"
[ KeyBinding "M-q" "close window" $ ConstFeature kill1
, KeyBinding "M-r" "run program" runCmdMenu
, KeyBinding "M-<Space>" "warp pointer" $ ConstFeature $ warpToWindow 0.5 0.5
, KeyBinding "M-C-s" "capture area" runAreaCapture
, KeyBinding "M-C-S-s" "capture screen" runScreenCapture
, KeyBinding "M-C-d" "capture desktop" runDesktopCapture
, KeyBinding "M-C-b" "browse captures" runCaptureBrowser
-- , ("M-C-S-s", "capture focused window", spawn myWindowCap)
]
, KeyGroup "Multimedia"
[ KeyBinding "<XF86AudioPlay>" "toggle play/pause" runTogglePlay
, KeyBinding "<XF86AudioPrev>" "previous track" runPrevTrack
, KeyBinding "<XF86AudioNext>" "next track" runNextTrack
, KeyBinding "<XF86AudioStop>" "stop" runStopPlay
, KeyBinding "<XF86AudioLowerVolume>" "volume down" runVolumeDown
, KeyBinding "<XF86AudioRaiseVolume>" "volume up" runVolumeUp
, KeyBinding "<XF86AudioMute>" "volume mute" runVolumeMute
]
, KeyGroup "Dunst"
[ KeyBinding "M-`" "dunst history" runNotificationHistory
, KeyBinding "M-S-`" "dunst close" runNotificationClose
, KeyBinding "M-M1-`" "dunst context menu" runNotificationContext
, KeyBinding "M-C-`" "dunst close all" runNotificationCloseAll
]
, 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" $ ConstFeature $ runPowerPrompt lock
, KeyBinding "M-<Home>" "quit xmonad" $ ConstFeature runQuitPrompt
, KeyBinding "M-<Delete>" "lock screen" runScreenLock
-- M-<F1> reserved for showing the keymap
, KeyBinding "M-<F2>" "restart xmonad" $ ConstFeature (runCleanup ts >> runRestart)
, KeyBinding "M-<F3>" "recompile xmonad" $ ConstFeature runRecompile
, KeyBinding "M-<F7>" "start Isync Service" runStartISyncService
, KeyBinding "M-C-<F7>" "start Isync Timer" runStartISyncTimer
, KeyBinding "M-<F8>" "select autorandr profile" runAutorandrMenu
, KeyBinding "M-<F9>" "toggle ethernet" runToggleEthernet
, KeyBinding "M-<F10>" "toggle bluetooth" runToggleBluetooth
, KeyBinding "M-<F11>" "toggle screensaver" $ ioFeature $ callToggle cl
, KeyBinding "M-<F12>" "switch gpu" runOptimusPrompt
]
]
where
cl = tsSessionClient ts
brightessControls ctl getter = (ioFeature . getter . ctl) cl
ib = brightessControls intelBacklightControls
ck = brightessControls clevoKeyboardControls