Refactor a bunch of stuff

8 files changed, 137 insertions, 74 deletions

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)