Merge commit '1b8d754cd64f3a3b94dbf41a04a30b456a75230e' into resourcetify

extern/affection/affection.cabal

@@ -102,7 +102,7 @@ library
   ghc-options:       -Wall
   -- Other library packages from which modules are imported.
   build-depends:       base >=4.9 && < 5
-                     , sdl2 ^>= 2.5
+                     , sdl2 >= 2.5
                      , linear
                      , text
                      , mtl
@@ -117,6 +117,7 @@ library
                      , stm
                      , uuid
                      , vector
+                     , resourcet
 
 -- This example shows the message system. only makes sense when compiling with
 -- verbose flag.
@@ -129,7 +130,7 @@ executable example00
   if flag(examples)
     build-depends:     base >=4.9 && < 5
                      , affection
-                     , sdl2 ^>= 2.5
+                     , sdl2 >= 2.5
                      , stm
   else
     buildable:       False
@@ -145,7 +146,7 @@ executable example01
   if flag(examples)
     build-depends:     base >=4.9 && < 5
                      , affection
-                     , sdl2 ^>= 2.5
+                     , sdl2 >= 2.5
                      , stm
                      , OpenGL
                      , random
@@ -168,7 +169,7 @@ executable example02
   if flag(examples)
     build-depends:     base >=4.9 && < 5
                      , affection
-                     , sdl2 ^>= 2.5
+                     , sdl2 >= 2.5
                      , stm
                      , OpenGL
                      , random

extern/affection/cabal.project

@@ -1,4 +1,4 @@
-constraints: affection +verbose
+constraints: affection +verbose +examples
 profiling: true
 packages:
   ./.

extern/affection/hie.yaml

@@ -0,0 +1,2 @@
+cradle:
+  cabal:

extern/affection/src/Affection.hs

@@ -1,6 +1,5 @@
 {-# LANGUAGE RecordWildCards #-}
 {-# LANGUAGE Strict #-}
-{-# LANGUAGE ExplicitForAll #-}
 {-# LANGUAGE ScopedTypeVariables #-}
 {-# LANGUAGE RankNTypes #-}
 {-# LANGUAGE TypeApplications #-}
@@ -23,12 +22,14 @@ import qualified Graphics.GL as GLRaw
 import Foreign.Marshal.Array
 
 import qualified Data.ByteString as B
-import qualified Data.ByteString.Char8 as B8
+
+import Data.String (fromString)
 
 import System.Clock
 
 import Control.Monad.Loops
 import Control.Monad.State.Strict
+import Control.Monad.Trans.Resource
 
 -- internal imports
 
@@ -46,46 +47,83 @@ withAffection
   :: forall us. (Affectionate us)
   => AffectionConfig us -- ^ Configuration of the Game and its engine.
   -> IO ()
-withAffection AffectionConfig{..} = do
+withAffection AffectionConfig{..} = runResourceT $ do
   liftIO $ logIO Debug "Affection starting"
   liftIO $ logIO Debug "Initializing SDL"
+
   -- intialiaze SDL
   case initComponents of
     All ->
       SDL.initializeAll
     Only is ->
       SDL.initialize is
+
   -- give SDL render quality
   SDL.HintRenderScaleQuality SDL.$= SDL.ScaleLinear
+
   -- just checking…
-  do
-    renderQuality <- SDL.get SDL.HintRenderScaleQuality
-    when (renderQuality /= SDL.ScaleLinear) $
-      logIO Warn "Linear texture filtering not enabled!"
+  renderQuality <- SDL.get SDL.HintRenderScaleQuality
+  when (renderQuality /= SDL.ScaleLinear) $
+    liftIO $ logIO Warn "Linear texture filtering not enabled!"
+  void $ liftIO (logIO Debug . fromString . show <$> (SDL.version :: IO (Integer, Integer, Integer)))
+
   -- construct window
   liftIO $ logIO Debug "Creating Window(s)"
-  windows <- zip3 (map (\(x,_,_) -> x) windowConfigs) <$>
+  windows <-
     mapM
-    (\wc -> SDL.createWindow windowTitle ((\(_,y,_) -> y) wc))
-    windowConfigs <*>
-    pure (map (\(_,_,z) -> z) windowConfigs)
+      (\(_, sdlWindowConfig, mode) -> do
+        (windowKey, window) <-
+          allocate
+            (SDL.createWindow windowTitle sdlWindowConfig)
+            (\window -> do
+              logIO Debug "Destroying Window"
+              SDL.destroyWindow window
+              )
+        return $ AffectionWindow window windowKey mode
+        )
+      windowConfigs
+
+  -- Show windows
+  mapM_ (SDL.showWindow . awWindow) windows
+
+  -- set modes of windows
+  mapM_ (\(AffectionWindow window _ mode) -> SDL.setWindowMode window mode) windows
+
+  -- Make GL context shareable
+  void $ SDL.glSetAttribute SDL.SDL_GL_SHARE_WITH_CURRENT_CONTEXT 1
+
+  -- Create OpenGL contexts
+  contexts <-
+    mapM
+      (\(AffectionWindow window _ _) -> do
+        (contextKey, context) <-
+          allocate
+            (SDL.glCreateContext window)
+            (\context -> do
+              logIO Debug "Destroying context"
+              SDL.glDeleteContext context
+              )
+        return $ AffectionContext context contextKey
+        )
+      windows
 
-  mapM_ (SDL.showWindow . (\(_,y,_) -> y)) windows
-  _ <- SDL.glSetAttribute SDL.SDL_GL_SHARE_WITH_CURRENT_CONTEXT 1
-  contexts <- zip (map (\(x,_,_) -> x) windows) <$>
-    mapM (SDL.glCreateContext . (\(_,y,_) -> y)) windows
-  mapM_ (\w -> flip SDL.setWindowMode  ((\(_,_,z) -> z) w) ((\(_,y,_) -> y) w)) windows
   -- sync updates with monitor
   -- SDL.swapInterval $= SDL.SynchronizedUpdates -- <- causes Problems with windows
-  liftIO $ logIO Debug "Getting Time"
+
   -- print current used GL Version
-  version <- peekArray0 (0 :: Word8) =<< GLRaw.glGetString GLRaw.GL_VERSION
-  print (B.pack version)
+  version <- liftIO $ peekArray0 (0 :: Word8) =<< GLRaw.glGetString GLRaw.GL_VERSION
+  liftIO $ print (B.pack version)
+
   -- get current time
-  execTime <- getTime Monotonic
+  liftIO $ logIO Debug "Getting Time"
+  execTime <- liftIO $ getTime Monotonic
   liftIO $ logIO Debug "Loading initial data container"
+
   -- construct game data object from provided Affectionate instance
-  gameData <- loadState @us
+  (gameDataKey, gameData) <-
+    allocate
+      (liftIO $ loadState @us)
+      (liftIO . cleanUp)
   -- build state container
   let initContainer = AffectionData
         { drawWindows     = windows
@@ -95,11 +133,12 @@ withAffection AffectionConfig{..} = do
         , sysTime         = execTime
         , pausedTime      = False
         }
+
   -- initialize and run state
-  (_, _) <- runStateT
-    (A.runState
+  void $ liftIO $ runAffection initContainer
       (do
         liftIO $ logIO Debug "Running Pre-Loop stage"
+
         -- run preLoop function from Affectionate
         preLoop gameData
         liftIO $ logIO Debug "Starting Loop"
@@ -107,31 +146,40 @@ withAffection AffectionConfig{..} = do
           (do
             -- get state
             ad <- get
+
             -- Measure time difference form last run
             now      <- liftIO $ getTime Monotonic
             let lastTime = sysTime ad
+
             -- compute dt and update elapsedTime
             let dt = fromIntegral
                    (toNanoSecs $ diffTimeSpec lastTime now) / (10 ^ (9 :: Int))
                 ne = elapsedTime ad + dt
+
             -- update state data object with new time values
             put $ ad
               { elapsedTime = ne
               , deltaTime = dt
               }
+
             -- poll events
             liftIO SDL.pumpEvents
             evs <- preHandleEvents =<< liftIO SDL.pollEvents
+
             -- handle events
             handleEvents gameData evs
+
             -- execute user defined update loop
             unless (pausedTime ad) (update gameData dt)
+
             -- clear GL buffer >> execute user defined draw loop >> flush GL buffer
             liftIO $ GL.clear [GL.ColorBuffer, GL.DepthBuffer, GL.StencilBuffer]
             draw gameData
             liftIO GL.flush
+
             -- actual displaying of newly drawn frame
-            mapM_ (SDL.glSwapWindow . (\(_,y,_) -> y)) windows
+            mapM_ (SDL.glSwapWindow . awWindow) windows
+
             -- save new time
             ad3 <- get
             when (sysTime ad == sysTime ad3) (
@@ -141,11 +189,16 @@ withAffection AffectionConfig{..} = do
               )
             )
         )
-      ) initContainer
+  -- Cleanup works
   liftIO $ logIO Debug "Loop ended. Cleaning"
-  cleanUp gameData
-  liftIO $ logIO Debug "Destroying Window"
-  mapM_ (SDL.glDeleteContext . snd) contexts
-  mapM_ (SDL.destroyWindow . (\(_,y,_) -> y)) windows
+  release gameDataKey
+  -- mapM_ (SDL.glDeleteContext . snd) contexts
+  -- mapM_ (SDL.destroyWindow . (\(_,y,_) -> y)) windows
   -- SDL.quit -- <- This causes segfaults depending on hardware
   liftIO $ logIO Debug "This is the end"
+
+runAffection
+  :: AffectionData
+  -> AffectionState AffectionData ResIO a
+  -> IO (a, AffectionData)
+runAffection initialState a = runResourceT $ runStateT (A.runState a) initialState

extern/affection/src/Affection/Types.hs

@@ -5,6 +5,8 @@ module Affection.Types
   , AffectionData(..)
   , AffectionStateInner
   , AffectionState(..)
+  , AffectionWindow(..)
+  , AffectionContext(..)
   , InitComponents(..)
   , Angle
   -- | SDL reexports
@@ -23,6 +25,7 @@ import qualified Data.Text as T
 
 import Control.Monad.IO.Class
 import Control.Monad.State.Strict
+import Control.Monad.Trans.Resource
 import qualified Control.Monad.Parallel as MP
 
 import System.Clock (TimeSpec)
@@ -50,35 +53,35 @@ data InitComponents
 
 -- | Main type for defining the look, feel and action of the whole application.
 data AffectionData = AffectionData
-  { drawWindows     ::
-    [
-    ( Word                                -- --^ Window identifier
-    , SDL.Window                          -- --^ Window linked with identifier
-    , SDL.WindowMode                      -- -- ^ current screen mode
-    )
-    ]                                     -- ^ SDL windows
-  , glContext       ::
-    [
-    ( Word                                -- --^ Window identifier
-    , SDL.GLContext                       -- --^ Associated OpenGL context
-    )
-    ]                                     -- ^ OpenGL rendering contexts
-  , elapsedTime     :: Double             -- ^ Elapsed time in seconds
-  , deltaTime       :: Double             -- ^ Elapsed time in seconds since last tick
-  , sysTime         :: TimeSpec           -- ^ System time (NOT the time on the clock)
-  , pausedTime      :: Bool               -- ^ Should the update loop be executed?
+  { drawWindows     :: [ AffectionWindow ]  -- ^ SDL windows
+  , glContext       :: [ AffectionContext ] -- ^ OpenGL rendering contexts
+  , elapsedTime     :: Double               -- ^ Elapsed time in seconds
+  , deltaTime       :: Double               -- ^ Elapsed time in seconds since last tick
+  , sysTime         :: TimeSpec             -- ^ System time (NOT the time on the clock)
+  , pausedTime      :: Bool                 -- ^ Should the update loop be executed?
   }
 
 -- | Inner 'StateT' monad for the update state
-type AffectionStateInner sd a = StateT sd a
+type AffectionStateInner sd m = StateT sd m
 
 -- | Affection's state monad
 newtype AffectionState sd m a = AffectionState
   { runState :: AffectionStateInner sd m a }
-  deriving (Functor, Applicative, Monad, MonadIO, MonadState sd)
+  deriving (Functor, Applicative, Monad, MonadIO, MonadState sd, MonadResource)
 
 instance MP.MonadParallel m => MP.MonadParallel (AffectionState sd m)
 
-type Affection a = AffectionState AffectionData IO a
+type Affection a = AffectionState AffectionData ResIO a
 
 type Angle = Double
+
+data AffectionWindow = AffectionWindow
+  { awWindow     :: SDL.Window
+  , awReleaseKey :: ReleaseKey
+  , awMode       :: SDL.WindowMode
+  }
+
+data AffectionContext = AffectionContext
+  { acContext    :: SDL.GLContext
+  , acReleaseKey :: ReleaseKey
+  }

extern/affection/src/Affection/Util.hs

@@ -39,32 +39,35 @@ getDelta = gets deltaTime
 toggleScreen :: Word -> Affection ()
 toggleScreen windowIdent = do
   ad <- get
-  let mwindow = find (\(ident, _, _) -> ident == windowIdent) (drawWindows ad)
-  case mwindow of
-    Just (ident, window, mode) -> do
-      newMode <- case mode of
-        SDL.FullscreenDesktop -> do
-          SDL.setWindowMode window SDL.Windowed
-          return SDL.Windowed
-        SDL.Windowed -> do
-          SDL.setWindowMode window SDL.FullscreenDesktop
-          return SDL.FullscreenDesktop
-        x -> do
-          liftIO $ logIO Warn ("Unexpected window mode: " <> fromString (show x))
-          return x
-      now <- liftIO $ getTime Monotonic
-      put ad
-        { sysTime = now
-        , drawWindows = map
-          (\e@(lid, win, _) ->
-            if lid == ident
-            then (lid, win, newMode)
-            else e
-            )
-          (drawWindows ad)
-        }
-    Nothing -> do
-      liftIO $ logIO Warn ("No window found with ident " <> fromString (show windowIdent))
+  (stop, alteredWindowList) <- foldM
+    (\(stop, resWindows) (num, aw@(AffectionWindow window _ mode)) -> do
+      if stop || num == windowIdent
+      then do
+        newMode <- case mode of
+          SDL.FullscreenDesktop -> do
+            liftIO $ SDL.setWindowMode window SDL.Windowed
+            return SDL.Windowed
+          SDL.Windowed -> do
+            liftIO $ SDL.setWindowMode window SDL.FullscreenDesktop
+            return SDL.FullscreenDesktop
+          x -> do
+            liftIO $ logIO Warn ("Unexpected window mode: " <> fromString (show x))
+            return x
+        return (True, resWindows ++ [aw { awMode = newMode }])
+      else
+        return (stop, resWindows ++ [aw])
+      )
+    (False, [])
+    (zip [0..] (drawWindows ad))
+  if stop
+  then do
+    now <- liftIO $ getTime Monotonic
+    put ad
+      { sysTime = now
+      , drawWindows = alteredWindowList
+      }
+  else
+    liftIO $ logIO Warn ("No window found with ident " <> fromString (show windowIdent))
 
 -- | Fit the GL Viewport to Window size
 fitViewport