Allow for hard quitting

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