update to new affection

.gitignore

@@ -8,6 +8,8 @@
 cabal.sandbox.config
 dist/
 dist-newstyle/
+.direnv/
+.envrc
 *.prof
 *.aux
 *.hp

cabal.config

@@ -1,2 +1,2 @@
-constraints: affection +verbose
+constraints: affection +debug
 profiling: True

cabal.project

@@ -2,3 +2,4 @@ packages:
   ./
   ../affection
 profiling: True
+constraints: affection +verbose

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)

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)
+  let (AffectionWindow awwindow _ _) = head $ drawWindows ad
-  SDL.glMakeCurrent ((\(_, y, _) -> y) $ head $ drawWindows ad) (snd $ head $ glContext 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)
+        (awWindow $ head $ drawWindows ad)
-        (snd $ head $ glContext ad)
+        (acContext $ head $ glContext ad)
       (ws, _) <- yieldSystemT (0, defStorage) (return ())
       void $ liftIO $ swapMVar (worldState ud) ws
       void $ liftIO $ swapMVar (state ud) Load

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"

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

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

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)

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