diff options
| -rw-r--r-- | README.md | 2 | ||||
| -rw-r--r-- | TODO.norg | 10 | ||||
| -rw-r--r-- | chelleport.cabal | 4 | ||||
| -rw-r--r-- | flake.nix | 9 | ||||
| -rw-r--r-- | justfile | 2 | ||||
| -rw-r--r-- | src/Chelleport.hs | 54 | ||||
| -rw-r--r-- | src/Chelleport/AppShell.hs | 38 | ||||
| -rw-r--r-- | src/Chelleport/Context.hs | 49 | ||||
| -rw-r--r-- | src/Chelleport/Control.hs | 8 | ||||
| -rw-r--r-- | src/Chelleport/Draw.hs | 26 | ||||
| -rw-r--r-- | src/Chelleport/KeySequence.hs | 29 | ||||
| -rw-r--r-- | src/Chelleport/Types.hs | 6 | ||||
| -rw-r--r-- | src/Chelleport/Utils.hs | 24 | ||||
| -rw-r--r-- | src/Chelleport/View.hs | 31 |
14 files changed, 183 insertions, 109 deletions
@@ -1,4 +1,4 @@ # Chelleport -WIP +Use your mouse with your keyboard. @@ -1,11 +1,13 @@ * Current - - (x) Center cursor inside grid cells - ( ) After 3 keys, 2nd level navigation (allow hjkl to move) - -* Later - - ( ) Highlight only the ones that are selected. Dim others - ( ) Include font and embed in build - ( ) Multimonitor mouse move issue +* Later + - ( ) Right click + - ( ) Double click + - ( ) Middle click + * Maybe - ( ) Move cursor on the first 2 keys to the center of the section + - ( ) Select / drag n drop diff --git a/chelleport.cabal b/chelleport.cabal index 488898e..105bdbe 100644 --- a/chelleport.cabal +++ b/chelleport.cabal @@ -11,8 +11,8 @@ description: Mouse control common common-config default-extensions: + ExplicitForAll, OverloadedStrings, - LambdaCase, QuasiQuotes, TemplateHaskell, TupleSections, @@ -53,6 +53,7 @@ library lib-chelleport Chelleport.Draw Chelleport.KeySequence Chelleport.Types + Chelleport.Utils Chelleport.View test-suite specs @@ -65,5 +66,4 @@ test-suite specs build-depends: lib-chelleport, neat-interpolation, - pretty-simple, hspec @@ -7,13 +7,16 @@ outputs = inputs@{ self, nixpkgs, flake-parts, ... }: flake-parts.lib.mkFlake { inherit inputs; } { systems = nixpkgs.lib.systems.flakeExposed; - imports = [ inputs.haskell-flake.flakeModule ]; + imports = [ + inputs.haskell-flake.flakeModule + ]; perSystem = { self', pkgs, lib, config, ... }: { haskellProjects.default = { projectRoot = builtins.toString (lib.fileset.toSource { root = ./.; fileset = lib.fileset.unions [ + ./bin ./src ./specs ./chelleport.cabal @@ -25,7 +28,7 @@ devShell = { # tools = hp: { fourmolu = hp.fourmolu; ghcid = null; }; - hlsCheck.enable = pkgs.stdenv.isDarwin; + hlsCheck.enable = false; }; autoWire = [ "packages" "apps" "checks" ]; @@ -40,7 +43,7 @@ ]; packages = with pkgs; [ just - haskellPackages.hspec-golden + nodemon ]; }; }; @@ -8,7 +8,7 @@ test: cabal test testw: - npx 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' build: nix build diff --git a/src/Chelleport.hs b/src/Chelleport.hs index c944dbd..c1547d7 100644 --- a/src/Chelleport.hs +++ b/src/Chelleport.hs @@ -1,12 +1,13 @@ module Chelleport where -import Chelleport.AppShell (Action (AppAction, SysQuit), hideWindow, setupAppShell, shutdownApp) +import Chelleport.AppShell (Action (AppAction, SysQuit), EventHandler, Update, hideWindow, setupAppShell) import Chelleport.Control (isKeyPress, isKeyPressWith, moveMouse, triggerMouseLeftClick) +import Chelleport.Draw (windowSize) import Chelleport.KeySequence (eventToKeycode, findMatchPosition, generateKeyCells, isValidKey, nextChars, toKeyChar) import Chelleport.Types +import Chelleport.Utils (intToCInt) import qualified Chelleport.View import qualified SDL -import Unsafe.Coerce (unsafeCoerce) open :: IO () open = setupAppShell initialState update eventToAction Chelleport.View.render @@ -16,43 +17,48 @@ initialState _ctx = do let cells = generateKeyCells (rows, columns) hintKeys pure $ State {stateCells = cells, stateKeySequence = []} where - rows = 16 - columns = 16 + rows = 12 + columns = 12 hintKeys = "ABCDEFGHIJKLMNOPRSTUVWXYZ1234567890" -update :: State -> DrawContext -> AppAction -> IO State -update state _ctx ResetKeys = pure state {stateKeySequence = []} -update state ctx TriggerLeftClick = do - hideWindow ctx - triggerMouseLeftClick ctx - shutdownApp ctx - pure state -update state ctx (FilterSequence key) = +update :: Update State AppAction +update state _ctx (FilterSequence key) = case liftA2 (,) (toKeyChar key) validChars of Just (keyChar, validChars') | keyChar `elem` validChars' -> do let newKeySequence = stateKeySequence state ++ [keyChar] let matchPosition = findMatchPosition newKeySequence $ stateCells state - maybe (pure ()) moveMouseToCell matchPosition - pure state {stateKeySequence = newKeySequence} - _ -> pure state + pure + ( state {stateKeySequence = newKeySequence}, + AppAction . MoveMousePosition <$> matchPosition + ) + _ -> pure (state, Nothing) where validChars = nextChars (stateKeySequence state) (stateCells state) - +update state ctx (MoveMousePosition (row, col)) = do + (x, y) <- getPosition + moveMouse ctx x y + pure (state, Nothing) + where cellDimensions = do - (SDL.V2 width height) <- SDL.get $ SDL.windowSize $ ctxWindow ctx + (SDL.V2 width height) <- windowSize ctx let rows = stateCells state - let wcell = width `div` unsafeCoerce (length $ head rows) - let hcell = height `div` unsafeCoerce (length rows) + let wcell = width `div` intToCInt (length $ head rows) + let hcell = height `div` intToCInt (length rows) pure (wcell, hcell) - moveMouseToCell (row, col) = do + getPosition = do (wcell, hcell) <- cellDimensions - let x = (wcell `div` 2) + wcell * unsafeCoerce col - let y = (hcell `div` 2) + hcell * unsafeCoerce row - moveMouse ctx x y + let x = (wcell `div` 2) + wcell * intToCInt col + let y = (hcell `div` 2) + hcell * intToCInt row + pure (x, y) +update state _ctx ResetKeys = pure (state {stateKeySequence = []}, Nothing) +update state ctx TriggerLeftClick = do + hideWindow ctx + triggerMouseLeftClick ctx + pure (state, Just SysQuit) -eventToAction :: State -> SDL.Event -> Maybe (Action AppAction) +eventToAction :: EventHandler State AppAction eventToAction _state event = case SDL.eventPayload event of SDL.QuitEvent -> Just SysQuit diff --git a/src/Chelleport/AppShell.hs b/src/Chelleport/AppShell.hs index 0a5bdfe..897af83 100644 --- a/src/Chelleport/AppShell.hs +++ b/src/Chelleport/AppShell.hs @@ -14,38 +14,54 @@ data Action act = SysQuit | AppAction act newtype SysState = SysState {sysExit :: Bool} +type Update state appAction = state -> DrawContext -> appAction -> IO (state, Maybe (Action appAction)) + +type EventHandler state appAction = state -> SDL.Event -> Maybe (Action appAction) + +type View state = state -> DrawContext -> IO () + +type Initializer state = DrawContext -> IO state + setupAppShell :: - (DrawContext -> IO state) -> - (state -> DrawContext -> appAction -> IO state) -> - (state -> SDL.Event -> Maybe (Action appAction)) -> - (state -> DrawContext -> IO ()) -> + -- forall state appAction. + Initializer state -> + Update state appAction -> + EventHandler state appAction -> + View state -> IO () setupAppShell initState update eventHandler draw = do -- Initialize SDL SDL.initializeAll TTF.initialize - ctx <- initializeContext state <- initState ctx + appLoop ctx (state, SysState {sysExit = False}) shutdownApp ctx where appLoop drawCtx (state, sysState) = do - events <- SDL.pollEvents - SDL.rendererDrawColor (ctxRenderer drawCtx) $= colorBackground SDL.clear $ ctxRenderer drawCtx draw state drawCtx SDL.present $ ctxRenderer drawCtx + events <- SDL.pollEvents + (newState, newSysState) <- foldM (evaluateEvent drawCtx) (state, sysState) events - unless (sysExit newSysState) $ appLoop drawCtx (newState, newSysState) - evaluateEvent drawCtx stTup event = maybe (pure stTup) (updateState drawCtx stTup) (eventHandler (fst stTup) event) + unless (sysExit newSysState) $ + appLoop drawCtx (newState, newSysState) + + evaluateEvent drawCtx stTup event = + maybe (pure stTup) (updateState drawCtx stTup) (eventHandler (fst stTup) event) + + evalUpdateResult _drawCtx sysState (state, Nothing) = pure (state, sysState) + evalUpdateResult drawCtx sysState (state, Just action) = updateState drawCtx (state, sysState) action - updateState _drawCtx (state, sysState) SysQuit = pure (state, sysState {sysExit = True}) - updateState drawCtx (state, sysState) (AppAction action) = (,sysState) <$> update state drawCtx action + updateState _ (state, sysState) SysQuit = pure (state, sysState {sysExit = True}) + updateState drawCtx (state, sysState) (AppAction action) = + update state drawCtx action >>= evalUpdateResult drawCtx sysState hideWindow :: DrawContext -> IO () hideWindow ctx = SDL.hideWindow (ctxWindow ctx) diff --git a/src/Chelleport/Context.hs b/src/Chelleport/Context.hs index 9b1e13e..b573975 100644 --- a/src/Chelleport/Context.hs +++ b/src/Chelleport/Context.hs @@ -1,26 +1,23 @@ module Chelleport.Context where import Chelleport.Types +import Foreign.C (CFloat) import qualified Graphics.X11 as X11 import SDL (($=)) import qualified SDL import qualified SDL.Font as TTF +windowOpacity :: CFloat +windowOpacity = 0.6 + +fontSize :: Int +fontSize = 24 + initializeContext :: IO DrawContext initializeContext = do - let windowCfg = - SDL.defaultWindow - { SDL.windowMode = SDL.FullscreenDesktop, - SDL.windowPosition = SDL.Absolute $ SDL.P $ SDL.V2 0 0, - SDL.windowInitialSize = SDL.V2 0 0, - SDL.windowBorder = False - } - window <- SDL.createWindow "Chelleport" windowCfg - renderer <- SDL.createRenderer window (-1) SDL.defaultRenderer - font <- TTF.load "Inter-Regular.ttf" 24 - - SDL.windowOpacity window $= 0.6 - SDL.rendererDrawBlendMode renderer $= SDL.BlendAlphaBlend + window <- initializeWindow + renderer <- initializeRenderer window + font <- loadFont display <- X11.openDisplay "" @@ -31,3 +28,29 @@ initializeContext = do ctxFont = font, ctxX11Display = display } + +loadFont :: IO TTF.Font +loadFont = do + font <- TTF.load "Inter-Regular.ttf" fontSize + TTF.setStyle font [TTF.Bold] + pure font + +initializeRenderer :: SDL.Window -> IO SDL.Renderer +initializeRenderer window = do + renderer <- SDL.createRenderer window (-1) SDL.defaultRenderer + SDL.windowOpacity window $= windowOpacity + SDL.rendererDrawBlendMode renderer $= SDL.BlendAlphaBlend + pure renderer + +initializeWindow :: IO SDL.Window +initializeWindow = do + let windowCfg = + SDL.defaultWindow + { SDL.windowMode = SDL.FullscreenDesktop, + SDL.windowPosition = SDL.Absolute $ SDL.P $ SDL.V2 0 0, + SDL.windowInitialSize = SDL.V2 0 0, + SDL.windowBorder = False + } + window <- SDL.createWindow "Chelleport" windowCfg + SDL.showWindow window + pure window diff --git a/src/Chelleport/Control.hs b/src/Chelleport/Control.hs index 94acf40..c915ae8 100644 --- a/src/Chelleport/Control.hs +++ b/src/Chelleport/Control.hs @@ -8,20 +8,18 @@ import qualified Graphics.X11.XTest as X11 import qualified SDL triggerMouseLeftClick :: DrawContext -> IO () -triggerMouseLeftClick ctx = do +triggerMouseLeftClick (DrawContext {ctxX11Display = display}) = do threadDelay 30_000 -- Wrap with delay to prevent async window close issues. TODO: Remove maybe? - let display = ctxX11Display ctx X11.fakeButtonPress display X11.button1 X11.sync display False threadDelay 30_000 moveMouse :: DrawContext -> CInt -> CInt -> IO () -moveMouse _ctx x y = do +moveMouse _ x y = do SDL.warpMouse SDL.WarpGlobal (SDL.P $ SDL.V2 x y) isKeyPress :: SDL.KeyboardEventData -> Bool -isKeyPress keyboardEvent = - SDL.keyboardEventKeyMotion keyboardEvent == SDL.Pressed +isKeyPress = (== SDL.Pressed) . SDL.keyboardEventKeyMotion isKeyPressWith :: SDL.KeyboardEventData -> SDL.Keycode -> Bool isKeyPressWith keyboardEvent keyCode = diff --git a/src/Chelleport/Draw.hs b/src/Chelleport/Draw.hs index fff5d0d..530713a 100644 --- a/src/Chelleport/Draw.hs +++ b/src/Chelleport/Draw.hs @@ -19,6 +19,9 @@ colorGray = SDL.V4 55 52 65 200 colorAccent :: SDL.V4 Word8 colorAccent = SDL.V4 110 112 247 255 +colorHighlight :: SDL.V4 Word8 +colorHighlight = colorAccent + colorGridLines :: SDL.V4 Word8 colorGridLines = SDL.V4 127 29 29 150 @@ -29,9 +32,9 @@ colorBackground :: SDL.V4 Word8 colorBackground = SDL.V4 15 12 25 0 drawText :: DrawContext -> SDL.V2 CInt -> SDL.V4 Word8 -> Text -> IO (CInt, CInt) -drawText ctx position color text = do - surface <- TTF.blended (ctxFont ctx) color text - texture <- SDL.createTextureFromSurface (ctxRenderer ctx) surface +drawText ctx@(DrawContext {ctxRenderer = renderer}) position color text = do + surface <- TTF.solid (ctxFont ctx) color text -- TTF.blended + texture <- SDL.createTextureFromSurface renderer surface SDL.freeSurface surface -- Get text dimensions @@ -40,18 +43,21 @@ drawText ctx position color text = do let textHeight = SDL.textureHeight textureInfo -- Render the texture - SDL.copy (ctxRenderer ctx) texture Nothing $ + SDL.copy renderer texture Nothing $ Just (SDL.Rectangle (SDL.P position) (SDL.V2 textWidth textHeight)) SDL.destroyTexture texture pure (textWidth, textHeight) +windowSize :: DrawContext -> IO (SDL.V2 CInt) +windowSize = SDL.get . SDL.windowSize . ctxWindow + drawHorizontalLine :: DrawContext -> CInt -> IO () -drawHorizontalLine ctx x = do - (SDL.V2 width _height) <- SDL.get $ SDL.windowSize $ ctxWindow ctx - SDL.drawLine (ctxRenderer ctx) (SDL.P $ SDL.V2 0 x) (SDL.P $ SDL.V2 width x) +drawHorizontalLine ctx@(DrawContext {ctxRenderer = renderer}) x = do + (SDL.V2 width _height) <- windowSize ctx + SDL.drawLine renderer (SDL.P $ SDL.V2 0 x) (SDL.P $ SDL.V2 width x) drawVerticalLine :: DrawContext -> CInt -> IO () -drawVerticalLine ctx x = do - (SDL.V2 _width height) <- SDL.get $ SDL.windowSize $ ctxWindow ctx - SDL.drawLine (ctxRenderer ctx) (SDL.P $ SDL.V2 x 0) (SDL.P $ SDL.V2 x height) +drawVerticalLine ctx@(DrawContext {ctxRenderer = renderer}) x = do + (SDL.V2 _width height) <- windowSize ctx + SDL.drawLine renderer (SDL.P $ SDL.V2 x 0) (SDL.P $ SDL.V2 x height) diff --git a/src/Chelleport/KeySequence.hs b/src/Chelleport/KeySequence.hs index 52e3a54..f112b57 100644 --- a/src/Chelleport/KeySequence.hs +++ b/src/Chelleport/KeySequence.hs @@ -1,34 +1,29 @@ module Chelleport.KeySequence where import Chelleport.Types (KeyGrid, KeySequence) -import Data.List (isPrefixOf, nub) +import Chelleport.Utils (findWithIndex, uniq) +import Control.Monad (guard) +import Data.List (isPrefixOf) import qualified Data.Map as Map import qualified SDL nextChars :: KeySequence -> KeyGrid -> Maybe [Char] -nextChars keys cells = +nextChars keySequence cells = case matches of [] -> Nothing - _ -> Just $ nub result + _ -> Just nextCharactersInSequence where - matches = concatMap (filter (isPrefixOf keys)) cells - result = concatMap (take 1 . drop (length keys)) matches - -findWithIndex :: (x -> Maybe r) -> Int -> [x] -> Maybe (Int, r) -findWithIndex _pred _index [] = Nothing -findWithIndex predicate index (x : ls) = - case predicate x of - Just item -> Just (index, item) - Nothing -> findWithIndex predicate (index + 1) ls + matches = concatMap (filter $ isPrefixOf keySequence) cells + nextCharactersInSequence = uniq $ concatMap (take 1 . drop (length keySequence)) matches findMatchPosition :: KeySequence -> KeyGrid -> Maybe (Int, Int) -findMatchPosition keys = findWithIndex findMatch 0 +findMatchPosition keySequence = findWithIndex searchRows 0 where - findMatch = - fmap fst . findWithIndex (\c -> if c == keys then Just () else Nothing) 0 + searchRows = fmap fst . findWithIndex searchInRow 0 + searchInRow = guard . (== keySequence) isValidKey :: SDL.Keycode -> Bool -isValidKey key = Map.member key keycodeMapping +isValidKey = (`Map.member` keycodeMapping) generateKeyCells :: (Int, Int) -> KeySequence -> KeyGrid generateKeyCells (rows, columns) hintKeys = @@ -48,7 +43,7 @@ generateKeyCells (rows, columns) hintKeys = | otherwise = 'J' toKeyChar :: SDL.Keycode -> Maybe Char -toKeyChar key = Map.lookup key keycodeMapping +toKeyChar = (`Map.lookup` keycodeMapping) eventToKeycode :: SDL.KeyboardEventData -> SDL.Keycode eventToKeycode = SDL.keysymKeycode . SDL.keyboardEventKeysym diff --git a/src/Chelleport/Types.hs b/src/Chelleport/Types.hs index 8f69e72..222a011 100644 --- a/src/Chelleport/Types.hs +++ b/src/Chelleport/Types.hs @@ -15,7 +15,11 @@ data State = State stateKeySequence :: KeySequence } -data AppAction = FilterSequence SDL.Keycode | TriggerLeftClick | ResetKeys +data AppAction + = FilterSequence SDL.Keycode + | MoveMousePosition (Int, Int) + | ResetKeys + | TriggerLeftClick data DrawContext = DrawContext { ctxWindow :: SDL.Window, diff --git a/src/Chelleport/Utils.hs b/src/Chelleport/Utils.hs new file mode 100644 index 0000000..5977039 --- /dev/null +++ b/src/Chelleport/Utils.hs @@ -0,0 +1,24 @@ +module Chelleport.Utils where + +import Data.List (nub) +import Foreign.C (CInt) +import Unsafe.Coerce (unsafeCoerce) + +intToCInt :: Int -> CInt +intToCInt = unsafeCoerce + +findWithIndex :: (x -> Maybe r) -> Int -> [x] -> Maybe (Int, r) +findWithIndex _predicate _index [] = Nothing +findWithIndex predicate index (x : ls) = + case predicate x of + Just item -> Just (index, item) + Nothing -> findWithIndex predicate (index + 1) ls + +uniq :: (Eq a) => [a] -> [a] +uniq = nub + +isEmpty :: [a] -> Bool +isEmpty = null + +isNotEmpty :: [a] -> Bool +isNotEmpty = not . isEmpty diff --git a/src/Chelleport/View.hs b/src/Chelleport/View.hs index cf51390..c02e704 100644 --- a/src/Chelleport/View.hs +++ b/src/Chelleport/View.hs @@ -2,6 +2,7 @@ module Chelleport.View (render) where import Chelleport.Draw import Chelleport.Types +import Chelleport.Utils (intToCInt, isEmpty, isNotEmpty) import Control.Monad (forM_, unless, void) import Data.IORef (modifyIORef', newIORef, readIORef) import Data.List (isPrefixOf) @@ -9,23 +10,19 @@ import qualified Data.Text as Text import Foreign.C (CInt) import SDL (($=)) import qualified SDL -import Unsafe.Coerce (unsafeCoerce) - -isEmpty :: [a] -> Bool -isEmpty = null render :: State -> DrawContext -> IO () render state ctx = do renderGridLines state ctx - (SDL.V2 width height) <- SDL.get $ SDL.windowSize $ ctxWindow ctx + (SDL.V2 width height) <- windowSize ctx let grid = stateCells state - let wcell = width `div` unsafeCoerce (length $ head grid) - let hcell = height `div` unsafeCoerce (length grid) + let wcell = width `div` intToCInt (length $ head grid) + let hcell = height `div` intToCInt (length grid) forM_ (zip [0 ..] grid) $ \(rowIndex, row) -> do - let py = rowIndex * hcell forM_ (zip [0 ..] row) $ \(colIndex, cell) -> do + let py = rowIndex * hcell let px = colIndex * wcell renderKeySequence ctx (stateKeySequence state) cell (px, py) @@ -37,7 +34,7 @@ renderKeySequence ctx keySequence cell (px, py) = do let textColor | isEmpty keySequence = colorWhite - | not $ isEmpty matched = colorAccent + | isNotEmpty matched = colorHighlight | otherwise = colorGray widthRef <- newIORef 0 @@ -51,20 +48,20 @@ renderKeySequence ctx keySequence cell (px, py) = do void $ drawText ctx (SDL.V2 pos py) textColor $ Text.pack remaining renderGridLines :: State -> DrawContext -> IO () -renderGridLines state ctx = do - (SDL.V2 width height) <- SDL.get $ SDL.windowSize $ ctxWindow ctx +renderGridLines state ctx@(DrawContext {ctxRenderer = renderer}) = do + (SDL.V2 width height) <- windowSize ctx let grid = stateCells state - let wcell = width `div` unsafeCoerce (length $ head grid) - let hcell = height `div` unsafeCoerce (length grid) + let wcell = width `div` intToCInt (length $ head grid) + let hcell = height `div` intToCInt (length grid) - SDL.rendererDrawColor (ctxRenderer ctx) $= colorGridLines - let rows = unsafeCoerce $ length grid - let columns = unsafeCoerce $ length $ head grid + SDL.rendererDrawColor renderer $= colorGridLines + let rows = intToCInt $ length grid + let columns = intToCInt $ length $ head grid forM_ [0 .. rows] $ \rowIndex -> do drawHorizontalLine ctx $ rowIndex * hcell forM_ [0 .. columns] $ \colIndex -> do drawVerticalLine ctx $ colIndex * wcell - SDL.rendererDrawColor (ctxRenderer ctx) $= colorAxisLines + SDL.rendererDrawColor renderer $= colorAxisLines drawHorizontalLine ctx (rows * hcell `div` 2) drawVerticalLine ctx (columns * wcell `div` 2) |
