mitigating memory leak, changing to IORef and making widnow movable

src/Affection.hs

@@ -18,12 +18,12 @@ import qualified GEGL as G
 
 import qualified Data.Text as T
 import Data.Maybe
+import Data.IORef
 
 import System.Clock
 
 import Control.Monad.Loops
 import Control.Monad.State
-import Control.Concurrent.MVar
 
 import Foreign.C.Types (CInt(..))
 import Foreign.Storable (peek)
@@ -47,11 +47,19 @@ withAffection AffectionConfig{..} = do
     Only is ->
       SDL.initialize is
   G.gegl_init
-  execTime <- newMVar =<< getTime Monotonic
+  execTime <- newIORef =<< getTime Monotonic
   window <- SDL.createWindow windowTitle windowConfig
   -- let surface = (flip SDL.Surface Nothing) rawSurfacePtr
   (oldSurf, surface) <- getSurfaces window
+  let (SDL.Surface ptr _) = surface
+  rawSurfacePtr <- Raw.convertSurfaceFormat ptr (SDL.toNumber SDL.ABGR8888) 0
+  pixelFormat <- liftIO $ peek . Raw.surfaceFormat =<< peek rawSurfacePtr
+  SDL.V2 (CInt rw) (CInt rh) <- liftIO $ SDL.surfaceDimensions surface
+  let (w, h) = (fromIntegral rw, fromIntegral rh)
+      stride = (fromIntegral $ Raw.pixelFormatBytesPerPixel pixelFormat) * w
+  pixels <- SDL.surfacePixels $ surface
   let bablFormat = B.PixelFormat B.RGBA B.CFu8
+      cpp        = B.babl_components_per_pixel bablFormat
   format <- B.babl_format bablFormat
   initContainer <- (\x -> AffectionData
     { quitEvent       = False
@@ -60,12 +68,17 @@ withAffection AffectionConfig{..} = do
     , windowSurface   = oldSurf
     , drawSurface     = surface
     , drawFormat      = format
+    , drawPixels      = pixels
+    , drawDimensions  = (w, h)
+    , drawStride      = stride
+    , drawCPP         = cpp
     , drawStack       = []
     , elapsedTime     = 0
     }) <$> loadState surface
   (_, nState) <- runStateT ( A.runState $ do
     preLoop
-    liftIO $ SDL.surfaceBlit surface Nothing oldSurf Nothing
+    pad <- get
+    liftIO $ SDL.surfaceBlit (drawSurface pad) Nothing (windowSurface pad) Nothing
     whileM_ (do
         current <- get
         return $ not $ A.quitEvent current
@@ -73,19 +86,11 @@ withAffection AffectionConfig{..} = do
       (do
         -- Measure time difference form last run
         now      <- liftIO $ getTime Monotonic
-        lastTime <- liftIO $ fromMaybe now <$> tryReadMVar execTime
+        lastTime <- liftIO $ readIORef execTime
         -- get state
         ad <- get
         -- clean draw requests from last run
-        pixels <- SDL.surfacePixels $ drawSurface ad
-        (SDL.Surface ptr _) <- SDL.getWindowSurface window
-        rawSurfacePtr <- Raw.convertSurfaceFormat ptr (SDL.toNumber SDL.ABGR8888) 0
-        pixelFormat <- liftIO $ peek . Raw.surfaceFormat =<< peek rawSurfacePtr
-        SDL.V2 (CInt rw) (CInt rh) <- liftIO $ SDL.surfaceDimensions surface
-        let (w, h) = (fromIntegral rw, fromIntegral rh)
-            stride = fromIntegral (Raw.pixelFormatBytesPerPixel pixelFormat) * w
-            cpp    = B.babl_components_per_pixel bablFormat
-        mapM_ (invalidateDrawRequest pixels stride cpp) $ drawStack ad
+        mapM_ (invalidateDrawRequest (drawPixels ad) (drawStride ad) (drawCPP ad)) (drawStack ad)
         -- compute dt and update elapsedTime
         let dt = (fromIntegral $ toNanoSecs $ diffTimeSpec lastTime now) / (fromIntegral 10 ^ 9)
         put $ ad
@@ -100,7 +105,8 @@ withAffection AffectionConfig{..} = do
         drawLoop
         -- handle all new draw requests
         ad2 <- get
-        clear <- catMaybes <$> mapM (handleDrawRequest pixels stride cpp) (drawStack ad2)
+        clear <- catMaybes <$>
+          mapM (handleDrawRequest (drawPixels ad) (drawStride ad) (drawCPP ad)) (drawStack ad2)
         -- save all draw requests to clear in next run
         put $ ad2
           { drawStack = clear }
@@ -112,8 +118,7 @@ withAffection AffectionConfig{..} = do
           Nothing
         liftIO $ SDL.updateWindowSurface $ drawWindow ad2
         -- save new time
-        _ <- liftIO $ swapMVar execTime $ now
-        return ()
+        liftIO $ writeIORef execTime $ now
       )
     ) initContainer
   G.gegl_exit
@@ -142,9 +147,19 @@ preHandleEvents evs =
     putNewSurface = do
       ad <- get
       (oldSurf, surface) <- liftIO $ getSurfaces $ drawWindow ad
+      pixels <- SDL.surfacePixels $ surface
+      SDL.V2 (CInt rw) (CInt rh) <- liftIO $ SDL.surfaceDimensions surface
+      let (SDL.Surface ptr _) = surface
+      rawSurfacePtr <- Raw.convertSurfaceFormat ptr (SDL.toNumber SDL.ABGR8888) 0
+      pixelFormat <- liftIO $ peek . Raw.surfaceFormat =<< peek rawSurfacePtr
+      let (w, h) = (fromIntegral rw, fromIntegral rh)
+          stride = fromIntegral (Raw.pixelFormatBytesPerPixel pixelFormat) * w
       put ad
-        { windowSurface = oldSurf
-        , drawSurface = surface
+        { windowSurface   = oldSurf
+        , drawSurface     = surface
+        , drawPixels      = pixels
+        , drawDimensions  = (w, h)
+        , drawStride      = stride
         }
 
 -- | Return the userstate to the user

src/Affection/Types.hs

@@ -44,6 +44,8 @@ import Control.Monad.State
 
 -- import Control.Concurrent.MVar
 
+import Foreign.Ptr (Ptr)
+
 -- | Configuration for the aplication. needed at startup.
 data AffectionConfig us = AffectionConfig
   { initComponents :: InitComponents
@@ -79,6 +81,10 @@ data AffectionData us = AffectionData
   , drawSurface     :: SDL.Surface        -- ^ SDL surface
   , drawFormat      :: B.BablFormatPtr    -- ^ Target format
   , drawStack       :: [DrawRequest]      -- ^ Stack of 'DrawRequest's to be processed
+  , drawPixels      :: Ptr ()             -- ^ Destination Pixel buffer
+  , drawDimensions  :: (Int, Int)   -- ^ Dimensions of target surface
+  , drawStride      :: Int                -- ^ Stride of target buffer
+  , drawCPP         :: Int                -- ^ Number of components per pixel
   , clearStack      :: [DrawRequest]      -- ^ Stack of 'DrawRequest's to be invalidated
   , elapsedTime     :: Double             -- ^ Elapsed time in seconds
   }