Only bind the necessary keys during a submap. A little strange, not sure how I feel about it, but it is worthwhile to keep aroundexperimental_only_bind_necessary

2 files changed, 48 insertions, 6 deletions

diff --git a/src/Rahm/Desktop/RebindKeys.hs b/src/Rahm/Desktop/RebindKeys.hs
index 0b4d768..040946f 100644
--- a/src/Rahm/Desktop/RebindKeys.hs
+++ b/src/Rahm/Desktop/RebindKeys.hs
@@ -77,6 +77,15 @@ doGrab dpy win (keyMask, keysym) = do
   forM_ codes $ \kc ->
     mapM_ (grab kc . (keyMask .|.)) =<< extraModifiers
 
+doUngrab :: Display -> Window -> (KeyMask, KeySym) -> X ()
+doUngrab dpy win (keyMask, keysym) = do
+  let grab kc m = io $ ungrabKey dpy kc m win
+
+  codes <- io $ getKeyCodesForKeysym dpy keysym
+
+  forM_ codes $ \kc ->
+    mapM_ (grab kc . (keyMask .|.)) =<< extraModifiers
+
 disableKey :: (KeyMask, KeySym) -> WindowHook
 disableKey key = remapKey key (return ())
 
diff --git a/src/Rahm/Desktop/Submap.hs b/src/Rahm/Desktop/Submap.hs
index da9fe77..496b5f5 100644
--- a/src/Rahm/Desktop/Submap.hs
+++ b/src/Rahm/Desktop/Submap.hs
@@ -11,11 +11,15 @@ module Rahm.Desktop.Submap (
 
 import XMonad hiding (keys)
 import Control.Monad.Fix (fix)
+import Control.Monad (void)
 import qualified Data.Map as Map
 import Data.Map (Map)
 import Control.Concurrent (threadDelay)
 import Data.Word (Word64)
 import Data.Time.Clock.POSIX
+import Rahm.Desktop.RebindKeys
+import Data.Set (Set, (\\))
+import qualified Data.Set as Set
 
 
 currentTimeMillis :: IO Int
@@ -46,7 +50,32 @@ getMaskEventWithTimeout timeout d mask fn = do
             then return True
             else threadDelay 1000 >> getMaskEventWithTimeout' ptr timeout
 
+data KeysToGrab = OnlyKeys [(KeyMask, KeySym)] | AllKeys
+
+grabKeys :: KeysToGrab -> X ()
+grabKeys AllKeys = do
+  XConf { theRoot = root, display = d } <- ask
+  void $ io $ grabKeyboard d root False grabModeAsync grabModeAsync currentTime
+grabKeys (OnlyKeys (Set.fromList -> keys)) = do
+  ks <- (Set.fromList . Map.keys) <$> asks keyActions
+  let keysToGrab = keys \\ ks -- Avoid grabbing already bound keys
+
+  XConf { theRoot = root, display = d } <- ask
+  mapM_ (doGrab d root) keysToGrab
+
+ungrabKeys :: KeysToGrab -> X ()
+ungrabKeys AllKeys = do
+  XConf { display = d } <- ask
+  io $ ungrabKeyboard d currentTime
+ungrabKeys (OnlyKeys (Set.fromList -> keys)) = do
+  ks <- (Set.fromList . Map.keys) <$> asks keyActions
+  let keysToUngrab = keys \\ ks -- Don't ungrab unbound keys!
+
+  XConf { display = d, theRoot = root } <- ask
+  mapM_ (doUngrab d root) keysToUngrab
+
 {-
+ -
  - Like submap fram XMonad.Actions.Submap, but sends the string from
  - XLookupString to the function along side the keysym.
  -
@@ -54,10 +83,10 @@ getMaskEventWithTimeout timeout d mask fn = do
  - but also allows submappings for keys that may not have a character associated
  - with them (for example, the function keys).
  -}
-mapNextStringWithKeysym :: (KeyMask -> KeySym -> String -> X ()) -> X ()
-mapNextStringWithKeysym fn = do
+mapNextStringWithKeysymOnlyGrabbing :: KeysToGrab -> (KeyMask -> KeySym -> String -> X ()) -> X ()
+mapNextStringWithKeysymOnlyGrabbing keysToGrab fn = do
   XConf { theRoot = root, display = d } <- ask
-  io $ grabKeyboard d root False grabModeAsync grabModeAsync currentTime
+  grabKeys keysToGrab
 
   ret <- io $ fix $ \nextkey -> do
     ret <-
@@ -75,18 +104,22 @@ mapNextStringWithKeysym fn = do
 
       Nothing -> return Nothing
 
-  io $ ungrabKeyboard d currentTime
+  ungrabKeys keysToGrab
   case ret of 
     Just (m, str, keysym) -> fn m keysym str
     Nothing -> return ()
 
+mapNextStringWithKeysym :: (KeyMask -> KeySym -> String -> X ()) -> X ()
+mapNextStringWithKeysym = mapNextStringWithKeysymOnlyGrabbing AllKeys
+
 {- Like submap, but on the character typed rather than the kysym. -}
 mapNextString :: (KeyMask -> String -> X ()) -> X () 
 mapNextString fn = mapNextStringWithKeysym (\m _ s -> fn m s)
 
 submapDefaultWithKey :: ((KeyMask, KeySym) -> X ()) -> Map (KeyMask, KeySym) (X ()) -> X ()
-submapDefaultWithKey def m = mapNextStringWithKeysym $ \mask sym _ -> do
-  Map.findWithDefault (def (mask, sym)) (mask, sym) m
+submapDefaultWithKey def m =
+    mapNextStringWithKeysymOnlyGrabbing (OnlyKeys $ Map.keys m) $ \mask sym _ -> do
+      Map.findWithDefault (def (mask, sym)) (mask, sym) m
 
 submapDefault :: X () -> Map (KeyMask, KeySym) (X ()) -> X ()
 submapDefault def = submapDefaultWithKey (const def)