diff options
| -rw-r--r-- | chelleport.cabal | 1 | ||||
| -rw-r--r-- | specs/Specs/AppEventSpec.hs | 51 | ||||
| -rw-r--r-- | src/Chelleport.hs | 7 | ||||
| -rw-r--r-- | src/Chelleport/Control.hs | 5 | ||||
| -rw-r--r-- | src/Chelleport/Types.hs | 2 |
5 files changed, 52 insertions, 14 deletions
diff --git a/chelleport.cabal b/chelleport.cabal index 2ea0a44..19c73c6 100644 --- a/chelleport.cabal +++ b/chelleport.cabal @@ -81,6 +81,7 @@ test-suite specs Mock Specs.KeySequenceSpec Specs.AppStateUpdateSpec + Specs.AppEventSpec build-depends: lib-chelleport, neat-interpolation, diff --git a/specs/Specs/AppEventSpec.hs b/specs/Specs/AppEventSpec.hs index 3cdbe94..9da4c87 100644 --- a/specs/Specs/AppEventSpec.hs +++ b/specs/Specs/AppEventSpec.hs @@ -11,7 +11,7 @@ test :: SpecWith () test = do describe "#eventHandler" $ do let mkEvent payload = SDL.Event {SDL.eventTimestamp = 0, SDL.eventPayload = payload} - let mkKeyboardEvent key motion = + let mkKeyboardEvent key motion modifier = mkEvent $ SDL.KeyboardEvent $ SDL.KeyboardEventData @@ -20,11 +20,12 @@ test = do SDL.keyboardEventKeysym = SDL.Keysym { SDL.keysymScancode = SDL.Scancode0, - SDL.keysymModifier = fromNumber 0, + SDL.keysymModifier = modifier, SDL.keysymKeycode = key }, SDL.keyboardEventKeyMotion = motion } + let defaultMod = fromNumber 0 context "when window quit event is triggered" $ do it "shuts down app" $ do @@ -33,31 +34,61 @@ test = do context "when escape key is pressed" $ do it "shuts down app" $ do - let action = eventHandler $ mkKeyboardEvent SDL.KeycodeEscape SDL.Pressed + let action = eventHandler $ mkKeyboardEvent SDL.KeycodeEscape SDL.Pressed defaultMod action `shouldBe` Just ShutdownApp context "when space key is pressed" $ do it "triggers left mouse button click" $ do - let action = eventHandler $ mkKeyboardEvent SDL.KeycodeSpace SDL.Pressed + let action = eventHandler $ mkKeyboardEvent SDL.KeycodeSpace SDL.Pressed defaultMod action `shouldBe` Just (TriggerMouseClick LeftClick) + context "when pressed with right shift" $ do + it "chains left mouse button click" $ do + let action = eventHandler $ mkKeyboardEvent SDL.KeycodeSpace SDL.Pressed (defaultMod {SDL.keyModifierRightShift = True}) + action `shouldBe` Just (ChainMouseClick LeftClick) + + context "when pressed with left shift" $ do + it "chains left mouse button click" $ do + let action = eventHandler $ mkKeyboardEvent SDL.KeycodeSpace SDL.Pressed (defaultMod {SDL.keyModifierLeftShift = True}) + action `shouldBe` Just (ChainMouseClick LeftClick) + + context "when minus key is pressed" $ do + it "triggers left mouse button click" $ do + let action = eventHandler $ mkKeyboardEvent SDL.KeycodeMinus SDL.Pressed defaultMod + action `shouldBe` Just (TriggerMouseClick RightClick) + + context "when pressed with right shift" $ do + it "chains right mouse button click" $ do + let action = eventHandler $ mkKeyboardEvent SDL.KeycodeMinus SDL.Pressed (defaultMod {SDL.keyModifierRightShift = True}) + action `shouldBe` Just (ChainMouseClick RightClick) + + context "when pressed with left shift" $ do + it "chains right mouse button click" $ do + let action = eventHandler $ mkKeyboardEvent SDL.KeycodeMinus SDL.Pressed (defaultMod {SDL.keyModifierLeftShift = True}) + action `shouldBe` Just (ChainMouseClick RightClick) + context "when tab key is pressed" $ do it "resets key state" $ do - let action = eventHandler $ mkKeyboardEvent SDL.KeycodeTab SDL.Pressed + let action = eventHandler $ mkKeyboardEvent SDL.KeycodeTab SDL.Pressed defaultMod + action `shouldBe` Just ResetKeys + + context "when backspace key is pressed" $ do + it "resets key state" $ do + let action = eventHandler $ mkKeyboardEvent SDL.KeycodeBackspace SDL.Pressed defaultMod action `shouldBe` Just ResetKeys context "when an alphanumeric key (excluding Q) is pressed" $ do it "calls key input handler" $ do - eventHandler (mkKeyboardEvent SDL.KeycodeA SDL.Pressed) `shouldBe` Just (HandleKeyInput SDL.KeycodeA) - eventHandler (mkKeyboardEvent SDL.KeycodeQ SDL.Pressed) `shouldBe` Just (HandleKeyInput SDL.KeycodeQ) - eventHandler (mkKeyboardEvent SDL.Keycode9 SDL.Pressed) `shouldBe` Just (HandleKeyInput SDL.Keycode9) + eventHandler (mkKeyboardEvent SDL.KeycodeA SDL.Pressed defaultMod) `shouldBe` Just (HandleKeyInput SDL.KeycodeA) + eventHandler (mkKeyboardEvent SDL.KeycodeQ SDL.Pressed defaultMod) `shouldBe` Just (HandleKeyInput SDL.KeycodeQ) + eventHandler (mkKeyboardEvent SDL.Keycode9 SDL.Pressed defaultMod) `shouldBe` Just (HandleKeyInput SDL.Keycode9) context "when shift key is pressed" $ do it "enables shift" $ do - let action = eventHandler $ mkKeyboardEvent SDL.KeycodeRShift SDL.Pressed + let action = eventHandler $ mkKeyboardEvent SDL.KeycodeRShift SDL.Pressed defaultMod action `shouldBe` Just (UpdateShiftState True) context "when shift key is released" $ do it "disabled shift" $ do - let action = eventHandler $ mkKeyboardEvent SDL.KeycodeRShift SDL.Released + let action = eventHandler $ mkKeyboardEvent SDL.KeycodeRShift SDL.Released defaultMod action `shouldBe` Just (UpdateShiftState False) diff --git a/src/Chelleport.hs b/src/Chelleport.hs index ae5ec6e..d00d112 100644 --- a/src/Chelleport.hs +++ b/src/Chelleport.hs @@ -53,11 +53,16 @@ eventHandler event = SDL.QuitEvent -> Just ShutdownApp SDL.KeyboardEvent ev | isKeyPressWith ev SDL.KeycodeEscape -> Just ShutdownApp + | isKeyPressWith ev SDL.KeycodeMinus || isKeyPressWith ev SDL.KeycodeUnderscore -> + if withShift ev + then Just $ ChainMouseClick RightClick + else Just $ TriggerMouseClick RightClick | isKeyPressWith ev SDL.KeycodeSpace -> if withShift ev then Just $ ChainMouseClick LeftClick else Just $ TriggerMouseClick LeftClick - | isKeyPressWith ev SDL.KeycodeTab -> Just ResetKeys + | isKeyPressWith ev SDL.KeycodeTab || isKeyPressWith ev SDL.KeycodeBackspace -> + Just ResetKeys | isKeyPressed ev && isValidKey (eventToKeycode ev) -> Just $ HandleKeyInput $ eventToKeycode ev | isKeyPressWith ev SDL.KeycodeLShift || isKeyPressWith ev SDL.KeycodeRShift -> diff --git a/src/Chelleport/Control.hs b/src/Chelleport/Control.hs index 38b6c53..2723cd2 100644 --- a/src/Chelleport/Control.hs +++ b/src/Chelleport/Control.hs @@ -20,13 +20,14 @@ instance (MonadIO m) => MonadControl (AppM m) where (DrawContext {ctxX11Display = display}) <- ask liftIO $ do -- Wrap with delay to prevent async window close issues. TODO: Remove maybe? - threadDelay 30_000 + threadDelay 20_000 X11.fakeButtonPress display x11Button X11.sync display False - threadDelay 30_000 + threadDelay 20_000 where x11Button = case btn of LeftClick -> X11.button1 + RightClick -> X11.button3 moveMousePointer x y = do DrawContext {ctxWindow = window} <- ask diff --git a/src/Chelleport/Types.hs b/src/Chelleport/Types.hs index 9752552..e648618 100644 --- a/src/Chelleport/Types.hs +++ b/src/Chelleport/Types.hs @@ -40,7 +40,7 @@ data DrawContext = DrawContext ctxX11Display :: X11.Display } -data MouseButtonType = LeftClick +data MouseButtonType = LeftClick | RightClick deriving (Show, Eq) newtype AppM m a = AppM {runAppM :: ReaderT DrawContext m a} |