Refactor concurrent side effects

appDodge/Main.hs

@@ -89,7 +89,7 @@ firstWorldLoad theConfig = do
             , _uvScreenLayers = [splashMenu]
             , _uvIOEffects = return
             , _uvTestString = testStringInit
-            , _uvConcEffects = NoConcEffect
+            , _uvSideEffects = mempty
             , _uvCanContinue = cancontinue
             , _uvMSeed = mseed
             }

src/Dodge/Concurrent.hs

@@ -3,25 +3,38 @@ module Dodge.Concurrent where
 --import qualified Data.Set as S
 import Control.Lens
 import Dodge.Data.Universe
+import Data.Sequence (Seq (..))
 
 --import Control.Concurrent
 --import SDL.Input.Keyboard.Codes
 
 conEffects :: Universe -> ConcurrentEffect Universe
-conEffects u = case u ^. uvConcEffects of
-    NewConcEffect{_ceFunction = eff} -> eff
+conEffects u = case u ^? uvSideEffects . _head of
+    Just NewSideEffect{_ceSideEffect = eff} -> ConcurrentEffect (u & uvSideEffects . _head %~ g) 
+        (dopop eff)
     _ -> NoConcurrentEffect
-
-tryConcEffect :: Bool -> String -> IO (Universe -> Maybe Universe) -> Universe -> Universe
-tryConcEffect bl str eff u = case u ^. uvConcEffects of
-    NoConcEffect -> u & uvConcEffects .~ NewConcEffect (ConcurrentEffect setstr (clearConcEff eff)) str bl
-    _ -> u
   where
-    setstr
-        | bl = uvConcEffects .~ BlockingConcEffect str
-        | otherwise = uvConcEffects .~ BackgroundConcEffect str
+    g seff = RunningSideEffect (_ceString seff)
+    dopop :: IO (Universe -> Maybe Universe) -> IO (Universe -> Maybe Universe)
+    dopop mf = do
+        f <- mf 
+        return $ f . (uvSideEffects %~ taker)
+    taker (_ :<| xs) = xs
+    taker _ = mempty
 
-clearConcEff :: IO (Universe -> Maybe Universe) -> IO (Universe -> Maybe Universe)
-clearConcEff eff = do
-    f <- eff
-    return (f . (uvConcEffects .~ NoConcEffect))
+addSideEffect :: IO (Universe -> Maybe Universe) -> String -> Universe -> Universe
+addSideEffect f s = uvSideEffects %~ (|> NewSideEffect f s)
+
+--tryConcEffect :: Bool -> String -> IO (Universe -> Maybe Universe) -> Universe -> Universe
+--tryConcEffect bl str eff u = case u ^. uvConcEffects of
+--    NoConcEffect -> u & uvConcEffects .~ NewConcEffect (ConcurrentEffect setstr (clearConcEff eff)) str bl
+--    _ -> u
+--  where
+--    setstr
+--        | bl = uvConcEffects .~ BlockingConcEffect str
+--        | otherwise = uvConcEffects .~ BackgroundConcEffect str
+
+--clearConcEff :: IO (Universe -> Maybe Universe) -> IO (Universe -> Maybe Universe)
+--clearConcEff eff = do
+--    f <- eff
+--    return (f . (uvConcEffects .~ NoConcEffect))

src/Dodge/Data/Universe.hs

@@ -1,5 +1,5 @@
-{-# LANGUAGE DeriveGeneric #-}
 {-# LANGUAGE DeriveAnyClass #-}
+{-# LANGUAGE DeriveGeneric #-}
 {-# LANGUAGE StrictData #-}
 {-# LANGUAGE TemplateHaskell #-}
 
@@ -9,16 +9,17 @@ module Dodge.Data.Universe (
     module Dodge.Data.World,
     module Data.Preload,
     module Picture.Data,
-    module Loop.Data
+    module Loop.Data,
 ) where
 
-import Loop.Data
 import Control.Lens
 --import qualified Data.Map.Strict as M
 import Data.Preload
+import Data.Sequence (Seq (..))
 import qualified Data.Text as T
 import Dodge.Data.Config
 import Dodge.Data.World
+import Loop.Data
 import Picture.Data
 import SDL (Scancode)
 
@@ -27,18 +28,19 @@ data Universe = Universe
     , _preloadData :: PreloadData
     , _uvScreenLayers :: [ScreenLayer]
     , _uvIOEffects :: Universe -> IO Universe
-    , _uvConcEffects :: ConcEffect
+    , _uvSideEffects :: Seq SideEffect
     , _uvConfig :: Configuration
     , _uvTestString :: Universe -> [String]
     , _uvCanContinue :: Bool
     , _uvMSeed :: Maybe Int
     }
 
-data ConcEffect = NoConcEffect
-    | NewConcEffect {_ceFunction :: ConcurrentEffect Universe
-        , _ceString :: String, _ceIsBlocking :: Bool}
-    | BlockingConcEffect {_ceString :: String}
-    | BackgroundConcEffect {_ceString :: String}
+data SideEffect
+    = NewSideEffect
+        { _ceSideEffect :: IO (Universe -> Maybe Universe)
+        , _ceString :: String
+        }
+    | RunningSideEffect {_ceString :: String}
 
 data OptionScreenFlag = NormalOptions | GameOverOptions | SplashOptions
     deriving (Eq, Ord, Show, Read) --Generic, Flat)
@@ -59,6 +61,7 @@ data ScreenLayer
         { _scInput :: T.Text
         , _scFooter :: String
         }
+
 --    | WaitScreen
 --        { _scWaitMessage :: Universe -> String
 --        , _scWaitTime :: Int
@@ -67,9 +70,10 @@ data ScreenLayer
 --        { _scDisplay :: Universe -> Picture
 --        }
 
-data MenuOptionDisplay = MODString {_modString :: String}
-    | MODBlockedString {_modString :: String} 
-    | MODStringOption {_modString :: String,_modOption :: String}
+data MenuOptionDisplay
+    = MODString {_modString :: String}
+    | MODBlockedString {_modString :: String}
+    | MODStringOption {_modString :: String, _modOption :: String}
 
 data MenuOption
     = Toggle
@@ -93,5 +97,5 @@ data IntID a = IntID Int a
 
 makeLenses ''Universe
 makeLenses ''ScreenLayer
-makeLenses ''ConcEffect
+makeLenses ''SideEffect
 makeLenses ''MenuOptionDisplay

src/Dodge/Menu.hs

@@ -71,7 +71,7 @@ saveQuit :: Universe -> IO (Maybe Universe)
 saveQuit u =
     return $
         Just $
-            u & tryConcEffect True "SAVING" (saveQuitConc u)
+            u & addSideEffect (saveQuitConc u) "SAVING"
 
 saveQuitConc :: Universe -> IO (Universe -> Maybe Universe)
 saveQuitConc u = do

src/Dodge/Render/Picture.hs

@@ -26,14 +26,9 @@ fixedCoordPictures u =
     cfig = _uvConfig u
 
 drawConcurrentMessage :: Universe -> Picture
-drawConcurrentMessage u = case u ^. uvConcEffects of
-    BlockingConcEffect str -> fillWidthText cfig str
-    --listPicturesAt
-    --(halfWidth cfig)
-    --(halfHeight cfig)
-    --cfig
-    --[centerText str]
-    BackgroundConcEffect str ->
+drawConcurrentMessage u = case u ^? uvSideEffects . _head of
+    --Just (BlockingConcEffect str) -> fillWidthText cfig str
+    Just (RunningSideEffect str) ->
         listPicturesAt
             (halfWidth cfig)
             (_windowY cfig - 50)

src/Dodge/Save.hs

@@ -18,6 +18,7 @@ import qualified Data.ByteString.Lazy as BS
 import Dodge.Data.Universe
 --import qualified Data.Set as S
 import System.Directory
+--import Data.Sequence ((|>))
 
 
 writeSaveSlot :: SaveSlot -> Universe -> IO (Universe -> Maybe Universe)
@@ -52,13 +53,14 @@ saveSlotPath QuicksaveSlot = "saveSlot/QuickSave"
 saveSlotPath (LevelStartSlot i) = "saveSlot/LevelStart" ++ show i
 
 saveWorldInSlot :: SaveSlot -> Universe -> Universe
-saveWorldInSlot slot u = tryConcEffect False "SAVING" (writeSaveSlot slot u) u
+--saveWorldInSlot slot u = u & uvSideEffects %~ (|> NewSideEffect (writeSaveSlot slot u) "SAVING")
+saveWorldInSlot slot u = u & addSideEffect (writeSaveSlot slot u) "SAVING"
     
 reloadLevelStart :: Universe -> Universe
 reloadLevelStart = loadSaveSlot (LevelStartSlot 0)
 
 loadSaveSlot :: SaveSlot -> Universe -> Universe
-loadSaveSlot slot = tryConcEffect True "LOADING" (readSaveSlot slot)
+loadSaveSlot slot = addSideEffect (readSaveSlot slot) "LOADING"
 
 doQuicksave :: Universe -> Universe
 doQuicksave = saveWorldInSlot QuicksaveSlot

src/Dodge/StartNewGame.hs

@@ -17,7 +17,7 @@ startNewGameInSlot slot u = startSeedGame slot i u
     i = fst $ randomR (0, maxBound) (_randGen (_uvWorld u))
 
 startSeedGame :: Int -> Int -> Universe -> Universe
-startSeedGame _ i = tryConcEffect True "GENERATING" (startSeedGameConc i)
+startSeedGame _ i = addSideEffect (startSeedGameConc i) "GENERATING"
 
 startSeedGameConc :: Int -> IO (Universe -> Maybe Universe)
 startSeedGameConc seed = do

src/Dodge/Update.hs

@@ -93,7 +93,6 @@ updateUniverseLast = over uvWorld (input . mouseButtons . each .~ True) -- to de
 {- For most menus the only way to change the world is using event handling.  -}
 updateUniverseMid :: Universe -> Universe
 updateUniverseMid u
-    | concurrentblocking = u
     | otherwise = case _uvScreenLayers u of
         (OptionScreen{_scOptionFlag = GameOverOptions} : _) ->
             u & uvWorld
@@ -106,10 +105,6 @@ updateUniverseMid u
                    )
         (_ : _) -> u
         [] -> functionalUpdate'' u
-  where
-    concurrentblocking = case u ^. uvConcEffects of
-        BlockingConcEffect{} -> True
-        _ -> False
 
 functionalUpdate'' :: Universe -> Universe
 functionalUpdate'' = advanceScrollAmount . functionalUpdate'

src/Loop.hs

@@ -161,7 +161,7 @@ doConLoop themvar spf window coneffs worldSideEffects eventFn !startWorld = go s
                 return ()
         let startWorld'' = case mconeff of
                 NoConcurrentEffect -> sw
-                ConcurrentEffect immediatef _ -> immediatef sw
+                ConcurrentEffect immediatef _ -> immediatef
         mconupdate <- tryTakeMVar themvar
         let mstartWorld' = case mconupdate of
                 Just conupdate -> conupdate startWorld''

src/Loop/Data.hs

@@ -6,6 +6,6 @@ module Loop.Data where
 data ConcurrentEffect world
     = NoConcurrentEffect
     | ConcurrentEffect
-        { _immediateEffect :: world -> world
+        { _immediateUpdate :: world
         , _sideEffect :: IO (world -> Maybe world)
         }