More flexing with the new keysM system.

4 files changed, 69 insertions, 16 deletions

diff --git a/harness/src/wl.c b/harness/src/wl.c
index f083a5e..2cefe06 100644
--- a/harness/src/wl.c
+++ b/harness/src/wl.c
@@ -2,6 +2,7 @@
 
 #include <stdio.h>
 #include <stdlib.h>
+#include <sys/time.h>
 #include <time.h>
 
 #include <wl.h>
diff --git a/package.yaml b/package.yaml
index 3a7c5b2..213a904 100644
--- a/package.yaml
+++ b/package.yaml
@@ -35,6 +35,7 @@ dependencies:
 - containers
 - data-default
 - transformers
+- monad-loops
 
 
 ghc-options:
@@ -69,8 +70,10 @@ executables:
     - -dynamic
     - -no-hs-main
     - -lHSrts-1.0.2-ghc9.4.7
+    - -O3
     cc-options:
       - -g3
+      - -O2
       - -shared
       - -Iharness/build/
       - -Iharness/include/
diff --git a/src/Config.hs b/src/Config.hs
index 9d090d6..759e3b8 100644
--- a/src/Config.hs
+++ b/src/Config.hs
@@ -1,5 +1,9 @@
 module Config (config) where
 
+import Control.Monad.IO.Class
+import Control.Monad.Loops
+import Control.Monad.RWS (MonadReader (ask))
+import qualified Wetterhorn.Core.KeyEvent as KeyEvent
 import Wetterhorn.Core.Keys
 import Wetterhorn.Core.W
 import Wetterhorn.Layout.Full
@@ -20,6 +24,22 @@ config =
                 bind 'l' $ wio $ putStrLn "lololololo"
                 bind 'j' $ wio $ putStrLn "JOGGING!"
 
+              subbind (Mod1 .+ 'p') $ do
+                str <-
+                  unfoldM
+                    ( do
+                        ke <- ask
+                        if KeyEvent.codepoint ke == '\r'
+                          then return Nothing
+                          else do
+                            Just (KeyEvent.codepoint ke) <$ nextKeyPress
+                    )
+
+                liftIO $ putStrLn $ "You input: " ++ str
+                bind (str == "hello") $ do
+                  liftIO $ putStrLn "You Win! *\\o/*"
+                liftIO $ putStrLn "You Lose :("
+
               forwardEvent,
             surfaceHook = wio . print
           },
diff --git a/src/Wetterhorn/Core/Keys.hs b/src/Wetterhorn/Core/Keys.hs
index c8f8aeb..4ed7a77 100644
--- a/src/Wetterhorn/Core/Keys.hs
+++ b/src/Wetterhorn/Core/Keys.hs
@@ -4,6 +4,7 @@ module Wetterhorn.Core.Keys
     KeysM,
     bind,
     subbind,
+    subbind_,
     (.+),
     Modifier (..),
     keys,
@@ -11,6 +12,9 @@ module Wetterhorn.Core.Keys
     weak,
     continue,
     WeakKeyMatcher,
+    nextKeyEvent,
+    nextKeyPress,
+    keyEvents,
   )
 where
 
@@ -72,6 +76,7 @@ newtype KeysM a = KeysM ((KeyEvent -> W ()) -> KeyEvent -> W (KeysMR a))
 
 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
   where
@@ -81,28 +86,32 @@ keys keysM = fix $ \top ke -> keys' top keysM ke
         NextKey keysM' -> putKeyHandler (keys' top keysM')
         Lift _ -> return ()
         _ -> putKeyHandler top
-
-putKeyHandler :: (KeyEvent -> W a) -> W ()
-putKeyHandler handler = do
-  s@State {currentHooks = hooks} <- get
-  put
-    s
-      { currentHooks =
-          hooks
-            { keyHook = void <$> handler
-            }
-      }
-
-nextKey :: KeysM KeyEvent
-nextKey = KeysM (\_ _ -> return (NextKey (KeysM (\_ -> return . Lift))))
-
+    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.
+nextKeyEvent :: KeysM KeyEvent
+nextKeyEvent = KeysM (\_ _ -> return (NextKey (KeysM (\_ -> return . Lift))))
+
+-- | Returns the next KeyPressed event. This is likely what 90% of use cases
+-- want rather than nextKeyEvent.
 nextKeyPress :: KeysM KeyEvent
 nextKeyPress = do
-  k <- nextKey
+  k <- nextKeyEvent
   if KeyEvent.state k /= KeyPressed
     then forwardEvent >> nextKeyPress
     else return k
 
+-- | Resets the handling of KeyBindings to the top. Operates like a 'continue'
+-- statement in imperative programming languages.
 continue :: KeysM ()
 continue = KeysM $ \_ _ -> return Continue
 
@@ -141,6 +150,11 @@ instance MonadReader KeyEvent KeysM where
   ask = KeysM (\_ -> return . Lift)
   local fn (KeysM fn') = KeysM $ \a (fn -> ns) -> fn' a ns
 
+--
+-- binding EDSL used to expressively create key bindings and subbindings inside
+-- a KeysM () context.
+--
+
 data KeyMatcher = KeyMatcher Word32 Char
   deriving (Show)
 
@@ -148,6 +162,7 @@ data KeyMatcher = KeyMatcher Word32 Char
 -- the exact ones given.
 newtype WeakKeyMatcher = WeakKeyMatcher KeyMatcher
 
+-- | Converts a KeyMatcher to a weak key matcher.
 weak :: KeyMatcher -> WeakKeyMatcher
 weak = WeakKeyMatcher
 
@@ -172,6 +187,12 @@ infixr 9 .+
 class MatchKey m where
   matchKey :: m -> KeyEvent -> Bool
 
+instance MatchKey (KeyEvent -> Bool) where
+  matchKey = ($)
+
+instance MatchKey Bool where
+  matchKey = const
+
 instance MatchKey Char where
   matchKey ch ev = ch == KeyEvent.codepoint ev
 
@@ -193,6 +214,14 @@ subbind m act = do
     act
     continue
 
+-- | Like 'subbind', but does not read the next keypress.
+subbind_ :: (MatchKey m) => m -> KeysM () -> KeysM ()
+subbind_ m act = do
+  ev <- ask
+  when (matchKey m ev) $ do
+    act
+    continue
+
 bind :: (MatchKey m) => m -> W () -> KeysM ()
 bind m act = do
   ev <- ask