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

3 files changed, 147 insertions, 17 deletions

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