[refactor] Wetterhorn -> Montis

3 files changed, 643 insertions, 0 deletions

diff --git a/plug/src/Montis/Dsl/Bind.hs b/plug/src/Montis/Dsl/Bind.hs
new file mode 100644
index 0000000..c7dbc43
--- /dev/null
+++ b/plug/src/Montis/Dsl/Bind.hs
@@ -0,0 +1,128 @@
+-- | eDSL for the 'bind' function. The 'bind' function provides an easy way to
+-- bind certain actions to other actions.
+module Montis.Dsl.Bind
+  ( bind,
+    (.+),
+    MatchEvent (..),
+    Modifier (..),
+    released,
+    weak,
+    run,
+    modifierToMask,
+    module X,
+  )
+where
+
+import Control.Monad
+import Control.Monad.Trans
+import Data.Bits
+import Data.Word
+import Montis.Core.ButtonEvent (ButtonEvent(..))
+import qualified Montis.Core.ButtonEvent as ButtonEvent
+import Montis.Core.KeyEvent (KeyEvent(..))
+import qualified Montis.Core.KeyEvent as KeyEvent
+import Montis.Core.W
+import Montis.Dsl.Buttons as X
+import Montis.Dsl.Input
+
+class MatchEvent m where
+  matches :: m -> InputEvent -> W Bool
+
+instance MatchEvent (InputEvent -> W Bool) where
+  matches = ($)
+
+instance MatchEvent Char where
+  matches ch (InputKeyEvent ke) = return $ KeyEvent.codepoint ke == ch
+  matches _ _ = return False
+
+instance MatchEvent Button where
+  matches (Button b) (InputButtonEvent be) =
+    return $ ButtonEvent.button be == b
+  matches _ _ = return False
+
+-- | Enumeration of possible modifiers.
+--
+-- ModX can be used for extra user-defined modifiers which are not standard xkb
+-- modifiers.
+data Modifier
+  = Shift
+  | Lock
+  | Control
+  | Mod1
+  | Mod2
+  | Mod3
+  | Mod4
+  | Mod5
+  | ModX Int
+  deriving (Eq, Ord, Show, Read)
+
+-- | Converts a modifier to its associated mask.
+modifierToMask :: Modifier -> Word32
+modifierToMask m =
+  1
+    `shiftL` case m of
+      Shift -> 0
+      Lock -> 1
+      Control -> 2
+      Mod1 -> 3
+      Mod2 -> 4
+      Mod3 -> 5
+      Mod4 -> 6
+      Mod5 -> 7
+      ModX b -> b + 8
+
+released :: (MatchEvent m) => m -> InputEvent -> W Bool
+released me ev | not (isPressEvent ev) = matches me ev
+released _ _ = return False
+
+data MatchModifiers = MatchModifiers
+  { weakModifierMatch :: Bool,
+    modifierMask :: Word32,
+    baseMatch :: InputEvent -> W Bool
+  }
+
+instance MatchEvent MatchModifiers where
+  matches (MatchModifiers weak bits base) ev = do
+    mods <- getMods ev
+    b <- liftW $ base ev
+
+    return $
+      b
+        && ( (not weak && mods == bits)
+               || (weak && (bits .&. mods == bits))
+           )
+    where
+      getMods (InputButtonEvent (ButtonEvent {ButtonEvent.modifiers = mods})) = return mods
+      getMods (InputKeyEvent (KeyEvent {KeyEvent.modifiers = mods})) = return mods
+      getMods _ = getModifierState
+
+class LiftMatchModifiers a where
+  toModifiers :: a -> MatchModifiers
+  default toModifiers :: (MatchEvent a) => a -> MatchModifiers
+  toModifiers = MatchModifiers False 0 . matches
+
+instance LiftMatchModifiers MatchModifiers where
+  toModifiers = id
+
+instance LiftMatchModifiers Char
+
+instance LiftMatchModifiers Button
+
+-- toModifiers ch = MatchModifiers False 0 (matches ch)
+
+(.+) :: (LiftMatchModifiers mods) => Modifier -> mods -> MatchModifiers
+(.+) modifier (toModifiers -> (MatchModifiers b mask base)) =
+  MatchModifiers b (mask .|. modifierToMask modifier) base
+
+infixr 9 .+
+
+bind :: (MatchEvent match) => InputEvent -> match -> InputM spy () -> InputM spy ()
+bind ev match action = do
+  matches' <- liftW $ matches match ev
+  when matches' (action >> continue)
+
+weak :: MatchModifiers -> MatchModifiers
+weak m = m {weakModifierMatch = True}
+
+run :: W () -> InputM spy ()
+run = liftW
diff --git a/plug/src/Montis/Dsl/Buttons.hsc b/plug/src/Montis/Dsl/Buttons.hsc
new file mode 100644
index 0000000..963d5ce
--- /dev/null
+++ b/plug/src/Montis/Dsl/Buttons.hsc
@@ -0,0 +1,229 @@
+module Montis.Dsl.Buttons where
+
+import Data.Word
+
+#include </usr/include/linux/input-event-codes.h>
+
+data Button = Button Word32
+
+btnMisc :: Button
+btnMisc = Button #const BTN_MISC
+
+btn0 :: Button
+btn0 = Button #const BTN_0
+
+btn1 :: Button
+btn1 = Button #const BTN_1
+
+btn2 :: Button
+btn2 = Button #const BTN_2
+
+btn3 :: Button
+btn3 = Button #const BTN_3
+
+btn4 :: Button
+btn4 = Button #const BTN_4
+
+btn5 :: Button
+btn5 = Button #const BTN_5
+
+btn6 :: Button
+btn6 = Button #const BTN_6
+
+btn7 :: Button
+btn7 = Button #const BTN_7
+
+btn8 :: Button
+btn8 = Button #const BTN_8
+
+btn9 :: Button
+btn9 = Button #const BTN_9
+
+btnMouse :: Button
+btnMouse = Button #const BTN_MOUSE
+
+btnLeft :: Button
+btnLeft = Button #const BTN_LEFT
+
+btnRight :: Button
+btnRight = Button #const BTN_RIGHT
+
+btnMiddle :: Button
+btnMiddle = Button #const BTN_MIDDLE
+
+btnSide :: Button
+btnSide = Button #const BTN_SIDE
+
+btnExtra :: Button
+btnExtra = Button #const BTN_EXTRA
+
+btnForward :: Button
+btnForward = Button #const BTN_FORWARD
+
+btnBack :: Button
+btnBack = Button #const BTN_BACK
+
+btnTask :: Button
+btnTask = Button #const BTN_TASK
+
+btnJoystick :: Button
+btnJoystick = Button #const BTN_JOYSTICK
+
+btnTrigger :: Button
+btnTrigger = Button #const BTN_TRIGGER
+
+btnThumb :: Button
+btnThumb = Button #const BTN_THUMB
+
+btnThumb2 :: Button
+btnThumb2 = Button #const BTN_THUMB2
+
+btnTop :: Button
+btnTop = Button #const BTN_TOP
+
+btnTop2 :: Button
+btnTop2 = Button #const BTN_TOP2
+
+btnPinkie :: Button
+btnPinkie = Button #const BTN_PINKIE
+
+btnBase :: Button
+btnBase = Button #const BTN_BASE
+
+btnBase2 :: Button
+btnBase2 = Button #const BTN_BASE2
+
+btnBase3 :: Button
+btnBase3 = Button #const BTN_BASE3
+
+btnBase4 :: Button
+btnBase4 = Button #const BTN_BASE4
+
+btnBase5 :: Button
+btnBase5 = Button #const BTN_BASE5
+
+btnBase6 :: Button
+btnBase6 = Button #const BTN_BASE6
+
+btnDead :: Button
+btnDead = Button #const BTN_DEAD
+
+btnGamepad :: Button
+btnGamepad = Button #const BTN_GAMEPAD
+
+btnSouth :: Button
+btnSouth = Button #const BTN_SOUTH
+
+btnA :: Button
+btnA = Button #const BTN_A
+
+btnEast :: Button
+btnEast = Button #const BTN_EAST
+
+btnB :: Button
+btnB = Button #const BTN_B
+
+btnC :: Button
+btnC = Button #const BTN_C
+
+btnNorth :: Button
+btnNorth = Button #const BTN_NORTH
+
+btnX :: Button
+btnX = Button #const BTN_X
+
+btnWest :: Button
+btnWest = Button #const BTN_WEST
+
+btnY :: Button
+btnY = Button #const BTN_Y
+
+btnZ :: Button
+btnZ = Button #const BTN_Z
+
+btnTl :: Button
+btnTl = Button #const BTN_TL
+
+btnTr :: Button
+btnTr = Button #const BTN_TR
+
+btnTl2 :: Button
+btnTl2 = Button #const BTN_TL2
+
+btnTr2 :: Button
+btnTr2 = Button #const BTN_TR2
+
+btnSelect :: Button
+btnSelect = Button #const BTN_SELECT
+
+btnStart :: Button
+btnStart = Button #const BTN_START
+
+btnMode :: Button
+btnMode = Button #const BTN_MODE
+
+btnThumbl :: Button
+btnThumbl = Button #const BTN_THUMBL
+
+btnThumbr :: Button
+btnThumbr = Button #const BTN_THUMBR
+
+btnDigi :: Button
+btnDigi = Button #const BTN_DIGI
+
+btnToolPen :: Button
+btnToolPen = Button #const BTN_TOOL_PEN
+
+btnToolRubber :: Button
+btnToolRubber = Button #const BTN_TOOL_RUBBER
+
+btnToolBrush :: Button
+btnToolBrush = Button #const BTN_TOOL_BRUSH
+
+btnToolPencil :: Button
+btnToolPencil = Button #const BTN_TOOL_PENCIL
+
+btnToolAirbrush :: Button
+btnToolAirbrush = Button #const BTN_TOOL_AIRBRUSH
+
+btnToolFinger :: Button
+btnToolFinger = Button #const BTN_TOOL_FINGER
+
+btnToolMouse :: Button
+btnToolMouse = Button #const BTN_TOOL_MOUSE
+
+btnToolLens :: Button
+btnToolLens = Button #const BTN_TOOL_LENS
+
+btnToolQuinttap :: Button
+btnToolQuinttap = Button #const BTN_TOOL_QUINTTAP
+
+btnStylus3 :: Button
+btnStylus3 = Button #const BTN_STYLUS3
+
+btnTouch :: Button
+btnTouch = Button #const BTN_TOUCH
+
+btnStylus :: Button
+btnStylus = Button #const BTN_STYLUS
+
+btnStylus2 :: Button
+btnStylus2 = Button #const BTN_STYLUS2
+
+btnToolDoubletap :: Button
+btnToolDoubletap = Button #const BTN_TOOL_DOUBLETAP
+
+btnToolTripletap :: Button
+btnToolTripletap = Button #const BTN_TOOL_TRIPLETAP
+
+btnToolQuadtap :: Button
+btnToolQuadtap = Button #const BTN_TOOL_QUADTAP
+
+btnWheel :: Button
+btnWheel = Button #const BTN_WHEEL
+
+btnGearDown :: Button
+btnGearDown = Button #const BTN_GEAR_DOWN
+
+btnGearUp :: Button
+btnGearUp = Button #const BTN_GEAR_UP
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)
+                  }
+            }