Using OverloadedRecordDot

5 files changed, 145 insertions, 178 deletions

diff --git a/game.cabal b/game.cabal
index 70155bb..7263429 100644
--- a/game.cabal
+++ b/game.cabal
@@ -33,6 +33,8 @@ library
     ghc-options:      -Wall -Werror -O2 -j
     default-extensions:
         OverloadedStrings
+        OverloadedRecordDot
+        DuplicateRecordFields
     hs-source-dirs:   src
     default-language: Haskell2010
 
diff --git a/src/Game.hs b/src/Game.hs
index 667053d..5a974c6 100644
--- a/src/Game.hs
+++ b/src/Game.hs
@@ -79,10 +79,10 @@ main = do
 toggleFullscreen :: ReaderT Env IO ()
 toggleFullscreen = do
   env <- ask
-  let fullscreen = _fullscreen env
-      renderRect = _renderRect env
-      renderer = _renderer env
-      window = _window env
+  let fullscreen = env._fullscreen
+      renderRect = env._renderRect
+      renderer = env._renderer
+      window = env._window
   fullscreen $~ not
   fs <- SDL.get fullscreen
   let mode = if fs then SDL.FullscreenDesktop else SDL.Windowed
@@ -104,12 +104,12 @@ toggleFullscreen = do
 gameLoop :: ReaderT Env IO ()
 gameLoop = do
   env <- ask
-  let renderer = _renderer env
-      canvas = _canvas env
-      renderRect = _renderRect env
-      controls = _controls env
-      map' = _map env
-      entities = _entities env
+  let renderer = env._renderer
+      canvas = env._canvas
+      renderRect = env._renderRect
+      controls = env._controls
+      map' = env._map
+      entities = env._entities
 
   events <- map SDL.eventPayload <$> SDL.pollEvents
 
@@ -125,7 +125,7 @@ gameLoop = do
     SDL.rendererRenderTarget renderer $= Just canvas
     SDL.clear renderer
 
-    updated <- liftIO $ E.update =<< readIORef entities
+    updated <- liftIO $ E.updateAll =<< readIORef entities
     entities $= updated
 
     -- render map and entities
diff --git a/src/Game/Controller.hs b/src/Game/Controller.hs
index ec1cdf3..b5cd685 100644
--- a/src/Game/Controller.hs
+++ b/src/Game/Controller.hs
@@ -9,14 +9,14 @@ import qualified SDL.Raw
 import Prelude hiding (init)
 
 data Controls = Controls
-  { cUp :: Bool,
-    cDown :: Bool,
-    cLeft :: Bool,
-    cRight :: Bool,
-    cA :: Bool,
-    cB :: Bool,
-    cMenu :: Bool,
-    cJoy :: Maybe SDL.Raw.Joystick
+  { up :: Bool,
+    down :: Bool,
+    left :: Bool,
+    right :: Bool,
+    a :: Bool,
+    b :: Bool,
+    menu :: Bool,
+    joy :: Maybe SDL.Raw.Joystick
   }
   deriving (Show)
 
@@ -39,29 +39,29 @@ init = do
 
 updateGamepad :: [SDL.EventPayload] -> Controls -> Controls
 updateGamepad events controls
-  | isNothing $ cJoy controls = controls
+  | isNothing $ controls.joy = controls
   -- XXX: deal with disconnection/reconnection
   | otherwise =
       controls
-        { cUp = fromMaybe (cUp controls) $ isPressedGamepad SDL.ControllerButtonDpadUp events,
-          cDown = fromMaybe (cDown controls) $ isPressedGamepad SDL.ControllerButtonDpadDown events,
-          cLeft = fromMaybe (cLeft controls) $ isPressedGamepad SDL.ControllerButtonDpadLeft events,
-          cRight = fromMaybe (cRight controls) $ isPressedGamepad SDL.ControllerButtonDpadRight events,
-          cA = fromMaybe (cA controls) $ isPressedGamepad SDL.ControllerButtonA events,
-          cB = fromMaybe (cB controls) $ isPressedGamepad SDL.ControllerButtonB events,
-          cMenu = fromMaybe (cMenu controls) $ isPressedGamepad SDL.ControllerButtonStart events
+        { up = fromMaybe controls.up $ isPressedGamepad SDL.ControllerButtonDpadUp events,
+          down = fromMaybe controls.down $ isPressedGamepad SDL.ControllerButtonDpadDown events,
+          left = fromMaybe controls.left $ isPressedGamepad SDL.ControllerButtonDpadLeft events,
+          right = fromMaybe controls.right $ isPressedGamepad SDL.ControllerButtonDpadRight events,
+          a = fromMaybe controls.a $ isPressedGamepad SDL.ControllerButtonA events,
+          b = fromMaybe controls.b $ isPressedGamepad SDL.ControllerButtonB events,
+          menu = fromMaybe controls.menu $ isPressedGamepad SDL.ControllerButtonStart events
         }
 
 updateKeyboard :: [SDL.EventPayload] -> Controls -> Controls
 updateKeyboard events controls =
   controls
-    { cUp = fromMaybe (cUp controls) $ isPressed SDL.KeycodeUp events,
-      cDown = fromMaybe (cDown controls) $ isPressed SDL.KeycodeDown events,
-      cLeft = fromMaybe (cLeft controls) $ isPressed SDL.KeycodeLeft events,
-      cRight = fromMaybe (cRight controls) $ isPressed SDL.KeycodeRight events,
-      cA = fromMaybe (cA controls) $ isPressed SDL.KeycodeZ events,
-      cB = fromMaybe (cB controls) $ isPressed SDL.KeycodeX events,
-      cMenu = fromMaybe (cMenu controls) $ isPressed SDL.KeycodeReturn events
+    { up = fromMaybe controls.up $ isPressed SDL.KeycodeUp events,
+      down = fromMaybe controls.down $ isPressed SDL.KeycodeDown events,
+      left = fromMaybe controls.left $ isPressed SDL.KeycodeLeft events,
+      right = fromMaybe controls.right $ isPressed SDL.KeycodeRight events,
+      a = fromMaybe controls.a $ isPressed SDL.KeycodeZ events,
+      b = fromMaybe controls.b $ isPressed SDL.KeycodeX events,
+      menu = fromMaybe controls.menu $ isPressed SDL.KeycodeReturn events
     }
 
 update :: [SDL.EventPayload] -> Controls -> Controls
diff --git a/src/Game/Entities.hs b/src/Game/Entities.hs
index b42f232..05149d0 100644
--- a/src/Game/Entities.hs
+++ b/src/Game/Entities.hs
@@ -1,4 +1,4 @@
-module Game.Entities (Entities, mkEntities, mkPlayer, mkEffect, append, update, render) where
+module Game.Entities (Entities, mkEntities, mkPlayer, mkEffect, append, updateAll, render) where
 
 import Data.Foldable (traverse_)
 import Data.IORef
@@ -40,20 +40,20 @@ data Entities = Entities S.SpriteSheet [Entity]
 data Spawn = DustEffectSpawn Int Int
 
 data Entity = Entity
-  { eType :: Type,
-    eX :: Int,
-    eY :: Int,
-    eDelay :: Int,
-    eFrame :: Int,
-    eFrameLimit :: Int,
-    eJumping :: Bool,
-    eGravity :: Int,
-    eDir :: Dir,
-    eSprite :: S.Sprite,
-    eUpdate :: Entity -> IO Entity,
-    eBlocked :: Int -> Int -> Bool,
-    eDestroy :: Bool,
-    eSpawns :: [Spawn]
+  { typ :: Type,
+    x :: Int,
+    y :: Int,
+    delay :: Int,
+    frame :: Int,
+    frameLimit :: Int,
+    jumping :: Bool,
+    gravity :: Int,
+    dir :: Dir,
+    sprite :: S.Sprite,
+    update :: Entity -> IO Entity,
+    isBlocked :: Int -> Int -> Bool,
+    destroy :: Bool,
+    spawns :: [Spawn]
   }
 
 mkEntities :: S.SpriteSheet -> Entities
@@ -63,13 +63,13 @@ append :: Entity -> Entities -> Entities
 append e (Entities sprites entities) = Entities sprites (entities ++ [e])
 
 processSpawn :: S.SpriteSheet -> Spawn -> IO Entity
-processSpawn sprites (DustEffectSpawn x y) = mkEffect sprites x y "dust"
+processSpawn sprites (DustEffectSpawn x' y') = mkEffect sprites x' y' "dust"
 
-update :: Entities -> IO Entities
-update (Entities sprites entities) = do
-  updated <- traverse (\e -> eUpdate e e) entities
-  new <- traverse (processSpawn sprites) (concatMap eSpawns updated)
-  pure $ Entities sprites $ map (\e -> e {eSpawns = []}) (filter (not . eDestroy) updated) ++ new
+updateAll :: Entities -> IO Entities
+updateAll (Entities sprites entities) = do
+  updated <- traverse (\e -> e.update e) entities
+  new <- traverse (processSpawn sprites) (concatMap (\e -> e.spawns) updated)
+  pure $ Entities sprites $ map (\e -> e {spawns = []}) (filter (not . destroy) updated) ++ new
 
 render :: SDL.Renderer -> Entities -> IO ()
 render renderer (Entities _ entities) = do
@@ -77,156 +77,127 @@ render renderer (Entities _ entities) = do
   where
     renderOne :: Entity -> IO ()
     renderOne e =
-      S.render renderer sp x y set frame
+      S.render renderer e.sprite e.x e.y set e.frame
       where
-        sp = eSprite e
-        x = eX e
-        y = eY e
-        set = toSpriteSet $ eDir e
-        frame = eFrame e
+        set = toSpriteSet e.dir
 
 mkEffect :: S.SpriteSheet -> Int -> Int -> String -> IO Entity
-mkEffect sprites x y name = do
+mkEffect sprites x' y' name = do
   s <- S.get sprites name
   pure $
     Entity
-      { eType = TypeEffect,
-        eX = x,
-        eY = y,
-        eDelay = frameDelay,
-        eFrame = 0,
-        eFrameLimit = 3,
-        eJumping = False,
-        eGravity = gravityOff,
-        eDir = DirRight,
-        eSprite = s,
-        eUpdate = pure . updateEffect,
-        eBlocked = \_ _ -> False,
-        eDestroy = False,
-        eSpawns = []
+      { typ = TypeEffect,
+        x = x',
+        y = y',
+        delay = frameDelay,
+        frame = 0,
+        frameLimit = 3,
+        jumping = False,
+        gravity = gravityOff,
+        dir = DirRight,
+        sprite = s,
+        update = pure . updateEffect,
+        isBlocked = \_ _ -> False,
+        destroy = False,
+        spawns = []
       }
 
 updateEffect :: Entity -> Entity
 updateEffect e
-  | delay > 0 = e {eDelay = delay - 1}
-  | frame + 1 < frameLimit = e {eDelay = frameDelay, eFrame = frame + 1}
-  | otherwise = e {eDestroy = True}
-  where
-    frame = eFrame e
-    frameLimit = eFrameLimit e
-    delay = eDelay e
+  | e.delay > 0 = e {delay = e.delay - 1}
+  | e.frame + 1 < e.frameLimit = e {delay = e.frameLimit, frame = e.frame + 1}
+  | otherwise = e {destroy = True}
 
 mkPlayer :: S.SpriteSheet -> Int -> Int -> IORef C.Controls -> (Int -> Int -> Bool) -> IO Entity
-mkPlayer sprites x y controls isBlocked = do
+mkPlayer sprites x' y' controls isBlocked' = do
   s <- S.get sprites "player"
   pure $
     Entity
-      { eType = TypePlayer,
-        eX = x,
-        eY = y,
-        eDelay = 0,
-        eFrame = 0,
-        eFrameLimit = 3,
-        eJumping = False,
-        eGravity = gravityOff,
-        eDir = DirRight,
-        eSprite = s,
-        eUpdate = updatePlayer controls,
-        eBlocked = isBlocked,
-        eDestroy = False,
-        eSpawns = []
+      { typ = TypePlayer,
+        x = x',
+        y = y',
+        delay = 0,
+        frame = 0,
+        frameLimit = 3,
+        jumping = False,
+        gravity = gravityOff,
+        dir = DirRight,
+        sprite = s,
+        update = updatePlayer controls,
+        isBlocked = isBlocked',
+        destroy = False,
+        spawns = []
       }
 
 updateFrame :: Bool -> Entity -> Entity
 updateFrame updated e
   | isGravityOn = e
-  | delay > 0 = e {eDelay = delay - 1}
-  | frame < frameLimit = e {eDelay = frameDelay, eFrame = if updated then frame + 1 else 0}
-  | otherwise = e {eDelay = frameDelay, eFrame = 0}
+  | e.delay > 0 = e {delay = e.delay - 1}
+  | e.frame < e.frameLimit = e {delay = frameDelay, frame = if updated then e.frame + 1 else 0}
+  | otherwise = e {delay = frameDelay, frame = 0}
   where
-    isGravityOn = eGravity e > gravityOff
-    frame = eFrame e
-    frameLimit = eFrameLimit e
-    delay = eDelay e
+    isGravityOn = e.gravity > gravityOff
 
 updateHorizontal :: Bool -> Bool -> Entity -> Entity
 updateHorizontal left right e
-  -- prevent pressing both directions (keyboard)
+  -- prevent pressing both directions (ky'board)
   | left && right = e
   -- change direction first
-  | left && eDir e /= DirLeft = e {eDir = DirLeft, eDelay = 0}
-  | right && eDir e /= DirRight = e {eDir = DirRight, eDelay = 0}
-  | left && isGoingDown = if isBlocked (x - 1) (y + 23) then e else e {eX = x - 1}
-  | left && not isGoingDown = if isBlocked (x - 1) (y + 23) && isBlocked (x - 1) (y + 17) then e else e {eX = x - 1}
-  | right && isGoingDown = if isBlocked (x + 17) (y + 23) then e else e {eX = x + 1}
-  | right && not isGoingDown = if isBlocked (x + 17) (y + 23) && isBlocked (x + 17) (y + 17) then e else e {eX = x + 1}
+  | left && e.dir /= DirLeft = e {dir = DirLeft, delay = 0}
+  | right && e.dir /= DirRight = e {dir = DirRight, delay = 0}
+  | left && isGoingDown = if e.isBlocked (e.x - 1) (e.y + 23) then e else e {x = e.x - 1}
+  | left && not isGoingDown = if e.isBlocked (e.x - 1) (e.y + 23) && e.isBlocked (e.x - 1) (e.y + 17) then e else e {x = e.x - 1}
+  | right && isGoingDown = if e.isBlocked (e.x + 17) (e.y + 23) then e else e {x = e.x + 1}
+  | right && not isGoingDown = if e.isBlocked (e.x + 17) (e.y + 23) && e.isBlocked (e.x + 17) (e.y + 17) then e else e {x = e.x + 1}
   | otherwise = e
   where
-    x = eX e
-    y = eY e
-    isBlocked = eBlocked e
-    gravity = eGravity e
-    isGoingDown = gravity == gravityOff || gravity >= gravityDown
+    isGoingDown = e.gravity == gravityOff || e.gravity >= gravityDown
 
 updateVertical :: Bool -> Bool -> Entity -> Entity
 updateVertical jump down e
   | not jump
-      || jumping
+      || e.jumping
       -- make jumping easier with "Coyote time"
-      || (gravity /= gravityOff && (gravity < gravityDown || gravity > jumpLimit)) =
+      || (e.gravity /= gravityOff && (e.gravity < gravityDown || e.gravity > jumpLimit)) =
       e
-  | not down = e {eJumping = True, eGravity = gravityUp, eFrame = jumpFrame, eSpawns = events ++ [DustEffectSpawn x (y + 8)]}
+  | not down = e {jumping = True, gravity = gravityUp, frame = jumpFrame, spawns = e.spawns ++ [DustEffectSpawn e.x (e.y + 8)]}
   -- go down a 8 pixel tall platform; not ideal to have these values hardcoded here
   -- but to be fair, the player height/width is hardcoded as well
   | down
-      && not (isBlocked (x + 2) (y + 24 + 8))
-      && not (isBlocked (x + 12) (y + 24 + 8)) =
-      applyGravity 8 e {eGravity = gravityDown, eFrame = jumpFrame, eY = eY e + 1}
+      && not (e.isBlocked (e.x + 2) (e.y + 24 + 8))
+      && not (e.isBlocked (e.x + 12) (e.y + 24 + 8)) =
+      applyGravity 8 e {gravity = gravityDown, frame = jumpFrame, y = e.y + 1}
   | otherwise = e
-  where
-    x = eX e
-    y = eY e
-    jumping = eJumping e
-    gravity = eGravity e
-    isBlocked = eBlocked e
-    events = eSpawns e
 
 applyGravity :: Int -> Entity -> Entity
 applyGravity v e
   | v == 0 = e
   -- hit the floor
   | isGoingDown
-      && (isBlocked (x + 2) (y + 24) || isBlocked (x + 12) (y + 24))
-      && not (isBlocked (x + 2) (y + 23))
-      && not (isBlocked (x + 12) (y + 23)) =
-      e {eJumping = False, eGravity = gravityOff, eDelay = 0}
-  | otherwise = applyGravity (v - 1) e {eY = y + change}
+      && (e.isBlocked (e.x + 2) (e.y + 24) || e.isBlocked (e.x + 12) (e.y + 24))
+      && not (e.isBlocked (e.x + 2) (e.y + 23))
+      && not (e.isBlocked (e.x + 12) (e.y + 23)) =
+      e {jumping = False, gravity = gravityOff, delay = 0}
+  | otherwise = applyGravity (v - 1) e {y = e.y + change}
   where
-    gravity = eGravity e
-    isGoingDown = gravity >= gravityDown
+    isGoingDown = e.gravity >= gravityDown
     change = if isGoingDown then 1 else -1
-    x = eX e
-    y = eY e
-    isBlocked = eBlocked e
 
 updateGravity :: Entity -> Entity
 updateGravity e
-  | current > gravityOff = applyGravity (gravityTable !! current) e {eGravity = new}
-  | not (isBlocked (x + 2) (y + 24) || isBlocked (x + 12) (y + 24)) = e {eGravity = gravityDown, eFrame = jumpFrame}
+  | current > gravityOff = applyGravity (gravityTable !! current) e {gravity = new}
+  | not (e.isBlocked (e.x + 2) (e.y + 24) || e.isBlocked (e.x + 12) (e.y + 24)) = e {gravity = gravityDown, frame = jumpFrame}
   | otherwise = e
   where
-    current = eGravity e
+    current = e.gravity
     new = if current > gravityOff && current < length gravityTable - 1 then current + 1 else current
-    x = eX e
-    y = eY e
-    isBlocked = eBlocked e
 
 updatePlayer :: IORef C.Controls -> Entity -> IO Entity
 updatePlayer controls e = do
   ctl <- readIORef controls
   pure $
     updateGravity $
-      updateVertical (C.cA ctl) (C.cDown ctl) $
-        updateHorizontal (C.cLeft ctl) (C.cRight ctl) $
-          -- left or right, but not both (keyboard)
-          updateFrame ((C.cLeft ctl || C.cRight ctl) && (C.cLeft ctl /= C.cRight ctl)) e
+      updateVertical ctl.a ctl.down $
+        updateHorizontal ctl.left ctl.right $
+          -- left or right, but not both (ky'board)
+          updateFrame ((ctl.left || ctl.right) && (ctl.left /= ctl.right)) e
diff --git a/src/Game/Map.hs b/src/Game/Map.hs
index 7866f97..94478bd 100644
--- a/src/Game/Map.hs
+++ b/src/Game/Map.hs
@@ -13,24 +13,24 @@ import Text.JSON
 import Text.JSON.Types
 
 data Tileset = Tileset
-  { tsCols :: Int,
-    tsWidth :: Int,
-    tsHeight :: Int,
-    tsFirstGid :: Int
+  { cols :: Int,
+    width :: Int,
+    height :: Int,
+    firstGid :: Int
   }
   deriving (Show)
 
 data TileLayer = TileLayer
-  { tlName :: String,
-    tlTiles :: [Int]
+  { name :: String,
+    tiles :: [Int]
   }
   deriving (Show)
 
 data MapData = MapData
-  { mWidth :: Int,
-    mHeight :: Int,
-    mTileset :: Tileset,
-    mLayers :: [TileLayer]
+  { width :: Int,
+    height :: Int,
+    tileset :: Tileset,
+    layers :: [TileLayer]
   }
   deriving (Show)
 
@@ -78,13 +78,10 @@ load filename tex = do
 -- | Check for collision detection vs "Blocked" TileLayer that MUST be last layer.
 --   x and y in pixels.
 isBlocked :: Map -> Int -> Int -> Bool
-isBlocked (Map (MapData width _ ts layers) _) x y =
-  tiles !! ((x `div` tw) + (y `div` th) * width) >= firstgid
+isBlocked (Map (MapData mapWidth _ ts ls) _) x y =
+  blocked !! ((x `div` ts.width) + (y `div` ts.height) * mapWidth) >= ts.firstGid
   where
-    tiles = tlTiles (last layers)
-    tw = tsWidth ts
-    th = tsHeight ts
-    firstgid = tsFirstGid ts
+    blocked = (last ls).tiles
 
 -- | Renders a map.
 render :: SDL.Renderer -> Map -> IO ()
@@ -93,28 +90,25 @@ render renderer (Map mapData tex) = do
     ( \layer ->
         mapM_
           ( \(x, y) ->
-              renderTile x y $ tlTiles layer !! (x + (y * mWidth mapData))
+              renderTile x y $ layer.tiles !! (x + (y * mapData.width))
           )
           index
     )
-    (init $ mLayers mapData)
+    (init $ mapData.layers)
   where
-    mw = mWidth mapData
-    mh = mHeight mapData
-    index = [(x, y) | x <- [0 .. mw - 1], y <- [0 .. mh - 1]]
+    index = [(x, y) | x <- [0 .. mapData.width - 1], y <- [0 .. mapData.height - 1]]
 
-    ts = mTileset mapData
-    firstgid = tsFirstGid ts
-    cols = tsCols ts
-    tileWidth = tsWidth ts
-    tileHeight = tsHeight ts
+    columns = mapData.tileset.cols
+    firstgid = mapData.tileset.firstGid
+    tileWidth = mapData.tileset.width
+    tileHeight = mapData.tileset.height
 
     renderTile :: Int -> Int -> Int -> IO ()
     renderTile x y tile
       | tile < firstgid = pure ()
       | otherwise = do
-          let tx = (tile - firstgid) `rem` cols
-              ty = (tile - firstgid) `div` cols
+          let tx = (tile - firstgid) `rem` columns
+              ty = (tile - firstgid) `div` columns
               src = U.rect (tx * tileWidth) (ty * tileHeight) tileWidth tileHeight
               dst = U.rect (x * tileWidth) (y * tileHeight) tileWidth tileHeight
           SDL.copy renderer tex (Just src) (Just dst)