From 7d358fde29e53fdbbf53c0fe9b89ba84f1ead350 Mon Sep 17 00:00:00 2001
From: justin <justin.g.kruger@gmail.com>
Date: Tue, 1 Nov 2022 16:48:55 +0000
Subject: [PATCH] Allow for hard quitting

---
 src/Dodge/Concurrent.hs    |  4 +++-
 src/Dodge/Data/Universe.hs |  1 +
 src/Loop.hs                | 20 ++++++++++----------
 src/Loop/Data.hs           |  3 +++
 4 files changed, 17 insertions(+), 11 deletions(-)

diff --git a/src/Dodge/Concurrent.hs b/src/Dodge/Concurrent.hs
index c5ccd2dbc..d335b77ed 100644
--- a/src/Dodge/Concurrent.hs
+++ b/src/Dodge/Concurrent.hs
@@ -12,6 +12,7 @@ conEffects :: Universe -> ConcurrentEffect Universe
 conEffects u = case u ^? uvSideEffects . _head of
     Just NewSideEffect{_ceSideEffect = eff} -> ConcurrentEffect (u & uvSideEffects . _head %~ g) 
         (dopop eff)
+    Just HardQuit -> ImmediateEffect (return Nothing)
     _ -> NoConcurrentEffect
   where
     g seff = RunningSideEffect (_ceString seff)
@@ -26,7 +27,8 @@ addSideEffect :: IO (Universe -> Maybe Universe) -> String -> Universe -> Univer
 addSideEffect f s = uvSideEffects %~ (|> NewSideEffect f s)
 
 hardQuit :: Universe -> Universe
-hardQuit = addSideEffect (return $ const Nothing) "QUITTING"
+hardQuit = uvSideEffects %~ (HardQuit <|)
+--hardQuit = addSideEffect (return $ const Nothing) "QUITTING"
 
 --tryConcEffect :: Bool -> String -> IO (Universe -> Maybe Universe) -> Universe -> Universe
 --tryConcEffect bl str eff u = case u ^. uvConcEffects of
diff --git a/src/Dodge/Data/Universe.hs b/src/Dodge/Data/Universe.hs
index ad627efc9..93c919548 100644
--- a/src/Dodge/Data/Universe.hs
+++ b/src/Dodge/Data/Universe.hs
@@ -41,6 +41,7 @@ data SideEffect
         , _ceString :: String
         }
     | RunningSideEffect {_ceString :: String}
+    | HardQuit
 
 data OptionScreenFlag = NormalOptions | GameOverOptions | SplashOptions
     deriving (Eq, Ord, Show, Read) --Generic, Flat)
diff --git a/src/Loop.hs b/src/Loop.hs
index 5e2561cbd..7633957ee 100644
--- a/src/Loop.hs
+++ b/src/Loop.hs
@@ -131,6 +131,7 @@ setupConLoop spf title winconfig paramCleanup ioStartWorld coneffs sideEffects e
                     (doConLoop themvar spf window coneffs sideEffects eventFn)
 
 -- | The internal loop.
+-- Note that ImmediateEffect from ConcurrentEffect does not work properly.
 doConLoop ::
     -- | The mvar for concurrency
     MVar (world -> Maybe world) ->
@@ -156,6 +157,7 @@ doConLoop themvar spf window coneffs worldSideEffects eventFn !startWorld = go s
         let mconeff = coneffs sw
         case mconeff of
             NoConcurrentEffect -> return ()
+            ImmediateEffect _ -> return ()
             ConcurrentEffect _ acc -> do
                 _ <- forkIO $ do
                     up <- acc
@@ -163,6 +165,7 @@ doConLoop themvar spf window coneffs worldSideEffects eventFn !startWorld = go s
                 return ()
         let startWorld'' = case mconeff of
                 NoConcurrentEffect -> sw
+                ImmediateEffect _ -> sw
                 ConcurrentEffect immediatef _ -> immediatef
         mconupdate <- tryTakeMVar themvar
         let mstartWorld' = case mconupdate of
@@ -239,21 +242,18 @@ doConLoop' themvar spf window coneffs worldSideEffects eventFn !startWorld = go
     go sw = do
         startTicks <- ticks
         es <- pollEvents
-        let mconeff = coneffs sw
-        case mconeff of
-            NoConcurrentEffect -> return ()
-            ConcurrentEffect _ acc -> do
+        mworldAfterCon <- case coneffs sw of
+            NoConcurrentEffect -> return $ Just sw
+            ImmediateEffect msw -> msw
+            ConcurrentEffect sw' acc -> do
                 _ <- forkIO $ do
                     up <- acc
                     putMVar themvar up
-                return ()
-        let startWorld'' = case mconeff of
-                NoConcurrentEffect -> sw
-                ConcurrentEffect immediatef _ -> immediatef
+                return $ Just sw'
         mconupdate <- tryTakeMVar themvar
         let mstartWorld' = case mconupdate of
-                Just conupdate -> conupdate startWorld''
-                Nothing -> Just startWorld''
+                Just conupdate -> conupdate =<< mworldAfterCon
+                Nothing -> mworldAfterCon
         case mstartWorld' of
             Nothing -> return ()
             Just startWorld' -> do
diff --git a/src/Loop/Data.hs b/src/Loop/Data.hs
index fa15996a8..7e9651670 100644
--- a/src/Loop/Data.hs
+++ b/src/Loop/Data.hs
@@ -5,6 +5,9 @@ module Loop.Data where
 
 data ConcurrentEffect world
     = NoConcurrentEffect
+    | ImmediateEffect
+        { _immediateEffect :: IO (Maybe world)
+        }
     | ConcurrentEffect
         { _immediateUpdate :: world
         , _sideEffect :: IO (world -> Maybe world)