Fixed bug where multiple configures would override previous configures for window-specific bindings

2 files changed, 15 insertions, 17 deletions

diff --git a/src/Internal/Keys.hs b/src/Internal/Keys.hs
index ad3d6b8..ce48dfd 100644
--- a/src/Internal/Keys.hs
+++ b/src/Internal/Keys.hs
@@ -1,9 +1,10 @@
-{-# LANGUAGE RankNTypes #-}
+{-# LANGUAGE RankNTypes, FlexibleContexts #-}
 module Internal.Keys (applyKeys) where
 
 import Data.Monoid (Endo(..))
 import Control.Monad.Trans.Class
 import Control.Monad.Reader
+import Control.Monad.Writer
 import Control.Monad.Loops (iterateWhile)
 import Control.Monad.Fix (fix)
 import Graphics.X11.ExtraTypes.XF86;
@@ -486,9 +487,13 @@ mouseMap = runButtons $ do
 -- 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
+windowSpecificBindings ::
+  XConfig l -> WriterT (Map (KeyMask, KeySym) (X ())) Query ()
+windowSpecificBindings config = do
+
+  w <- lift ask
+
+  let configureIf b k = tell =<< lift (b --> return (runKeys k config))
 
   configureIf (flip elem browsers <$> className) $ do
 
@@ -576,10 +581,6 @@ windowSpecificBindings = do
     -- [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 {
@@ -593,8 +594,12 @@ windowBindings xconfig =
   where
     doQuery :: Query ()
     doQuery = do
-      keysM <- windowSpecificBindings
-      forM_ (Map.toList $ runKeys keysM xconfig) $ \(key, action) -> do
+      map <- execWriterT $ windowSpecificBindings xconfig
+      w <- ask
+
+      liftX $ logs $ printf "For Window: %s" (show w)
+      forM_ (Map.toList map) $ \(key, action) -> do
+        liftX $ logs $ printf "   -- remap: %s" (show key)
         remapKey key action
 
 applyKeys :: XConfig l -> IO (XConfig l)
diff --git a/src/Internal/KeysM.hs b/src/Internal/KeysM.hs
index dfb1429..f834796 100644
--- a/src/Internal/KeysM.hs
+++ b/src/Internal/KeysM.hs
@@ -28,13 +28,6 @@ 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)