From 1d4372a6b583e386d68aa113463f298f577c8233 Mon Sep 17 00:00:00 2001 From: nek0 Date: Mon, 2 Jan 2023 02:18:06 +0100 Subject: [PATCH] get reader monad in place --- src/Init.hs | 8 +++--- src/Main.hs | 57 ++++++++++++++++++++++--------------------- src/Types.hs | 35 ++++++++++++++++++++++++++ vulkan-tutorial.cabal | 2 +- 4 files changed, 68 insertions(+), 34 deletions(-) diff --git a/src/Init.hs b/src/Init.hs index 529b067..f80232f 100644 --- a/src/Init.hs +++ b/src/Init.hs @@ -25,8 +25,7 @@ import Types import Mesh initEngine - :: (MonadResource m, MonadFail m) - => m EngineData + :: Render EngineData initEngine = do -- initialize SDL2 with all subsystems void $ allocate_ @@ -58,9 +57,8 @@ initEngine = do initVulkan - :: (MonadResource m, MonadFail m) - => SDL.Window - -> m EngineData + :: SDL.Window + -> Render EngineData initVulkan window = do vulkanInstance <- createInstance window diff --git a/src/Main.hs b/src/Main.hs index 235da0f..fd21325 100644 --- a/src/Main.hs +++ b/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 - engineData <- initEngine +main = do + container <- STM.newEmptyTMVarIO + runRender (ReadState container) $ do + engineData <- initEngine - SDL.showWindow $ engineWindow engineData + SDL.showWindow $ engineWindow engineData - -- create abort condition for upcoming lop - quit <- liftIO $ STM.newTMVarIO True - showPipeline <- liftIO $ STM.newTMVarIO Green - frameContainer <- liftIO $ STM.newTMVarIO 0 + -- create abort condition for upcoming lop + quit <- liftIO $ STM.newTMVarIO True + frameContainer <- liftIO $ STM.newTMVarIO 0 - -- main loop - whileM_ - (liftIO $ STM.atomically $ STM.readTMVar quit + -- main loop + whileM_ + (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) diff --git a/src/Types.hs b/src/Types.hs index 36f02a9..e629d26 100644 --- a/src/Types.hs +++ b/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 diff --git a/vulkan-tutorial.cabal b/vulkan-tutorial.cabal index 3123e9c..1bae691 100644 --- a/vulkan-tutorial.cabal +++ b/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