diff --git a/.gitignore b/.gitignore index 8100c6f..7482a14 100644 --- a/.gitignore +++ b/.gitignore @@ -8,6 +8,8 @@ cabal.sandbox.config dist/ dist-newstyle/ +.direnv/ +.envrc *.prof *.aux *.hp diff --git a/cabal.config b/cabal.config index a48c35b..7b652c6 100644 --- a/cabal.config +++ b/cabal.config @@ -1,2 +1,2 @@ -constraints: affection +verbose +constraints: affection +debug profiling: True diff --git a/cabal.project b/cabal.project index 00222c9..e237b3f 100644 --- a/cabal.project +++ b/cabal.project @@ -2,3 +2,4 @@ packages: ./ ../affection profiling: True +constraints: affection +verbose diff --git a/src/Load.hs b/src/Load.hs index 0a9d6f0..7560ee5 100644 --- a/src/Load.hs +++ b/src/Load.hs @@ -8,6 +8,7 @@ import Graphics.Rendering.OpenGL.GL.FlushFinish (finish) import Control.Concurrent (forkIO) import Control.Concurrent.MVar import Control.Monad +import Control.Monad.Trans.Resource (ResIO) import qualified Data.Map as M import qualified Data.Text as T @@ -45,7 +46,7 @@ loadLoad ud = do (nano ud) (stateMVar ud) (stateProgress ud) - SDL.glMakeCurrent (fromJust curWin) (snd $ head $ glContext ad) + SDL.glMakeCurrent (fromJust curWin) (acContext $ head $ glContext ad) void $ liftIO $ swapMVar (state ud) Load void $ liftIO $ swapMVar (assetFonts ud) (M.fromList [ (FontBedstead, "bedstead") @@ -53,12 +54,12 @@ loadLoad ud = do ) loadFork - :: SystemState Entity (AffectionState (AffectionData) IO) + :: SystemState Entity (AffectionState (AffectionData) ResIO) -> SDL.Window -> SDL.GLContext -> Context -> MVar - ( SystemState Entity (AffectionState (AffectionData) IO) + ( SystemState Entity (AffectionState (AffectionData) ResIO) , StateData ) -> MVar (Float, T.Text) diff --git a/src/Main.hs b/src/Main.hs index d2490bb..5534282 100644 --- a/src/Main.hs +++ b/src/Main.hs @@ -17,6 +17,7 @@ import Data.Maybe (fromJust) import Control.Monad import Control.Concurrent.MVar +import Control.Monad.Trans.Resource (allocate) -- internal imports @@ -60,8 +61,9 @@ main = do pre :: UserData -> Affection () pre ud = do ad <- A.get - threadCtx <- SDL.glCreateContext ((\(_, y, _) -> y) $ head $ drawWindows ad) - SDL.glMakeCurrent ((\(_, y, _) -> y) $ head $ drawWindows ad) (snd $ head $ glContext ad) + let (AffectionWindow awwindow _ _) = head $ drawWindows ad + threadCtx <- SDL.glCreateContext awwindow + SDL.glMakeCurrent awwindow (acContext $ head $ glContext ad) let Subsystems w _ k j _ = subsystems ud _ <- partSubscribe w (fitViewport (1280/720)) _ <- partSubscribe w (exitOnWindowClose ud) @@ -70,7 +72,7 @@ pre ud = do u <- partSubscribe j (cacheJoypad ud) (ws, _) <- yieldSystemT (0, defStorage) (return ()) void $ liftIO $ swapMVar (threadContext ud) (Just threadCtx) - void $ liftIO $ swapMVar (window ud) (Just $ (\(_, y, _) -> y) $ head $ drawWindows ad) + void $ liftIO $ swapMVar (window ud) (Just awwindow) void $ liftIO $ putMVar (worldState ud) ws void $ liftIO $ putMVar (joyUUID ud) u @@ -90,8 +92,8 @@ quitGame ud (MsgKeyboardEvent _ _ SDL.Pressed False sym) mapM_ (partUnSubscribe j) curUUID mapM_ (partUnSubscribe t) curUUID SDL.glMakeCurrent - ((\(_, y, _) -> y) $ head $ drawWindows ad) - (snd $ head $ glContext ad) + (awWindow $ head $ drawWindows ad) + (acContext $ head $ glContext ad) (ws, _) <- yieldSystemT (0, defStorage) (return ()) void $ liftIO $ swapMVar (worldState ud) ws void $ liftIO $ swapMVar (state ud) Load diff --git a/src/MainGame/WorldMap.hs b/src/MainGame/WorldMap.hs index a1282fe..6ecae84 100644 --- a/src/MainGame/WorldMap.hs +++ b/src/MainGame/WorldMap.hs @@ -12,6 +12,7 @@ import NanoVG hiding (V2(..)) import Control.Monad (when, void) import Control.Monad.State.Strict (evalStateT) +import Control.Monad.Trans.Resource (ResIO, runResourceT) import Control.Concurrent.MVar import Control.Concurrent (forkIO) import Control.Parallel.Strategies hiding (dot) @@ -85,7 +86,7 @@ changeMaps2 _ _ = return () loadMapFork :: UserData -> AffectionData - -> MVar (SystemState Entity (AffectionState AffectionData IO), StateData) + -> MVar (SystemState Entity (AffectionState AffectionData ResIO), StateData) -> MVar (Float, T.Text) -> IO () loadMapFork ud ad future progress = do @@ -130,7 +131,7 @@ loadMapFork ud ad future progress = do , "Creating WorldState" ))) wState <- liftIO $ readMVar (worldState ud) - (nws, mmimgmat) <- evalStateT (runState (yieldSystemT wState $ do + (nws, mmimgmat) <- runResourceT $ evalStateT (runState (yieldSystemT wState $ do liftIO $ modifyMVar_ progress (return . (\(p, _) -> ( p + increment , "Registering copiers into WorldState" diff --git a/src/NPC.hs b/src/NPC.hs index 4396c3d..dc1aba7 100644 --- a/src/NPC.hs +++ b/src/NPC.hs @@ -15,6 +15,7 @@ import Data.String import Control.Monad.IO.Class (MonadIO(..)) import Control.Monad.Trans (lift) +import Control.Monad.Trans.Resource (ResIO) import Control.Concurrent.MVar import Control.Concurrent (forkIO) @@ -33,7 +34,7 @@ import Object () getPosBounds :: SystemT Entity - (AffectionState AffectionData IO) + (AffectionState AffectionData ResIO) [(V2 Double, Boundaries Double)] getPosBounds = do efor allEnts $ do @@ -47,10 +48,10 @@ getPosBounds = do updateNPCs :: M.Matrix (Maybe ImgId) -> M.Matrix TileState - -> SystemState Entity (AffectionState AffectionData IO) + -> SystemState Entity (AffectionState AffectionData ResIO) -> V.Vector ReachPoint -> Double - -> SystemT Entity (AffectionState AffectionData IO) () + -> SystemT Entity (AffectionState AffectionData ResIO) () updateNPCs imgmat tsmat ws rrp dt = do updateStats dt posbounds <- getPosBounds @@ -263,7 +264,7 @@ standStill imgmat tsmat pos' rot' ws posbounds rp = do updateStats :: Double - -> SystemT Entity (AffectionState AffectionData IO) () + -> SystemT Entity (AffectionState AffectionData ResIO) () updateStats dt = emap allEnts $ do with npcStats diff --git a/src/Types/ObjClass.hs b/src/Types/ObjClass.hs index 9413919..081ba91 100644 --- a/src/Types/ObjClass.hs +++ b/src/Types/ObjClass.hs @@ -5,6 +5,7 @@ module Types.ObjClass where import Affection +import Control.Monad.Trans.Resource (ResIO) import Data.Ecstasy import Types.Entity @@ -15,7 +16,7 @@ class ObjectAction otype ostate where -> otype -> ostate -> Ent - -> SystemT Entity (AffectionState AffectionData IO) () + -> SystemT Entity (AffectionState AffectionData ResIO) () objectTransition :: otype @@ -23,7 +24,7 @@ class ObjectAction otype ostate where -> Bool -> Ent -> Maybe Ent - -> SystemT Entity (AffectionState AffectionData IO) (Entity 'SetterOf) + -> SystemT Entity (AffectionState AffectionData ResIO) (Entity 'SetterOf) class ActionTime otype ostate where actionTime :: otype -> ostate -> Double diff --git a/src/Types/UserData.hs b/src/Types/UserData.hs index 14b18f5..c220b97 100644 --- a/src/Types/UserData.hs +++ b/src/Types/UserData.hs @@ -16,6 +16,7 @@ import qualified Data.Text as T import Data.Ecstasy import Control.Concurrent.MVar +import Control.Monad.Trans.Resource import Types.StateData import Types.ImgId @@ -34,10 +35,10 @@ data UserData = UserData , translation :: MVar Translation , nano :: Context , uuid :: MVar [UUID] - , worldState :: MVar (SystemState Entity (AffectionState AffectionData IO)) + , worldState :: MVar (SystemState Entity (AffectionState AffectionData ResIO)) , stateData :: MVar StateData , stateMVar :: MVar - ( SystemState Entity (AffectionState AffectionData IO) + ( SystemState Entity (AffectionState AffectionData ResIO) , StateData ) , stateProgress :: MVar (Float, T.Text) diff --git a/tracer-game.cabal b/tracer-game.cabal index 80b802e..3c505de 100644 --- a/tracer-game.cabal +++ b/tracer-game.cabal @@ -80,6 +80,7 @@ executable tracer-game , mtl , parallel , split + , resourcet hs-source-dirs: src ghc-options: -Wall -threaded default-language: Haskell2010