[feat] add basic key binding DSL.HEADmain

4 files changed, 107 insertions, 18 deletions

diff --git a/montis/src/Config.hs b/montis/src/Config.hs
index 8ec06dd..f71b5f9 100644
--- a/montis/src/Config.hs
+++ b/montis/src/Config.hs
@@ -1,27 +1,21 @@
 module Config (config) where
 
-import Control.Monad.IO.Class (liftIO)
-import Data.Bits (shiftL, (.&.))
+import Data.Bits (shiftL)
 import Data.Word (Word32)
 import Montis.Core
-import Montis.Core.Runtime (warpCursor)
 import Montis.Standard.Drag (DragConfig (DragConfig))
-import Montis.Standard.Keys (KeysConfig (KeysConfig), subkeys)
+import Montis.Standard.Keys.Dsl
 import Montis.Standard.Mouse (MouseConfig (MouseConfig))
 
-keys :: KeyEvent -> Montis Bool
-keys ev
-  | keyEvent_modifiers ev .&. mod1Mask == 0 = return False
-  | otherwise = case keyEvent_codepoint ev of
-      'j' -> do
-        liftIO (putStrLn "j was pressed!")
-        subkeys $ \ev -> case keyEvent_codepoint ev of
-          'k' -> do
-            liftIO (putStrLn "k was pressed after j!")
-            warpCursor 0 0
-            return True
-          _ -> return False
-      _ -> return False
+keyBindings :: [Binding]
+keyBindings =
+  [ Bind
+      (Mod1 .+ 'j')
+      [ Bind (Mod1 .+ 'k') (mio $ putStrLn "Pressed 'k' after 'j'")
+      ],
+    Bind (Mod1 .+ 'Q') requestRebirth,
+    Bind (Mod1 .+ 's') (\(keyEvent :: KeyEvent) -> mio (print keyEvent))
+  ]
 
 mod1Mask :: Word32
 mod1Mask = 1 `shiftL` 3 -- WLR_MODIFIER_ALT
@@ -30,4 +24,4 @@ config :: MontisConfig
 config =
   install MouseConfig $
     install (DragConfig mod1Mask) $
-      install (KeysConfig keys) defaultConfig
+      withBindings keyBindings defaultConfig
diff --git a/montis/src/Montis/Core/Monad.hs b/montis/src/Montis/Core/Monad.hs
index 4c0d106..0eee819 100644
--- a/montis/src/Montis/Core/Monad.hs
+++ b/montis/src/Montis/Core/Monad.hs
@@ -123,3 +123,7 @@ xConfigGet = do
     fromMaybe def $
       Map.lookup (typeRepr (Proxy :: Proxy a)) exts
         >>= (\(Extension a) -> cast a)
+
+
+mio :: IO a -> Montis a
+mio = liftIO
diff --git a/montis/src/Montis/Core/Runtime.hs b/montis/src/Montis/Core/Runtime.hs
index 0d4c905..541cc6b 100644
--- a/montis/src/Montis/Core/Runtime.hs
+++ b/montis/src/Montis/Core/Runtime.hs
@@ -7,6 +7,7 @@ module Montis.Core.Runtime
     setToplevelPosition,
     toplevelAt,
     warpCursor,
+    requestRebirth,
   )
 where
 
@@ -27,6 +28,11 @@ type ToplevelHandle = Ptr ForeignMontisToplevel
 unwrapSelf :: SelfPtr -> Ptr Void
 unwrapSelf (SelfPtr p) = p
 
+requestRebirth :: Montis ()
+requestRebirth = do
+  (SelfPtr p) <- getSelfPtr
+  liftIO $ foreign_doRequestHotReload p
+
 getSeat :: Montis (Maybe WlrSeat)
 getSeat = do
   self <- getSelfPtr
diff --git a/montis/src/Montis/Standard/Keys/Dsl.hs b/montis/src/Montis/Standard/Keys/Dsl.hs
new file mode 100644
index 0000000..096a8b9
--- /dev/null
+++ b/montis/src/Montis/Standard/Keys/Dsl.hs
@@ -0,0 +1,85 @@
+{-# LANGUAGE ImpredicativeTypes #-}
+
+-- | Small DSL for defining key bindings and nested sub-maps.
+module Montis.Standard.Keys.Dsl where
+
+import Control.Monad.Loops (anyM)
+import Data.Bits (shiftL, (.&.))
+import Montis.Core (Config, KeyEvent (keyEvent_codepoint, keyEvent_modifiers), Montis (..), install)
+import Montis.Standard.Keys
+
+-- | A predicate over a key event.
+class KeyMatch a where
+  matches :: a -> KeyEvent -> Montis Bool
+
+instance KeyMatch Char where
+  matches c k = return $ keyEvent_codepoint k == c
+
+-- | Modifier matches using wlroots bit positions.
+data Modifier = Mod1 | Mod2 | Mod3 | Mod4 | Mod5 | Any | None
+
+instance KeyMatch Modifier where
+  matches Mod1 ev = return $ keyEvent_modifiers ev .&. (1 `shiftL` 3) /= 0
+  matches Mod2 ev = return $ keyEvent_modifiers ev .&. (1 `shiftL` 4) /= 0
+  matches Mod3 ev = return $ keyEvent_modifiers ev .&. (1 `shiftL` 5) /= 0
+  matches Mod4 ev = return $ keyEvent_modifiers ev .&. (1 `shiftL` 6) /= 0
+  matches Mod5 ev = return $ keyEvent_modifiers ev .&. (1 `shiftL` 7) /= 0
+  matches Any _ = return True
+  matches None ev = return $ keyEvent_modifiers ev == 0
+
+-- | Actions run when a binding matches. Each action reports handled status.
+class Action b where
+  run :: b -> Montis Bool
+
+instance Action (Montis ()) where
+  run a = a >> return True
+
+instance Action (KeyEvent -> Montis ()) where
+  run f = subkeys (\e -> f e >> return True)
+
+-- | Submap to the first binding that matches.
+instance Action [Binding] where
+  run bs = subkeys $ \ev ->
+    anyM
+      ( \(Bind k a) -> do
+          m <- matches k ev
+          if m then run a >> return True else return False
+      )
+      bs
+
+instance Action (Montis [Binding]) where
+  run mbs = do
+    bs <- mbs
+    run bs
+
+-- | A single binding from a matcher to an action.
+data Binding where
+  Bind :: forall k b. (KeyMatch k, Action b) => k -> b -> Binding
+
+-- | A matcher for key + modifier chords.
+data ChordMatch where
+  ChordMatch :: forall k2 k1. (KeyMatch k2, KeyMatch k1) => k2 -> k1 -> ChordMatch
+
+(.+) :: (KeyMatch k1, KeyMatch k2) => k1 -> k2 -> ChordMatch
+(.+) = ChordMatch
+
+instance KeyMatch ChordMatch where
+  matches (ChordMatch a b) ev = do
+    ma <- matches a ev
+    mb <- matches b ev
+    return (ma && mb)
+
+-- | Installs the bindings into a config as the starting key hook.
+withBindings :: [Binding] -> Config Montis -> Config Montis
+withBindings bs =
+  install
+    ( KeysConfig
+        ( \ev ->
+            anyM
+              ( \(Bind k a) -> do
+                  m <- matches k ev
+                  if m then run a >> return True else return False
+              )
+              bs
+        )
+    )