get reader monad in place
This commit is contained in:
parent
5601e6fcab
commit
1d4372a6b5
4 changed files with 68 additions and 34 deletions
|
@ -25,8 +25,7 @@ import Types
|
||||||
import Mesh
|
import Mesh
|
||||||
|
|
||||||
initEngine
|
initEngine
|
||||||
:: (MonadResource m, MonadFail m)
|
:: Render EngineData
|
||||||
=> m EngineData
|
|
||||||
initEngine = do
|
initEngine = do
|
||||||
-- initialize SDL2 with all subsystems
|
-- initialize SDL2 with all subsystems
|
||||||
void $ allocate_
|
void $ allocate_
|
||||||
|
@ -58,9 +57,8 @@ initEngine = do
|
||||||
|
|
||||||
|
|
||||||
initVulkan
|
initVulkan
|
||||||
:: (MonadResource m, MonadFail m)
|
:: SDL.Window
|
||||||
=> SDL.Window
|
-> Render EngineData
|
||||||
-> m EngineData
|
|
||||||
initVulkan window = do
|
initVulkan window = do
|
||||||
|
|
||||||
vulkanInstance <- createInstance window
|
vulkanInstance <- createInstance window
|
||||||
|
|
|
@ -3,6 +3,7 @@
|
||||||
{-# LANGUAGE DataKinds #-}
|
{-# LANGUAGE DataKinds #-}
|
||||||
module Main where
|
module Main where
|
||||||
|
|
||||||
|
import qualified Control.Concurrent.STM as STM
|
||||||
import Control.Monad
|
import Control.Monad
|
||||||
import Control.Monad.Loops
|
import Control.Monad.Loops
|
||||||
import Control.Monad.IO.Class
|
import Control.Monad.IO.Class
|
||||||
|
@ -10,7 +11,6 @@ import Control.Monad.Trans.Resource
|
||||||
import Data.Bits
|
import Data.Bits
|
||||||
import Data.Word
|
import Data.Word
|
||||||
import qualified SDL hiding (V2)
|
import qualified SDL hiding (V2)
|
||||||
import qualified Control.Concurrent.STM as STM
|
|
||||||
import qualified Vulkan as Vk
|
import qualified Vulkan as Vk
|
||||||
import qualified Vulkan.Zero as Vk
|
import qualified Vulkan.Zero as Vk
|
||||||
|
|
||||||
|
@ -21,14 +21,15 @@ import Draw (drawFrame)
|
||||||
import Types
|
import Types
|
||||||
|
|
||||||
main :: IO ()
|
main :: IO ()
|
||||||
main = runResourceT $ do
|
main = do
|
||||||
|
container <- STM.newEmptyTMVarIO
|
||||||
|
runRender (ReadState container) $ do
|
||||||
engineData <- initEngine
|
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
|
||||||
|
@ -39,7 +40,7 @@ main = runResourceT $ do
|
||||||
frameNumber <- liftIO $ STM.atomically $ STM.takeTMVar frameContainer
|
frameNumber <- liftIO $ STM.atomically $ STM.takeTMVar frameContainer
|
||||||
liftIO $ STM.atomically $ STM.putTMVar frameContainer (succ frameNumber)
|
liftIO $ STM.atomically $ STM.putTMVar frameContainer (succ frameNumber)
|
||||||
-- draw
|
-- draw
|
||||||
drawFrame engineData showPipeline frameNumber
|
drawFrame engineData frameNumber
|
||||||
-- poll events
|
-- poll events
|
||||||
evs <- liftIO SDL.pollEvents
|
evs <- liftIO SDL.pollEvents
|
||||||
-- flip abort condition on window close
|
-- flip abort condition on window close
|
||||||
|
|
35
src/Types.hs
35
src/Types.hs
|
@ -1,6 +1,12 @@
|
||||||
{-# LANGUAGE DuplicateRecordFields #-}
|
{-# LANGUAGE DuplicateRecordFields #-}
|
||||||
|
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
|
||||||
|
{-# LANGUAGE DeriveFunctor #-}
|
||||||
module Types where
|
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 qualified Data.Vector as V
|
||||||
import Foreign
|
import Foreign
|
||||||
import Foreign.C.Types (CInt)
|
import Foreign.C.Types (CInt)
|
||||||
|
@ -145,3 +151,32 @@ data AllocatedImage = AllocatedImage
|
||||||
, allocation :: VMA.Allocation
|
, allocation :: VMA.Allocation
|
||||||
}
|
}
|
||||||
deriving (Show)
|
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
|
||||||
|
|
|
@ -52,7 +52,7 @@ executable vulkan-tutorial
|
||||||
, text
|
, text
|
||||||
, vector
|
, vector
|
||||||
, resourcet
|
, resourcet
|
||||||
, transformers
|
, mtl
|
||||||
hs-source-dirs: src
|
hs-source-dirs: src
|
||||||
default-language: Haskell2010
|
default-language: Haskell2010
|
||||||
ghc-options: -Wall
|
ghc-options: -Wall
|
||||||
|
|
Loading…
Reference in a new issue