Minor refactor

9 files changed, 108 insertions, 95 deletions

diff --git a/chelleport.cabal b/chelleport.cabal
index ceeb2af..8efc16a 100644
--- a/chelleport.cabal
+++ b/chelleport.cabal
@@ -58,6 +58,7 @@ library lib-chelleport
   exposed-modules:
     Chelleport
     Chelleport.AppShell
+    Chelleport.Config
     Chelleport.Context
     Chelleport.Control
     Chelleport.Draw
diff --git a/specs/Specs/AppEventSpec.hs b/specs/Specs/AppEventSpec.hs
index 9da4c87..390fbc2 100644
--- a/specs/Specs/AppEventSpec.hs
+++ b/specs/Specs/AppEventSpec.hs
@@ -37,6 +37,11 @@ test = do
         let action = eventHandler $ mkKeyboardEvent SDL.KeycodeEscape SDL.Pressed defaultMod
         action `shouldBe` Just ShutdownApp
 
+    context "when ctrl+v is pressed" $ do
+      it "toggles dragging" $ do
+        let action = eventHandler $ mkKeyboardEvent SDL.KeycodeV SDL.Pressed (defaultMod {SDL.keyModifierLeftCtrl = True})
+        action `shouldBe` Just MouseDragToggle
+
     context "when space key is pressed" $ do
       it "triggers left mouse button click" $ do
         let action = eventHandler $ mkKeyboardEvent SDL.KeycodeSpace SDL.Pressed defaultMod
diff --git a/src/Chelleport.hs b/src/Chelleport.hs
index 95e8af9..df3433e 100644
--- a/src/Chelleport.hs
+++ b/src/Chelleport.hs
@@ -22,18 +22,19 @@ import Control.Monad.Reader (ReaderT (runReaderT))
 import Data.Maybe (fromMaybe, isJust)
 import qualified SDL
 
-runEff :: (MonadIO m) => DrawContext -> AppM m x -> m x
-runEff ctx action = runReaderT (runAppM action) ctx
-
 run :: IO ()
 run = do
   ctx <- initializeContext
-  setupAppShell
-    ctx
-    (runEff ctx initialState)
-    (\state -> runEff ctx . update state)
-    (const eventHandler)
-    (runEff ctx . Chelleport.View.render)
+  runAppWithCtx ctx $
+    setupAppShell
+      ctx
+      initialState
+      update
+      (const eventHandler)
+      Chelleport.View.render
+  where
+    runAppWithCtx :: (MonadIO m) => DrawContext -> AppM m x -> m x
+    runAppWithCtx ctx action = runReaderT (runAppM action) ctx
 
 initialState :: (Monad m) => m State
 initialState = do
diff --git a/src/Chelleport/AppShell.hs b/src/Chelleport/AppShell.hs
index 8f8a19d..ba31982 100644
--- a/src/Chelleport/AppShell.hs
+++ b/src/Chelleport/AppShell.hs
@@ -1,11 +1,11 @@
 module Chelleport.AppShell (setupAppShell, MonadAppShell (..)) where
 
+import Chelleport.Config
 import Chelleport.Control (MonadControl (releaseMouseButton))
-import Chelleport.Draw (colorBackground)
 import Chelleport.Types
 import Control.Monad (foldM)
 import Control.Monad.IO.Class (MonadIO (liftIO))
-import Control.Monad.RWS (MonadReader (ask))
+import Control.Monad.RWS (MonadReader (ask), asks)
 import qualified Graphics.X11 as X11
 import SDL (($=))
 import qualified SDL
@@ -17,45 +17,44 @@ class (Monad m) => MonadAppShell m where
   shutdownApp :: m ()
 
 instance (MonadIO m) => MonadAppShell (AppM m) where
-  hideWindow = ask >>= SDL.hideWindow . ctxWindow
-  showWindow = ask >>= SDL.showWindow . ctxWindow
+  hideWindow = asks ctxWindow >>= SDL.hideWindow
+  showWindow = asks ctxWindow >>= SDL.showWindow
   shutdownApp = do
-    ctx <- ask
-    SDL.destroyRenderer $ ctxRenderer ctx
-    SDL.destroyWindow $ ctxWindow ctx
+    DrawContext {ctxRenderer = renderer, ctxWindow = window, ctxX11Display = x11Display} <- ask
+    SDL.destroyRenderer renderer
+    SDL.destroyWindow window
     releaseMouseButton
     SDL.quit
     liftIO $ do
-      X11.closeDisplay $ ctxX11Display ctx
+      X11.closeDisplay x11Display
       exitSuccess
 
-type Update state appAction = state -> appAction -> IO (state, Maybe appAction)
+type Update m state appAction = state -> appAction -> m (state, Maybe appAction)
 
 type EventHandler state appAction = state -> SDL.Event -> Maybe appAction
 
-type View state = state -> IO ()
+type View m state = state -> m ()
 
-type Initializer state = IO state
+type Initializer m state = m state
 
 setupAppShell ::
+  (MonadIO m) =>
   DrawContext ->
-  Initializer state ->
-  Update state appAction ->
+  Initializer m state ->
+  Update m state appAction ->
   EventHandler state appAction ->
-  View state ->
-  IO ()
-setupAppShell ctx initState update eventHandler draw = do
-  state <- initState
-  appLoop state
+  View m state ->
+  m ()
+setupAppShell (DrawContext {ctxRenderer = renderer}) getInitState update eventHandler draw =
+  getInitState >>= appLoop
   where
-    appLoop state = do
-      SDL.rendererDrawColor (ctxRenderer ctx) $= colorBackground
-      SDL.clear $ ctxRenderer ctx
-      draw state
-      SDL.present $ ctxRenderer ctx
+    appLoop currentState = do
+      SDL.rendererDrawColor renderer $= colorBackground
+      SDL.clear renderer
+      draw currentState
+      SDL.present renderer
 
-      events <- SDL.pollEvents
-      newState <- foldM evaluateEvent state events
+      newState <- SDL.pollEvents >>= foldM evaluateEvent currentState
 
       appLoop newState
 
diff --git a/src/Chelleport/Config.hs b/src/Chelleport/Config.hs
new file mode 100644
index 0000000..65b7077
--- /dev/null
+++ b/src/Chelleport/Config.hs
@@ -0,0 +1,41 @@
+module Chelleport.Config where
+
+import Chelleport.Types
+import Foreign.C (CFloat)
+import qualified SDL
+
+colorWhite :: Color
+colorWhite = SDL.V4 255 255 255 255
+
+colorLightGray :: Color
+colorLightGray = SDL.V4 100 100 100 255
+
+colorGray :: Color
+colorGray = SDL.V4 55 52 65 200
+
+colorAccent :: Color
+colorAccent = SDL.V4 110 112 247 255
+
+colorHighlight :: Color
+colorHighlight = colorAccent
+
+colorGridLines :: Color
+colorGridLines = colorGray
+
+colorFocusLines :: Color
+colorFocusLines = colorLightGray
+
+colorAxisLines :: Color
+colorAxisLines = colorAccent
+
+colorBackground :: Color
+colorBackground = SDL.V4 15 12 25 0
+
+colorFineGrainGrid :: Color
+colorFineGrainGrid = SDL.V4 55 52 65 100
+
+windowOpacity :: CFloat
+windowOpacity = 0.4
+
+fontSize :: Int
+fontSize = 24
diff --git a/src/Chelleport/Context.hs b/src/Chelleport/Context.hs
index 3c2c850..b721812 100644
--- a/src/Chelleport/Context.hs
+++ b/src/Chelleport/Context.hs
@@ -1,22 +1,18 @@
 module Chelleport.Context (initializeContext) where
 
+-- import Data.Time.Clock.System
+-- import qualified Debug.Trace as Debug
+
+import Chelleport.Config
 import Chelleport.Types
 import Data.ByteString (ByteString)
 import Data.FileEmbed (embedFileRelative)
--- import Data.Time.Clock.System
--- import qualified Debug.Trace as Debug
 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.5
-
-fontSize :: Int
-fontSize = 24
-
 -- benchmark :: String -> IO a -> IO a
 -- benchmark msg m = do
 --   start <- systemNanoseconds <$> getSystemTime
diff --git a/src/Chelleport/Control.hs b/src/Chelleport/Control.hs
index fa25681..80be6f8 100644
--- a/src/Chelleport/Control.hs
+++ b/src/Chelleport/Control.hs
@@ -80,15 +80,14 @@ isKeyReleaseWith :: SDL.KeyboardEventData -> SDL.Keycode -> Bool
 isKeyReleaseWith keyboardEvent keyCode =
   isKeyRelease keyboardEvent && eventToKeycode keyboardEvent == keyCode
 
+keyModifier :: SDL.KeyboardEventData -> SDL.KeyModifier
+keyModifier = SDL.keysymModifier . SDL.keyboardEventKeysym
+
 withShift :: SDL.KeyboardEventData -> Bool
-withShift event = SDL.keyModifierLeftShift modifier || SDL.keyModifierRightShift modifier
-  where
-    modifier = SDL.keysymModifier . SDL.keyboardEventKeysym $ event
+withShift ev = SDL.keyModifierLeftShift (keyModifier ev) || SDL.keyModifierRightShift (keyModifier ev)
 
 withCtrl :: SDL.KeyboardEventData -> Bool
-withCtrl event = SDL.keyModifierLeftCtrl modifier || SDL.keyModifierRightCtrl modifier
-  where
-    modifier = SDL.keysymModifier . SDL.keyboardEventKeysym $ event
+withCtrl ev = SDL.keyModifierLeftCtrl (keyModifier ev) || SDL.keyModifierRightCtrl (keyModifier ev)
 
 directionalIncrement :: (CInt, CInt) -> Char -> (Int, Int)
 directionalIncrement (incX, incY) = \case
diff --git a/src/Chelleport/Draw.hs b/src/Chelleport/Draw.hs
index cba040a..3f67848 100644
--- a/src/Chelleport/Draw.hs
+++ b/src/Chelleport/Draw.hs
@@ -2,10 +2,9 @@ module Chelleport.Draw where
 
 import Chelleport.Types
 import Chelleport.Utils (intToCInt)
-import Control.Monad.Reader (MonadIO, MonadReader (ask))
+import Control.Monad.Reader (MonadIO, MonadReader (ask), asks)
 import Data.Text (Text)
 import qualified Data.Vector.Storable as Vector
-import Data.Word (Word8)
 import Foreign.C (CInt)
 import SDL (($=))
 import qualified SDL
@@ -13,19 +12,19 @@ import qualified SDL.Font as TTF
 
 class (Monad m) => MonadDraw m where
   drawLine :: (CInt, CInt) -> (CInt, CInt) -> m ()
-  drawText :: (CInt, CInt) -> SDL.V4 Word8 -> Text -> m (CInt, CInt)
+  drawText :: (CInt, CInt) -> Color -> Text -> m (CInt, CInt)
   drawCircle :: Int -> (CInt, CInt) -> m ()
-  setDrawColor :: SDL.V4 Word8 -> m ()
+  setDrawColor :: Color -> m ()
   windowSize :: m (CInt, CInt)
   windowPosition :: m (CInt, CInt)
 
 instance (MonadIO m) => MonadDraw (AppM m) where
   drawLine (x1, y1) (x2, y2) = do
-    DrawContext {ctxRenderer = renderer} <- ask
+    renderer <- asks ctxRenderer
     SDL.drawLine renderer (SDL.P $ SDL.V2 x1 y1) (SDL.P $ SDL.V2 x2 y2)
 
   setDrawColor color = do
-    DrawContext {ctxRenderer = renderer} <- ask
+    renderer <- asks ctxRenderer
     SDL.rendererDrawColor renderer $= color
 
   drawText (x, y) color text = do
@@ -47,22 +46,23 @@ instance (MonadIO m) => MonadDraw (AppM m) where
     pure (textWidth, textHeight)
 
   drawCircle radius (x, y) = do
-    DrawContext {ctxRenderer = renderer} <- ask
-    let renderedPoints = radius * 7
-    let toTheta n = fromIntegral n * (2 * pi) / fromIntegral renderedPoints
-    let toPointOnCircle n =
-          SDL.V2
-            (x + round ((fromIntegral radius :: Float) * cos (toTheta n)))
-            (y + round ((fromIntegral radius :: Float) * sin (toTheta n)))
-    let points = Vector.generate renderedPoints (SDL.P . toPointOnCircle)
-    SDL.drawPoints renderer points
+    renderer <- asks ctxRenderer
+    SDL.drawPoints renderer pointsOnACircle
+    where
+      pointsOnACircle = Vector.generate renderedPoints (SDL.P . toPointOnCircle)
+      renderedPoints = radius * 7
+      toTheta n = fromIntegral n * (2 * pi) / fromIntegral renderedPoints
+      toPointOnCircle n =
+        SDL.V2
+          (x + round ((fromIntegral radius :: Float) * cos (toTheta n)))
+          (y + round ((fromIntegral radius :: Float) * sin (toTheta n)))
 
   windowSize = do
-    SDL.V2 x y <- ask >>= SDL.get . SDL.windowSize . ctxWindow
+    SDL.V2 x y <- asks ctxWindow >>= SDL.get . SDL.windowSize
     pure (x, y)
 
   windowPosition = do
-    SDL.V2 x y <- ask >>= SDL.getWindowAbsolutePosition . ctxWindow
+    SDL.V2 x y <- asks ctxWindow >>= SDL.getWindowAbsolutePosition
     pure (x, y)
 
 cellSize :: (MonadDraw m) => State -> m (CInt, CInt)
@@ -81,33 +81,3 @@ drawVerticalLine :: (MonadDraw m) => CInt -> m ()
 drawVerticalLine x = do
   (_, height) <- windowSize
   drawLine (x, 0) (x, height)
-
-colorWhite :: SDL.V4 Word8
-colorWhite = SDL.V4 255 255 255 255
-
-colorLightGray :: SDL.V4 Word8
-colorLightGray = SDL.V4 100 100 100 255
-
-colorGray :: SDL.V4 Word8
-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 = colorGray
-
-colorFocusLines :: SDL.V4 Word8
-colorFocusLines = colorLightGray
-
-colorAxisLines :: SDL.V4 Word8
-colorAxisLines = colorAccent
-
-colorBackground :: SDL.V4 Word8
-colorBackground = SDL.V4 15 12 25 0
-
-colorFineGrainGrid :: SDL.V4 Word8
-colorFineGrainGrid = SDL.V4 55 52 65 100
diff --git a/src/Chelleport/View.hs b/src/Chelleport/View.hs
index 069e49c..459251b 100644
--- a/src/Chelleport/View.hs
+++ b/src/Chelleport/View.hs
@@ -1,5 +1,6 @@
 module Chelleport.View (render) where
 
+import Chelleport.Config
 import Chelleport.Draw
 import Chelleport.Types
 import Chelleport.Utils (intToCInt, isEmpty, isNotEmpty)