get reader monad in place

This commit is contained in:
nek0 2023-01-02 02:18:06 +01:00
parent 5601e6fcab
commit 1d4372a6b5
4 changed files with 68 additions and 34 deletions

View file

@ -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

View file

@ -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)

View file

@ -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

View file

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