[refactor] Wetterhorn -> Montis

1 files changed, 286 insertions, 0 deletions

diff --git a/plug/src/Montis/Dsl/Input.hs b/plug/src/Montis/Dsl/Input.hs
new file mode 100644
index 0000000..4855951
--- /dev/null
+++ b/plug/src/Montis/Dsl/Input.hs
@@ -0,0 +1,286 @@
+{-# LANGUAGE DataKinds #-}
+
+module Montis.Dsl.Input
+  ( InputM,
+    InputEvent (..),
+    InputProxy (..),
+    NoProxy,
+    withProxies,
+    forwardEvent,
+    forwardKey,
+    whenKeyEvent,
+    whenButtonEvent,
+    useInputHandler,
+    unwrap,
+    filterEvent,
+    isPressEvent,
+    nextInputEventThat,
+    replayEvents,
+    isKeyEvent,
+    nextInputPressEvent,
+    continue,
+    nextInputEvent,
+    getModifierState,
+  )
+where
+
+import Control.Concurrent (threadDelay)
+import Control.Monad
+import Control.Monad.Cont (MonadCont)
+import Control.Monad.Loops (andM)
+import Control.Monad.RWS
+  ( MonadIO (liftIO),
+    MonadReader (ask),
+    MonadState (get),
+    MonadTrans (lift),
+    RWST,
+    execRWST,
+    gets,
+    modify,
+  )
+import Control.Monad.Trans.Cont
+import Control.Monad.Trans.Maybe (MaybeT (runMaybeT))
+import Data.IORef (newIORef, readIORef, writeIORef)
+import Data.Proxy
+import Data.Word (Word32)
+import qualified Montis.Core.ButtonEvent as ButtonEvent
+import qualified Montis.Core.KeyEvent as KeyEvent
+import Montis.Core.W (W (..))
+import qualified Montis.Core.W as W
+import Montis.Foreign.WlRoots (guardNull, wlrKeyboardGetModifiers, wlrSeatGetKeyboard, wlrSeatKeyboardNotifyKey, wlrSeatSetKeyboard)
+
+class InputProxy (spy :: k) where
+  onKeyEvent :: Proxy spy -> InputEvent -> MaybeT W InputEvent
+
+instance (InputProxy h, InputProxy t) => InputProxy (h ': t) where
+  onKeyEvent _ = onKeyEvent (Proxy :: Proxy h) <=< onKeyEvent (Proxy :: Proxy t)
+
+instance InputProxy '[] where
+  onKeyEvent _ = return
+
+data NoProxy
+
+instance InputProxy NoProxy where
+  onKeyEvent _ = return
+
+instance (InputProxy s1, InputProxy s2) => InputProxy (s1, s2) where
+  onKeyEvent proxy = onKeyEvent (fmap fst proxy) <=< onKeyEvent (fmap snd proxy)
+
+-- | Union of event types.
+data InputEvent
+  = InputButtonEvent ButtonEvent.ButtonEvent
+  | InputKeyEvent KeyEvent.KeyEvent
+
+-- | Context for the input.
+newtype InputContext spy = InputContext
+  { -- | Top of the input routine. Used in "continue" statement.
+    inputTop :: InputM spy ()
+  }
+
+newtype InputState spy = InputState
+  { inputSource :: InputM spy InputEvent
+  }
+
+-- | Input monad for handling all kinds of input.
+newtype InputM spy a = InputM (ContT () (RWST (InputContext spy) () (InputState spy) W) a)
+  deriving (Monad, Functor, Applicative, MonadCont, MonadIO)
+
+instance MonadFail (InputM spy) where
+  fail _ = continue
+
+-- | Lifts a W action to an InputM action.
+instance W.Wlike (InputM spy) where
+  liftW = InputM . lift . lift
+
+-- | Resets the input handler to the top.
+continue :: InputM spy a
+continue = do
+  (InputContext {inputTop = (InputM top)}) <- InputM ask
+  InputM $ shiftT (\_ -> resetT top)
+
+-- | Forwards the given key event to the focused window.
+forwardKey :: KeyEvent.KeyEvent -> W ()
+forwardKey keyEvent = do
+  seatPtr <- W.getSeat
+  W.wio $ do
+    wlrSeatSetKeyboard
+      seatPtr
+      (KeyEvent.device keyEvent)
+
+    wlrSeatKeyboardNotifyKey
+      seatPtr
+      (KeyEvent.timeMs keyEvent)
+      (KeyEvent.keycode keyEvent)
+      ( case KeyEvent.state keyEvent of
+          KeyEvent.KeyReleased -> 0
+          _ -> 1
+      )
+
+-- | Executes a function if the input event is a key event. If it is not a key
+-- event, then nothing happens.
+whenKeyEvent :: (Monad m) => InputEvent -> (KeyEvent.KeyEvent -> m ()) -> m ()
+whenKeyEvent (InputKeyEvent ke) = ($ ke)
+whenKeyEvent _ = const (return ())
+
+-- | Executes a function in the input event is a button event. If it is not a
+-- button event, then nothing happens.
+whenButtonEvent ::
+  (Monad m) => InputEvent -> (ButtonEvent.ButtonEvent -> m ()) -> m ()
+whenButtonEvent (InputButtonEvent be) = ($ be)
+whenButtonEvent _ = const (return ())
+
+-- | Forwards the given input event to focused window.
+forwardEvent :: (W.Wlike m) => InputEvent -> m ()
+forwardEvent = \case
+  InputKeyEvent kv -> W.liftW $ forwardKey kv
+  InputButtonEvent _ -> return ()
+
+-- | "Unwraps" a maybe. If the maybe is present, the handler proceeds. If the
+-- maybe is not present, the handler restarts execution from the top.
+unwrap :: Maybe a -> InputM spy a
+unwrap (Just val) = return val
+unwrap Nothing = continue
+
+-- | Runs the series of events from the top as if they were input.
+replayEvents :: [InputEvent] -> InputM spy ()
+replayEvents events = do
+  ioref <- liftIO (newIORef events)
+
+  (InputM oldInput) <- InputM $ gets inputSource
+
+  let newInput =
+        InputM $
+          shiftT
+            ( \thingToDo -> do
+                r <- liftIO (readIORef ioref)
+                case r of
+                  [] -> do
+                    modify $ \st -> st {inputSource = InputM oldInput}
+                    a <- oldInput
+                    lift (thingToDo a)
+                  (a : as) -> do
+                    liftIO (writeIORef ioref as)
+                    lift (thingToDo a)
+            )
+
+  InputM $ modify $ \st -> st {inputSource = newInput}
+  where
+    delay to act = liftIO (threadDelay to) >> act
+
+-- | Call in the reset handler with the InputM handler you wolud like to use.
+useInputHandler :: (InputProxy spy) => InputM spy () -> W ()
+useInputHandler (forever -> top@(InputM ctop)) = do
+  void $ execRWST (runContT ctop return) (InputContext top) (InputState useSeatEvents)
+
+-- | Returns the next input event that's either a kep press or a button press.
+nextInputPressEvent :: InputM spy InputEvent
+nextInputPressEvent = nextInputEventThat (andM [isPressEvent, not . modifierKey])
+
+modifierKey :: InputEvent -> Bool
+modifierKey (InputKeyEvent (KeyEvent.KeyEvent {codepoint = '\NUL'})) = True
+modifierKey _ = False
+
+nextInputEventThat :: (InputEvent -> Bool) -> InputM spy InputEvent
+nextInputEventThat fn =
+  nextInputEvent
+    >>= ( \ie ->
+            if fn ie
+              then return ie
+              else forwardEvent ie >> nextInputEventThat fn
+        )
+
+isKeyEvent :: InputEvent -> Bool
+isKeyEvent (InputKeyEvent _) = True
+isKeyEvent _ = False
+
+isPressEvent :: InputEvent -> Bool
+isPressEvent (InputButtonEvent be)
+  | ButtonEvent.state be == ButtonEvent.ButtonPressed =
+    True
+isPressEvent (InputKeyEvent ke)
+  | KeyEvent.state ke == KeyEvent.KeyPressed =
+    True
+isPressEvent _ = False
+
+-- | Returns the event only if it matches the filter. If it does not match the
+-- filter, execution resets to the top.
+filterEvent :: (InputEvent -> Bool) -> InputEvent -> InputM spy InputEvent
+filterEvent fn ev | fn ev = return ev
+filterEvent _ _ = continue
+
+getModifierState :: W Word32
+getModifierState = do
+  seat <- W.getSeat
+  keyboard <- W.wio $ wlrSeatGetKeyboard seat
+  maybe (return 0) (W.wio . wlrKeyboardGetModifiers) (guardNull keyboard)
+
+nextInputEvent :: InputM spy InputEvent
+nextInputEvent = join $ InputM $ gets inputSource
+
+withProxies :: Proxy spy -> InputM spy a -> InputM spy a
+withProxies _ = id
+
+-- | Gets the next input event.
+useSeatEvents :: forall spy. (InputProxy spy) => InputM spy InputEvent
+useSeatEvents =
+  InputM $
+    shiftT
+      ( \thingToDo -> do
+          putButtonHandler $ \be -> do
+            runSpies thingToDo (InputButtonEvent be)
+
+          putKeyHandler $ \ke -> do
+            runSpies thingToDo (InputKeyEvent ke)
+      )
+  where
+    runSpies fn ev = do
+      evM <- lift $ runMaybeT (onKeyEvent (Proxy :: Proxy spy) ev)
+      mapM_
+        ( \ev' -> do
+            clearButtonHandler
+            clearKeyHandler
+            fn ev'
+        )
+        evM
+
+    clearButtonHandler =
+      lift $
+        modify $ \st ->
+          st
+            { W.currentHooks =
+                (W.currentHooks st)
+                  { W.buttonHook = const (return ())
+                  }
+            }
+
+    clearKeyHandler =
+      lift $
+        modify $ \st ->
+          st
+            { W.currentHooks =
+                (W.currentHooks st)
+                  { W.keyHook = const (return ())
+                  }
+            }
+
+    putButtonHandler h = lift $ do
+      (r, s) <- (,) <$> ask <*> get
+      lift $
+        modify $ \st ->
+          st
+            { W.currentHooks =
+                (W.currentHooks st)
+                  { W.buttonHook = \be -> void (execRWST (h be) r s)
+                  }
+            }
+
+    putKeyHandler h = lift $ do
+      (r, s) <- (,) <$> ask <*> get
+      lift $
+        modify $ \st ->
+          st
+            { W.currentHooks =
+                (W.currentHooks st)
+                  { W.keyHook = \ke -> void (execRWST (h ke) r s)
+                  }
+            }