diff options
| -rw-r--r-- | specs/Mock.hs | 12 | ||||
| -rw-r--r-- | specs/Specs/AppStateUpdateSpec.hs | 54 | ||||
| -rw-r--r-- | src/Chelleport.hs | 48 | ||||
| -rw-r--r-- | src/Chelleport/AppShell.hs | 4 | ||||
| -rw-r--r-- | src/Chelleport/Control.hs | 27 | ||||
| -rw-r--r-- | src/Chelleport/Types.hs | 14 |
6 files changed, 121 insertions, 38 deletions
diff --git a/specs/Mock.hs b/specs/Mock.hs index 5644a06..c44aff3 100644 --- a/specs/Mock.hs +++ b/specs/Mock.hs @@ -17,10 +17,10 @@ data Call | CallDrawText (CInt, CInt) Color Text | CallGetMousePointerPosition | CallHideWindow - | CallMouseButtonDown - | CallMouseButtonUp + | CallPressMouseButton + | CallReleaseMouseButton | CallMoveMousePosition CInt CInt - | CallPressMouseButton MouseButtonType + | CallClickMouseButton MouseButtonType | CallSetDrawColor Color | CallShowWindow | CallShutdownApp @@ -45,11 +45,11 @@ newtype TestM m a = TestM {runTestM :: StateT MockCalls m a} deriving (Functor, Applicative, Monad, MonadIO, MonadState MockCalls) instance (MonadIO m) => MonadControl (TestM m) where - pressMouseButton btn = registerMockCall $ CallPressMouseButton btn + clickMouseButton btn = registerMockCall $ CallClickMouseButton btn moveMousePointer x y = registerMockCall $ CallMoveMousePosition x y getMousePointerPosition = (42, 42) <$ registerMockCall CallGetMousePointerPosition - mouseButtonDown = registerMockCall CallMouseButtonDown - mouseButtonUp = registerMockCall CallMouseButtonUp + pressMouseButton = registerMockCall CallPressMouseButton + releaseMouseButton = registerMockCall CallReleaseMouseButton mockWindowWidth :: CInt mockWindowWidth = 1920 diff --git a/specs/Specs/AppStateUpdateSpec.hs b/specs/Specs/AppStateUpdateSpec.hs index fd79c95..7c03f1a 100644 --- a/specs/Specs/AppStateUpdateSpec.hs +++ b/specs/Specs/AppStateUpdateSpec.hs @@ -33,7 +33,8 @@ test = do { stateKeySequence = [], stateIsShiftPressed = False, stateIsMatched = False, - stateGrid = [["ABC", "DEF"], ["DJK", "JKL"]] + stateGrid = [["ABC", "DEF"], ["DJK", "JKL"]], + stateIsDragging = False } context "with action HandleKeyInput" $ do @@ -69,7 +70,7 @@ test = do it "hides window and triggers mouse click" $ do (_, mock) <- runWithMocks $ update currentState $ TriggerMouseClick LeftClick - calls mock `shouldContain` [CallHideWindow, CallPressMouseButton LeftClick] + calls mock `shouldContain` [CallHideWindow, CallClickMouseButton LeftClick] it "continues with action ShutdownApp without updating state" $ do ((nextState, action), _) <- runWithMocks $ update currentState $ TriggerMouseClick LeftClick @@ -81,13 +82,58 @@ test = do it "hides window, triggers mouse click and shows the window again" $ do (_, mock) <- runWithMocks $ update currentState $ ChainMouseClick LeftClick - calls mock `shouldBe` [CallHideWindow, CallPressMouseButton LeftClick, CallShowWindow] + calls mock `shouldBe` [CallHideWindow, CallClickMouseButton LeftClick, CallShowWindow] it "continues with action ResetKeys without updating state" $ do ((nextState, action), _) <- runWithMocks $ update currentState $ ChainMouseClick LeftClick action `shouldBe` Just ResetKeys nextState `shouldBe` currentState + context "with action MouseDragToggle" $ do + context "when is dragging is true" $ do + let currentState = defaultState {stateIsDragging = True} + + it "toggles dragging state" $ do + ((state, _), _) <- runWithMocks $ update currentState MouseDragToggle + state `shouldBe` state {stateIsDragging = False} + + it "continues with action MouseDragEnd" $ do + ((_, action), _) <- runWithMocks $ update currentState MouseDragToggle + action `shouldBe` Just MouseDragEnd + + context "when is dragging is false" $ do + let currentState = defaultState {stateIsDragging = False} + + it "toggles dragging state" $ do + ((state, _), _) <- runWithMocks $ update currentState MouseDragToggle + state `shouldBe` state {stateIsDragging = True} + + it "continues with action MouseDragStart" $ do + ((_, action), _) <- runWithMocks $ update currentState MouseDragToggle + action `shouldBe` Just MouseDragStart + + context "with action MouseDragStart" $ do + let currentState = defaultState + + it "hides window, starts dragging and shows the window again" $ do + (_, mock) <- runWithMocks $ update currentState MouseDragStart + calls mock `shouldContain` [CallHideWindow, CallPressMouseButton, CallShowWindow] + + it "does not continue or update state" $ do + (result, _) <- runWithMocks $ update currentState MouseDragStart + result `shouldBe` (currentState, Nothing) + + context "with action MouseDragEnd" $ do + let currentState = defaultState + + it "hides window, stops dragging and shows the window again" $ do + (_, mock) <- runWithMocks $ update currentState MouseDragEnd + calls mock `shouldContain` [CallHideWindow, CallReleaseMouseButton, CallShowWindow] + + it "does not continue or update state" $ do + (result, _) <- runWithMocks $ update currentState MouseDragStart + result `shouldBe` (currentState, Nothing) + context "with action MoveMousePosition" $ do let currentState = defaultState let rows = intToCInt $ length $ stateGrid currentState @@ -97,7 +143,7 @@ test = do it "moves mouse pointer to center of cell of given coordinates" $ do (_, mock) <- runWithMocks $ update currentState $ MoveMousePosition (0, 0) -- handleMocks - -- [ CallPressMouseButton LeftClick `returns` (1, 2), + -- [ CallClickMouseButton LeftClick `returns` (1, 2), -- CallHideWindow `returns` () -- ] mock diff --git a/src/Chelleport.hs b/src/Chelleport.hs index 3f78aba..95e8af9 100644 --- a/src/Chelleport.hs +++ b/src/Chelleport.hs @@ -2,7 +2,16 @@ module Chelleport where import Chelleport.AppShell (MonadAppShell (hideWindow, showWindow, shutdownApp), setupAppShell) import Chelleport.Context (initializeContext) -import Chelleport.Control (MonadControl (getMousePointerPosition, mouseButtonDown, mouseButtonUp, moveMousePointer, pressMouseButton), directionalIncrement, eventToKeycode, isKeyPressWith, isKeyPressed, isKeyReleaseWith, withShift) +import Chelleport.Control + ( MonadControl (clickMouseButton, getMousePointerPosition, moveMousePointer, pressMouseButton, releaseMouseButton), + directionalIncrement, + eventToKeycode, + isKeyPressWith, + isKeyPressed, + isKeyReleaseWith, + withCtrl, + withShift, + ) import Chelleport.Draw (MonadDraw (windowPosition), cellSize) import Chelleport.KeySequence (findMatchPosition, generateGrid, isValidKey, nextChars, toKeyChar) import Chelleport.Types @@ -13,11 +22,7 @@ import Control.Monad.Reader (ReaderT (runReaderT)) import Data.Maybe (fromMaybe, isJust) import qualified SDL -runEff :: - (MonadIO m) => - DrawContext -> - AppM m x -> - m x +runEff :: (MonadIO m) => DrawContext -> AppM m x -> m x runEff ctx action = runReaderT (runAppM action) ctx run :: IO () @@ -38,7 +43,8 @@ initialState = do { stateGrid = cells, stateKeySequence = [], stateIsMatched = False, - stateIsShiftPressed = False + stateIsShiftPressed = False, + stateIsDragging = False } where rows = 9 @@ -50,7 +56,8 @@ eventHandler event = case SDL.eventPayload event of SDL.QuitEvent -> Just ShutdownApp SDL.KeyboardEvent ev - | isKeyPressWith ev SDL.KeycodeEscape -> Just ShutdownApp + | isKeyPressWith ev SDL.KeycodeEscape -> + Just ShutdownApp | isKeyPressWith ev SDL.KeycodeMinus || isKeyPressWith ev SDL.KeycodeUnderscore -> if withShift ev then Just $ ChainMouseClick RightClick @@ -61,6 +68,8 @@ eventHandler event = else Just $ TriggerMouseClick LeftClick | isKeyPressWith ev SDL.KeycodeTab || isKeyPressWith ev SDL.KeycodeBackspace -> Just ResetKeys + | withCtrl ev && isKeyPressWith ev SDL.KeycodeV -> + Just MouseDragToggle | isKeyPressed ev && isValidKey (eventToKeycode ev) -> Just $ HandleKeyInput $ eventToKeycode ev | isKeyPressWith ev SDL.KeycodeLShift || isKeyPressWith ev SDL.KeycodeRShift -> @@ -118,13 +127,13 @@ update state ResetKeys = do -- Trigger click update state (TriggerMouseClick btn) = do hideWindow - pressMouseButton btn + clickMouseButton btn pure (state, Just ShutdownApp) -- Chain clicks update state (ChainMouseClick btn) = do hideWindow - pressMouseButton btn + clickMouseButton btn showWindow pure (state, Just ResetKeys) @@ -133,6 +142,25 @@ update state ShutdownApp = do shutdownApp pure (state, Nothing) +-- Mouse dragging +update state MouseDragToggle + | stateIsDragging state = pure (state {stateIsDragging = False}, Just MouseDragEnd) + | otherwise = pure (state {stateIsDragging = True}, Just MouseDragStart) +-- +-- Mouse button press +update state MouseDragStart = do + hideWindow + pressMouseButton + showWindow + pure (state, Nothing) + +-- Mouse button release +update state MouseDragEnd = do + hideWindow + releaseMouseButton + showWindow + pure (state, Nothing) + -- Set/unset whether shift is pressed update state (UpdateShiftState shift) = pure (state {stateIsShiftPressed = shift}, Nothing) diff --git a/src/Chelleport/AppShell.hs b/src/Chelleport/AppShell.hs index b31c964..382f61e 100644 --- a/src/Chelleport/AppShell.hs +++ b/src/Chelleport/AppShell.hs @@ -1,6 +1,6 @@ module Chelleport.AppShell (setupAppShell, MonadAppShell (..)) where -import Chelleport.Control (MonadControl (mouseButtonUp)) +import Chelleport.Control (MonadControl (releaseMouseButton)) import Chelleport.Draw (colorBackground) import Chelleport.Types import Control.Monad (foldM) @@ -23,7 +23,7 @@ instance (MonadIO m) => MonadAppShell (AppM m) where ctx <- ask SDL.destroyRenderer $ ctxRenderer ctx SDL.destroyWindow $ ctxWindow ctx - mouseButtonUp + releaseMouseButton liftIO $ do X11.closeDisplay $ ctxX11Display ctx exitSuccess diff --git a/src/Chelleport/Control.hs b/src/Chelleport/Control.hs index 2dcb565..fa25681 100644 --- a/src/Chelleport/Control.hs +++ b/src/Chelleport/Control.hs @@ -12,25 +12,25 @@ import qualified Graphics.X11 as X11 import qualified SDL class (Monad m) => MonadControl m where - pressMouseButton :: MouseButtonType -> m () + clickMouseButton :: MouseButtonType -> m () moveMousePointer :: CInt -> CInt -> m () - mouseButtonDown :: m () - mouseButtonUp :: m () + pressMouseButton :: m () + releaseMouseButton :: m () getMousePointerPosition :: m (CInt, CInt) foreign import ccall unsafe "X11/extensions/XTest.h XTestFakeButtonEvent" xSimulateButtonEvent :: X11.Display -> X11.Button -> Bool -> X11.Time -> IO X11.Status -- Wrap with delay to prevent async window close issues -withDelay :: (MonadIO m) => m () -> m () -withDelay act = delay >> act >> delay +withInteractionDelay :: (MonadIO m) => m () -> m () +withInteractionDelay act = delay >> act >> delay where delay = liftIO (threadDelay 20_000) instance (MonadIO m) => MonadControl (AppM m) where - pressMouseButton btn = do + clickMouseButton btn = do (DrawContext {ctxX11Display = display}) <- ask - withDelay . liftIO $ do + withInteractionDelay . liftIO $ do xSimulateButtonEvent display x11Button True 0 xSimulateButtonEvent display x11Button False 0 X11.sync display False @@ -51,15 +51,15 @@ instance (MonadIO m) => MonadControl (AppM m) where Debug.traceM "ERROR: Cant query pointer" pure (x, y) - mouseButtonDown = do + pressMouseButton = do (DrawContext {ctxX11Display = display}) <- ask - withDelay . liftIO $ do + withInteractionDelay . liftIO $ do xSimulateButtonEvent display X11.button1 True 0 X11.sync display False - mouseButtonUp = do + releaseMouseButton = do (DrawContext {ctxX11Display = display}) <- ask - withDelay . liftIO $ do + withInteractionDelay . liftIO $ do xSimulateButtonEvent display X11.button1 False 0 X11.sync display False @@ -85,6 +85,11 @@ withShift event = SDL.keyModifierLeftShift modifier || SDL.keyModifierRightShift where modifier = SDL.keysymModifier . SDL.keyboardEventKeysym $ event +withCtrl :: SDL.KeyboardEventData -> Bool +withCtrl event = SDL.keyModifierLeftCtrl modifier || SDL.keyModifierRightCtrl modifier + where + modifier = SDL.keysymModifier . SDL.keyboardEventKeysym $ event + directionalIncrement :: (CInt, CInt) -> Char -> (Int, Int) directionalIncrement (incX, incY) = \case 'H' -> (-cIntToInt incX, 0) diff --git a/src/Chelleport/Types.hs b/src/Chelleport/Types.hs index e648618..b114189 100644 --- a/src/Chelleport/Types.hs +++ b/src/Chelleport/Types.hs @@ -18,18 +18,22 @@ data State = State { stateGrid :: KeyGrid, stateKeySequence :: KeySequence, stateIsMatched :: Bool, - stateIsShiftPressed :: Bool + stateIsShiftPressed :: Bool, + stateIsDragging :: Bool } deriving (Show, Eq) data AppAction - = HandleKeyInput SDL.Keycode + = ChainMouseClick MouseButtonType + | HandleKeyInput SDL.Keycode + | IncrementMouseCursor (Int, Int) + | MouseDragStart + | MouseDragEnd + | MouseDragToggle | MoveMousePosition (Int, Int) | ResetKeys - | TriggerMouseClick MouseButtonType - | ChainMouseClick MouseButtonType - | IncrementMouseCursor (Int, Int) | ShutdownApp + | TriggerMouseClick MouseButtonType | UpdateShiftState Bool deriving (Show, Eq) |