diff options
| -rw-r--r-- | montis/src/Config.hs | 14 | ||||
| -rw-r--r-- | montis/src/Montis/Base/Foreign/WlRoots.hs | 8 | ||||
| -rw-r--r-- | montis/src/Montis/Core/Runtime.hs | 6 | ||||
| -rw-r--r-- | montis/src/Montis/Standard/Bindings.hs (renamed from montis/src/Montis/Standard/Keys.hs) | 77 | ||||
| -rw-r--r-- | montis/src/Montis/Standard/Bindings/Button.hsc | 230 | ||||
| -rw-r--r-- | montis/src/Montis/Standard/Bindings/Dsl.hs | 113 | ||||
| -rw-r--r-- | montis/src/Montis/Standard/Drag.hs | 179 | ||||
| -rw-r--r-- | montis/src/Montis/Standard/Keys/Dsl.hs | 85 | ||||
| -rw-r--r-- | montis/src/Montis/Standard/Mouse.hs | 5 |
9 files changed, 515 insertions, 202 deletions
diff --git a/montis/src/Config.hs b/montis/src/Config.hs index f71b5f9..5ba1c40 100644 --- a/montis/src/Config.hs +++ b/montis/src/Config.hs @@ -3,8 +3,9 @@ module Config (config) where import Data.Bits (shiftL) import Data.Word (Word32) import Montis.Core -import Montis.Standard.Drag (DragConfig (DragConfig)) -import Montis.Standard.Keys.Dsl +import Montis.Standard.Bindings.Button +import Montis.Standard.Bindings.Dsl +import Montis.Standard.Drag import Montis.Standard.Mouse (MouseConfig (MouseConfig)) keyBindings :: [Binding] @@ -14,7 +15,12 @@ keyBindings = [ Bind (Mod1 .+ 'k') (mio $ putStrLn "Pressed 'k' after 'j'") ], Bind (Mod1 .+ 'Q') requestRebirth, - Bind (Mod1 .+ 's') (\(keyEvent :: KeyEvent) -> mio (print keyEvent)) + Bind (Mod1 .+ 'q') requestExit, + Bind (Mod1 .+ 's') (\(keyEvent :: KeyEvent) -> mio (print keyEvent)), + Bind (Mod1 .+ 'S') (\(keyEvent :: KeyEvent) -> mio (print keyEvent)), + Bind (Mod1 .+ btnLeft) startWindowMove, + Bind (Mod1 .+ btnRight) startWindowResize, + Bind (Mod1 .+ btnMiddle) (\(buttonEvent :: ButtonEvent) -> mio (print buttonEvent)) ] mod1Mask :: Word32 @@ -23,5 +29,5 @@ mod1Mask = 1 `shiftL` 3 -- WLR_MODIFIER_ALT config :: MontisConfig config = install MouseConfig $ - install (DragConfig mod1Mask) $ + install DragConfig $ withBindings keyBindings defaultConfig diff --git a/montis/src/Montis/Base/Foreign/WlRoots.hs b/montis/src/Montis/Base/Foreign/WlRoots.hs index 272567f..d9c9bd7 100644 --- a/montis/src/Montis/Base/Foreign/WlRoots.hs +++ b/montis/src/Montis/Base/Foreign/WlRoots.hs @@ -42,3 +42,11 @@ foreign import ccall "wlr_seat_keyboard_notify_key" -- | Forwards a key event to the seat with time, keycode, and state. seatKeyboardNotifyKey :: WlrSeat -> Word32 -> Word32 -> Word32 -> IO () seatKeyboardNotifyKey (WlrSeat p) = foreign_wlrSeatKeyboardNotifyKey p + +foreign import ccall "wlr_seat_pointer_notify_button" + foreign_wlrSeatPointerNotifyButton :: + Ptr ForeignWlrSeat -> Word32 -> Word32 -> Word32 -> IO () + +-- | Forwards a pointer button event to the seat. +seatPointerNotifyButton :: WlrSeat -> Word32 -> Word32 -> Word32 -> IO () +seatPointerNotifyButton (WlrSeat p) = foreign_wlrSeatPointerNotifyButton p diff --git a/montis/src/Montis/Core/Runtime.hs b/montis/src/Montis/Core/Runtime.hs index 541cc6b..40f4e71 100644 --- a/montis/src/Montis/Core/Runtime.hs +++ b/montis/src/Montis/Core/Runtime.hs @@ -8,6 +8,7 @@ module Montis.Core.Runtime toplevelAt, warpCursor, requestRebirth, + requestExit, ) where @@ -33,6 +34,11 @@ requestRebirth = do (SelfPtr p) <- getSelfPtr liftIO $ foreign_doRequestHotReload p +requestExit :: Montis () +requestExit = do + (SelfPtr p) <- getSelfPtr + liftIO $ foreign_doRequestExit p 0 + getSeat :: Montis (Maybe WlrSeat) getSeat = do self <- getSelfPtr diff --git a/montis/src/Montis/Standard/Keys.hs b/montis/src/Montis/Standard/Bindings.hs index 0b670eb..7905b4b 100644 --- a/montis/src/Montis/Standard/Keys.hs +++ b/montis/src/Montis/Standard/Bindings.hs @@ -1,34 +1,37 @@ -module Montis.Standard.Keys where +module Montis.Standard.Bindings where -import Control.Monad (when) +import Control.Monad (unless, 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 Montis.Base.Foreign.WlRoots (seatKeyboardNotifyKey) -import Montis.Core.Events (KeyEvent (..), KeyState (..)) +import Montis.Base.Foreign.WlRoots (seatKeyboardNotifyKey, seatPointerNotifyButton) +import Montis.Core.Events (ButtonEvent (..), ButtonState (..), KeyEvent (..), KeyState (..)) import Montis.Core.Monad (Montis, xConfigGet, xStateGet, xStateModify) import Montis.Core.Runtime (getSeat) import Montis.Core.State ( Config (startingHooks), ConfigModule (..), - Hooks (keyHook), + Hooks (keyHook, buttonHook), StateExtension (..), ) +data InputEvent where + InputEvent :: Either KeyEvent ButtonEvent -> InputEvent + -- | Configuration for the keybindings. -data KeysConfig where - KeysConfig :: - { startCont :: KeyEvent -> Montis Bool +data InputsConfig where + InputsConfig :: + { startCont :: InputEvent -> Montis Bool } -> - KeysConfig + InputsConfig deriving (Typeable) -instance Default KeysConfig where - def = KeysConfig $ \_ -> return False +instance Default InputsConfig where + def = InputsConfig $ \_ -> return False -subkeys :: (KeyEvent -> Montis Bool) -> Montis Bool +subkeys :: (InputEvent -> Montis Bool) -> Montis Bool subkeys fn = do xStateModify $ \keyState -> keyState @@ -37,35 +40,46 @@ subkeys fn = do return True -- | State of the keys right now. -data KeysState where - KeysState :: - { awaiting :: Maybe (KeyEvent -> Montis Bool), +data InputsState where + InputsState :: + { awaiting :: Maybe (InputEvent -> Montis Bool), ignoredKeys :: Set.Set Word32 } -> - KeysState + InputsState -instance StateExtension KeysState where - initialValue = KeysState Nothing Set.empty +instance StateExtension InputsState where + initialValue = InputsState Nothing Set.empty marshalExtension = const Nothing demarshalExtension = const Nothing -- | Configurable module for keys. -instance ConfigModule Montis KeysConfig where +instance ConfigModule Montis InputsConfig where alterConfig _ c = let oh = keyHook (startingHooks c) + obh = buttonHook (startingHooks c) in c { startingHooks = (startingHooks c) - { keyHook = \ev -> runEv ev >> oh ev + { keyHook = \ev -> runEv (InputEvent (Left ev)) >> oh ev, + buttonHook = \ev -> liftIO (putStrLn $ "Is it working? " ++ show ev) >> runEv (InputEvent (Right ev)) >> obh ev } } where isKeyPress ev = keyEvent_state ev == KeyPressed isKeyRelease ev = keyEvent_state ev == KeyReleased shouldIgnoreEvent ev = do - KeysState {ignoredKeys} <- xStateGet + InputsState {ignoredKeys} <- xStateGet return $ Set.member (keyEvent_keycode ev) ignoredKeys - runEv ev = do + runEv :: InputEvent -> Montis () + runEv iv@(InputEvent (Right ev)) = do + handler' <- awaiting <$> xStateGet + handler <- maybe (startCont <$> xConfigGet) return handler' + xStateModify $ \st -> + st {awaiting = Nothing} + handled <- handler iv + unless handled $ + forwardButtonToSeat ev + runEv iv@(InputEvent (Left ev)) = do shouldIgnore <- shouldIgnoreEvent ev if isKeyRelease ev && shouldIgnore then xStateModify $ \ks -> @@ -79,7 +93,7 @@ instance ConfigModule Montis KeysConfig where -- Reset the hadler. xStateModify $ \st -> st {awaiting = Nothing} - handler ev + handler iv else return False if not handled @@ -105,6 +119,23 @@ forwardKeyToSeat ev = do (keyEvent_keycode ev) (keyStateToWord32 (keyEvent_state ev)) +forwardButtonToSeat :: ButtonEvent -> Montis () +forwardButtonToSeat ev = do + mseat <- getSeat + case mseat of + Nothing -> return () + Just seat -> + liftIO $ + seatPointerNotifyButton + seat + (buttonEvent_timeMs ev) + (buttonEvent_button ev) + (buttonStateToWord32 (buttonEvent_state ev)) + +buttonStateToWord32 :: ButtonState -> Word32 +buttonStateToWord32 ButtonReleased = 0 +buttonStateToWord32 ButtonPressed = 1 + keyStateToWord32 :: KeyState -> Word32 keyStateToWord32 KeyReleased = 0 keyStateToWord32 KeyPressed = 1 diff --git a/montis/src/Montis/Standard/Bindings/Button.hsc b/montis/src/Montis/Standard/Bindings/Button.hsc new file mode 100644 index 0000000..c3f7249 --- /dev/null +++ b/montis/src/Montis/Standard/Bindings/Button.hsc @@ -0,0 +1,230 @@ +module Montis.Standard.Bindings.Button 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/montis/src/Montis/Standard/Bindings/Dsl.hs b/montis/src/Montis/Standard/Bindings/Dsl.hs new file mode 100644 index 0000000..73c26c8 --- /dev/null +++ b/montis/src/Montis/Standard/Bindings/Dsl.hs @@ -0,0 +1,113 @@ +{-# LANGUAGE ImpredicativeTypes #-} + +-- | Small DSL for defining key bindings and nested sub-maps. +module Montis.Standard.Bindings.Dsl where + +import Control.Monad.Loops (anyM) +import Data.Bits (shiftL, (.&.)) +import Data.Word (Word32) +import Montis.Core (ButtonEvent (buttonEvent_button, buttonEvent_modifiers, buttonEvent_state), ButtonState (ButtonPressed), Config, KeyEvent (keyEvent_codepoint, keyEvent_modifiers), Montis (..), install) +import Montis.Standard.Bindings +import Montis.Standard.Bindings.Button + +-- | A predicate over a key event. +class InputMatch a where + matches :: a -> InputEvent -> Montis Bool + +instance InputMatch Char where + matches c (InputEvent (Left k)) = return $ keyEvent_codepoint k == c + matches _ _ = return False + +-- | Modifier matches using wlroots bit positions. +data Modifier = Mod1 | Mod2 | Mod3 | Mod4 | Mod5 | Any | None + +instance InputMatch Modifier where + matches Mod1 ev = return $ inputModifiers ev .&. (1 `shiftL` 3) /= 0 + matches Mod2 ev = return $ inputModifiers ev .&. (1 `shiftL` 4) /= 0 + matches Mod3 ev = return $ inputModifiers ev .&. (1 `shiftL` 5) /= 0 + matches Mod4 ev = return $ inputModifiers ev .&. (1 `shiftL` 6) /= 0 + matches Mod5 ev = return $ inputModifiers ev .&. (1 `shiftL` 7) /= 0 + matches Any _ = return True + matches None ev = return $ inputModifiers ev == 0 + +instance InputMatch Button where + matches (Button b) (InputEvent (Right ev)) = + return $ buttonEvent_button ev == b && buttonEvent_state ev == ButtonPressed + matches _ _ = return False + +inputModifiers :: InputEvent -> Word32 +inputModifiers (InputEvent (Left k)) = keyEvent_modifiers k +inputModifiers (InputEvent (Right b)) = buttonEvent_modifiers b + +-- | Actions run when a binding matches. Each action reports handled status. +class Action b where + run :: b -> Montis Bool + +instance Action (Montis ()) where + run a = a >> return True + +instance Action (InputEvent -> Montis ()) where + run f = subkeys (\e -> f e >> return True) + +instance Action (KeyEvent -> Montis ()) where + run f = + subkeys + ( \case + (InputEvent (Left k)) -> f k >> return True + _ -> return True + ) + +instance Action (ButtonEvent -> Montis ()) where + run f = + subkeys + ( \case + (InputEvent (Right b)) -> f b >> return True + _ -> return True + ) + +-- | Submap to the first binding that matches. +instance Action [Binding] where + run bs = subkeys $ \ev -> + anyM + ( \(Bind k a) -> do + m <- matches k ev + if m then run a >> return True else return False + ) + bs + +instance Action (Montis [Binding]) where + run mbs = do + bs <- mbs + run bs + +-- | A single binding from a matcher to an action. +data Binding where + Bind :: forall k b. (InputMatch k, Action b) => k -> b -> Binding + +-- | A matcher for key + modifier chords. +data ChordMatch where + ChordMatch :: forall k2 k1. (InputMatch k2, InputMatch k1) => k2 -> k1 -> ChordMatch + +(.+) :: (InputMatch k1, InputMatch k2) => k1 -> k2 -> ChordMatch +(.+) = ChordMatch + +instance InputMatch ChordMatch where + matches (ChordMatch a b) ev = do + ma <- matches a ev + mb <- matches b ev + return (ma && mb) + +-- | Installs the bindings into a config as the starting key hook. +withBindings :: [Binding] -> Config Montis -> Config Montis +withBindings bs = + install + ( InputsConfig + ( \ev -> + anyM + ( \(Bind k a) -> do + m <- matches k ev + if m then run a >> return True else return False + ) + bs + ) + ) diff --git a/montis/src/Montis/Standard/Drag.hs b/montis/src/Montis/Standard/Drag.hs index a6ee878..63d585b 100644 --- a/montis/src/Montis/Standard/Drag.hs +++ b/montis/src/Montis/Standard/Drag.hs @@ -1,59 +1,48 @@ -module Montis.Standard.Drag where +module Montis.Standard.Drag + ( DragConfig(..), + startDragging, + stopDragging, + windowMove, + windowResize, + startWindowResize, + startWindowMove, + ) +where -import Data.Bits ((.&.)) import Data.Data (Typeable) -import Data.Word (Word32) import Montis.Core import Montis.Core.Runtime import Montis.Core.State ( Config (startingHooks), ConfigModule (..), - Hooks (buttonHook, motionHook), + Hooks (motionHook), StateExtension (..), ) import Montis.Standard.Mouse (CursorPosition (CursorPosition)) +import Control.Monad.Cont (MonadIO(liftIO)) data DragConfig where - DragConfig :: - { dragModifierMask :: Word32 - } -> - DragConfig + DragConfig :: DragConfig deriving (Typeable) instance ConfigModule Montis DragConfig where - alterConfig cfg c = - let ohb = buttonHook (startingHooks c) - ohm = motionHook (startingHooks c) + alterConfig _ c = + let ohm = motionHook (startingHooks c) + obtn = buttonHook (startingHooks c) in c { startingHooks = (startingHooks c) - { buttonHook = \ev -> onButton (dragModifierMask cfg) ev >> ohb ev, - motionHook = \ev -> onMotion ev >> ohm ev + { motionHook = \ev -> onMotion ev >> ohm ev, + buttonHook = \ev -> onButton ev >> obtn ev } } -data DragState = DragState - { dragToplevel :: ToplevelHandle, - dragOffsetX :: Double, - dragOffsetY :: Double - } - deriving (Typeable) - -data ResizeState = ResizeState - { resizeToplevel :: ToplevelHandle, - resizeStartX :: Double, - resizeStartY :: Double, - resizeStartW :: Double, - resizeStartH :: Double, - resizeStartCursorX :: Double, - resizeStartCursorY :: Double - } - deriving (Typeable) - -data DragAction - = DragMove DragState - | DragResize ResizeState - deriving (Typeable) +data DragAction where + DragAction :: + { onMotionAction :: MotionEvent -> Montis (), + _onButtonReleaseAction :: ButtonEvent -> Montis () + } -> + DragAction newtype Dragging = Dragging (Maybe DragAction) deriving (Typeable) @@ -63,61 +52,77 @@ instance StateExtension Dragging where marshalExtension _ = Nothing demarshalExtension _ = Nothing -leftButton :: Word32 -leftButton = 272 -- BTN_LEFT +startWindowResize :: Montis () +startWindowResize = do + f <- windowResize + startDragging f (const stopDragging) + +startWindowMove :: Montis () +startWindowMove = do + f <- windowMove + startDragging f (const stopDragging) + +windowMove :: Montis (MotionEvent -> Montis ()) +windowMove = do + CursorPosition (x0, y0) <- xStateGet + mtl <- toplevelAt x0 y0 + case mtl of + Nothing -> return (const $ return ()) + Just tl -> do + (tx, ty, _tw, _th) <- getToplevelGeometry tl + let offsetX = x0 - tx + offsetY = y0 - ty + return $ \ev -> do + let (x1, y1) = motionEvent_absolute ev + setToplevelPosition tl (x1 - offsetX) (y1 - offsetY) + +windowResize :: Montis (MotionEvent -> Montis ()) +windowResize = do + CursorPosition (startX, startY) <- xStateGet + mtl <- toplevelAt startX startY + case mtl of + Nothing -> return (const $ return ()) + Just tl -> do + (tx, ty, startW, startH) <- getToplevelGeometry tl + let warpX = tx + startW + warpY = ty + startH + warpCursor warpX warpY + xStatePut (CursorPosition (warpX, warpY)) + return $ \ev -> do + let (x, y) = motionEvent_absolute ev + newW = max 1 (startW + (x - warpX)) + newH = max 1 (startH + (y - warpY)) + setToplevelGeometry + tl + tx + ty + newW + newH + +startDragging :: (MotionEvent -> Montis ()) -> (ButtonEvent -> Montis ()) -> Montis () +startDragging dragFn endFn = + xStatePut $ + Dragging + (Just (DragAction dragFn endFn)) -rightButton :: Word32 -rightButton = 273 -- BTN_RIGHT +stopDragging :: Montis () +stopDragging = xStatePut (Dragging Nothing) -onButton :: Word32 -> ButtonEvent -> Montis () -onButton modMask ev - | buttonEvent_button ev /= leftButton && buttonEvent_button ev /= rightButton = return () - | buttonEvent_state ev == ButtonPressed = do - if buttonEvent_modifiers ev .&. modMask == 0 - then return () - else do - CursorPosition (x, y) <- xStateGet - mtl <- toplevelAt x y - case mtl of - Nothing -> xStatePut (Dragging Nothing) - Just tl -> do - (tx, ty, tw, th) <- getToplevelGeometry tl - if buttonEvent_button ev == rightButton - then do - let warpX = tx + tw - warpY = ty + th - warpCursor warpX warpY - xStatePut (CursorPosition (warpX, warpY)) - xStatePut $ - Dragging - ( Just - ( DragResize - (ResizeState tl tx ty tw th warpX warpY) - ) - ) - else - xStatePut $ - Dragging - (Just (DragMove (DragState tl (x - tx) (y - ty)))) - | buttonEvent_state ev == ButtonReleased = - xStatePut (Dragging Nothing) - | otherwise = return () +onButton :: ButtonEvent -> Montis () +onButton bev = do + case buttonEvent_state bev of + ButtonReleased -> do + liftIO $ putStrLn "!! Button Released." + xStateGet + >>= ( \case + (Dragging (Just (DragAction _ stopFn))) -> stopFn bev + _ -> return () + ) + ButtonPressed -> return () onMotion :: MotionEvent -> Montis () onMotion ev = do - let (x, y) = motionEvent_absolute ev - xStatePut (CursorPosition (x, y)) - Dragging mdrag <- xStateGet - case mdrag of + (Dragging act) <- xStateGet + case act of Nothing -> return () - Just (DragMove (DragState tl dx dy)) -> - setToplevelPosition tl (x - dx) (y - dy) - Just (DragResize rs) -> do - let newW = max 1 (resizeStartW rs + (x - resizeStartCursorX rs)) - newH = max 1 (resizeStartH rs + (y - resizeStartCursorY rs)) - setToplevelGeometry - (resizeToplevel rs) - (resizeStartX rs) - (resizeStartY rs) - newW - newH + Just action -> onMotionAction action ev diff --git a/montis/src/Montis/Standard/Keys/Dsl.hs b/montis/src/Montis/Standard/Keys/Dsl.hs deleted file mode 100644 index 096a8b9..0000000 --- a/montis/src/Montis/Standard/Keys/Dsl.hs +++ /dev/null @@ -1,85 +0,0 @@ -{-# LANGUAGE ImpredicativeTypes #-} - --- | Small DSL for defining key bindings and nested sub-maps. -module Montis.Standard.Keys.Dsl where - -import Control.Monad.Loops (anyM) -import Data.Bits (shiftL, (.&.)) -import Montis.Core (Config, KeyEvent (keyEvent_codepoint, keyEvent_modifiers), Montis (..), install) -import Montis.Standard.Keys - --- | A predicate over a key event. -class KeyMatch a where - matches :: a -> KeyEvent -> Montis Bool - -instance KeyMatch Char where - matches c k = return $ keyEvent_codepoint k == c - --- | Modifier matches using wlroots bit positions. -data Modifier = Mod1 | Mod2 | Mod3 | Mod4 | Mod5 | Any | None - -instance KeyMatch Modifier where - matches Mod1 ev = return $ keyEvent_modifiers ev .&. (1 `shiftL` 3) /= 0 - matches Mod2 ev = return $ keyEvent_modifiers ev .&. (1 `shiftL` 4) /= 0 - matches Mod3 ev = return $ keyEvent_modifiers ev .&. (1 `shiftL` 5) /= 0 - matches Mod4 ev = return $ keyEvent_modifiers ev .&. (1 `shiftL` 6) /= 0 - matches Mod5 ev = return $ keyEvent_modifiers ev .&. (1 `shiftL` 7) /= 0 - matches Any _ = return True - matches None ev = return $ keyEvent_modifiers ev == 0 - --- | Actions run when a binding matches. Each action reports handled status. -class Action b where - run :: b -> Montis Bool - -instance Action (Montis ()) where - run a = a >> return True - -instance Action (KeyEvent -> Montis ()) where - run f = subkeys (\e -> f e >> return True) - --- | Submap to the first binding that matches. -instance Action [Binding] where - run bs = subkeys $ \ev -> - anyM - ( \(Bind k a) -> do - m <- matches k ev - if m then run a >> return True else return False - ) - bs - -instance Action (Montis [Binding]) where - run mbs = do - bs <- mbs - run bs - --- | A single binding from a matcher to an action. -data Binding where - Bind :: forall k b. (KeyMatch k, Action b) => k -> b -> Binding - --- | A matcher for key + modifier chords. -data ChordMatch where - ChordMatch :: forall k2 k1. (KeyMatch k2, KeyMatch k1) => k2 -> k1 -> ChordMatch - -(.+) :: (KeyMatch k1, KeyMatch k2) => k1 -> k2 -> ChordMatch -(.+) = ChordMatch - -instance KeyMatch ChordMatch where - matches (ChordMatch a b) ev = do - ma <- matches a ev - mb <- matches b ev - return (ma && mb) - --- | Installs the bindings into a config as the starting key hook. -withBindings :: [Binding] -> Config Montis -> Config Montis -withBindings bs = - install - ( KeysConfig - ( \ev -> - anyM - ( \(Bind k a) -> do - m <- matches k ev - if m then run a >> return True else return False - ) - bs - ) - ) diff --git a/montis/src/Montis/Standard/Mouse.hs b/montis/src/Montis/Standard/Mouse.hs index 933a2f4..c981c61 100644 --- a/montis/src/Montis/Standard/Mouse.hs +++ b/montis/src/Montis/Standard/Mouse.hs @@ -9,6 +9,7 @@ import Montis.Core.State Hooks (buttonHook, motionHook), StateExtension (..), ) +import Control.Monad (forM_) data MouseConfig where MouseConfig :: MouseConfig @@ -45,6 +46,4 @@ onButton ev | otherwise = do CursorPosition (x, y) <- xStateGet mtl <- toplevelAt x y - case mtl of - Nothing -> return () - Just tl -> focusToplevel tl + forM_ mtl focusToplevel |