diff options
| -rw-r--r-- | TODO.norg | 1 | ||||
| -rw-r--r-- | chelleport.cabal | 27 | ||||
| -rw-r--r-- | flake.nix | 2 | ||||
| -rw-r--r-- | justfile | 3 | ||||
| -rw-r--r-- | specs/Mock.hs | 32 | ||||
| -rw-r--r-- | specs/Specs/AppStateUpdateSpec.hs | 9 | ||||
| -rw-r--r-- | src/Chelleport.hs | 9 | ||||
| -rw-r--r-- | src/Chelleport/AppShell.hs | 2 | ||||
| -rw-r--r-- | src/Chelleport/Control.hs | 48 | ||||
| -rw-r--r-- | src/Chelleport/Draw.hs | 17 |
10 files changed, 105 insertions, 45 deletions
@@ -8,3 +8,4 @@ - ( ) Look into making controls cross-platform (remove x11?) * Maybe + - ( ) Scroll diff --git a/chelleport.cabal b/chelleport.cabal index 19c73c6..1397a33 100644 --- a/chelleport.cabal +++ b/chelleport.cabal @@ -16,17 +16,17 @@ Flag release common common-config default-extensions: - ExplicitForAll, - FlexibleContexts, - FlexibleInstances, - GeneralizedNewtypeDeriving, - LambdaCase, - NamedFieldPuns, - NumericUnderscores, - OverloadedStrings, - QuasiQuotes, - TemplateHaskell, - TupleSections, + ExplicitForAll + FlexibleContexts + FlexibleInstances + GeneralizedNewtypeDeriving + LambdaCase + NamedFieldPuns + NumericUnderscores + OverloadedStrings + QuasiQuotes + TemplateHaskell + TupleSections UndecidableInstances default-language: Haskell2010 build-depends: @@ -41,6 +41,7 @@ common warnings -Wall -Wincomplete-record-updates -Wincomplete-uni-patterns -Wunused-foralls -Wextra -Wno-unused-do-bind -Wname-shadowing -fwarn-tabs -fprint-explicit-foralls -fprint-explicit-kinds + extra-libraries: Xtst if flag(release) ghc-options: -O2 -Werror @@ -59,8 +60,7 @@ library lib-chelleport file-embed == 0.0.16.0, sdl2-ttf == 2.1.3, vector == 0.13.1.0, - X11 == 1.10.3, - xtest == 0.2 + X11 == 1.10.3 exposed-modules: Chelleport Chelleport.AppShell @@ -84,5 +84,4 @@ test-suite specs Specs.AppEventSpec build-depends: lib-chelleport, - neat-interpolation, hspec @@ -62,6 +62,8 @@ packages = with pkgs; [ just nodemon + xorg.libXtst + xorg.libX11 ]; }; }; @@ -8,7 +8,8 @@ test *args: cabal test {{args}} testw *args: - nodemon -e .hs -w src --exec 'ghcid -c "cabal repl test:specs" -T :main' + # nodemon -e .hs -w src --exec 'ghcid -c "cabal repl test:specs" -T :main' + nodemon -e .hs -w src -w specs --exec 'clear && just test {{args}}' build: nix build diff --git a/specs/Mock.hs b/specs/Mock.hs index db07e6f..5644a06 100644 --- a/specs/Mock.hs +++ b/specs/Mock.hs @@ -12,16 +12,19 @@ import Foreign.C (CInt) import Test.Hspec data Call - = CallPressMouseButton MouseButtonType - | CallMoveMousePosition CInt CInt + = CallDrawCircle Int (CInt, CInt) + | CallDrawLine (CInt, CInt) (CInt, CInt) + | CallDrawText (CInt, CInt) Color Text | CallGetMousePointerPosition | CallHideWindow + | CallMouseButtonDown + | CallMouseButtonUp + | CallMoveMousePosition CInt CInt + | CallPressMouseButton MouseButtonType + | CallSetDrawColor Color | CallShowWindow | CallShutdownApp - | CallDrawLine (CInt, CInt) (CInt, CInt) - | CallDrawText (CInt, CInt) Color Text - | CallDrawCircle Int (CInt, CInt) - | CallSetDrawColor Color + | CallWindowPosition | CallWindowSize deriving (Show, Eq) @@ -45,13 +48,28 @@ instance (MonadIO m) => MonadControl (TestM m) where pressMouseButton btn = registerMockCall $ CallPressMouseButton btn moveMousePointer x y = registerMockCall $ CallMoveMousePosition x y getMousePointerPosition = (42, 42) <$ registerMockCall CallGetMousePointerPosition + mouseButtonDown = registerMockCall CallMouseButtonDown + mouseButtonUp = registerMockCall CallMouseButtonUp + +mockWindowWidth :: CInt +mockWindowWidth = 1920 + +mockWindowHeight :: CInt +mockWindowHeight = 1080 + +mockWindowOffsetX :: CInt +mockWindowOffsetX = 200 + +mockWindowOffsetY :: CInt +mockWindowOffsetY = 100 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 = 100 <$ registerMockCall CallWindowSize + windowSize = (mockWindowWidth, mockWindowHeight) <$ registerMockCall CallWindowSize + windowPosition = (mockWindowOffsetX, mockWindowOffsetY) <$ registerMockCall CallWindowPosition instance (MonadIO m) => MonadAppShell (TestM m) where hideWindow = registerMockCall CallHideWindow diff --git a/specs/Specs/AppStateUpdateSpec.hs b/specs/Specs/AppStateUpdateSpec.hs index 3f8ca47..fd79c95 100644 --- a/specs/Specs/AppStateUpdateSpec.hs +++ b/specs/Specs/AppStateUpdateSpec.hs @@ -2,7 +2,7 @@ module Specs.AppStateUpdateSpec where import Chelleport (initialState, update) import Chelleport.Types -import Chelleport.Utils (uniq) +import Chelleport.Utils (intToCInt, uniq) import Control.Monad (join) import Mock import qualified SDL @@ -90,6 +90,8 @@ test = do context "with action MoveMousePosition" $ do let currentState = defaultState + let rows = intToCInt $ length $ stateGrid currentState + let columns = intToCInt $ length $ head $ stateGrid currentState -- TODO: Test with inline mocked values it "moves mouse pointer to center of cell of given coordinates" $ do @@ -98,7 +100,10 @@ test = do -- [ CallPressMouseButton LeftClick `returns` (1, 2), -- CallHideWindow `returns` () -- ] - mock `shouldHaveCalled` CallMoveMousePosition 25 25 + mock + `shouldHaveCalled` CallMoveMousePosition + (mockWindowOffsetX + mockWindowWidth `div` columns `div` 2) + (mockWindowOffsetY + mockWindowHeight `div` rows `div` 2) it "does not continue or update state" $ do (result, _) <- runWithMocks $ update currentState $ MoveMousePosition (0, 0) diff --git a/src/Chelleport.hs b/src/Chelleport.hs index d00d112..3f78aba 100644 --- a/src/Chelleport.hs +++ b/src/Chelleport.hs @@ -1,11 +1,9 @@ -{-# LANGUAGE MultiParamTypeClasses #-} - module Chelleport where import Chelleport.AppShell (MonadAppShell (hideWindow, showWindow, shutdownApp), setupAppShell) import Chelleport.Context (initializeContext) -import Chelleport.Control (MonadControl (getMousePointerPosition, moveMousePointer, pressMouseButton), directionalIncrement, eventToKeycode, isKeyPressWith, isKeyPressed, isKeyReleaseWith, withShift) -import Chelleport.Draw (MonadDraw, cellSize) +import Chelleport.Control (MonadControl (getMousePointerPosition, mouseButtonDown, mouseButtonUp, moveMousePointer, pressMouseButton), directionalIncrement, eventToKeycode, isKeyPressWith, isKeyPressed, isKeyReleaseWith, withShift) +import Chelleport.Draw (MonadDraw (windowPosition), cellSize) import Chelleport.KeySequence (findMatchPosition, generateGrid, isValidKey, nextChars, toKeyChar) import Chelleport.Types import Chelleport.Utils (intToCInt) @@ -110,7 +108,8 @@ update state (MoveMousePosition (row, col)) = do (wcell, hcell) <- cellSize state let x = (wcell `div` 2) + wcell * intToCInt col let y = (hcell `div` 2) + hcell * intToCInt row - pure (x, y) + (winx, winy) <- windowPosition + pure (winx + x, winy + y) -- Reset entered key sequence and state update state ResetKeys = do diff --git a/src/Chelleport/AppShell.hs b/src/Chelleport/AppShell.hs index 28007f7..b31c964 100644 --- a/src/Chelleport/AppShell.hs +++ b/src/Chelleport/AppShell.hs @@ -1,5 +1,6 @@ module Chelleport.AppShell (setupAppShell, MonadAppShell (..)) where +import Chelleport.Control (MonadControl (mouseButtonUp)) import Chelleport.Draw (colorBackground) import Chelleport.Types import Control.Monad (foldM) @@ -22,6 +23,7 @@ instance (MonadIO m) => MonadAppShell (AppM m) where ctx <- ask SDL.destroyRenderer $ ctxRenderer ctx SDL.destroyWindow $ ctxWindow ctx + mouseButtonUp liftIO $ do X11.closeDisplay $ ctxX11Display ctx exitSuccess diff --git a/src/Chelleport/Control.hs b/src/Chelleport/Control.hs index 2723cd2..2dcb565 100644 --- a/src/Chelleport/Control.hs +++ b/src/Chelleport/Control.hs @@ -3,39 +3,65 @@ module Chelleport.Control where import Chelleport.Types import Chelleport.Utils (cIntToInt) import Control.Concurrent (threadDelay) +import Control.Monad (unless) import Control.Monad.IO.Class (MonadIO (liftIO)) import Control.Monad.Reader (MonadReader (ask)) -import Foreign.C (CInt) +import qualified Debug.Trace as Debug +import Foreign.C.Types import qualified Graphics.X11 as X11 -import qualified Graphics.X11.XTest as X11 import qualified SDL class (Monad m) => MonadControl m where pressMouseButton :: MouseButtonType -> m () moveMousePointer :: CInt -> CInt -> m () + mouseButtonDown :: m () + mouseButtonUp :: 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 + where + delay = liftIO (threadDelay 20_000) + instance (MonadIO m) => MonadControl (AppM m) where pressMouseButton btn = do (DrawContext {ctxX11Display = display}) <- ask - liftIO $ do - -- Wrap with delay to prevent async window close issues. TODO: Remove maybe? - threadDelay 20_000 - X11.fakeButtonPress display x11Button + withDelay . liftIO $ do + xSimulateButtonEvent display x11Button True 0 + xSimulateButtonEvent display x11Button False 0 X11.sync display False - threadDelay 20_000 where x11Button = case btn of LeftClick -> X11.button1 RightClick -> X11.button3 moveMousePointer x y = do - DrawContext {ctxWindow = window} <- ask - SDL.warpMouse (SDL.WarpInWindow window) (SDL.P $ SDL.V2 x y) + SDL.warpMouse SDL.WarpGlobal (SDL.P $ SDL.V2 x y) getMousePointerPosition = do - (SDL.P (SDL.V2 x y)) <- SDL.getAbsoluteMouseLocation - pure (x, y) + DrawContext {ctxX11Display = display} <- ask + liftIO $ do + win <- X11.rootWindow display $ X11.defaultScreen display + (success, _, _, x, y, _, _, _) <- X11.queryPointer display win + unless success $ do + Debug.traceM "ERROR: Cant query pointer" + pure (x, y) + + mouseButtonDown = do + (DrawContext {ctxX11Display = display}) <- ask + withDelay . liftIO $ do + xSimulateButtonEvent display X11.button1 True 0 + X11.sync display False + + mouseButtonUp = do + (DrawContext {ctxX11Display = display}) <- ask + withDelay . liftIO $ do + xSimulateButtonEvent display X11.button1 False 0 + X11.sync display False isKeyPressed :: SDL.KeyboardEventData -> Bool isKeyPressed = (== SDL.Pressed) . SDL.keyboardEventKeyMotion diff --git a/src/Chelleport/Draw.hs b/src/Chelleport/Draw.hs index 2fdb311..cba040a 100644 --- a/src/Chelleport/Draw.hs +++ b/src/Chelleport/Draw.hs @@ -16,7 +16,8 @@ class (Monad m) => MonadDraw m where drawText :: (CInt, CInt) -> SDL.V4 Word8 -> Text -> m (CInt, CInt) drawCircle :: Int -> (CInt, CInt) -> m () setDrawColor :: SDL.V4 Word8 -> m () - windowSize :: m (SDL.V2 CInt) + windowSize :: m (CInt, CInt) + windowPosition :: m (CInt, CInt) instance (MonadIO m) => MonadDraw (AppM m) where drawLine (x1, y1) (x2, y2) = do @@ -56,23 +57,29 @@ instance (MonadIO m) => MonadDraw (AppM m) where let points = Vector.generate renderedPoints (SDL.P . toPointOnCircle) SDL.drawPoints renderer points - windowSize = ask >>= SDL.get . SDL.windowSize . ctxWindow + windowSize = do + SDL.V2 x y <- ask >>= SDL.get . SDL.windowSize . ctxWindow + pure (x, y) + + windowPosition = do + SDL.V2 x y <- ask >>= SDL.getWindowAbsolutePosition . ctxWindow + pure (x, y) cellSize :: (MonadDraw m) => State -> m (CInt, CInt) cellSize (State {stateGrid}) = do - (SDL.V2 width height) <- windowSize + (width, height) <- windowSize let wcell = width `div` intToCInt (length $ head stateGrid) let hcell = height `div` intToCInt (length stateGrid) pure (wcell, hcell) drawHorizontalLine :: (MonadDraw m) => CInt -> m () drawHorizontalLine y = do - (SDL.V2 width _) <- windowSize + (width, _) <- windowSize drawLine (0, y) (width, y) drawVerticalLine :: (MonadDraw m) => CInt -> m () drawVerticalLine x = do - (SDL.V2 _width height) <- windowSize + (_, height) <- windowSize drawLine (x, 0) (x, height) colorWhite :: SDL.V4 Word8 |