Better KeysM implementation and functions.

This is making better key bindings possible and awesome!

3 files changed, 159 insertions, 192 deletions

diff --git a/src/Config.hs b/src/Config.hs
index 87a0277..9d090d6 100644
--- a/src/Config.hs
+++ b/src/Config.hs
@@ -9,14 +9,18 @@ config =
   defaultConfig
     { hooks =
         defaultHooks
-          { keyHook = ofKeys testKeys,
-              -- runKeybinds $ do
-              --   bind (Mod1 .+ 'r') (shellExec "wofi --show run")
+          { keyHook = keys $ do
+              ignoreReleaseEvents
 
-              --   subbind (Mod1 .+ 'g') $ do
-              --     bind 't' $ shellExec "alacritty"
+              bind (Mod1 .+ 'r') (shellExec "wofi --show run")
+              bind (Shift .+ Mod1 .+ 'R') requestHotReload
+              bind (Mod1 .+ 't') (shellExec "alacritty")
 
-              --   bind (Mod1 .+ 'Q') requestHotReload,
+              subbind (Mod1 .+ 'l') $ do
+                bind 'l' $ wio $ putStrLn "lololololo"
+                bind 'j' $ wio $ putStrLn "JOGGING!"
+
+              forwardEvent,
             surfaceHook = wio . print
           },
       layout = WindowLayout Full
diff --git a/src/Wetterhorn/Core/Keys.hs b/src/Wetterhorn/Core/Keys.hs
index d08a49f..c8f8aeb 100644
--- a/src/Wetterhorn/Core/Keys.hs
+++ b/src/Wetterhorn/Core/Keys.hs
@@ -1,18 +1,34 @@
-module Wetterhorn.Core.Keys where
-
-import Control.Monad.Reader (MonadReader (ask), MonadTrans (lift), ReaderT (runReaderT), asks, void, when)
-import Control.Monad.State (MonadState (get, put), gets)
+module Wetterhorn.Core.Keys
+  ( forwardKey,
+    forwardEvent,
+    KeysM,
+    bind,
+    subbind,
+    (.+),
+    Modifier (..),
+    keys,
+    ignoreReleaseEvents,
+    weak,
+    continue,
+    WeakKeyMatcher,
+  )
+where
+
+import Control.Monad (void, when)
+import Control.Monad.Fix (fix)
+import Control.Monad.IO.Class
+import Control.Monad.Reader.Class
+import Control.Monad.State (MonadState (get, put))
 import Data.Bits
-import Data.Kind
 import Data.Word
 import Wetterhorn.Core.KeyEvent
 import qualified Wetterhorn.Core.KeyEvent as KeyEvent
 import Wetterhorn.Core.W
 import Wetterhorn.Foreign.WlRoots (wlrSeatKeyboardNotifyKey, wlrSeatSetKeyboard)
 
--- | Passes a key event through the current seat.
-passThroughKey :: KeyEvent -> W ()
-passThroughKey keyEvent = do
+-- | Forwards the given key event to the focused window.
+forwardKey :: KeyEvent -> W ()
+forwardKey keyEvent = do
   seatPtr <- getSeat
   wio $ do
     wlrSeatSetKeyboard
@@ -28,32 +44,15 @@ passThroughKey keyEvent = do
           _ -> 1
       )
 
-data Binding = Skip | Nevermind | JustAction (W ())
-
-newtype Keybinds a = Keybinds (ReaderT KeyEvent (Either (Maybe (W ()))) a)
-  deriving (Functor, Applicative, Monad, MonadReader KeyEvent)
-
-runKeybinds :: Keybinds a -> KeyEvent -> W ()
-runKeybinds (Keybinds kb) ke =
-  case runReaderT kb ke of
-    Left (Just action) -> action
-    _ -> do
-      resetKeys
-      passThroughKey ke
-
-resetKeys :: W ()
-resetKeys = do
-  Config {hooks = Hooks {keyHook = originalKeyHook}} <- ask
-  s@State {currentHooks = hooks} <- get
-  put s {currentHooks = hooks {keyHook = originalKeyHook}}
-
--- subbind :: Keybinds a -> W ()
--- subbind kb = do
---   s@State {currentHooks = hooks} <- get
---   put s {currentHooks = hooks {keyHook = runKeybinds kb}}
+-- | Forwards the current key event to the focused window.
+forwardEvent :: KeysM ()
+forwardEvent = liftW . forwardKey =<< ask
 
+-- | Enumeration of possible modifiers
 data Modifier = Shift | Lock | Control | Mod1 | Mod2 | Mod3 | Mod4 | Mod5
+  deriving (Eq, Ord, Show, Read, Enum, Bounded)
 
+-- | Converts a modifier to its associated mask.
 modifierToMask :: Modifier -> Word32
 modifierToMask m =
   1
@@ -67,185 +66,143 @@ modifierToMask m =
       Mod4 -> 6
       Mod5 -> 7
 
--- class MatchesKeyEvent a where
---   matchesKeyEvent :: a -> KeyEvent -> Bool
---
--- instance MatchesKeyEvent Modifier where
---   matchesKeyEvent m keyEvent =
---     (modifiers keyEvent .&. modifierToMask m) /= 0
---
--- instance MatchesKeyEvent Char where
---   matchesKeyEvent c e = c == codepoint e
---
--- newtype Match = Match (KeyEvent -> Bool)
---
--- instance MatchesKeyEvent Match where
---   matchesKeyEvent (Match f) = f
---
--- (.+) :: (MatchesKeyEvent m1, MatchesKeyEvent m2) => m1 -> m2 -> Match
--- (.+) match1 match2 = Match $ \ke -> matchesKeyEvent match1 ke && matchesKeyEvent match2 ke
---
--- bind :: (MatchesKeyEvent m) => m -> W () -> Keybinds ()
--- bind condition action = do
---   ke <- ask
---   when (state ke == KeyPressed && matchesKeyEvent condition ke) $
---     Keybinds $
---       lift (Left $ Just (action >> resetKeys))
---   when (state ke == KeyReleased && matchesKeyEvent condition ke) (return ())
---
--- subbind :: (MatchesKeyEvent m) => m -> Keybinds () -> Keybinds ()
--- subbind condition subkeys = do
---   ke <- ask
---   when (state ke == KeyPressed && matchesKeyEvent condition ke) $
---     Keybinds $
---       lift
---         ( Left $
---             Just $
---               nextKey (runKeybinds subkeys)
---         )
---   when (state ke == KeyReleased && matchesKeyEvent condition ke) (return ())
---
--- nevermind :: Keybinds ()
--- nevermind = Keybinds $ lift (Left Nothing)
-
-testKeys :: KeysM ()
-testKeys = do
-  k1 <- nextKeyPress
-
-  when (KeyEvent.codepoint k1 == 'R') $
-    liftW requestHotReload
-
-  liftW $ wio $ putStrLn $ "1 " ++ show k1
-  ck <- currentKey
-  liftW $ wio $ putStrLn $ "1' " ++ show ck
-  k2 <- nextKeyPress
-  liftW $ wio $ putStrLn $ "2 " ++ show k2
-  testKeys
-
-newtype KeysM a = KeysM (KeyEvent -> W (Either (KeysM a) a))
-
-ofKeys :: KeysM a -> KeyEvent -> W ()
-ofKeys (KeysM fn) ke = do
-  e <- fn ke
-  case e of
-    Right _ -> return ()
-    Left next -> runKeysM next
-
-runKeysM :: KeysM a -> W ()
-runKeysM k = do
+-- | The Keys monad. This monad abstracts away control flow for handling key
+-- bindings. This makes it easy to make key-sequence bindings.
+newtype KeysM a = KeysM ((KeyEvent -> W ()) -> KeyEvent -> W (KeysMR a))
+
+data KeysMR a = NextKey (KeysM a) | Lift a | Continue
+
+keys :: KeysM a -> KeyEvent -> W ()
+keys 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')
+        Lift _ -> return ()
+        _ -> putKeyHandler top
+
+putKeyHandler :: (KeyEvent -> W a) -> W ()
+putKeyHandler handler = do
   s@State {currentHooks = hooks} <- get
   put
     s
       { currentHooks =
           hooks
-            { keyHook = ofKeys k
+            { keyHook = void <$> handler
             }
       }
 
-liftW :: W a -> KeysM a
-liftW act = KeysM (\_ -> Right <$> act)
-
-keysJoin :: KeysM (KeysM a) -> KeysM a
-keysJoin (KeysM f) = KeysM $ \keyEvent -> do
-  e <- f keyEvent
-  case e of
-    Right (KeysM f') -> f' keyEvent
-    Left sub -> return $ Left $ keysJoin sub
-
 nextKey :: KeysM KeyEvent
-nextKey = KeysM (\_ -> return (Left (KeysM (return . Right))))
+nextKey = KeysM (\_ _ -> return (NextKey (KeysM (\_ -> return . Lift))))
 
 nextKeyPress :: KeysM KeyEvent
 nextKeyPress = do
   k <- nextKey
   if KeyEvent.state k /= KeyPressed
-    then nextKeyPress
+    then forwardEvent >> nextKeyPress
     else return k
 
-currentKey :: KeysM KeyEvent
-currentKey = KeysM (return . Right)
+continue :: KeysM ()
+continue = KeysM $ \_ _ -> return Continue
 
 instance Functor KeysM where
-  fmap f (KeysM fn) = KeysM $ \keyEvent -> do
-    e <- fn keyEvent
+  fmap f (KeysM fn) = KeysM $ \top keyEvent -> do
+    e <- fn top keyEvent
     return $
       case e of
-        Left ma -> Left $ fmap f ma
-        Right a -> Right $ f a
+        NextKey ma -> NextKey $ fmap f ma
+        Lift a -> Lift $ f a
+        Continue -> Continue
 
 instance Applicative KeysM where
-  pure a = KeysM (\_ -> return (Right a))
+  pure a = KeysM (\_ _ -> return (Lift a))
   (<*>) mfn ma = do
     fn <- mfn
     fn <$> ma
 
 instance Monad KeysM where
-  return = pure
   a >>= fmb = keysJoin (fmap fmb a)
-
--- keysJoin (KeysM fn) = KeysM $ \ke -> do
---   nextKeys <- fn ke
---   case nextKeys of
---     NextKey -> NextKey
---     (KeysM fn') -> fn' ke
-
--- data KeysResult a = DoDefer (KeyEvent -> W (KeysM a)) | DoIdent a
--- data KeysM a = KeysM (KeyEvent -> W (KeysResult a))
---
--- keysJoin :: KeysM (KeysM a) -> KeysM a
--- keysJoin (KeysM fn) = KeysM $ \ke -> do
---  kr <- fn ke
---  case kr of
---    DoDefer nextKeyFn ->
-
--- data KeysM a where
---   Ident :: W a -> KeysM a
---   NextKey :: (KeyEvent -> W (KeysM a)) -> KeysM a
---
--- runKeysM :: KeysM a -> KeyEvent -> W ()
--- runKeysM (Ident ma) _ = void ma
--- runKeysM (NextKey fn) keyEvent = do
---   val <- fn keyEvent
---   s@State {currentHooks = hooks} <- get
---   put s {currentHooks = hooks {keyHook = runKeysM val}}
---
--- instance Functor KeysM where
---   fmap f (Ident wa) = Ident $ fmap f wa
---   fmap f (NextKey fn) = NextKey $ fmap (fmap f) . fn
---
--- instance Applicative KeysM where
---   pure = Ident . pure
---
---
--- joinKeysM :: KeysM (KeysM a) -> KeysM a
--- joinKeysM (Ident mKeysMA) =
---   Ident $ do
---     keysMa <- mKeysMA
---     case keysMa of
---       Ident ma -> ma
---       NextKey ->
---
--- instance Monad KeysM where
---   return = pure
-
--- (Ident ma) >>= fn =
-
--- nextKey :: (KeyEvent -> W ()) -> W ()
--- nextKey evf = do
---   s@State {currentHooks = hooks} <- get
---   put s {currentHooks = hooks {keyHook = evf}}
-
---
--- data KeyM a where
---   Ident :: W a -> KeyM a
---   Deferred :: KeyM KeyEvent
---   Cont :: (KeyEvent -> KeyM b) -> KeyM b
---
--- instance Functor KeyM where
---   fmap fn k = case k of
---     Ident wa -> Ident (fn <$> wa)
---     Deferred -> Cont (pure . fn)
---     Cont f -> Cont (fmap fn . f)
-
--- bind :: KeyM KeyEvent -> (KeyEvent -> KeyM b) -> KeyM b
--- bind = undefined
+    where
+      keysJoin (KeysM f) = KeysM $ \top keyEvent -> do
+        e <- f top keyEvent
+        case e of
+          Lift (KeysM f') -> f' top keyEvent
+          NextKey sub -> return $ NextKey $ keysJoin sub
+          Continue -> return Continue
+
+instance Wlike KeysM where
+  liftW act = KeysM (\_ _ -> Lift <$> act)
+
+instance MonadIO KeysM where
+  liftIO = liftW . wio
+
+instance MonadReader KeyEvent KeysM where
+  ask = KeysM (\_ -> return . Lift)
+  local fn (KeysM fn') = KeysM $ \a (fn -> ns) -> fn' a ns
+
+data KeyMatcher = KeyMatcher Word32 Char
+  deriving (Show)
+
+-- | Like a KeyMatcher, but allows additional modifiers to be pressed, not just
+-- the exact ones given.
+newtype WeakKeyMatcher = WeakKeyMatcher KeyMatcher
+
+weak :: KeyMatcher -> WeakKeyMatcher
+weak = WeakKeyMatcher
+
+class KeyMatcherId r where
+  toKeyMatcher :: r -> KeyMatcher
+
+instance KeyMatcherId KeyMatcher where
+  toKeyMatcher = id
+
+instance KeyMatcherId Char where
+  toKeyMatcher = KeyMatcher 0
+
+class KeyMatcherBuilder b where
+  (.+) :: (KeyMatcherId i) => b -> i -> KeyMatcher
+
+instance KeyMatcherBuilder Modifier where
+  (.+) m (toKeyMatcher -> (KeyMatcher mods ch)) =
+    KeyMatcher (mods .|. modifierToMask m) ch
+
+infixr 9 .+
+
+class MatchKey m where
+  matchKey :: m -> KeyEvent -> Bool
+
+instance MatchKey Char where
+  matchKey ch ev = ch == KeyEvent.codepoint ev
+
+instance MatchKey KeyMatcher where
+  matchKey (KeyMatcher m ch) ev =
+    ch == KeyEvent.codepoint ev && m == KeyEvent.modifiers ev
+
+instance MatchKey WeakKeyMatcher where
+  matchKey (WeakKeyMatcher (KeyMatcher m ch)) ev =
+    ch == KeyEvent.codepoint ev && (m .|. ms) == ms
+    where
+      ms = KeyEvent.modifiers ev
+
+subbind :: (MatchKey m) => m -> KeysM () -> KeysM ()
+subbind m act = do
+  ev <- ask
+  when (matchKey m ev) $ do
+    _ <- nextKeyPress
+    act
+    continue
+
+bind :: (MatchKey m) => m -> W () -> KeysM ()
+bind m act = do
+  ev <- ask
+  when (matchKey m ev) $ do
+    liftW act
+    continue
+
+ignoreReleaseEvents :: KeysM ()
+ignoreReleaseEvents = do
+  ev <- ask
+  when (KeyEvent.state ev /= KeyEvent.KeyPressed) $ do
+    forwardEvent
+    continue
diff --git a/src/Wetterhorn/Core/W.hs b/src/Wetterhorn/Core/W.hs
index b2b044e..b809545 100644
--- a/src/Wetterhorn/Core/W.hs
+++ b/src/Wetterhorn/Core/W.hs
@@ -90,7 +90,7 @@ handleWindowMessage m (WindowLayout l) = WindowLayout <$> handleMessage m l
 readWindowLayout :: WindowLayout -> String -> WindowLayout
 readWindowLayout (WindowLayout l) s
   | (Just x) <- readLayout s =
-      WindowLayout (asTypeOf x l)
+    WindowLayout (asTypeOf x l)
 readWindowLayout l _ = l
 
 serializeWindowLayout :: WindowLayout -> String
@@ -223,3 +223,9 @@ shellExec = wio . ForeignInterface.doShellExec
 
 wio :: IO a -> W a
 wio = liftIO
+
+class Wlike m where
+  liftW :: W a -> m a
+
+instance Wlike W where
+  liftW = id