Update stack lts to 20.1

2022-11-28 16:50:52 -08:00 · 2022-11-28 16:50:52 -08:00 · e271067771
commit e271067771
parent e3605d48f3
6 changed files with 79 additions and 77 deletions
--- a/src/Tetris.hs
+++ b/src/Tetris.hs
@ -187,7 +187,8 @@ timeStep = do
    False -> gravitate
    True -> do
      freezeBlock
-      clearFullRows >>= addToRowClears
+      n <- clearFullRows
+      addToRowClears n
      updateScore
      nextBlock

@ -326,8 +327,9 @@ shuffle xs
  | null xs = mempty
  | otherwise = do
    randomPosition <- getStdRandom (randomR (0, length xs - 1))
-    let (left, y :<| ys) = Seq.splitAt randomPosition xs
-    fmap (y <|) (shuffle $ left >< ys)
+    case Seq.splitAt randomPosition xs of
+      (left, y :<| ys) ->  fmap (y <|) (shuffle $ left >< ys)
+      _ -> error "impossible"

 v2 :: (a, a) -> V2 a
 v2 (x, y) = V2 x y
--- a/src/UI/Game.hs
+++ b/src/UI/Game.hs
@ -7,8 +7,9 @@ module UI.Game
  ) where

 import Control.Concurrent (threadDelay, forkIO)
-import Control.Monad (void, forever)
+import Control.Monad (void, forever, when, unless)
 import Control.Monad.IO.Class (liftIO)
+import Control.Monad.Trans.State (execStateT)
 import Prelude hiding (Left, Right)

 import Brick hiding (Down)
@ -16,8 +17,7 @@ import Brick.BChan
 import qualified Brick.Widgets.Border as B
 import qualified Brick.Widgets.Border.Style as BS
 import qualified Brick.Widgets.Center as C
-import Control.Lens hiding (preview, op)
-import Control.Monad.Trans.State
+import Control.Lens hiding (preview, op, zoom)
 import qualified Graphics.Vty as V
 import Data.Map (Map)
 import qualified Data.Map as M
@ -51,7 +51,7 @@ app = App
  { appDraw         = drawUI
  , appChooseCursor = neverShowCursor
  , appHandleEvent  = handleEvent
-  , appStartEvent   = return
+  , appStartEvent   = pure ()
  , appAttrMap      = const theMap
  }

@ -81,35 +81,33 @@ levelToDelay n = floor $ 400000 * (0.85 :: Double) ^ (2 * n)

 -- Handling events

-handleEvent :: UI -> BrickEvent Name Tick -> EventM Name (Next UI)
-handleEvent ui (AppEvent Tick                      ) = handleTick ui
-handleEvent ui (VtyEvent (V.EvKey V.KRight      [])) = exec (shift Right) ui
-handleEvent ui (VtyEvent (V.EvKey V.KLeft       [])) = exec (shift Left) ui
-handleEvent ui (VtyEvent (V.EvKey V.KDown       [])) = exec (shift Down) ui
-handleEvent ui (VtyEvent (V.EvKey (V.KChar 'l') [])) = exec (shift Right) ui
-handleEvent ui (VtyEvent (V.EvKey (V.KChar 'h') [])) = exec (shift Left) ui
-handleEvent ui (VtyEvent (V.EvKey (V.KChar 'j') [])) = exec (shift Down) ui
-handleEvent ui (VtyEvent (V.EvKey V.KUp         [])) = exec rotate ui
-handleEvent ui (VtyEvent (V.EvKey (V.KChar 'k') [])) = exec rotate ui
-handleEvent ui (VtyEvent (V.EvKey (V.KChar ' ') [])) =
+handleEvent :: BrickEvent Name Tick -> EventM Name UI ()
+handleEvent (AppEvent Tick                      ) = handleTick
+handleEvent (VtyEvent (V.EvKey V.KRight      [])) = exec (shift Right)
+handleEvent (VtyEvent (V.EvKey V.KLeft       [])) = exec (shift Left)
+handleEvent (VtyEvent (V.EvKey V.KDown       [])) = exec (shift Down)
+handleEvent (VtyEvent (V.EvKey (V.KChar 'l') [])) = exec (shift Right)
+handleEvent (VtyEvent (V.EvKey (V.KChar 'h') [])) = exec (shift Left)
+handleEvent (VtyEvent (V.EvKey (V.KChar 'j') [])) = exec (shift Down)
+handleEvent (VtyEvent (V.EvKey V.KUp         [])) = exec rotate
+handleEvent (VtyEvent (V.EvKey (V.KChar 'k') [])) = exec rotate
+handleEvent (VtyEvent (V.EvKey (V.KChar ' ') [])) =
  guarded
    (not . view paused)
    (over game (execTetris hardDrop) . set locked True)
-    ui
-handleEvent ui (VtyEvent (V.EvKey (V.KChar 'p') [])) =
+handleEvent (VtyEvent (V.EvKey (V.KChar 'p') [])) =
  guarded
    (not . view locked)
    (over paused not)
-    ui
-handleEvent ui (VtyEvent (V.EvKey (V.KChar 'r') [])) = restart ui
-handleEvent ui (VtyEvent (V.EvKey (V.KChar 'q') [])) = halt ui
-handleEvent ui (VtyEvent (V.EvKey V.KEsc        [])) = halt ui
-handleEvent ui _ = continue ui
+handleEvent (VtyEvent (V.EvKey (V.KChar 'r') [])) = restart
+handleEvent (VtyEvent (V.EvKey (V.KChar 'q') [])) = halt
+handleEvent (VtyEvent (V.EvKey V.KEsc        [])) = halt
+handleEvent _ = pure ()

 -- | This common execution function is used for all game user input except hard
 -- drop and pause. If paused or locked (from hard drop) do nothing, else
 -- execute the state computation.
-exec :: Tetris () -> UI -> EventM Name (Next UI)
+exec :: Tetris () -> EventM Name UI ()
 exec op =
  guarded
    (not . \ui -> ui ^. paused || ui ^. locked)
@ -117,29 +115,30 @@ exec op =

 -- | This base execution function takes a predicate and only issues UI
 -- modification when predicate passes and game is not over.
-guarded :: (UI -> Bool) -> (UI -> UI) -> UI -> EventM Name (Next UI)
-guarded p f ui = continue
-  $ if not (p ui) || ui ^. game . to isGameOver
-    then ui
-    else f ui
+guarded :: (UI -> Bool) -> (UI -> UI) -> EventM Name UI ()
+guarded p f = do
+  ui <- get
+  when (p ui && not (ui ^. game . to isGameOver)) $
+    modify f

 -- | Handles time steps, does nothing if game is over or paused
-handleTick :: UI -> EventM Name (Next UI)
-handleTick ui =
-  if ui ^. paused || ui ^. game . to isGameOver
-  then continue ui
-  else do
-    next <- execStateT timeStep $ ui ^. game
-    continue $ ui & game .~ next
-                  & locked .~ False
+handleTick :: EventM Name UI ()
+handleTick = do
+  ui <- get
+  unless (ui ^. paused || ui ^. game . to isGameOver) $ do
+    -- awkward, should just mutate the inner state
+    --zoom game timeStep
+    g' <- execStateT timeStep $ ui ^. game
+    game .= g'
+    locked .= False

 -- | Restart game at the same level
-restart :: UI -> EventM Name (Next UI)
-restart ui = do
-  let lvl = ui ^. (game . level)
+restart :: EventM Name UI ()
+restart = do
+  lvl <- use $ game . level
  g <- liftIO $ initGame lvl
-  continue $ ui & game .~ g
-                & locked .~ False
+  game .= g
+  locked .= False

 -- Drawing

@ -311,25 +310,25 @@ tToColor J = V.blue
 tToColor L = V.white

 iAttr, oAttr, tAttr, sAttr, zAttr, jAttr, lAttr :: AttrName
-iAttr = "I"
-oAttr = "O"
-tAttr = "T"
-sAttr = "S"
-zAttr = "Z"
-jAttr = "J"
-lAttr = "L"
+iAttr = attrName "I"
+oAttr = attrName "O"
+tAttr = attrName "T"
+sAttr = attrName "S"
+zAttr = attrName "Z"
+jAttr = attrName "J"
+lAttr = attrName "L"

 ihAttr, ohAttr, thAttr, shAttr, zhAttr, jhAttr, lhAttr :: AttrName
-ihAttr = "Ih"
-ohAttr = "Oh"
-thAttr = "Th"
-shAttr = "Sh"
-zhAttr = "Zh"
-jhAttr = "Jh"
-lhAttr = "Lh"
+ihAttr = attrName "Ih"
+ohAttr = attrName "Oh"
+thAttr = attrName "Th"
+shAttr = attrName "Sh"
+zhAttr = attrName "Zh"
+jhAttr = attrName "Jh"
+lhAttr = attrName "Lh"

 emptyAttr :: AttrName
-emptyAttr = "empty"
+emptyAttr = attrName "empty"

 gameOverAttr :: AttrName
-gameOverAttr = "gameOver"
+gameOverAttr = attrName "gameOver"
--- a/src/UI/PickLevel.hs
+++ b/src/UI/PickLevel.hs
@ -3,6 +3,7 @@ module UI.PickLevel
  ) where

 import System.Exit (exitSuccess)
+import Control.Monad (when)

 import Brick
 import qualified Brick.Widgets.Border as B
@ -14,7 +15,7 @@ app :: App (Maybe Int) e ()
 app = App
  { appDraw         = const [ui]
  , appHandleEvent  = handleEvent
-  , appStartEvent   = return
+  , appStartEvent   = pure ()
  , appAttrMap      = const $ attrMap V.defAttr []
  , appChooseCursor = neverShowCursor
  }
@ -31,15 +32,15 @@ ui =
    $ C.center
    $ str " Choose Level (0-9)"

-handleEvent :: Maybe Int -> BrickEvent () e -> EventM () (Next (Maybe Int))
-handleEvent n (VtyEvent (V.EvKey V.KEsc        _)) = halt n
-handleEvent n (VtyEvent (V.EvKey (V.KChar 'q') _)) = halt n
-handleEvent n (VtyEvent (V.EvKey (V.KChar 'Q') _)) = halt n
-handleEvent n (VtyEvent (V.EvKey (V.KChar d) [])) =
-  if d `elem` ['0' .. '9']
-  then halt $ Just (read [d])
-  else continue n
-handleEvent n _ = continue n
+handleEvent :: BrickEvent () e -> EventM () (Maybe Int) ()
+handleEvent (VtyEvent (V.EvKey V.KEsc        _)) = halt
+handleEvent (VtyEvent (V.EvKey (V.KChar 'q') _)) = halt
+handleEvent (VtyEvent (V.EvKey (V.KChar 'Q') _)) = halt
+handleEvent (VtyEvent (V.EvKey (V.KChar d) [])) =
+  when (d `elem` ['0' .. '9']) $ do
+    put $ Just $ read [d]
+    halt
+handleEvent _ = pure ()

 pickLevel :: IO Int
 pickLevel = defaultMain app Nothing >>= maybe exitSuccess return
--- a/stack.yaml
+++ b/stack.yaml
@ -3,7 +3,7 @@ extra-package-dbs: []
 packages:
  - '.'
 extra-deps: []
-resolver: lts-17.9
+resolver: lts-20.1
 nix:
  packages:
    - gcc
--- a/stack.yaml.lock
+++ b/stack.yaml.lock
@ -6,7 +6,7 @@
 packages: []
 snapshots:
 - completed:
-    size: 567037
-    url: https://raw.githubusercontent.com/commercialhaskell/stackage-snapshots/master/lts/17/9.yaml
-    sha256: d7d8d5106e53d1669964bd8bd2b0f88a5ad192d772f5376384b76738fd992311
-  original: lts-17.9
+    sha256: b73b2b116143aea728c70e65c3239188998bac5bc3be56465813dacd74215dc5
+    size: 648424
+    url: https://raw.githubusercontent.com/commercialhaskell/stackage-snapshots/master/lts/20/1.yaml
+  original: lts-20.1
--- a/tetris.cabal
+++ b/tetris.cabal
@ -1,11 +1,11 @@
 name:                tetris
-version:             0.1.4.0
+version:             0.1.4.1
 homepage:            https://github.com/samtay/tetris#readme
 license:             BSD3
 license-file:        LICENSE
 author:              Sam Tay
 maintainer:          sam.chong.tay@pm.me
-copyright:           2021 Sam Tay
+copyright:           2022 Sam Tay
 category:            Web
 build-type:          Simple
 extra-source-files:  README.md