882 lines
31 KiB
Haskell
882 lines
31 KiB
Haskell
{-# LANGUAGE FlexibleContexts #-}
|
|
{-# LANGUAGE FlexibleInstances #-}
|
|
{-# LANGUAGE MultiParamTypeClasses #-}
|
|
{-# LANGUAGE OverloadedStrings #-}
|
|
{-# LANGUAGE RankNTypes #-}
|
|
|
|
--------------------------------------------------------------------------------
|
|
-- XMonad binary
|
|
|
|
module Main (main) where
|
|
|
|
import Data.Internal.DBus
|
|
import Data.Internal.XIO
|
|
import Data.Monoid
|
|
import Data.Text.IO (hPutStrLn)
|
|
import Graphics.X11.Types
|
|
import Graphics.X11.Xlib.Atom
|
|
import Graphics.X11.Xlib.Extras
|
|
import Options.Applicative hiding (action)
|
|
import RIO
|
|
import RIO.Directory
|
|
import RIO.List
|
|
import RIO.Process
|
|
import qualified RIO.Text as T
|
|
import System.Posix.Signals
|
|
import System.Process
|
|
( getPid
|
|
, getProcessExitCode
|
|
)
|
|
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
|
|
|
|
main :: IO ()
|
|
main = parse >>= xio
|
|
|
|
parse :: IO XOpts
|
|
parse = execParser opts
|
|
where
|
|
parseOpts = parseDeps <|> parseTest <|> pure XRun
|
|
opts =
|
|
info (parseOpts <**> helper) $
|
|
fullDesc <> header "xmonad: the best window manager ever"
|
|
|
|
data XOpts = XDeps | XTest | XRun
|
|
|
|
parseDeps :: Parser XOpts
|
|
parseDeps =
|
|
flag'
|
|
XDeps
|
|
(long "deps" <> short 'd' <> help "print dependencies")
|
|
|
|
parseTest :: Parser XOpts
|
|
parseTest =
|
|
flag'
|
|
XTest
|
|
(long "test" <> short 't' <> help "test dependencies without running")
|
|
|
|
xio :: XOpts -> IO ()
|
|
xio o = runXIO $
|
|
case o of
|
|
XDeps -> printDeps
|
|
XTest -> undefined
|
|
XRun -> run
|
|
|
|
run :: XIO ()
|
|
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
|
|
withDBusX_ $ \db -> do
|
|
let fs = features $ dbSysClient db
|
|
withDBusInterfaces db (fsDBusExporters fs) $ \unexporters -> do
|
|
withXmobar $ \xmobarP -> do
|
|
withChildDaemons fs $ \ds -> do
|
|
let toClean = Cleanup ds (Just xmobarP) unexporters
|
|
void $ executeSometimes $ fsRemovableMon fs $ dbSysClient db
|
|
void $ async $ void $ executeSometimes $ fsPowerMon fs
|
|
dws <- startDynWorkspaces fs
|
|
runIO <- askRunInIO
|
|
let cleanup = runCleanup runIO toClean db
|
|
kbs <- filterExternal <$> evalExternal (fsKeys fs runIO cleanup db)
|
|
sk <- evalAlways $ fsShowKeys fs
|
|
ha <- evalAlways $ fsACPIHandler fs
|
|
tt <- evalAlways $ fsTabbedTheme fs
|
|
let conf =
|
|
ewmh $
|
|
addKeymap dws (liftIO . runIO . sk) kbs $
|
|
docks $
|
|
def
|
|
{ terminal = myTerm
|
|
, modMask = myModMask
|
|
, layoutHook = myLayouts tt
|
|
, manageHook = myManageHook dws
|
|
, handleEventHook = myEventHook runIO 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
|
|
where
|
|
startDynWorkspaces fs = do
|
|
dws <- catMaybes <$> mapM evalSometimes (fsDynWorkspaces fs)
|
|
void $ async $ runWorkspaceMon dws
|
|
return dws
|
|
|
|
runXMonad :: (LayoutClass l Window, Read (l Window)) => XConfig l -> IO ()
|
|
runXMonad conf = do
|
|
dirs <- getCreateDirectories
|
|
launch conf dirs
|
|
|
|
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
|
|
_ -> return ()
|
|
|
|
data FeatureSet = FeatureSet
|
|
{ fsKeys :: (XIO () -> IO ()) -> X () -> DBusState -> [KeyGroup FeatureX]
|
|
, fsDBusExporters :: [Maybe SesClient -> Sometimes (XIO (), XIO ())]
|
|
, fsPowerMon :: SometimesIO
|
|
, fsRemovableMon :: Maybe SysClient -> SometimesIO
|
|
, fsDaemons :: [Sometimes (XIO (Process () () ()))]
|
|
, fsACPIHandler :: Always (String -> X ())
|
|
, fsTabbedTheme :: Always Theme
|
|
, fsDynWorkspaces :: [Sometimes DynWorkspace]
|
|
, fsShowKeys :: Always ([((KeyMask, KeySym), NamedAction)] -> XIO ())
|
|
}
|
|
|
|
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
|
|
|
|
features :: Maybe SysClient -> FeatureSet
|
|
features cl =
|
|
FeatureSet
|
|
{ fsKeys = externalBindings
|
|
, fsDBusExporters = dbusExporters
|
|
, fsPowerMon = runPowermon
|
|
, fsRemovableMon = runRemovableMon
|
|
, fsACPIHandler = runHandleACPI
|
|
, fsDynWorkspaces = allDWs'
|
|
, fsTabbedTheme = tabbedFeature
|
|
, fsShowKeys = runShowKeys
|
|
, fsDaemons = [runNetAppDaemon cl, runAutolock]
|
|
}
|
|
|
|
withXmobar :: (Process Handle () () -> XIO a) -> XIO a
|
|
withXmobar = bracket startXmobar stopXmobar
|
|
|
|
startXmobar :: XIO (Process Handle () ())
|
|
startXmobar = do
|
|
logInfo "starting xmobar child process"
|
|
p <- proc "xmobar" [] start
|
|
io $ hSetBuffering (getStdin p) LineBuffering
|
|
return p
|
|
where
|
|
start =
|
|
startProcess
|
|
. setStdin createPipe
|
|
. setCreateGroup True
|
|
|
|
stopXmobar
|
|
:: (MonadReader env m, HasLogFunc env, MonadUnliftIO m)
|
|
=> Process Handle () ()
|
|
-> m ()
|
|
stopXmobar p = do
|
|
logInfo "stopping xmobar child process"
|
|
io $ killNoWait p
|
|
|
|
withChildDaemons
|
|
:: FeatureSet
|
|
-> ([(Utf8Builder, Process () () ())] -> XIO a)
|
|
-> XIO a
|
|
withChildDaemons fs = bracket (startChildDaemons fs) stopChildDaemons
|
|
|
|
startChildDaemons :: FeatureSet -> XIO [(Utf8Builder, Process () () ())]
|
|
startChildDaemons fs = catMaybes <$> mapM start (fsDaemons fs)
|
|
where
|
|
start s@(Sometimes sname _ _) = do
|
|
let sname_ = Utf8Builder $ encodeUtf8Builder sname
|
|
res <- executeSometimes s
|
|
case res of
|
|
Just p -> do
|
|
logInfo $ "starting child process: " <> sname_
|
|
return $ Just (sname_, p)
|
|
-- don't log anything here since presumably the feature itself will log
|
|
-- an error if it fails during execution
|
|
_ -> return Nothing
|
|
|
|
stopChildDaemons
|
|
:: (MonadReader env m, HasLogFunc env, MonadUnliftIO m)
|
|
=> [(Utf8Builder, Process () () ())]
|
|
-> m ()
|
|
stopChildDaemons = mapM_ stop
|
|
where
|
|
stop (n, p) = do
|
|
logInfo $ "stopping child process: " <> n
|
|
liftIO $ killNoWait p
|
|
|
|
printDeps :: XIO ()
|
|
printDeps = withDBus_ $ \db -> do
|
|
runIO <- askRunInIO
|
|
let mockCleanup = runCleanup runIO mockClean db
|
|
let bfs =
|
|
concatMap (fmap kbMaybeAction . kgBindings) $
|
|
externalBindings runIO mockCleanup db
|
|
let dbus =
|
|
fmap (\f -> f $ dbSesClient db) dbusExporters
|
|
:: [Sometimes (XIO (), XIO ())]
|
|
let others = [runRemovableMon $ dbSysClient db, runPowermon]
|
|
-- TODO might be better to use glog for this?
|
|
mapM_ logInfo $
|
|
fmap showFulfillment $
|
|
sort $
|
|
nub $
|
|
concat $
|
|
fmap dumpSometimes dbus
|
|
++ fmap dumpSometimes others
|
|
++ fmap dumpSometimes allDWs'
|
|
++ fmap dumpFeature bfs
|
|
where
|
|
mockClean = Cleanup {clChildren = [], clXmobar = Nothing, clDBusUnexporters = []}
|
|
|
|
--------------------------------------------------------------------------------
|
|
-- Concurrency configuration
|
|
|
|
data Cleanup = Cleanup
|
|
{ clChildren :: [(Utf8Builder, Process () () ())]
|
|
, clXmobar :: Maybe (Process Handle () ())
|
|
, clDBusUnexporters :: [XIO ()]
|
|
}
|
|
|
|
runCleanup
|
|
:: (XIO () -> IO ())
|
|
-> Cleanup
|
|
-> DBusState
|
|
-> X ()
|
|
runCleanup runIO ts db = liftIO $ runIO $ do
|
|
mapM_ stopXmobar $ clXmobar ts
|
|
stopChildDaemons $ clChildren ts
|
|
sequence_ $ clDBusUnexporters 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
|
|
|
|
--------------------------------------------------------------------------------
|
|
-- Startuphook configuration
|
|
|
|
-- TODO add _NET_DESKTOP_VIEWPORTS to _NET_SUPPORTED?
|
|
myStartupHook :: X ()
|
|
myStartupHook =
|
|
setDefaultCursor xC_left_ptr
|
|
<+> startupHook def
|
|
|
|
--------------------------------------------------------------------------------
|
|
-- 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'
|
|
, dwCmd = Just $ spawnCmd exe []
|
|
}
|
|
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
|
|
|
|
-- 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 [] $
|
|
io $
|
|
vmExists vm
|
|
name = T.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
|
|
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"
|
|
|
|
allDWs' :: [Sometimes DynWorkspace]
|
|
allDWs' =
|
|
[ xsaneDynamicWorkspace
|
|
, vmDynamicWorkspace
|
|
, gimpDynamicWorkspace
|
|
, f5vpnDynamicWorkspace
|
|
]
|
|
|
|
--------------------------------------------------------------------------------
|
|
-- 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 :/
|
|
myLayouts tt =
|
|
onWorkspace vmTag vmLayout $
|
|
onWorkspace gimpTag gimpLayout $
|
|
mkToggle (single HIDE) $
|
|
tall ||| fulltab ||| full
|
|
where
|
|
addTopBar = noFrillsDeco shrinkText tt
|
|
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
|
|
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 :: 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]
|
|
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 :: Process Handle () () -> X ()
|
|
logXinerama p = withWindowSet $ \ws ->
|
|
io $
|
|
hPutStrLn (getStdin p) $
|
|
T.unwords $
|
|
filter (not . T.null) [onScreen ws, offScreen ws, sep, layout ws, nWindows ws]
|
|
where
|
|
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
|
|
nWindows =
|
|
(\x -> T.concat ["(", x, ")"])
|
|
. T.pack
|
|
. show
|
|
. length
|
|
. W.integrate'
|
|
. W.stack
|
|
. W.workspace
|
|
. W.current
|
|
hilightBgColor = "#A6D3FF"
|
|
hilightFgColor = XT.blend' 0.4 hilightBgColor XT.fgColor
|
|
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)
|
|
|
|
compareXCoord
|
|
:: W.Screen i1 l1 a1 ScreenId ScreenDetail
|
|
-> W.Screen i2 l2 a2 ScreenId ScreenDetail
|
|
-> Ordering
|
|
compareXCoord s0 s1 = compare (go s0) (go s1)
|
|
where
|
|
go = (\(Rectangle x _ _ _) -> x) . snd . getScreenIdAndRectangle
|
|
|
|
--------------------------------------------------------------------------------
|
|
-- 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
|
|
, -- 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
|
|
:: (MonadReader env m, HasLogFunc env, MonadUnliftIO m)
|
|
=> (m () -> IO ())
|
|
-> (String -> X ())
|
|
-> Event
|
|
-> X All
|
|
myEventHook runIO handler = xMsgEventHook runIO handler <+> handleEventHook def
|
|
|
|
-- | React to ClientMessage events from concurrent threads
|
|
xMsgEventHook
|
|
:: (MonadReader env m, HasLogFunc env, MonadUnliftIO m)
|
|
=> (m () -> IO ())
|
|
-> (String -> X ())
|
|
-> Event
|
|
-> X All
|
|
xMsgEventHook runIO handler ClientMessageEvent {ev_message_type = t, ev_data = d}
|
|
| t == bITMAP = do
|
|
let (xtype, tag) = splitXMsg d
|
|
case xtype of
|
|
Workspace -> removeDynamicWorkspace tag
|
|
ACPI -> handler tag
|
|
Unknown -> liftIO $ runIO $ logWarn "unknown concurrent message"
|
|
return (All True)
|
|
xMsgEventHook _ _ _ = return (All True)
|
|
|
|
--------------------------------------------------------------------------------
|
|
-- Keymap configuration
|
|
|
|
myModMask :: KeyMask
|
|
myModMask = mod4Mask
|
|
|
|
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)
|
|
|
|
internalBindings :: [DynWorkspace] -> XConfig Layout -> [KeyGroup (X ())]
|
|
internalBindings dws 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 (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
|
|
|
|
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] -> XIO [KeyGroup MaybeX]
|
|
evalExternal = mapM go
|
|
where
|
|
go k@KeyGroup {kgBindings = bs} =
|
|
(\bs' -> k {kgBindings = bs'}) <$> mapM evalKeyBinding bs
|
|
|
|
evalKeyBinding :: KeyBinding FeatureX -> XIO (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 =
|
|
[ kb {kbMaybeAction = x}
|
|
| kb@KeyBinding {kbMaybeAction = Just x} <- bs
|
|
]
|
|
}
|
|
|
|
externalBindings :: (XIO () -> IO ()) -> X () -> DBusState -> [KeyGroup FeatureX]
|
|
externalBindings runIO cleanup db =
|
|
[ KeyGroup
|
|
"Launchers"
|
|
[ KeyBinding "<XF86Search>" "select/launch app" $ Left $ toX runAppMenu
|
|
, KeyBinding "M-g" "launch clipboard manager" $ Left $ toX runClipMenu
|
|
, KeyBinding "M-a" "launch network selector" $ Left $ toX $ runNetMenu sys
|
|
, KeyBinding "M-w" "launch window selector" $ Left $ toX runWinMenu
|
|
, KeyBinding "M-u" "launch device selector" $ Left $ toX runDevMenu
|
|
, KeyBinding "M-b" "launch bitwarden selector" $ Left $ toX $ runBwMenu ses
|
|
, KeyBinding "M-v" "launch ExpressVPN selector" $ Left $ toX runVPNMenu
|
|
, KeyBinding "M-e" "launch bluetooth selector" $ Left $ toX runBTMenu
|
|
, KeyBinding "M-C-e" "launch editor" $ Left $ toX runEditor
|
|
, KeyBinding "M-C-w" "launch browser" $ Left $ toX runBrowser
|
|
, KeyBinding "M-C-t" "launch terminal with tmux" $ Left $ toX runTMux
|
|
, KeyBinding "M-C-S-t" "launch terminal" $ Left $ toX runTerm
|
|
, KeyBinding "M-C-q" "launch calc" $ Left $ toX runCalc
|
|
, KeyBinding "M-C-f" "launch file manager" $ Left $ toX runFileManager
|
|
]
|
|
, KeyGroup
|
|
"Actions"
|
|
[ KeyBinding "M-q" "close window" $ ftrAlways "kill window function" kill1
|
|
, KeyBinding "M-r" "run program" $ Left $ toX runCmdMenu
|
|
, KeyBinding "M-<Space>" "warp pointer" $ ftrAlways "warp function" $ warpToWindow 0.5 0.5
|
|
, KeyBinding "M-C-s" "capture area" $ Left $ toX $ runAreaCapture ses
|
|
, KeyBinding "M-C-S-s" "capture screen" $ Left $ toX $ runScreenCapture ses
|
|
, KeyBinding "M-C-d" "capture desktop" $ Left $ toX $ runDesktopCapture ses
|
|
, KeyBinding "M-C-b" "browse captures" $ Left $ toX runCaptureBrowser
|
|
-- , ("M-C-S-s", "capture focused window", spawn myWindowCap)
|
|
]
|
|
, KeyGroup
|
|
"Multimedia"
|
|
[ KeyBinding "<XF86AudioPlay>" "toggle play/pause" $ Left $ toX runTogglePlay
|
|
, KeyBinding "<XF86AudioPrev>" "previous track" $ Left $ toX runPrevTrack
|
|
, KeyBinding "<XF86AudioNext>" "next track" $ Left $ toX runNextTrack
|
|
, KeyBinding "<XF86AudioStop>" "stop" $ Left $ toX runStopPlay
|
|
, KeyBinding "<XF86AudioLowerVolume>" "volume down" $ Left $ toX runVolumeDown
|
|
, KeyBinding "<XF86AudioRaiseVolume>" "volume up" $ Left $ toX runVolumeUp
|
|
, KeyBinding "<XF86AudioMute>" "volume mute" $ Left $ toX runVolumeMute
|
|
]
|
|
, KeyGroup
|
|
"Dunst"
|
|
[ KeyBinding "M-`" "dunst history" $ Left $ toX $ runNotificationHistory ses
|
|
, KeyBinding "M-S-`" "dunst close" $ Left $ toX $ runNotificationClose ses
|
|
, KeyBinding "M-M1-`" "dunst context menu" $ Left $ toX $ runNotificationContext ses
|
|
, KeyBinding "M-C-`" "dunst close all" $ Left $ toX $ 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 $ toX runAutorandrMenu
|
|
, KeyBinding "M-<F9>" "toggle ethernet" $ Left $ toX runToggleEthernet
|
|
, KeyBinding "M-<F10>" "toggle bluetooth" $ Left $ toX $ runToggleBluetooth sys
|
|
, KeyBinding "M-<F11>" "toggle screensaver" $ Left $ toX $ callToggle ses
|
|
, KeyBinding "M-<F12>" "switch gpu" $ Left runOptimusPrompt
|
|
]
|
|
]
|
|
where
|
|
ses = dbSesClient db
|
|
sys = dbSysClient db
|
|
brightessControls ctl getter = (toX . getter . ctl) ses
|
|
ib = Left . brightessControls intelBacklightControls
|
|
ck = Left . brightessControls clevoKeyboardControls
|
|
ftrAlways n = Right . Always n . Always_ . FallbackAlone
|
|
restartf = ftrAlways "restart function" (cleanup >> runRestart)
|
|
recompilef = ftrAlways "recompile function" runRecompile
|
|
toX_ = liftIO . runIO
|
|
toX = fmap toX_
|
|
|
|
type MaybeX = Maybe (X ())
|
|
|
|
type FeatureX = Feature (X ())
|