Implement ability to customize the keys "putHandler" functionality.

This will be useful for the future when I will implement macro-recording
functionality.

2 files changed, 33 insertions, 16 deletions

diff --git a/src/Config.hs b/src/Config.hs
index 0cc1c02..4521cc1 100644
--- a/src/Config.hs
+++ b/src/Config.hs
@@ -8,12 +8,20 @@ import Wetterhorn.Core.Keys
 import Wetterhorn.Core.W
 import Wetterhorn.Layout.Full
 
+alsoLog :: KeyHandler -> W ()
+alsoLog kh =
+  putKeyHandler
+    ( \ke -> do
+        liftIO $ putStrLn $ (: []) $ KeyEvent.codepoint ke
+        kh ke
+    )
+
 config :: Config WindowLayout
 config =
   defaultConfig
     { hooks =
         defaultHooks
-          { keyHook = keys $ do
+          { keyHook = keysWithHandler alsoLog $ do
               ignoreReleaseEvents
 
               bind (Mod1 .+ 'r') (shellExec "wofi --show run")
diff --git a/src/Wetterhorn/Core/Keys.hs b/src/Wetterhorn/Core/Keys.hs
index 30db96d..90c24c4 100644
--- a/src/Wetterhorn/Core/Keys.hs
+++ b/src/Wetterhorn/Core/Keys.hs
@@ -14,6 +14,9 @@ module Wetterhorn.Core.Keys
     WeakKeyMatcher,
     nextKeyEvent,
     nextKeyPress,
+    keysWithHandler,
+    putKeyHandler,
+    KeyHandler,
   )
 where
 
@@ -73,28 +76,34 @@ modifierToMask m =
 -- bindings. This makes it easy to make key-sequence bindings.
 newtype KeysM a = KeysM ((KeyEvent -> W ()) -> KeyEvent -> W (KeysMR a))
 
+type KeyHandler = KeyEvent -> W ()
+
 -- Return type in the keysM monad.
 data KeysMR a = NextKey (KeysM a) | Lift a | Continue
 
--- | Convert a KeyM operation to a KeyEvent handler.
-keys :: KeysM a -> KeyEvent -> W ()
-keys keysM = fix $ \top ke -> keys' top keysM ke
+keysWithHandler :: (KeyHandler -> W ()) -> KeysM a -> KeyHandler
+keysWithHandler nextAction keysM = fix $ \top ke -> keys' top keysM ke
   where
     keys' top (KeysM fn) ke = do
       e <- fn top ke
       case e of
-        NextKey keysM' -> putKeyHandler (keys' top keysM')
+        NextKey keysM' -> nextAction (keys' top keysM')
         Lift _ -> return ()
-        _ -> putKeyHandler top
-    putKeyHandler handler = do
-      s@State {currentHooks = hooks} <- get
-      put
-        s
-          { currentHooks =
-              hooks
-                { keyHook = void <$> handler
-                }
-          }
+        _ -> nextAction top
+
+keys :: KeysM a -> KeyEvent -> W ()
+keys = keysWithHandler putKeyHandler
+
+putKeyHandler :: KeyHandler -> W ()
+putKeyHandler handler = do
+  s@State {currentHooks = hooks} <- get
+  put
+    s
+      { currentHooks =
+          hooks
+            { keyHook = void <$> handler
+            }
+      }
 
 -- | Returns the next key event. This returns both key pressed and key released
 -- events, so it's good to be careful because duplicate casess can happen.
@@ -148,7 +157,7 @@ instance Wlike KeysM where
 instance MonadIO KeysM where
   liftIO = liftW . wio
 
--- | Reads the current KeyEvent.
+-- | Monad
 instance MonadReader KeyEvent KeysM where
   ask = KeysM (\_ -> return . Lift)
   local fn (KeysM fn') = KeysM $ \a (fn -> ns) -> fn' a ns