Add a DSL for configuring Window-Specific bindings and move it into the Keys.hs file.

3 files changed, 126 insertions, 44 deletions

diff --git a/src/Internal/Keys.hs b/src/Internal/Keys.hs
index 446b7b7..21988f8 100644
--- a/src/Internal/Keys.hs
+++ b/src/Internal/Keys.hs
@@ -1,6 +1,7 @@
 {-# LANGUAGE RankNTypes #-}
 module Internal.Keys (applyKeys) where
 
+import Data.Monoid (Endo(..))
 import Control.Monad.Trans.Class
 import Control.Monad.Reader
 import Control.Monad.Loops (iterateWhile)
@@ -479,9 +480,122 @@ mouseMap = runButtons $ do
       forM_ (map fst workspaceButtons) $ \b ->
         bind b $ noMod $ continuous workspaceButtons b
 
+-- Bindings specific to a window. These are set similarly to th ekeymap above,
+-- but uses a Query monad to tell which windows the keys will apply to.
+--
+-- This is useful to create hotkeys in applications where hot keys are not
+-- configurable, or to remove keybindings that are irritating (looking at you,
+-- ctrl+w in Chrome!!).
+windowSpecificBindings :: Query (KeysM l ())
+windowSpecificBindings = do
+  w <- ask
+
+  configureIf (flip elem browsers <$> className) $ do
+
+    -- if the window is a browser, configure these bindings. Lots of browsers
+    -- make up their own garbage bindings that are not standard across many
+    -- other applications. This alleviates the issue.
+    --
+    -- Consistency with terminal:
+    --
+    --   Ctrl+h is backspace
+    --   Ctrl+w is ctrl+backspace
+    --   Ctrl+u is ctrl+shift+backspace
+    --
+    -- Consistency with Vim/Emacs-ish:
+    --
+    --   Alt+{Shift,Ctrl,}+{h,j,k,l} -> {Shift,Ctrl,}+{Left,Down,Up,Right}
+    --   Ctrl+b -> Ctrl+Left
+    --   Ctrl+e -> Ctrl+Right
+    --   Ctrl+$ -> End
+    --   Ctrl+^ -> Home
+    --
+    --   Ctrl+d -> Delete current tab.
+
+
+    let mods = permuteMods [shiftMask, controlMask, 0]
+
+    bind xK_h $ do
+      rawMask controlMask $ sendKey (0, xK_BackSpace) w
+      forM_ mods $ \mask ->
+        rawMask (altMask .|. mask) $ sendKey (mask, xK_Left) w
+
+    bind xK_j $
+      forM_ mods $ \mask ->
+        rawMask (altMask .|. mask) $ sendKey (mask, xK_Down) w
+
+    bind xK_k $
+      forM_ mods $ \mask ->
+        rawMask (altMask .|.mask) $ sendKey (mask, xK_Up) w
+
+    bind xK_l $
+      forM_ mods $ \mask ->
+        rawMask (altMask .|. mask) $ sendKey (mask, xK_Right) w
+
+    bind xK_u $
+      rawMask controlMask $ sendKey (controlMask .|. shiftMask, xK_BackSpace) w
+
+    bind xK_w $
+      rawMask controlMask $ sendKey (controlMask, xK_BackSpace) w
+
+    bind xK_b $ do
+      rawMask controlMask $ sendKey (controlMask, xK_Left) w
+      rawMask (controlMask .|. shiftMask) $
+        sendKey (controlMask .|. shiftMask, xK_Left) w
+
+    bind xK_e $ do
+      rawMask controlMask $ sendKey (controlMask, xK_Right) w
+      rawMask (controlMask .|. shiftMask) $
+        sendKey (controlMask .|. shiftMask, xK_Right) w
+
+    bind xK_dollar $
+      rawMask controlMask $ sendKey (0, xK_End) w
+
+    bind xK_at $
+      rawMask (controlMask .|. shiftMask) $ sendKey (0, xK_Home) w
+
+    bind xK_d $
+      rawMask controlMask $ sendKey (controlMask, xK_w) w
+
+    bind xK_F2 $
+      -- Experimental.
+      noMod $ logs "This is a test"
+
+
+  where
+    browsers = ["Google-chrome", "Brave-browser", "firefox-default"]
+
+    -- Create a permutation from a list of modifiers.
+    --
+    -- i.e. permuteMods [C, S, M] will return
+    --
+    -- [C, S, M, C + M, C + S, M + S, C + S + M, 0]
+    permuteMods = map (foldl' (.|.) 0) . filterM (const [True, False])
+
+
+    configureIf :: Query Bool -> KeysM l () -> Query (KeysM l ())
+    configureIf b k = b --> return k
+
+windowBindings :: XConfig l -> XConfig l
+windowBindings xconfig =
+  xconfig {
+    startupHook = do
+      forAllWindows (runQuery doQuery)
+      startupHook xconfig,
+
+    manageHook = (doQuery >> return (Endo id)) <> manageHook xconfig
+  }
+  
+  where
+    doQuery :: Query ()
+    doQuery = do
+      keysM <- windowSpecificBindings
+      forM_ (Map.toList $ runKeys keysM xconfig) $ \(key, action) -> do
+        remapKey key action
+
 applyKeys :: XConfig l -> IO (XConfig l)
 applyKeys config =
-    return $ config { keys = keymap, mouseBindings = mouseMap }
+    return $ windowBindings $ config { keys = keymap, mouseBindings = mouseMap }
 
 click :: X ()
 click = do
diff --git a/src/Internal/KeysM.hs b/src/Internal/KeysM.hs
index f834796..dfb1429 100644
--- a/src/Internal/KeysM.hs
+++ b/src/Internal/KeysM.hs
@@ -28,6 +28,13 @@ class Bindable k where
 
   bind :: k -> BindingBuilder (BindableValue k) a -> BindableMonad k l ()
 
+instance Semigroup (KeysM l ()) where
+  (<>) = mappend
+
+instance Monoid (KeysM l ()) where
+  mempty = return ()
+  mappend = (>>)
+
 runKeys :: KeysM l a -> XConfig l -> Map (KeyMask, KeySym) (X ())
 runKeys (KeysM stateM) config =
   snd $ execState stateM (config, Map.empty)
diff --git a/src/Main.hs b/src/Main.hs
index 44fb358..a83f1c3 100644
--- a/src/Main.hs
+++ b/src/Main.hs
@@ -10,6 +10,7 @@ import XMonad.Hooks.ManageHelpers (isFullscreen, doFullFloat)
 import XMonad.Layout.Fullscreen (fullscreenEventHook)
 import System.Environment (setEnv)
 import Data.Monoid
+import qualified Data.Map as Map
 
 import Internal.Swallow
 import Internal.Windows
@@ -19,6 +20,7 @@ import Internal.Layout
 import Internal.Logger
 import Internal.DMenu (menuCommandString)
 import Internal.RebindKeys
+import Internal.KeysM
 
 import qualified XMonad as X
 import qualified XMonad.StackSet as W
@@ -35,49 +37,7 @@ main = do
   xmobar <- spawnXMobar
 
   (=<<) X.xmonad $
-    applyKeys $ ewmh $ docks $ windowHooks (composeAll [
-           let browsers = ["Google-chrome", "Brave-browser", "firefox-default"] in
-
-           (flip elem browsers <$> className) --> composeAll [
-             -- The geniuses that made chrome decided that Ctrl+W should kill
-             -- the current tab! This makes it consistent with the rest of the
-             -- world ... ctrl+w deletes the last word (ctrl+backspace).
-             rebindKey (controlMask, xK_w) (controlMask, xK_BackSpace)
-
-             -- Terminal Ctrl-H sends a backspace. (Technically not, but that's
-             -- usually the semantics). Make it this way in Chrome.
-           , rebindKey (controlMask, xK_h) (0, xK_BackSpace)
-
-             -- Ctrl+u usually deletes the whole line. This is roughly
-             -- ctrl+shift+backspace
-           , rebindKey (controlMask, xK_u) (controlMask .|. shiftMask, xK_BackSpace)
-
-             -- Make it to ctrl+d deletes the current tab instead of ctrl+w.
-           , rebindKey (controlMask, xK_e) (controlMask, xK_w)
-
-             -- Vim-ish keybindings to go back and forward.
-           , rebindKey (controlMask, xK_b) (controlMask, xK_Left)
-           , rebindKey (controlMask, xK_e) (controlMask, xK_Right)
-           , rebindKey (controlMask .|. shiftMask, xK_b) (controlMask .|. shiftMask, xK_Left)
-           , rebindKey (controlMask .|. shiftMask, xK_e) (controlMask .|. shiftMask, xK_Right)
-
-             -- Baskic Vim-like motion with the alt key.
-           , rebindKey (mod1Mask, xK_h) (0, xK_Left)
-           , rebindKey (mod1Mask, xK_j) (0, xK_Down)
-           , rebindKey (mod1Mask, xK_k) (0, xK_Up)
-           , rebindKey (mod1Mask, xK_l) (0, xK_Right)
-
-           , rebindKey (shiftMask .|. mod1Mask, xK_h) (shiftMask, xK_Left)
-           , rebindKey (shiftMask .|. mod1Mask, xK_j) (shiftMask, xK_Down)
-           , rebindKey (shiftMask .|. mod1Mask, xK_k) (shiftMask, xK_Up)
-           , rebindKey (shiftMask .|. mod1Mask, xK_l) (shiftMask, xK_Right)
-
-           , rebindKey (controlMask .|. mod1Mask, xK_h) (controlMask, xK_Left)
-           , rebindKey (controlMask .|. mod1Mask, xK_j) (controlMask, xK_Down)
-           , rebindKey (controlMask .|. mod1Mask, xK_k) (controlMask, xK_Up)
-           , rebindKey (controlMask .|. mod1Mask, xK_l) (controlMask, xK_Right)
-           ]
-        ]) $ def
+    applyKeys $ ewmh $ docks $  def
        { terminal    = "alacritty"
        , modMask     = mod3Mask
        , borderWidth = 2
@@ -111,6 +71,7 @@ main = do
        , logHook = xMobarLogHook xmobar
        }
 
+
 doCenterFloat :: ManageHook
 doCenterFloat =
   ask >>= \w -> doF . W.float w . centerRect . snd =<< liftX (floatLocation w)