xmonad-config/bin/xmonad.hs

{-# 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 ())