[feat] Add Keys.hs, which provides a basic framework for adding keybindings.

4 files changed, 175 insertions, 26 deletions

diff --git a/plug/src/Config.hs b/plug/src/Config.hs
index 5cf616f..7314604 100644
--- a/plug/src/Config.hs
+++ b/plug/src/Config.hs
@@ -1,6 +1,7 @@
 module Config () where
 
 import Control.Monad.IO.Class (liftIO)
+import Data.Bits (shiftL, (.&.))
 import Data.Maybe (fromMaybe)
 import Data.Typeable (Typeable)
 import Data.Void (Void)
@@ -12,6 +13,7 @@ import Foreign.Ptr (nullPtr)
 import Foreign.Storable (peek)
 import Montis.Base.Foreign.Runtime
 import Montis.Core
+import Montis.Standard.Keys (KeysConfig (KeysConfig), subkeys)
 
 foreign export ccall "plugin_cold_start"
   coldStart :: MontisColdStart
@@ -25,15 +27,32 @@ coldStart = coldStartMontis config
 hotStart :: MontisHotStart
 hotStart = hotStartMontis config
 
+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!")
+            return True
+          _ -> return False
+      _ -> return False
+
+mod1Mask :: Word32
+mod1Mask = 1 `shiftL` 3 -- WLR_MODIFIER_ALT
+
 config :: MontisConfig
 config =
-  defaultConfig
-    { startingHooks =
-        (startingHooks defaultConfig)
-          { buttonHook = onButton,
-            motionHook = onMotion
-          }
-    }
+  install (KeysConfig keys) $
+    defaultConfig
+      { startingHooks =
+          (startingHooks defaultConfig)
+            { buttonHook = onButton,
+              motionHook = onMotion
+            }
+      }
 
 data DragState = DragState
   { dragToplevel :: Ptr ForeignMontisToplevel,
@@ -66,7 +85,7 @@ onButton ev
   | buttonEvent_button ev /= leftButton = return ()
   | buttonEvent_state ev == ButtonPressed = do
       self <- getSelfPtr
-      CursorPosition (x, y) <- fromMaybe (CursorPosition (0, 0)) <$> xStateGet
+      CursorPosition (x, y) <- xStateGet
       newDrag <- liftIO $ do
         tl <- foreign_toplevelAt (unwrapSelf self) (realToFrac x) (realToFrac y)
         if tl == nullPtr
@@ -85,7 +104,7 @@ onMotion :: MotionEvent -> Montis ()
 onMotion ev = do
   let (x, y) = motionEvent_absolute ev
   xStatePut (CursorPosition (x, y))
-  Dragging mdrag <- fromMaybe (Dragging Nothing) <$> xStateGet
+  Dragging mdrag <- xStateGet
   case mdrag of
     Nothing -> return ()
     Just (DragState tl dx dy) -> do
diff --git a/plug/src/Montis/Core/Monad.hs b/plug/src/Montis/Core/Monad.hs
index 4d5ac3b..b7d1633 100644
--- a/plug/src/Montis/Core/Monad.hs
+++ b/plug/src/Montis/Core/Monad.hs
@@ -62,10 +62,10 @@ defaultConfig =
   Config
     { startingHooks =
         Hooks
-          { keyHook = liftIO . print,
-            surfaceHook = liftIO . print,
-            buttonHook = liftIO . print,
-            motionHook = liftIO . print
+          { keyHook = const (return ()),
+            surfaceHook = const (return ()),
+            buttonHook = const (return ()),
+            motionHook = const (return ())
           },
       -- Default hooks are no-ops except for basic printing, which makes the
       -- system usable without extra wiring during development.
@@ -93,15 +93,26 @@ xStatePut xst = do
 -- | Retrieve a typed extension, demarshalling it if needed and caching it back.
 --   When the extension is stored in marshalled form, it is decoded and then
 --   reinserted so future lookups are fast.
-xStateGet :: forall a. (StateExtension a) => Montis (Maybe a)
+xStateGet :: forall a. (StateExtension a) => Montis a
 xStateGet = do
   mp <- gets extensibleState
   case lookupByType (Proxy :: Proxy a) mp of
-    Nothing -> return Nothing
-    Just (Right (Extension v)) -> return (cast v)
+    Nothing -> return initialValue
+    Just (Right (Extension v)) -> return $ fromMaybe initialValue (cast v)
     Just (Left s) -> do
       let x = (demarshalExtension s :: Maybe a)
-       in forM_ x xStatePut >> return x
+       in forM_ x xStatePut >> return (fromMaybe initialValue x)
+
+-- | Modifies the typed extension bi the given function.
+xStateModify :: forall a. (StateExtension a) => (a -> a) -> Montis ()
+xStateModify fn = do
+  s <- xStateGet
+  (xStatePut . fn) s
+
+xStateModifyM :: forall a. (StateExtension a) => (a -> Montis a) -> Montis ()
+xStateModifyM fn = do
+  s <- xStateGet
+  xStatePut =<< fn s
 
 -- | Retrieve a typed configuration extension or return the default
 --   instance if the extension had not been configured.
diff --git a/plug/src/Montis/Core/State.hs b/plug/src/Montis/Core/State.hs
index 5a35e88..ce8f903 100644
--- a/plug/src/Montis/Core/State.hs
+++ b/plug/src/Montis/Core/State.hs
@@ -48,16 +48,21 @@ data Hooks m where
     } ->
     Hooks m
 
+-- | Class for a configurable model.
+class (Typeable a) => ConfigModule m a where
+  alterConfig :: a -> Config m -> Config m
+
 -- | Configures a typed configuration extension.
-configure :: forall a m. (Typeable a) => a -> Config m -> Config m
-configure a c =
-  c
-    { configExtensions =
-        M.insert
-          (typeRepr (Proxy :: Proxy a))
-          (Extension a)
-          (configExtensions c)
-    }
+install :: forall a m. (ConfigModule m a) => a -> Config m -> Config m
+install a c =
+  alterConfig a $
+    c
+      { configExtensions =
+          M.insert
+            (typeRepr (Proxy :: Proxy a))
+            (Extension a)
+            (configExtensions c)
+      }
 
 -- | Typeclass defining the set of types which can be used as state extensions
 -- to the W monad. These state extensions may be persistent or not.
diff --git a/plug/src/Montis/Standard/Keys.hs b/plug/src/Montis/Standard/Keys.hs
new file mode 100644
index 0000000..24f232b
--- /dev/null
+++ b/plug/src/Montis/Standard/Keys.hs
@@ -0,0 +1,114 @@
+module Montis.Standard.Keys where
+
+import Control.Monad (when)
+import Control.Monad.IO.Class (liftIO)
+import Data.Data (Typeable)
+import Data.Default.Class (Default (..))
+import Data.Set qualified as Set
+import Data.Word (Word32)
+import Foreign.Ptr (Ptr, castPtr, nullPtr)
+import Montis.Base.Foreign.Runtime (foreign_getSeat)
+import Montis.Base.Foreign.WlRoots (seatKeyboardNotifyKey)
+import Montis.Base.Foreign.WlRoots.Types (ForeignWlrSeat, WlrSeat (WlrSeat))
+import Montis.Core.Events (KeyEvent (..), KeyState (..))
+import Montis.Core.Monad (Montis, getSelfPtr, xConfigGet, xStateGet, xStateModify)
+import Montis.Core.State
+  ( Config (startingHooks),
+    ConfigModule (..),
+    Hooks (keyHook),
+    SelfPtr (..),
+    StateExtension (..),
+  )
+
+-- | Configuration for the keybindings.
+data KeysConfig where
+  KeysConfig ::
+    { startCont :: KeyEvent -> Montis Bool
+    } ->
+    KeysConfig
+  deriving (Typeable)
+
+instance Default KeysConfig where
+  def = KeysConfig $ \_ -> return False
+
+subkeys :: (KeyEvent -> Montis Bool) -> Montis Bool
+subkeys fn = do
+  xStateModify $ \keyState ->
+    keyState
+      { awaiting = Just fn
+      }
+  return True
+
+-- | State of the keys right now.
+data KeysState where
+  KeysState ::
+    { awaiting :: Maybe (KeyEvent -> Montis Bool),
+      ignoredKeys :: Set.Set Word32
+    } ->
+    KeysState
+
+instance StateExtension KeysState where
+  initialValue = KeysState Nothing Set.empty
+  marshalExtension = const Nothing
+  demarshalExtension = const Nothing
+
+-- | Configurable module for keys.
+instance ConfigModule Montis KeysConfig where
+  alterConfig _ c =
+    let oh = keyHook (startingHooks c)
+     in c
+          { startingHooks =
+              (startingHooks c)
+                { keyHook = \ev -> runEv ev >> oh ev
+                }
+          }
+    where
+      isKeyPress ev = keyEvent_state ev == KeyPressed
+      isKeyRelease ev = keyEvent_state ev == KeyReleased
+      shouldIgnoreEvent ev = do
+        KeysState {ignoredKeys} <- xStateGet
+        return $ Set.member (keyEvent_keycode ev) ignoredKeys
+      runEv ev = do
+        shouldIgnore <- shouldIgnoreEvent ev
+        if isKeyRelease ev && shouldIgnore
+          then xStateModify $ \ks ->
+            ks {ignoredKeys = Set.delete (keyEvent_keycode ev) (ignoredKeys ks)}
+          else do
+            handled <-
+              if isKeyPress ev
+                then do
+                  handler' <- awaiting <$> xStateGet
+                  handler <- maybe (startCont <$> xConfigGet) return handler'
+                  -- Reset the hadler.
+                  xStateModify $ \st ->
+                    st {awaiting = Nothing}
+                  handler ev
+                else return False
+
+            if not handled
+              then do
+                self <- getSelfPtr
+                liftIO $ forwardKeyToSeat self ev
+              else when (isKeyPress ev) $
+                xStateModify $
+                  \ks ->
+                    ks
+                      { ignoredKeys =
+                          Set.insert (keyEvent_keycode ev) (ignoredKeys ks)
+                      }
+
+forwardKeyToSeat :: SelfPtr -> KeyEvent -> IO ()
+forwardKeyToSeat (SelfPtr ctx) ev = do
+  seatPtr <- foreign_getSeat ctx
+  if seatPtr == nullPtr
+    then return ()
+    else
+      seatKeyboardNotifyKey
+        (WlrSeat (castPtr seatPtr :: Ptr ForeignWlrSeat))
+        (keyEvent_timeMs ev)
+        (keyEvent_keycode ev)
+        (keyStateToWord32 (keyEvent_state ev))
+
+keyStateToWord32 :: KeyState -> Word32
+keyStateToWord32 KeyReleased = 0
+keyStateToWord32 KeyPressed = 1