path: root/src/Internal/Keys.hs

{-# LANGUAGE RankNTypes #-}
module Internal.Keys (applyKeys) where

import Internal.Intercept (setIntercept)
import Control.Monad.Loops (iterateWhile)
import Control.Monad.Fix (fix)
import Graphics.X11.ExtraTypes.XF86;
import Internal.KeysM
import Internal.SwapMaster (swapMaster)
import XMonad.Hooks.ManageDocks
import XMonad.Layout.MosaicAlt
import Graphics.X11.ExtraTypes.XorgDefault
import System.Process
import XMonad.Util.Ungrab
import XMonad.Layout.Spacing
import Data.Maybe (isJust, fromMaybe)
import Debug.Trace
import Control.Applicative
import Prelude hiding ((!!))
import Control.Monad
import Data.Char
import Data.List hiding ((!!))
import Data.List.Safe ((!!))
import Data.Map (Map)
import Internal.Layout
import Internal.Marking
import Internal.PromptConfig
import System.IO
import Text.Printf
import XMonad
import Internal.Submap
import XMonad.Actions.WindowNavigation
import XMonad.Prompt
import XMonad.Prompt.Input
import XMonad.Prompt.Shell
import XMonad.Util.CustomKeys
import XMonad.Util.Scratchpad
import XMonad.Actions.RotSlaves
import XMonad.Actions.CopyWindow as CopyWindow
import XMonad.Actions.SpawnOn as SpawnOn

import qualified Data.Map as Map
import qualified XMonad.StackSet as W

import Internal.Lib
import Internal.DMenu
import Internal.PassMenu
import Internal.Logger
import Internal.ScreenRotate (screenRotateForward, screenRotateBackward)

type KeyMap l = XConfig l -> Map (KeyMask, KeySym) (X ())
type ButtonsMap l = XConfig l -> Map (KeyMask, Button) (Window -> X ())


decreaseVolume = spawn "pactl set-sink-volume @DEFAULT_SINK@ -5%"
increaseVolume = spawn "pactl set-sink-volume @DEFAULT_SINK@ +5%"
playPause = spawn "spotify-control play"
mediaPrev = spawn "spotify-control prev"
mediaNext = spawn "spotify-control next"


button6 :: Button
button6 = 6

button7 :: Button
button7 = 7

button8 :: Button
button8 = 8

button9 :: Button
button9 = 9

button10 :: Button
button10 = 10

button11 :: Button
button11 = 11

button12 :: Button
button12 = 12

button13 :: Button
button13 = 13

button14 :: Button
button14 = 14

button15 :: Button
button15 = 15

keymap :: KeyMap l
keymap = runKeys $ do
  config <- getConfig

  let defaultKey key = fromMaybe (return ()) $ Map.lookup key (keymap config)
      subkeys = submapDefaultWithKey defaultKey . flip runKeys config

  bind xK_apostrophe $ do
    justMod $ subkeys $ do
      bind xK_apostrophe $
        (noMod -|- justMod) jumpToLast
      mapAlpha 0 jumpToMark

    shiftMod $ subkeys $ do
      bind xK_apostrophe $
        (noMod -|- shiftMod -|- rawMask shiftMask) swapWithLastMark
      mapAlpha shiftMask swapWithMark

  bind xK_BackSpace $ do
    -- The only raw keybinding. Meant to get a terminal to unbrick XMonad if
    -- something goes wrong with the keyboard layout and for first-time boots
    -- where dmenu/alacritty may not be installed.
    rawMask mod4Mask $ spawn "xterm"
    justMod $ spawn "pkill -SIGUSR1 xmobar"

  bind xK_F1 $ do
    -- Button programmed on mouse
    rawMask shiftMask $ click >> withFocused (windows . W.sink)

    shiftMod playPause

  bind xK_F2 $
    -- Button programmed on mouse
    rawMask shiftMask $ click >> sendMessage ToggleZoom

  bind xK_F3 $
    -- Button programmed on mouse
    rawMask shiftMask $ subkeys $ do

      bind xK_F1 $ -- Make it harder to close so I don't accidentally git it.
        rawMask shiftMask $ click >> CopyWindow.kill1

      -- I Don't really use these, but they could be bound to something cool!
      bind xK_F2 $
        rawMask shiftMask mediaNext
      bind xK_F3 $
        rawMask shiftMask mediaPrev

  bind xK_F10 $ do
    justMod playPause

  bind xK_F11 $ do
    justMod mediaPrev

  bind xK_F12 $ do
    justMod mediaNext

  bind xK_Return $ do
    justMod swapMaster

  bind xK_Tab $ do
    justMod  $ windows W.focusDown
    shiftMod $ windows W.focusUp

  -- Switch between different screens. These are the leftmost keys on the home
  -- row in a Dvorak layout. One might want to switch these to ASD for QWERTY.
  forM_ (zip [xK_a, xK_o, xK_e] [0..]) $ \(key, idx) ->
    bind key $ do
      -- Move focus to that screen.
      justMod  $ withScreen W.view idx
      -- Swap the current screen with the one given
      altMod   $ withScreen W.greedyView idx
      -- Move the current window to the select screen.
      shiftMod $ withScreen W.shift idx

  bind xK_bracketright $ do
    justMod $ sendMessage $ modifyWindowBorder 5

  bind xK_bracketleft $ do
    justMod $ sendMessage $ modifyWindowBorder (-5)

  bind xK_b $ do
    justMod $ spawn "bluetooth-select.sh"

  bind xK_c $ do
    justMod runPassMenu
    shiftMod CopyWindow.kill1

  bind xK_f $ do
    justMod  $ sendMessage FlipLayout
    shiftMod $ sendMessage HFlipLayout

  bind xK_g $ do
    justMod $ mapNextString $ \_ str ->
      case str of
        [ch] | isAlphaNum ch -> gotoWorkspace ch
        [' '] -> gotoAccompaningWorkspace
        _ -> return ()
    shiftMod $ mapNextString $ \_ str ->
      case str of
        [ch] | isAlphaNum ch -> shiftToWorkspace ch
        _ -> return ()
    shiftAltMod $ mapNextString $ \_ str ->
      case str of
        [ch] | isAlphaNum ch -> swapWorkspace ch
        _ -> return ()

  bind xK_h $ do
    justMod    $ windows W.focusDown
    shiftMod   $ windows W.swapDown
    controlMod rotAllDown

  bind xK_j $ do
    justMod $ sendMessage ShrinkZoom

  bind xK_k $ do
    justMod $ sendMessage ExpandZoom

  bind xK_l $ do
    justMod    $ windows W.focusUp
    shiftMod   $ windows W.swapUp
    controlMod rotAllUp
    altMod     $ spawn "xsecurelock"

  bind xK_minus $ do
    justMod  $ sendMessage (IncMasterN (-1))
    shiftMod $ withFocused $ sendMessage . shrinkWindowAlt

  bind xK_m $ do
    justMod $ subkeys $
      mapAlpha 0 markCurrentWindow

  bind xK_n $ do
    justMod $ relativeWorkspaceShift next

  bind xK_p $ do
    justMod $ relativeWorkspaceShift prev

  bind xK_plus $ do
    justMod  $ sendMessage (IncMasterN 1)
    shiftMod $ withFocused $ sendMessage . expandWindowAlt

  bind xK_q $ do
    shiftMod $ spawn "xmonad --recompile && xmonad --restart"
    
    justMod $ subkeys $ do

      bind xK_q $
        (justMod -|- noMod) $ do
          firstMotion@(x, y) <- nextMotion
          (x', y') <- iterateWhile (==firstMotion) nextMotion

          logs $ printf "Motion: (%d, %d) (%d, %d)" x y x' y'

          if (x' - x) < 0
            then mediaPrev
            else mediaNext

      bind xK_t $

        (justMod -|- noMod) $
          setIntercept (modMask config, xK_i) $
            logs $ "Intercepted!"
 
  bind xK_r $ do
    justMod runDMenu
    shiftMod $ sendMessage DoRotate

  bind xK_s $ do
    altMod $ spawn "sudo -A systemctl suspend && xsecurelock"

  bind xK_space $ do
    justMod  $ sendMessage NextLayout
    shiftMod $ sendMessage NextLayout

  bind xK_t $ do
    justMod  $ spawn (terminal config)
    shiftMod $ withFocused $ windows . W.sink
    altMod   $ spawn (terminal config ++ " -t Floating\\ Term")

  bind xK_v $
    -- Allows repeated strokes of M-h and M-l to reduce and increase volume
    -- respectively.
    justMod $ fix $ \recur -> subkeys $ do
      bind xK_h $ do
        justMod $ do
           decreaseVolume
           recur

      bind xK_l $ do
        justMod $ do
           increaseVolume
           recur

      bind xK_v $ do
        justMod $ recur

  bind xK_w $ do
    justMod windowJump

  bind xK_x $ do
    justMod $ sendMessage ToggleStruts

  bind xK_z $ do

    justMod $ subkeys $ do

      bind xK_g $ do
        (justMod -|- noMod) $ mapNextString $ \_ s ->
          case s of
            [ch] | isAlphaNum ch -> windows (CopyWindow.copy s)
            _ -> return ()

      bind xK_p $ do
        (justMod -|- noMod) $ mapNextString $ \_ str ->
          spawn $ printf "gxmessage 'typed: \"%s\"\ncodes: \"%s\"\nunicode: á\n'"
            str
            (show (map ord str))

      bind xK_t $ do
        (justMod -|- noMod) $ logs "Test Log"

      bind xK_n $ do
        (justMod -|- noMod) $ spawn (terminal config ++ " -t Notes -e notes new")

      bind xK_c $ do
        shiftMod CopyWindow.killAllOtherCopies

      bind xK_e $ do
        (justMod -|- noMod) $ spawn "emoji-select.sh"
        (shiftMod -|- rawMask shiftMask) $ spawn "emoticon-select.sh"

      bind xK_a $
        (justMod -|- noMod) $ spawn "set-sink.sh"

      bind xK_w $
        (justMod -|- noMod) $ spawn "networkmanager_dmenu"

      bind xK_o $
        (justMod -|- noMod) $ spawn "library-view.sh"

      bind xK_v $ do
        (justMod -|- noMod) $ spawn "set-volume.sh"
        (shiftMod -|- rawMask shiftMask) $ spawn "set-volume.sh -a"

      -- Double-tap Z to toggle zoom.
      bind xK_z $ do
        noMod -|- justMod $ sendMessage ToggleZoom

      -- Z is reserved to create sub keybindings to do various things.
      -- I don't really use these at the moment.
      bind xK_h $ noMod mediaPrev
      bind xK_j $ noMod playPause
      bind xK_l $ noMod mediaNext

    -- Centers the current focused window. i.e. toggles the Zoom layout
    -- modifier.
    shiftMod $ sendMessage ToggleZoom

  bind xF86XK_Calculator $ do
    noMod $ spawn $ terminal config ++ " -t Floating\\ Term -e /usr/bin/env python3"

  bind xF86XK_AudioLowerVolume $ do
    noMod $ spawn "pactl set-sink-volume @DEFAULT_SINK@ -1%"
    justMod mediaPrev

  bind xF86XK_AudioRaiseVolume $ do
    noMod $ spawn "pactl set-sink-volume @DEFAULT_SINK@ +1%"
    justMod mediaNext

  bind xF86XK_AudioMute $ do
    noMod $ spawn "pactl set-sink-mute @DEFAULT_SINK@ toggle"

  bind xF86XK_AudioPlay $ do
    noMod playPause

  bind xF86XK_AudioNext $ do
    noMod mediaNext

  bind xF86XK_AudioPrev $ do
    noMod mediaPrev

  bind xF86XK_AudioPrev $ do
    noMod mediaPrev

  bind xF86XK_MonBrightnessUp $ do
    noMod $ spawn "set-backlight.sh +0.05"
    justMod $ spawn "set-backlight.sh 1"

  bind xF86XK_MonBrightnessDown $ do
    noMod $ spawn "set-backlight.sh -0.05"
    justMod $ spawn "set-backlight.sh 0.01"
    rawMask shiftMask $ spawn "set-backlight.sh 0"

mouseMap :: ButtonsMap l
mouseMap = runButtons $ do
  config <- getConfig

  let x button = Map.lookup button (mouseMap config)

  let defaultButtons button = fromMaybe (\w -> return ()) $
          Map.lookup button (mouseMap config)
      subMouse = submapButtonsWithKey defaultButtons . flip runButtons config


  let continuous :: [(Button, X ())] -> Button -> Window -> X ()
      continuous actions button w = do
        case find ((==button) . fst) actions of
          Just (_, action) -> action
          Nothing -> return ()

        (subMouse $
          forM_ (map fst actions) $ \b ->
            bind b $ noMod $ \w -> continuous actions b w) w

  bind button1 $ do
    justMod $ \w -> focus w >> mouseMoveWindow w >> windows W.shiftMaster

  bind button2 $ do
    justMod $ windows . (W.shiftMaster .) . W.focusWindow

  bind button3 $ do
    justMod $ \w -> focus w >> mouseResizeWindow w >> windows W.shiftMaster

  bind button6 $
    justMod $ const (relativeWorkspaceShift prev)

  bind button7 $
    justMod $ const (relativeWorkspaceShift next)

  bind button8 $
    justMod $ const mediaPrev

  bind button9 $
    justMod $ const mediaNext

  bind button14 $ do
    noMod $ subMouse $ do

      bind button13 $ do
        noMod $ \_ -> click >> CopyWindow.kill1

      bind button14 $ do
        noMod $ \_ -> click >> sendMessage ToggleZoom

      bind button15 $ do
        noMod $ \_ -> spawn "pavucontrol"

      let mediaButtons = [
            (button4, increaseVolume),
            (button5, decreaseVolume),
            (button2, playPause),
            (button9, mediaNext),
            (button8, mediaPrev),
            (button6, mediaPrev),
            (button7, mediaNext)
            ]

      forM_ (map fst mediaButtons) $ \b ->
        bind b $ noMod $ continuous mediaButtons b

  bind button13 $ noMod $ subMouse $ do
    bind button1 $ noMod mouseMoveWindow
    bind button3 $ noMod mouseResizeWindow
    bind button13 $ noMod $ windows . W.sink


  bind button15 $ do

    noMod $ subMouse $ do
      
      bind button15 $ do
        noMod $ const jumpToLast


      let workspaceButtons = [
            (button2, swapMaster),

            (button9, relativeWorkspaceShift next),
            (button8, relativeWorkspaceShift prev),

            (button4, windows W.focusUp),
            (button5, windows W.focusDown),

            (button7, windows screenRotateForward),
            (button6, windows screenRotateBackward)
            ]

      forM_ (map fst workspaceButtons) $ \b ->
        bind b $ noMod $ continuous workspaceButtons b

applyKeys :: XConfig l -> IO (XConfig l)
applyKeys config =
    return $ config { keys = keymap, mouseBindings = mouseMap }

click :: X ()
click = do
  (dpy, root) <- asks $ (,) <$> display <*> theRoot
  (_, _, window, _, _, _, _, _) <- io $ queryPointer dpy root
  focus window

modifyWindowBorder :: Integer -> SpacingModifier
modifyWindowBorder i = ModifyWindowBorder $ \(Border a b c d) ->
  Border (clip $ a + i) (clip $ b + i) (clip $ c + i) (clip $ d + i)

  where clip i | i < 0 = 0
        clip i | otherwise = i