Implement more stuff. Add DSL for binding to the new input handler.

6 files changed, 442 insertions, 51 deletions

diff --git a/package.yaml b/package.yaml
index 48f839a..cd8023b 100644
--- a/package.yaml
+++ b/package.yaml
@@ -58,6 +58,7 @@ ghc-options:
 - -XViewPatterns
 - -XDerivingVia
 - -XDisambiguateRecordFields
+- -XLambdaCase
 - -fPIC
 
 executables:
diff --git a/src/Config.hs b/src/Config.hs
index 5f09cbe..dab514b 100644
--- a/src/Config.hs
+++ b/src/Config.hs
@@ -1,13 +1,14 @@
 module Config (config) where
 
-import Text.Printf
 import Control.Monad.IO.Class
 import Control.Monad.Loops
-import Wetterhorn.Core.KeyEvent qualified as KeyEvent
-import Wetterhorn.Core.Keys
+import Text.Printf
 import Wetterhorn.Core.W
+import Wetterhorn.Dsl.Bind
+import Wetterhorn.Dsl.Input
 import Wetterhorn.Keys.Macros
 import Wetterhorn.Layout.Full
+import Control.Monad (unless)
 
 config :: Config WindowLayout
 config =
@@ -19,42 +20,28 @@ config =
           },
       layout = WindowLayout Full,
       resetHook = do
-        useKeysWithContinuation recordMacroContinuation $ do
-          ev <- nextButtonOrKeyPress
-
-          case ev of
-            Right kp -> do
-              bind kp (Mod1 .+ 'q') macroKeyBind
-
-              bind kp (weak $ Mod1 .+ '@') replayMacroKeybind
+        useInputHandler $ do
+          ev <- nextInputEvent
 
-              bind kp (Mod1 .+ 'r') (shellExec "wofi --show run")
+          bind ev (released btnLeft) $ do
+            wio $ putStrLn "Left Button Released!!"
 
-              bind kp (Shift .+ Mod1 .+ 'R') requestHotReload
+          unless (isPressEvent ev) $ do
+            forwardEvent ev
+            continue
 
-              bind kp (Mod1 .+ 't') (shellExec "alacritty")
+          bind ev (Shift .+ Mod1 .+ 'R') requestHotReload
 
-              bind kp (Mod1 .+ 'n') (return () :: W ())
+          bind ev (Mod1 .+ 't') (shellExec "alacritty")
 
-              bind kp (weak $ Mod1 .+ '∫') (shellExec "gxmessage hi")
+          bind ev (Mod1 .+ 'p') $ do
+            ev2 <- nextInputPressEvent
 
-              bind kp (Mod1 .+ 'p') $ do
-                str <-
-                  unfoldM
-                    ( do
-                        ke <- nextKeyPress
-                        return $
-                          if KeyEvent.codepoint ke == '\r'
-                            then Nothing
-                            else Just (KeyEvent.codepoint ke)
-                    )
-                liftIO $ putStrLn $ "You input: " ++ str
-                bind kp (str == "hello") $ do
-                  wio $ putStrLn "You Win! *\\o/*"
-                liftIO $ putStrLn "You lose :("
+            bind ev2 (Mod1 .+ 'p') $ do
+              wio $ putStrLn "Test"
 
-              forwardEvent kp
+          bind ev (Mod1 .+ btnLeft) $ do
+            wio $ putStrLn "Left Button Press!!"
 
-            Left but ->
-              liftIO $ putStrLn $ "ButtonEvent! " ++ (show but)
+          forwardEvent ev
     }
diff --git a/src/Wetterhorn/Dsl/Bind.hs b/src/Wetterhorn/Dsl/Bind.hs
new file mode 100644
index 0000000..7bdb9de
--- /dev/null
+++ b/src/Wetterhorn/Dsl/Bind.hs
@@ -0,0 +1,129 @@
+-- | eDSL for the 'bind' function. The 'bind' function provides an easy way to
+-- bind certain actions to other actions.
+module Wetterhorn.Dsl.Bind
+  ( bind,
+    (.+),
+    MatchEvent (..),
+    Modifier (..),
+    released,
+    weak,
+    spy,
+    module X,
+  )
+where
+
+import Control.Monad
+import Control.Monad.Trans
+import Data.Bits
+import Data.Word
+import qualified Wetterhorn.Core.ButtonEvent as ButtonEvent
+import qualified Wetterhorn.Core.KeyEvent as KeyEvent
+import Wetterhorn.Core.W
+import Wetterhorn.Dsl.Buttons as X
+import Wetterhorn.Dsl.Input
+
+class MatchEvent m where
+  matches :: m -> InputEvent -> InputM Bool
+
+instance MatchEvent (InputEvent -> InputM 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
+
+class InputAction m where
+  doAction :: m -> InputM ()
+
+instance (a ~ ()) => InputAction (W a) where
+  doAction = liftW
+
+instance (a ~ ()) => InputAction (InputM a) where
+  doAction = id
+
+-- | Enumeration of possible modifiers
+data Modifier = Shift | Lock | Control | Mod1 | Mod2 | Mod3 | Mod4 | Mod5
+  deriving (Eq, Ord, Show, Read, Enum, Bounded)
+
+-- | 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
+
+released :: (MatchEvent m) => m -> InputEvent -> InputM Bool
+released me ev | not (isPressEvent ev) = matches me ev
+released _ _ = return False
+
+data MatchModifiers = MatchModifiers
+  { weakModifierMatch :: Bool,
+    modifierMask :: Word32,
+    baseMatch :: InputEvent -> InputM Bool
+  }
+
+instance MatchEvent MatchModifiers where
+  matches (MatchModifiers weak bits base) ev@(InputKeyEvent ke) = do
+    b <- base ev
+
+    return $
+      b
+        && ( (not weak && KeyEvent.modifiers ke == bits)
+               || (weak && (bits .&. KeyEvent.modifiers ke == bits))
+           )
+  matches (MatchModifiers weak bits base) ev = do
+    mods <- liftW getModifierState
+    b <- base ev
+
+    return $
+      b
+        && ( (not weak && mods == bits)
+               || (weak && (bits .&. mods == bits))
+           )
+
+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 .+
+
+-- | Like 'bind', but does not restart consume the event and start from the top,
+-- rather it continues the operation as normal.
+spy :: (MatchEvent match, InputAction action) => InputEvent -> match -> action -> InputM ()
+spy ev match action = do
+  matches' <- matches match ev
+  when matches' (doAction action)
+
+bind :: (MatchEvent match, InputAction action) => InputEvent -> match -> action -> InputM ()
+bind ev match action = do
+  matches' <- matches match ev
+  when matches' (doAction action >> continue)
+
+weak :: MatchModifiers -> MatchModifiers
+weak m = m {weakModifierMatch = True}
diff --git a/src/Wetterhorn/Dsl/Buttons.hsc b/src/Wetterhorn/Dsl/Buttons.hsc
new file mode 100644
index 0000000..c3e049c
--- /dev/null
+++ b/src/Wetterhorn/Dsl/Buttons.hsc
@@ -0,0 +1,229 @@
+module Wetterhorn.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/src/Wetterhorn/Core/Input.hs b/src/Wetterhorn/Dsl/Input.hs
index d3fbb0c..55f1a5b 100644
--- a/src/Wetterhorn/Core/Input.hs
+++ b/src/Wetterhorn/Dsl/Input.hs
@@ -1,26 +1,33 @@
-module Wetterhorn.Core.Input
-  ( forwardEvent,
+module Wetterhorn.Dsl.Input
+  ( InputM,
+    InputEvent (..),
+    forwardEvent,
     forwardKey,
     whenKeyEvent,
     whenButtonEvent,
-    InputM,
-    InputEvent,
+    useInputHandler,
+    unwrap,
+    filterEvent,
+    isPressEvent,
+    nextInputEventThat,
     nextInputPressEvent,
     continue,
-    unwrap,
     nextInputEvent,
+    getModifierState,
   )
 where
 
-import Control.Monad (void)
+import Control.Monad (forever, void)
 import Control.Monad.Cont (MonadCont)
 import Control.Monad.RWS (MonadIO, MonadReader (ask), MonadState (get), MonadTrans (lift), RWST, execRWST, modify)
 import Control.Monad.Trans.Cont
+import Data.Maybe (fromMaybe)
+import Data.Word (Word32)
 import qualified Wetterhorn.Core.ButtonEvent as ButtonEvent
 import qualified Wetterhorn.Core.KeyEvent as KeyEvent
 import Wetterhorn.Core.W (W (..))
 import qualified Wetterhorn.Core.W as W
-import Wetterhorn.Foreign.WlRoots (wlrSeatKeyboardNotifyKey, wlrSeatSetKeyboard)
+import Wetterhorn.Foreign.WlRoots (guardNull, wlrKeyboardGetModifiers, wlrSeatGetKeyboard, wlrSeatKeyboardNotifyKey, wlrSeatSetKeyboard)
 
 -- | Union of event types.
 data InputEvent
@@ -90,20 +97,45 @@ unwrap :: Maybe a -> InputM a
 unwrap (Just val) = return val
 unwrap Nothing = continue
 
+-- | Call in the reset handler with the InputM handler you wolud like to use.
+useInputHandler :: InputM () -> W ()
+useInputHandler (forever -> top@(InputM ctop)) = do
+  void $ execRWST (runContT ctop return) (InputContext top) ()
+
 -- | Returns the next input event that's either a kep press or a button press.
 nextInputPressEvent :: InputM InputEvent
-nextInputPressEvent = do
+nextInputPressEvent = nextInputEventThat isPressEvent
+
+nextInputEventThat :: (InputEvent -> Bool) -> InputM InputEvent
+nextInputEventThat fn =
   nextInputEvent
-    >>= ( \ie -> case ie of
-            InputButtonEvent be
-              | ButtonEvent.state be == ButtonEvent.ButtonPressed ->
-                return ie
-            InputKeyEvent ke
-              | KeyEvent.state ke == KeyEvent.KeyPressed ->
-                return ie
-            _ -> nextInputEvent
+    >>= ( \ie ->
+            if fn ie
+              then return ie
+              else forwardEvent ie >> nextInputEventThat fn
         )
 
+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 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)
+
 -- | Gets the next input event.
 nextInputEvent :: InputM InputEvent
 nextInputEvent =
diff --git a/src/Wetterhorn/Foreign/WlRoots.hs b/src/Wetterhorn/Foreign/WlRoots.hs
index 05ed3d6..0581b77 100644
--- a/src/Wetterhorn/Foreign/WlRoots.hs
+++ b/src/Wetterhorn/Foreign/WlRoots.hs
@@ -1,8 +1,10 @@
 module Wetterhorn.Foreign.WlRoots where
 
-import Foreign (IntPtr, Ptr, Word32, intPtrToPtr, ptrToIntPtr)
+import Foreign (IntPtr, Ptr, Word32, intPtrToPtr, ptrToIntPtr, nullPtr)
 import Text.Read
 
+data WlrKeyboard
+
 data WlrPointer
 
 data WlrPointerButtonEvent
@@ -47,7 +49,18 @@ instance ForeignSurface WlrXdgSurface where
 instance ForeignSurface WlrXWaylandSurface where
   toSurface = XWaylandSurface
 
-foreign import ccall "wlr_seat_set_keyboard" wlrSeatSetKeyboard :: Ptr WlrSeat -> Ptr WlrInputDevice -> IO ()
+guardNull :: Ptr a -> Maybe (Ptr a)
+guardNull p | p == nullPtr = Nothing
+guardNull p = Just p
+
+foreign import ccall "wlr_seat_set_keyboard" wlrSeatSetKeyboard ::
+    Ptr WlrSeat -> Ptr WlrInputDevice -> IO ()
+
+foreign import ccall "wlr_seat_get_keyboard" wlrSeatGetKeyboard ::
+    Ptr WlrSeat -> IO (Ptr WlrKeyboard)
+
+foreign import ccall "wlr_keyboard_get_modifiers" wlrKeyboardGetModifiers ::
+    Ptr WlrKeyboard -> IO Word32
 
 foreign import ccall "wlr_seat_keyboard_notify_key"
   wlrSeatKeyboardNotifyKey ::