get reader monad in place

src/Init.hs

@@ -25,8 +25,7 @@ import Types
 import Mesh
 
 initEngine
-  :: (MonadResource m, MonadFail m)
+  :: Render EngineData
-  => m EngineData
 initEngine = do
   -- initialize SDL2 with all subsystems
   void $ allocate_
@@ -58,9 +57,8 @@ initEngine = do
 
 
 initVulkan
-  :: (MonadResource m, MonadFail m)
+  :: SDL.Window
-  => SDL.Window
+  -> Render EngineData
-  -> m EngineData
 initVulkan window = do
 
   vulkanInstance <- createInstance window

src/Main.hs

@@ -3,6 +3,7 @@
 {-# LANGUAGE DataKinds #-}
 module Main where
 
+import qualified Control.Concurrent.STM as STM
 import Control.Monad
 import Control.Monad.Loops
 import Control.Monad.IO.Class
@@ -10,7 +11,6 @@ import Control.Monad.Trans.Resource
 import Data.Bits
 import Data.Word
 import qualified SDL hiding (V2)
-import qualified Control.Concurrent.STM as STM
 import qualified Vulkan as Vk
 import qualified Vulkan.Zero as Vk
 
@@ -21,38 +21,39 @@ import Draw (drawFrame)
 import Types
 
 main :: IO ()
-main = runResourceT $ do
+main = do
-  engineData <- initEngine
+  container <- STM.newEmptyTMVarIO
+  runRender (ReadState container) $ do
+    engineData <- initEngine
 
-  SDL.showWindow $ engineWindow engineData
+    SDL.showWindow $ engineWindow engineData
 
-  -- create abort condition for upcoming lop
+    -- create abort condition for upcoming lop
-  quit <- liftIO $ STM.newTMVarIO True
+    quit <- liftIO $ STM.newTMVarIO True
-  showPipeline <- liftIO $ STM.newTMVarIO Green
+    frameContainer <- liftIO $ STM.newTMVarIO 0
-  frameContainer <- liftIO $ STM.newTMVarIO 0
 
-  -- main loop
+    -- main loop
-  whileM_
+    whileM_
-    (liftIO $ STM.atomically $ STM.readTMVar quit
+      (liftIO $ STM.atomically $ STM.readTMVar quit
+        )
+      ( do
+        frameNumber <- liftIO $ STM.atomically $ STM.takeTMVar frameContainer
+        liftIO $ STM.atomically $ STM.putTMVar frameContainer (succ frameNumber)
+        -- draw
+        drawFrame engineData frameNumber
+        -- poll events
+        evs <- liftIO SDL.pollEvents
+        -- flip abort condition on window close
+        mapM_
+          (\e -> case SDL.eventPayload e of
+            SDL.WindowClosedEvent _ ->
+              void $ liftIO $ STM.atomically $ STM.swapTMVar quit False
+            _ -> return ()
+            )
+          evs
       )
-    ( do
-      frameNumber <- liftIO $ STM.atomically $ STM.takeTMVar frameContainer
-      liftIO $ STM.atomically $ STM.putTMVar frameContainer (succ frameNumber)
-      -- draw
-      drawFrame engineData showPipeline frameNumber
-      -- poll events
-      evs <- liftIO SDL.pollEvents
-      -- flip abort condition on window close
-      mapM_
-        (\e -> case SDL.eventPayload e of
-          SDL.WindowClosedEvent _ ->
-            void $ liftIO $ STM.atomically $ STM.swapTMVar quit False
-          _ -> return ()
-          )
-        evs
-    )
 
-  Vk.deviceWaitIdle $ engineLogicalDevice engineData
+    Vk.deviceWaitIdle $ engineLogicalDevice engineData
 
 createBufferView
   :: (MonadResource m)

src/Types.hs

@@ -1,6 +1,12 @@
 {-# LANGUAGE DuplicateRecordFields #-}
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
+{-# LANGUAGE DeriveFunctor #-}
 module Types where
 
+import Control.Concurrent.STM.TMVar as STM
+import Control.Monad.IO.Class
+import Control.Monad.Reader
+import Control.Monad.Trans.Resource
 import qualified Data.Vector as V
 import Foreign
 import Foreign.C.Types (CInt)
@@ -145,3 +151,32 @@ data AllocatedImage = AllocatedImage
   , allocation :: VMA.Allocation
   }
   deriving (Show)
+
+data Material = Material
+  { materialPipeline       :: Vk.Pipeline
+  , materialPipelineLayout :: Vk.PipelineLayout
+  }
+  deriving (Show)
+
+data RenderObject = RenderObject
+  { objectMesh     :: Mesh
+  , objectMaterial :: Material
+  , objectMatrix   :: M44 Float
+  }
+  deriving (Show)
+
+newtype ReadState = ReadState
+  { renderables :: STM.TMVar (V.Vector RenderObject)
+  }
+
+newtype RenderReader rd m a = RenderReader
+  { runRenderInner :: RenderInner rd m a
+  }
+  deriving (Functor, Applicative, Monad, MonadIO, MonadReader rd, MonadResource, MonadFail)
+
+type RenderInner rd m = ReaderT rd m
+
+type Render a = RenderReader ReadState ResIO a
+
+runRender :: ReadState -> Render a -> IO a
+runRender rd actions = runResourceT $ flip runReaderT rd $ runRenderInner actions

vulkan-tutorial.cabal

@@ -52,7 +52,7 @@ executable vulkan-tutorial
                     , text
                     , vector
                     , resourcet
-                    , transformers
+                    , mtl
     hs-source-dirs:   src
     default-language: Haskell2010
     ghc-options:      -Wall