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

2 files changed, 122 insertions, 1 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)