Attempt to improve perfomance

src/Loop.hs

@@ -13,6 +13,7 @@ module Loop (
     setupConLoop,
 ) where
 
+import Loop.Data
 import Control.Concurrent
 import Control.Exception
 import Control.Monad
@@ -104,8 +105,9 @@ setupConLoop ::
     (world -> IO ()) ->
     -- | Initial simulation state.
     IO world ->
-    -- | Concurrent effects. Evaluating 'Nothing' exits the loop
-    (world -> Maybe (world -> world, IO (world -> Maybe world))) ->
+    ---- | Concurrent effects. Evaluating 'Nothing' exits the loop
+    --(world -> Maybe (world -> world, IO (world -> Maybe world))) ->
+    (world -> ConcurrentEffect world) ->
     -- | update, called once per frame. Allows for side effects such as rendering.
     (world -> IO world) ->
     -- | SDL Event handling, once per frame. Evaluating 'Nothing' exits the loop.
@@ -134,9 +136,10 @@ doConLoop ::
     Int ->
     -- | The SDL window.
     Window ->
-    -- | Concurrent effects, the first function in the pair is applied
-    -- immediately
-    (world -> Maybe (world -> world, IO (world -> Maybe world))) ->
+    ---- | Concurrent effects, the first function in the pair is applied
+    ---- immediately
+    --(world -> Maybe (world -> world, IO (world -> Maybe world))) ->
+    (world -> ConcurrentEffect world) ->
     -- | simulation update.
     (world -> IO world) ->
     -- | SDL Event handling.
@@ -150,13 +153,15 @@ doConLoop themvar spf window coneffs worldSideEffects eventFn !startWorld = go s
         startTicks <- ticks
         let mconeff = coneffs sw
         case mconeff of
-            Nothing -> return ()
-            Just (_, acc) -> do
+            NoConcurrentEffect -> return ()
+            ConcurrentEffect _ acc -> do
                 _ <- forkIO $ do
                     up <- acc
                     putMVar themvar up
                 return ()
-        let startWorld'' = maybe id fst mconeff sw
+        let startWorld'' = case mconeff of
+                NoConcurrentEffect -> sw
+                ConcurrentEffect immediatef _ -> immediatef sw
         mconupdate <- tryTakeMVar themvar
         let mstartWorld' = case mconupdate of
                 Just conupdate -> conupdate startWorld''