aboutsummaryrefslogtreecommitdiff
diff options
context:
space:
mode:
Diffstat (limited to '')
-rw-r--r--TODO.norg1
-rw-r--r--chelleport.cabal6
-rw-r--r--specs/Main.hs2
-rw-r--r--specs/Mock.hs11
-rw-r--r--specs/Specs/AppEventSpec.hs68
-rw-r--r--specs/Specs/AppStateUpdateSpec.hs113
-rw-r--r--specs/Specs/KeySequenceSpec.hs2
-rw-r--r--src/Chelleport.hs10
8 files changed, 196 insertions, 17 deletions
diff --git a/TODO.norg b/TODO.norg
index 5f18d5c..4aa978e 100644
--- a/TODO.norg
+++ b/TODO.norg
@@ -1,7 +1,6 @@
* Current
- ( ) Multimonitor mouse move issue
- ( ) Right click
- - ( ) Tests
* Later
- ( ) Double click
diff --git a/chelleport.cabal b/chelleport.cabal
index ebca222..2ea0a44 100644
--- a/chelleport.cabal
+++ b/chelleport.cabal
@@ -33,6 +33,7 @@ common common-config
base,
text,
mtl == 2.3.1,
+ sdl2 == 2.5.5.0,
containers
common warnings
@@ -56,7 +57,6 @@ library lib-chelleport
build-depends:
bytestring,
file-embed == 0.0.16.0,
- sdl2 == 2.5.5.0,
sdl2-ttf == 2.1.3,
vector == 0.13.1.0,
X11 == 1.10.3,
@@ -73,12 +73,14 @@ library lib-chelleport
Chelleport.View
test-suite specs
- import: common-config
+ import: common-config, warnings
type: exitcode-stdio-1.0
hs-source-dirs: specs
main-is: Main.hs
other-modules:
+ Mock
Specs.KeySequenceSpec
+ Specs.AppStateUpdateSpec
build-depends:
lib-chelleport,
neat-interpolation,
diff --git a/specs/Main.hs b/specs/Main.hs
index 5253fb9..4308669 100644
--- a/specs/Main.hs
+++ b/specs/Main.hs
@@ -1,5 +1,6 @@
module Main (main) where
+import qualified Specs.AppEventSpec
import qualified Specs.AppStateUpdateSpec
import qualified Specs.KeySequenceSpec
import Test.Hspec (hspec)
@@ -8,3 +9,4 @@ main :: IO ()
main = hspec $ do
Specs.KeySequenceSpec.test
Specs.AppStateUpdateSpec.test
+ Specs.AppEventSpec.test
diff --git a/specs/Mock.hs b/specs/Mock.hs
index 7dad452..db07e6f 100644
--- a/specs/Mock.hs
+++ b/specs/Mock.hs
@@ -6,9 +6,10 @@ import Chelleport.Draw (MonadDraw (..))
import Chelleport.Types
import Control.Monad (void)
import Control.Monad.IO.Class (MonadIO)
-import Control.Monad.State (MonadState (get, state), StateT (runStateT), gets)
+import Control.Monad.State (MonadState (state), StateT (runStateT))
import Data.Text (Text)
import Foreign.C (CInt)
+import Test.Hspec
data Call
= CallPressMouseButton MouseButtonType
@@ -25,11 +26,15 @@ data Call
deriving (Show, Eq)
newtype MockCalls = MockCalls {calls :: [Call]}
+ deriving (Show)
registerMockCall :: (MonadState MockCalls m) => Call -> m ()
registerMockCall call =
void $ state (\mock -> ((), MockCalls {calls = calls mock ++ [call]}))
+shouldHaveCalled :: (HasCallStack) => MockCalls -> Call -> Expectation
+shouldHaveCalled mock call = calls mock `shouldContain` [call]
+
runWithMocks :: (MonadIO m) => TestM m a -> m (a, MockCalls)
runWithMocks action = runStateT (runTestM action) (MockCalls [])
@@ -39,14 +44,14 @@ newtype TestM m a = TestM {runTestM :: StateT MockCalls m a}
instance (MonadIO m) => MonadControl (TestM m) where
pressMouseButton btn = registerMockCall $ CallPressMouseButton btn
moveMousePointer x y = registerMockCall $ CallMoveMousePosition x y
- getMousePointerPosition = (0, 0) <$ registerMockCall CallGetMousePointerPosition
+ getMousePointerPosition = (42, 42) <$ registerMockCall CallGetMousePointerPosition
instance (MonadIO m) => MonadDraw (TestM m) where
drawLine p1 p2 = registerMockCall $ CallDrawLine p1 p2
drawText p color text = (0, 0) <$ registerMockCall (CallDrawText p color text)
drawCircle radius p = registerMockCall $ CallDrawCircle radius p
setDrawColor color = registerMockCall $ CallSetDrawColor color
- windowSize = 0 <$ registerMockCall CallWindowSize
+ windowSize = 100 <$ registerMockCall CallWindowSize
instance (MonadIO m) => MonadAppShell (TestM m) where
hideWindow = registerMockCall CallHideWindow
diff --git a/specs/Specs/AppEventSpec.hs b/specs/Specs/AppEventSpec.hs
new file mode 100644
index 0000000..9ac9d4c
--- /dev/null
+++ b/specs/Specs/AppEventSpec.hs
@@ -0,0 +1,68 @@
+module Specs.AppEventSpec where
+
+import Chelleport (eventHandler)
+import Chelleport.Types
+import qualified SDL
+import SDL.Internal.Numbered (FromNumber (fromNumber))
+import Test.Hspec
+import Unsafe.Coerce (unsafeCoerce)
+
+test :: SpecWith ()
+test = do
+ describe "#eventHandler" $ do
+ let mkEvent payload = SDL.Event {SDL.eventTimestamp = 0, SDL.eventPayload = payload}
+ let mkKeyboardEvent key motion =
+ mkEvent $
+ SDL.KeyboardEvent $
+ SDL.KeyboardEventData
+ { SDL.keyboardEventWindow = unsafeCoerce (0 :: Integer),
+ SDL.keyboardEventRepeat = False,
+ SDL.keyboardEventKeysym =
+ SDL.Keysym
+ { SDL.keysymScancode = SDL.Scancode0,
+ SDL.keysymModifier = fromNumber 0,
+ SDL.keysymKeycode = key
+ },
+ SDL.keyboardEventKeyMotion = motion
+ }
+
+ context "when window quit event is triggered" $ do
+ it "shuts down app" $ do
+ let action = eventHandler $ mkEvent SDL.QuitEvent
+ action `shouldBe` Just ShutdownApp
+
+ context "when q key is pressed" $ do
+ it "shuts down app" $ do
+ let action = eventHandler $ mkKeyboardEvent SDL.KeycodeQ SDL.Pressed
+ action `shouldBe` Just ShutdownApp
+
+ context "when escape key is pressed" $ do
+ it "shuts down app" $ do
+ let action = eventHandler $ mkKeyboardEvent SDL.KeycodeEscape SDL.Pressed
+ 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
+ action `shouldBe` Just TriggerLeftClick
+
+ context "when tab key is pressed" $ do
+ it "resets key state" $ do
+ let action = eventHandler $ mkKeyboardEvent SDL.KeycodeTab SDL.Pressed
+ 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.KeycodeB SDL.Pressed) `shouldBe` Just (HandleKeyInput SDL.KeycodeB)
+ eventHandler (mkKeyboardEvent SDL.Keycode9 SDL.Pressed) `shouldBe` Just (HandleKeyInput SDL.Keycode9)
+
+ context "when shift key is pressed" $ do
+ it "enables shift" $ do
+ let action = eventHandler $ mkKeyboardEvent SDL.KeycodeRShift SDL.Pressed
+ action `shouldBe` Just (UpdateShiftState True)
+
+ context "when shift key is released" $ do
+ it "disabled shift" $ do
+ let action = eventHandler $ mkKeyboardEvent SDL.KeycodeRShift SDL.Released
+ action `shouldBe` Just (UpdateShiftState False)
diff --git a/specs/Specs/AppStateUpdateSpec.hs b/specs/Specs/AppStateUpdateSpec.hs
index 0b5cac0..169cd8b 100644
--- a/specs/Specs/AppStateUpdateSpec.hs
+++ b/specs/Specs/AppStateUpdateSpec.hs
@@ -1,20 +1,123 @@
module Specs.AppStateUpdateSpec where
-import Chelleport (update)
+import Chelleport (initialState, update)
import Chelleport.Types
import Mock
+import qualified SDL
import Test.Hspec
+test :: SpecWith ()
test = do
+ describe "#initialState" $ do
+ it "returns the initial state of the app" $ do
+ (initState, _) <- runWithMocks initialState
+ length (stateGrid initState) `shouldBe` 9
+ stateGrid initState `shouldSatisfy` all ((== 16) . length)
+ stateGrid initState `shouldSatisfy` all (all ((== 2) . length))
+ stateKeySequence initState `shouldBe` []
+ stateIsMatched initState `shouldBe` False
+ stateIsShiftPressed initState `shouldBe` False
+
describe "#update" $ do
+ let defaultState =
+ State
+ { stateKeySequence = [],
+ stateIsShiftPressed = False,
+ stateIsMatched = False,
+ stateGrid = [["ABC", "DEF"], ["DJK", "JKL"]]
+ }
+
+ context "with action HandleKeyInput" $ do
+ context "when there are no matches" $ do
+ let currentState = defaultState {stateKeySequence = "D"}
+
+ context "when input key sequence has matching values in grid" $ do
+ it "does not update" $ do
+ ((nextState, action), _) <- runWithMocks $ update currentState $ HandleKeyInput SDL.KeycodeZ
+ action `shouldBe` Nothing
+ nextState `shouldBe` currentState
+
+ context "when input key sequence does not have matching values in grid" $ do
+ it "adds key to key sequence" $ do
+ ((nextState, action), _) <- runWithMocks $ update currentState $ HandleKeyInput SDL.KeycodeE
+ action `shouldBe` Nothing
+ nextState `shouldBe` currentState {stateKeySequence = "DE"}
+
+ context "when there is a matches" $ do
+ let currentState = defaultState {stateKeySequence = "DE"}
+
+ context "when input key sequence does not have matching values in grid" $ do
+ it "adds key to key sequence and enables isMatched" $ do
+ ((nextState, _), _) <- runWithMocks $ update currentState $ HandleKeyInput SDL.KeycodeF
+ nextState `shouldBe` currentState {stateKeySequence = "DEF", stateIsMatched = True}
+
+ it "continues with MoveMousePosition action" $ do
+ ((_, action), _) <- runWithMocks $ update currentState $ HandleKeyInput SDL.KeycodeF
+ action `shouldBe` Just (MoveMousePosition (0, 1))
+
context "with action TriggerLeftClick" $ do
- let state = State {stateKeySequence = [], stateIsShiftPressed = False, stateIsMatched = False, stateGrid = []}
+ let currentState = defaultState
it "hides window and triggers left clicks" $ do
- (_, mock) <- runWithMocks $ update state TriggerLeftClick
+ (_, mock) <- runWithMocks $ update currentState TriggerLeftClick
calls mock `shouldContain` [CallHideWindow, CallPressMouseButton LeftClick]
it "continues with action ShutdownApp without updating state" $ do
- ((state, action), mock) <- runWithMocks $ update state TriggerLeftClick
+ ((nextState, action), _) <- runWithMocks $ update currentState TriggerLeftClick
+ -- handleMocks
+ -- [ CallPressMouseButton LeftClick `returns` (1, 2),
+ -- CallHideWindow `returns` ()
+ -- ]
action `shouldBe` Just ShutdownApp
- state `shouldBe` state
+ nextState `shouldBe` currentState
+
+ context "with action MoveMousePosition" $ do
+ let currentState = defaultState
+
+ -- TODO: Test with inline mocked values
+ it "moves mouse pointer to center of cell of given coordinates" $ do
+ (_, mock) <- runWithMocks $ update currentState $ MoveMousePosition (0, 0)
+ mock `shouldHaveCalled` CallMoveMousePosition 25 25
+
+ it "does not continue or update state" $ do
+ (result, _) <- runWithMocks $ update currentState $ MoveMousePosition (0, 0)
+ result `shouldBe` (currentState, Nothing)
+
+ context "with action ResetKeys" $ do
+ let currentState = defaultState
+
+ it "resets state without any action" $ do
+ ((nextState, action), _) <- runWithMocks $ update currentState ResetKeys
+ action `shouldBe` Nothing
+ nextState `shouldBe` currentState {stateKeySequence = [], stateIsMatched = False}
+
+ context "with action IncrementMouseCursor" $ do
+ let currentState = defaultState
+
+ -- TODO: Test with inline mocked values
+ it "hides window and triggers left clicks" $ do
+ (_, mock) <- runWithMocks $ update currentState $ IncrementMouseCursor (10, -20)
+ mock `shouldHaveCalled` CallMoveMousePosition 52 22
+
+ it "does not continue or update state" $ do
+ (result, _) <- runWithMocks $ update currentState $ IncrementMouseCursor (0, 0)
+ result `shouldBe` (currentState, Nothing)
+
+ context "with action ShutdownApp" $ do
+ let currentState = defaultState
+
+ it "hides window and triggers left clicks" $ do
+ (_, mock) <- runWithMocks $ update currentState ShutdownApp
+ mock `shouldHaveCalled` CallShutdownApp
+
+ it "does not continue or update state" $ do
+ (result, _) <- runWithMocks $ update currentState ShutdownApp
+ result `shouldBe` (currentState, Nothing)
+
+ context "with action UpdateShiftState" $ do
+ let currentState = defaultState
+
+ it "updates shift state without any action" $ do
+ ((nextState, action), _) <- runWithMocks $ update currentState $ UpdateShiftState True
+ action `shouldBe` Nothing
+ nextState `shouldBe` currentState {stateIsShiftPressed = True}
diff --git a/specs/Specs/KeySequenceSpec.hs b/specs/Specs/KeySequenceSpec.hs
index 2efbece..7a92105 100644
--- a/specs/Specs/KeySequenceSpec.hs
+++ b/specs/Specs/KeySequenceSpec.hs
@@ -1,9 +1,9 @@
module Specs.KeySequenceSpec where
import Chelleport.KeySequence (findMatchPosition, generateGrid, nextChars)
-import qualified Debug.Trace as Debug
import Test.Hspec
+test :: SpecWith ()
test = do
describe "#nextChars" $ do
context "when there is a partial match" $ do
diff --git a/src/Chelleport.hs b/src/Chelleport.hs
index 6b443b5..98d1aa6 100644
--- a/src/Chelleport.hs
+++ b/src/Chelleport.hs
@@ -30,7 +30,7 @@ run = do
ctx
(runEff ctx initialState)
(\state -> runEff ctx . update state)
- eventToAction
+ (const eventHandler)
(runEff ctx . Chelleport.View.render)
initialState :: (MonadIO m) => m State
@@ -48,8 +48,8 @@ initialState = do
columns = 16
hintKeys = ['A' .. 'Z'] \\ "Q"
-eventToAction :: EventHandler State AppAction
-eventToAction _state event =
+eventHandler :: SDL.Event -> Maybe AppAction
+eventHandler event =
case SDL.eventPayload event of
SDL.QuitEvent -> Just ShutdownApp
SDL.KeyboardEvent ev
@@ -72,8 +72,8 @@ update ::
m (State, Maybe AppAction)
-- Act on key inputs
update state (HandleKeyInput key) = do
- case liftA2 (,) (toKeyChar key) validChars of
- Just (keyChar, validChars')
+ case (toKeyChar key, validChars) of
+ (Just keyChar, Just validChars')
| stateIsMatched state && keyChar `elem` ("HJKL" :: String) -> do
incr <- incrementValue
let action = IncrementMouseCursor $ directionalIncrement incr keyChar