From aa65e21b70824d5eec9df2655b0e590c96037788 Mon Sep 17 00:00:00 2001
From: Devin Lehmacher <lehmacdj@gmail.com>
Date: Sat, 15 Aug 2020 13:23:43 -0700
Subject: [PATCH] simplify an effect out of fullGameLoop

---
 app/console/Main.hs | 13 ++++++++++---
 src/ConsoleUI.hs    | 10 ++++++----
 src/Game.hs         |  6 +++---
 3 files changed, 19 insertions(+), 10 deletions(-)

diff --git a/app/console/Main.hs b/app/console/Main.hs
index 78d919f..0547c83 100644
--- a/app/console/Main.hs
+++ b/app/console/Main.hs
@@ -31,23 +31,30 @@ handleIndexError = (>>= either (const writeErrorMessage) pure) . runError
   where
     writeErrorMessage = writeln "error: unrecoverable index out of bounds error"
 
+handleQuitGame ::
+  Member ConsoleIO r => Sem (Error QuitGame : r) () -> Sem r ()
+handleQuitGame = (>>= either (const writeErrorMessage) pure) . runError
+  where
+    writeErrorMessage = writeln "goodbye! :)"
+
 playGame ::
   GameState ->
   Sem
     [ Output Turn,
       PlayerIO,
-      Error GameOver,
       State GameState,
       Error CardDoesNotExist,
       ConsoleIO
     ]
-    Void ->
+    () ->
   IO ()
 playGame startingState game =
   game
     & ignoreOutput @Turn . outputTurnToConsoleIO
+    & raiseUnder @(Error QuitGame)
     & runPlayerIOAsConsoleUI
-    & runGame startingState
+    & handleQuitGame
+    & fmap fst . runState startingState
     & (=<<) printEndgameResult
     & handleIndexError
     & raiseUnder @(Embed (InputT IO))
diff --git a/src/ConsoleUI.hs b/src/ConsoleUI.hs
index 7d0205c..68bb12c 100644
--- a/src/ConsoleUI.hs
+++ b/src/ConsoleUI.hs
@@ -124,18 +124,20 @@ getInputCommandFromConsoleIO = runInputSem go
         Left e -> writeln (errorBundlePretty e) >> go
         Right command -> pure command
 
+data QuitGame = QuitGame
+
 -- | interpreting a command returns the turn that the command produces if it
 -- is one and otherwise executes the command in the effect context
 interpretCommand ::
-  Throws '[GameOver] r =>
+  Throws '[QuitGame] r =>
   Command ->
   Sem r RawTurn
 interpretCommand = \case
-  Quit -> throw GameOver
+  Quit -> throw QuitGame
   TakeTurn t -> pure t
 
 runPlayerIOAsConsoleUI ::
-  Members [ConsoleIO, Error GameOver] r =>
+  Members [ConsoleIO, Error QuitGame] r =>
   Sem (PlayerIO : r) a ->
   Sem r a
 runPlayerIOAsConsoleUI =
@@ -152,5 +154,5 @@ runPlayerIOAsConsoleUI =
     . raiseUnder @(Input RawTurn)
     . raiseUnder @(Output (Player', Information))
     -- final effects we want to interpret in terms of
-    . raiseUnder @(Error GameOver)
+    . raiseUnder @(Error QuitGame)
     . raiseUnder @ConsoleIO
diff --git a/src/Game.hs b/src/Game.hs
index 26622db..17a6ba0 100644
--- a/src/Game.hs
+++ b/src/Game.hs
@@ -615,15 +615,15 @@ gameLoop currentPlayer = do
 -- | takes care of giving info about initial cards to players
 fullGameLoop ::
   ( Members [PlayerIO, State GameState, Output Turn] r,
-    Throws [CardDoesNotExist, GameOver] r
+    Throws '[CardDoesNotExist] r
   ) =>
-  Sem r Void
+  Sem r ()
 fullGameLoop = do
   s <- get @GameState
   for_ (s ^@.. #hands . #underlyingMap . (itraversed <.> itraversed)) $
     \((p, cix), c) ->
       for_ (s ^.. playersExcept p) $ giveInfo $ CardSatisfies p cix $ cardIs c
-  gameLoop (firstPlayer s)
+  runError' @GameOver (gameLoop (firstPlayer s)) $> ()
 
 -- | A deck is only valid if it is a permutation of all of the cards
 startingDeckValid :: Deck -> Bool