Add C-v to drag n drop within the grid

4 files changed, 65 insertions, 28 deletions

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)