aboutsummaryrefslogtreecommitdiff
diff options
context:
space:
mode:
Diffstat (limited to '')
-rw-r--r--specs/Specs/AppEventSpec.hs2
-rw-r--r--specs/Specs/AppStateUpdateSpec.hs31
-rw-r--r--src/Chelleport.hs22
-rw-r--r--src/Chelleport/AppShell.hs10
-rw-r--r--src/Chelleport/Types.hs12
5 files changed, 41 insertions, 36 deletions
diff --git a/specs/Specs/AppEventSpec.hs b/specs/Specs/AppEventSpec.hs
index 18e685b..3cdbe94 100644
--- a/specs/Specs/AppEventSpec.hs
+++ b/specs/Specs/AppEventSpec.hs
@@ -39,7 +39,7 @@ test = do
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
+ action `shouldBe` Just (TriggerMouseClick LeftClick)
context "when tab key is pressed" $ do
it "resets key state" $ do
diff --git a/specs/Specs/AppStateUpdateSpec.hs b/specs/Specs/AppStateUpdateSpec.hs
index d8502db..3f8ca47 100644
--- a/specs/Specs/AppStateUpdateSpec.hs
+++ b/specs/Specs/AppStateUpdateSpec.hs
@@ -2,6 +2,8 @@ module Specs.AppStateUpdateSpec where
import Chelleport (initialState, update)
import Chelleport.Types
+import Chelleport.Utils (uniq)
+import Control.Monad (join)
import Mock
import qualified SDL
import Test.Hspec
@@ -11,13 +13,20 @@ 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
+ it "returns grid with 16x9 key sequences" $ do
+ (initState, _) <- runWithMocks initialState
+ length (stateGrid initState) `shouldBe` 9
+ stateGrid initState `shouldSatisfy` all ((== 16) . length)
+ stateGrid initState `shouldSatisfy` all (all ((== 2) . length))
+
+ it "returns grid with all unique key sequences" $ do
+ (initState, _) <- runWithMocks initialState
+ join (stateGrid initState) `shouldBe` uniq (join $ stateGrid initState)
+
describe "#update" $ do
let defaultState =
State
@@ -55,27 +64,27 @@ test = do
((_, action), _) <- runWithMocks $ update currentState $ HandleKeyInput SDL.KeycodeF
action `shouldBe` Just (MoveMousePosition (0, 1))
- context "with action TriggerLeftClick" $ do
+ context "with action TriggerMouseClick" $ do
let currentState = defaultState
- it "hides window and triggers left click" $ do
- (_, mock) <- runWithMocks $ update currentState TriggerLeftClick
+ it "hides window and triggers mouse click" $ do
+ (_, mock) <- runWithMocks $ update currentState $ TriggerMouseClick LeftClick
calls mock `shouldContain` [CallHideWindow, CallPressMouseButton LeftClick]
it "continues with action ShutdownApp without updating state" $ do
- ((nextState, action), _) <- runWithMocks $ update currentState TriggerLeftClick
+ ((nextState, action), _) <- runWithMocks $ update currentState $ TriggerMouseClick LeftClick
action `shouldBe` Just ShutdownApp
nextState `shouldBe` currentState
- context "with action ChainLeftClick" $ do
+ context "with action ChainMouseClick" $ do
let currentState = defaultState
- it "hides window, triggers left click and shows the window again" $ do
- (_, mock) <- runWithMocks $ update currentState ChainLeftClick
+ 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]
it "continues with action ResetKeys without updating state" $ do
- ((nextState, action), _) <- runWithMocks $ update currentState ChainLeftClick
+ ((nextState, action), _) <- runWithMocks $ update currentState $ ChainMouseClick LeftClick
action `shouldBe` Just ResetKeys
nextState `shouldBe` currentState
diff --git a/src/Chelleport.hs b/src/Chelleport.hs
index 6c06af4..ae5ec6e 100644
--- a/src/Chelleport.hs
+++ b/src/Chelleport.hs
@@ -32,7 +32,7 @@ run = do
(const eventHandler)
(runEff ctx . Chelleport.View.render)
-initialState :: (MonadIO m) => m State
+initialState :: (Monad m) => m State
initialState = do
let cells = fromMaybe (pure undefined) $ generateGrid 0 (rows, columns) hintKeys
pure $
@@ -55,8 +55,8 @@ eventHandler event =
| isKeyPressWith ev SDL.KeycodeEscape -> Just ShutdownApp
| isKeyPressWith ev SDL.KeycodeSpace ->
if withShift ev
- then Just ChainLeftClick
- else Just TriggerLeftClick
+ then Just $ ChainMouseClick LeftClick
+ else Just $ TriggerMouseClick LeftClick
| isKeyPressWith ev SDL.KeycodeTab -> Just ResetKeys
| isKeyPressed ev && isValidKey (eventToKeycode ev) ->
Just $ HandleKeyInput $ eventToKeycode ev
@@ -66,11 +66,7 @@ eventHandler event =
Just $ UpdateShiftState False
_ -> Nothing
-update ::
- (MonadAppShell m, MonadDraw m, MonadControl m) =>
- State ->
- AppAction ->
- m (State, Maybe AppAction)
+update :: (MonadAppShell m, MonadDraw m, MonadControl m) => State -> AppAction -> m (State, Maybe AppAction)
-- Act on key inputs
update state (HandleKeyInput key) = do
case (toKeyChar key, validChars) of
@@ -115,16 +111,16 @@ update state (MoveMousePosition (row, col)) = do
update state ResetKeys = do
pure (state {stateKeySequence = [], stateIsMatched = False}, Nothing)
--- Trigger left click
-update state TriggerLeftClick = do
+-- Trigger click
+update state (TriggerMouseClick btn) = do
hideWindow
- pressMouseButton LeftClick
+ pressMouseButton btn
pure (state, Just ShutdownApp)
-- Chain clicks
-update state ChainLeftClick = do
+update state (ChainMouseClick btn) = do
hideWindow
- pressMouseButton LeftClick
+ pressMouseButton btn
showWindow
pure (state, Just ResetKeys)
diff --git a/src/Chelleport/AppShell.hs b/src/Chelleport/AppShell.hs
index e8cd3ab..28007f7 100644
--- a/src/Chelleport/AppShell.hs
+++ b/src/Chelleport/AppShell.hs
@@ -1,4 +1,4 @@
-module Chelleport.AppShell where
+module Chelleport.AppShell (setupAppShell, MonadAppShell (..)) where
import Chelleport.Draw (colorBackground)
import Chelleport.Types
@@ -26,6 +26,14 @@ instance (MonadIO m) => MonadAppShell (AppM m) where
X11.closeDisplay $ ctxX11Display ctx
exitSuccess
+type Update state appAction = state -> appAction -> IO (state, Maybe appAction)
+
+type EventHandler state appAction = state -> SDL.Event -> Maybe appAction
+
+type View state = state -> IO ()
+
+type Initializer state = IO state
+
setupAppShell ::
DrawContext ->
Initializer state ->
diff --git a/src/Chelleport/Types.hs b/src/Chelleport/Types.hs
index ca17c23..9752552 100644
--- a/src/Chelleport/Types.hs
+++ b/src/Chelleport/Types.hs
@@ -26,8 +26,8 @@ data AppAction
= HandleKeyInput SDL.Keycode
| MoveMousePosition (Int, Int)
| ResetKeys
- | TriggerLeftClick
- | ChainLeftClick
+ | TriggerMouseClick MouseButtonType
+ | ChainMouseClick MouseButtonType
| IncrementMouseCursor (Int, Int)
| ShutdownApp
| UpdateShiftState Bool
@@ -40,14 +40,6 @@ data DrawContext = DrawContext
ctxX11Display :: X11.Display
}
-type Update state appAction = state -> appAction -> IO (state, Maybe appAction)
-
-type EventHandler state appAction = state -> SDL.Event -> Maybe appAction
-
-type View state = state -> IO ()
-
-type Initializer state = IO state
-
data MouseButtonType = LeftClick
deriving (Show, Eq)