xmonad-config/bin/xmonad.hs

{-# LANGUAGE FlexibleInstances     #-}
{-# LANGUAGE MultiParamTypeClasses #-}

--------------------------------------------------------------------------------
-- | XMonad binary

module Main (main) where

import           Control.Concurrent
import           Control.Monad                                (unless)

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.Control
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
  cl <- startXMonadService
  (h, p) <- spawnPipe "xmobar"
  _ <- forkIO runPowermon
  _ <- forkIO runRemovableMon
  _ <- forkIO $ runWorkspaceMon allDWs
  let ts = ThreadState
        { client = cl
        , childPIDs = [p]
        , childHandles = [h]
        }
  (ekbs, missing) <- fmap filterExternal $ evalExternal $ externalBindings ts
  -- TODO this seems really dumb but I can't print outside the launch function;
  -- this seems like a buffering problem since I can print something here and
  -- then print from the launch function (eg in the X monad) and both messages
  -- will print. However, trying to flush the print output from here makes
  -- xmonad bootloop
  let missingErrs = warnMissing <$> missing
  launch
    $ ewmh
    $ addKeymap ekbs
    $ def { terminal = myTerm
          , modMask = myModMask
          , layoutHook = myLayouts
          , manageHook = myManageHook
          , handleEventHook = myEventHook
          , startupHook = myStartupHook missingErrs
          , workspaces = myWorkspaces
          , logHook = myLoghook h
          , clickJustFocuses = False
          , focusFollowsMouse = False
          , normalBorderColor = T.bordersColor
          , focusedBorderColor = T.selectedBordersColor
          }

--------------------------------------------------------------------------------
-- | Concurrency configuration

data ThreadState = ThreadState
    { client       :: Client
    , childPIDs    :: [ProcessHandle]
    , childHandles :: [Handle]
    }

-- TODO shouldn't this be run by a signal handler?
runCleanup :: ThreadState -> X ()
runCleanup ts = io $ do
  mapM_ killHandle $ childPIDs ts
  stopXMonadService $ client ts

--------------------------------------------------------------------------------
-- | Startuphook configuration
--
-- For some reason I can't print error messages (perhaps a buffering/flushing
-- problem) outside the 'launch' function so pass them here to be printed.

-- TODO add _NET_DESKTOP_VIEWPORTS to _NET_SUPPORTED?
myStartupHook :: [String] -> X ()
myStartupHook msgs = setDefaultCursor xC_left_ptr
  <+> io (mapM_ print msgs)
  <+> 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"

allDWs :: [DynWorkspace]
allDWs = [ xsaneDynamicWorkspace
         , wmDynamicWorkspace
         , gimpDynamicWorkspace
         ]

--------------------------------------------------------------------------------
-- | 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 = "#8fc7ff"
    hilightFgColor = T.blend' 0.5 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 :: Event -> X All
myEventHook = xMsgEventHook <+> docksEventHook <+> handleEventHook def

-- | React to ClientMessage events from concurrent threads
xMsgEventHook :: Event -> X All
xMsgEventHook ClientMessageEvent { ev_message_type = t, ev_data = d }
  | t == bITMAP = do
    let (xtype, tag) = splitXMsg d
    case xtype of
      Workspace -> removeDynamicWorkspace tag
      ACPI      -> handleACPI 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
    ]

  -- dummy map for dunst commands (defined separately but this makes them show
  -- up in the help menu)
  , KeyGroup "Dunst"
    [ KeyBinding "M-`" "dunst history" skip
    , KeyBinding "M-S-`" "dunst close" skip
    , KeyBinding "M-M1-`" "dunst context menu" skip
    , KeyBinding "M-C-`" "dunst close all" skip
    ]
  ]

mkNamedSubmap :: XConfig Layout ->  KeyGroup (X ()) -> [((KeyMask, KeySym), NamedAction)]
mkNamedSubmap c KeyGroup { kgHeader = h, kgBindings = b } =
  (subtitle h:) $ mkNamedKeymap c
  $ (\KeyBinding{kbSyms = s, kbDesc = d, kbAction = a} -> (s, addName d a))
  <$> b

data KeyBinding a = KeyBinding
  { kbSyms   :: String
  , kbDesc   :: String
  , kbAction :: a
  }

data KeyGroup a = KeyGroup
  { kgHeader   :: String
  , kgBindings :: [KeyBinding a]
  }

evalExternal :: [KeyGroup (IO MaybeX)] -> IO [KeyGroup MaybeX]
evalExternal = mapM go
  where
    go k@KeyGroup { kgBindings = bs } =
      (\bs' -> k { kgBindings = bs' }) <$> mapM evalKeyBinding bs

evalKeyBinding :: Monad m => KeyBinding (m a) -> m (KeyBinding a)
evalKeyBinding k@KeyBinding { kbAction = a } = (\b -> k { kbAction = b }) <$> a

filterExternal :: [KeyGroup MaybeX] -> ([KeyGroup (X ())], [Dependency])
filterExternal kgs = let kgs' = fmap go kgs in (fst <$> kgs', concatMap snd kgs')
  where
    go k@KeyGroup { kgBindings = bs } = let bs' = go' <$> bs in
      (k { kgBindings = mapMaybe fst bs' }, concatMap snd bs')
    go' k@KeyBinding{ kbDesc = d, kbAction = a } = case a of
      Installed x ds -> (Just $ k{ kbAction = x }, ds)
      Missing ds     -> (Just $ k{ kbDesc = flagMissing d, kbAction = skip }, ds)
      Ignore         -> (Nothing, [])
    flagMissing s = "[!!!]" ++ s

externalBindings :: ThreadState -> [KeyGroup (IO MaybeX)]
externalBindings ts =
  [ 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" $ noCheck kill1
    , KeyBinding "M-r" "run program" runCmdMenu
    , KeyBinding "M-<Space>" "warp pointer" $ noCheck $ 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 "System"
    [ KeyBinding "M-." "backlight up" $ noCheck runIncBacklight
    , KeyBinding "M-," "backlight down" $ noCheck runDecBacklight
    , KeyBinding "M-M1-," "backlight min" $ noCheck runMinBacklight
    , KeyBinding "M-M1-." "backlight max" $ noCheck runMaxBacklight
    , KeyBinding "M-<End>" "power menu" $ noCheck runPowerPrompt
    , KeyBinding "M-<Home>" "quit xmonad" $ noCheck runQuitPrompt
    , KeyBinding "M-<Delete>" "lock screen" runScreenLock
    -- M-<F1> reserved for showing the keymap
    , KeyBinding "M-<F2>" "restart xmonad" $ noCheck (runCleanup ts >> runRestart)
    , KeyBinding "M-<F3>" "recompile xmonad" $ noCheck 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" $ noCheck runToggleDPMS
    , KeyBinding "M-<F12>" "switch gpu" runOptimusPrompt
    ]
  ]