Allow for hard quitting

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

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)

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
+        mworldAfterCon <- case coneffs sw of
-        case mconeff of
+            NoConcurrentEffect -> return $ Just sw
-            NoConcurrentEffect -> return ()
+            ImmediateEffect msw -> msw
-            ConcurrentEffect _ acc -> do
+            ConcurrentEffect sw' acc -> do
                 _ <- forkIO $ do
                     up <- acc
                     putMVar themvar up
-                return ()
+                return $ Just sw'
-        let startWorld'' = case mconeff of
-                NoConcurrentEffect -> sw
-                ConcurrentEffect immediatef _ -> immediatef
         mconupdate <- tryTakeMVar themvar
         let mstartWorld' = case mconupdate of
-                Just conupdate -> conupdate startWorld''
+                Just conupdate -> conupdate =<< mworldAfterCon
-                Nothing -> Just startWorld''
+                Nothing -> mworldAfterCon
         case mstartWorld' of
             Nothing -> return ()
             Just startWorld' -> do

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)