module Engine.Types where
import RIO
import Control.Monad.Trans.Resource (ResourceT)
import Control.Monad.Trans.Resource qualified as ResourceT
import Data.Kind (Type)
import Graphics.UI.GLFW qualified as GLFW
import RIO.App (App, appEnv, appState)
import RIO.Lens (_1)
import UnliftIO.Resource (MonadResource, ReleaseKey)
import Vulkan.Core10 qualified as Vk
import Vulkan.Extensions.VK_KHR_surface qualified as Khr
import Vulkan.NamedType ((:::))
import Vulkan.Utils.QueueAssignment (QueueFamilyIndex(..))
import VulkanMemoryAllocator qualified as VMA
import Engine.Setup.Window (Window)
import Engine.Types.Options (Options)
import Engine.Types.RefCounted (RefCounted)
import Engine.Vulkan.Swapchain (SwapchainResources(..))
import Engine.Vulkan.Types (HasVulkan(..), HasSwapchain(..))
import Engine.Vulkan.Types qualified as Vulkan
import Engine.Worker qualified as Worker
data GlobalHandles = GlobalHandles
{ GlobalHandles -> Options
ghOptions :: Options
, GlobalHandles -> Window
ghWindow :: GLFW.Window
, GlobalHandles -> SurfaceKHR
ghSurface :: Khr.SurfaceKHR
, GlobalHandles -> Instance
ghInstance :: Vk.Instance
, GlobalHandles -> PhysicalDevice
ghPhysicalDevice :: Vk.PhysicalDevice
, GlobalHandles -> PhysicalDeviceInfo
ghPhysicalDeviceInfo :: Vulkan.PhysicalDeviceInfo
, GlobalHandles -> Device
ghDevice :: Vk.Device
, GlobalHandles -> Allocator
ghAllocator :: VMA.Allocator
, GlobalHandles -> Queues (QueueFamilyIndex, Queue)
ghQueues :: Vulkan.Queues (QueueFamilyIndex, Vk.Queue)
, GlobalHandles -> Var Extent2D
ghScreenVar :: Worker.Var Vk.Extent2D
, GlobalHandles -> StageSwitchVar
ghStageSwitch :: StageSwitchVar
}
{-# INLINE askScreenVar #-}
askScreenVar
:: MonadReader (App GlobalHandles st) m
=> m (Worker.Var Vk.Extent2D)
askScreenVar :: forall st (m :: * -> *).
MonadReader (App GlobalHandles st) m =>
m (Var Extent2D)
askScreenVar = forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks forall a b. (a -> b) -> a -> b
$ GlobalHandles -> Var Extent2D
ghScreenVar forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall env st. App env st -> env
appEnv
instance HasVulkan GlobalHandles where
getInstance :: GlobalHandles -> Instance
getInstance = GlobalHandles -> Instance
ghInstance
getQueues :: GlobalHandles -> Queues (QueueFamilyIndex, Queue)
getQueues = GlobalHandles -> Queues (QueueFamilyIndex, Queue)
ghQueues
getPhysicalDevice :: GlobalHandles -> PhysicalDevice
getPhysicalDevice = GlobalHandles -> PhysicalDevice
ghPhysicalDevice
getPhysicalDeviceInfo :: GlobalHandles -> PhysicalDeviceInfo
getPhysicalDeviceInfo = GlobalHandles -> PhysicalDeviceInfo
ghPhysicalDeviceInfo
getDevice :: GlobalHandles -> Device
getDevice = GlobalHandles -> Device
ghDevice
getAllocator :: GlobalHandles -> Allocator
getAllocator = GlobalHandles -> Allocator
ghAllocator
type StageStack = [StackStage]
data NextStage
= Finish
| Replace StackStage
| PushRestart StackStage
| PushFreeze StackStage
data StackStage where
StackStage
:: forall rp p rr st
. Vulkan.RenderPass rp
=> Stage rp p rr st
-> StackStage
StackStageContinue
:: forall rp p rr st
. Vulkan.RenderPass rp
=> ReleaseKey
-> st
-> Stage rp p rr st
-> StackStage
type StageSwitchVar = TMVar StageSwitch
data StageSwitch
= StageSwitchPending NextStage
| StageSwitchHandled
type StageRIO st = RIO (App GlobalHandles st)
type StageSetupRIO = RIO (App GlobalHandles (Maybe SwapchainResources))
type StageFrameRIO rp p rr st = RIO (App GlobalHandles st, Frame rp p rr)
instance HasStateRef st (App GlobalHandles st, Frame rp p rr) where
stateRefL :: Lens' (App GlobalHandles st, Frame rp p rr) (SomeRef st)
stateRefL =
forall s a b t. (s -> a) -> (s -> b -> t) -> Lens s t a b
lens
(forall env st. App env st -> SomeRef st
appState forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> a
fst)
(\(App GlobalHandles st
app, Frame rp p rr
frame) SomeRef st
st' ->
( App GlobalHandles st
app
{ appState :: SomeRef st
appState = SomeRef st
st'
}
, Frame rp p rr
frame
)
)
data Stage rp p rr st = forall a . Stage
{ forall rp p rr st. Stage rp p rr st -> Text
sTitle :: Text
, forall rp p rr st.
Stage rp p rr st
-> SwapchainResources -> ResourceT (StageRIO st) rp
sAllocateRP :: SwapchainResources -> ResourceT (StageRIO st) rp
, forall rp p rr st.
Stage rp p rr st
-> SwapchainResources -> rp -> ResourceT (StageRIO st) p
sAllocateP :: SwapchainResources -> rp -> ResourceT (StageRIO st) p
, forall rp p rr st.
Stage rp p rr st
-> StageRIO (Maybe SwapchainResources) (ReleaseKey, st)
sInitialRS :: StageRIO (Maybe SwapchainResources) (ReleaseKey, st)
, forall rp p rr st.
Stage rp p rr st
-> Queues CommandPool -> rp -> p -> ResourceT (StageRIO st) rr
sInitialRR :: Vulkan.Queues Vk.CommandPool -> rp -> p -> ResourceT (StageRIO st) rr
, ()
sBeforeLoop :: StageRIO st a
, forall rp p rr st.
Stage rp p rr st -> st -> rr -> StageFrameRIO rp p rr st ()
sUpdateBuffers :: st -> rr -> StageFrameRIO rp p rr st ()
, forall rp p rr st.
Stage rp p rr st
-> CommandBuffer
-> rr
-> ("image index" ::: Word32)
-> StageFrameRIO rp p rr st ()
sRecordCommands :: Vk.CommandBuffer -> rr -> "image index" ::: Word32 -> StageFrameRIO rp p rr st ()
, ()
sAfterLoop :: a -> StageRIO st ()
}
data Frame renderpass pipelines resources = Frame
{ forall renderpass pipelines resources.
Frame renderpass pipelines resources -> Word64
fIndex :: Word64
, forall renderpass pipelines resources.
Frame renderpass pipelines resources -> Window
fWindow :: Window
, forall renderpass pipelines resources.
Frame renderpass pipelines resources -> SurfaceKHR
fSurface :: Khr.SurfaceKHR
, forall renderpass pipelines resources.
Frame renderpass pipelines resources -> Maybe PresentModeKHR
fPresent :: Maybe Khr.PresentModeKHR
, forall renderpass pipelines resources.
Frame renderpass pipelines resources -> SampleCountFlagBits
fMSAA :: Vk.SampleCountFlagBits
, forall renderpass pipelines resources.
Frame renderpass pipelines resources -> SwapchainResources
fSwapchainResources :: SwapchainResources
, forall renderpass pipelines resources.
Frame renderpass pipelines resources -> renderpass
fRenderpass :: renderpass
, forall renderpass pipelines resources.
Frame renderpass pipelines resources -> pipelines
fPipelines :: pipelines
, forall renderpass pipelines resources.
Frame renderpass pipelines resources -> Semaphore
fRenderFinishedHostSemaphore :: Vk.Semaphore
, forall renderpass pipelines resources.
Frame renderpass pipelines resources -> (RefCounted, InternalState)
fStageResources :: (RefCounted, ResourceT.InternalState)
, forall renderpass pipelines resources.
Frame renderpass pipelines resources -> IORef [GPUWork]
fGPUWork :: IORef [GPUWork]
, forall renderpass pipelines resources.
Frame renderpass pipelines resources -> (ReleaseKey, InternalState)
fResources :: (ReleaseKey, ResourceT.InternalState)
, forall renderpass pipelines resources.
Frame renderpass pipelines resources -> RecycledResources resources
fRecycledResources :: RecycledResources resources
}
instance HasSwapchain (Frame renderpass pipelines resources) where
getSurfaceExtent :: Frame renderpass pipelines resources -> Extent2D
getSurfaceExtent = forall a. HasSwapchain a => a -> Extent2D
getSurfaceExtent forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall renderpass pipelines resources.
Frame renderpass pipelines resources -> SwapchainResources
fSwapchainResources
getSurfaceFormat :: Frame renderpass pipelines resources -> Format
getSurfaceFormat = forall a. HasSwapchain a => a -> Format
getSurfaceFormat forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall renderpass pipelines resources.
Frame renderpass pipelines resources -> SwapchainResources
fSwapchainResources
getDepthFormat :: Frame renderpass pipelines resources -> Format
getDepthFormat = forall a. HasSwapchain a => a -> Format
getDepthFormat forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall renderpass pipelines resources.
Frame renderpass pipelines resources -> SwapchainResources
fSwapchainResources
getMultisample :: Frame renderpass pipelines resources -> SampleCountFlagBits
getMultisample = forall a. HasSwapchain a => a -> SampleCountFlagBits
getMultisample forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall renderpass pipelines resources.
Frame renderpass pipelines resources -> SwapchainResources
fSwapchainResources
getAnisotropy :: Frame renderpass pipelines resources
-> "max sampler anisotropy" ::: Float
getAnisotropy = forall a. HasSwapchain a => a -> "max sampler anisotropy" ::: Float
getAnisotropy forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall renderpass pipelines resources.
Frame renderpass pipelines resources -> SwapchainResources
fSwapchainResources
getSwapchainViews :: Frame renderpass pipelines resources -> Vector ImageView
getSwapchainViews = forall a. HasSwapchain a => a -> Vector ImageView
getSwapchainViews forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall renderpass pipelines resources.
Frame renderpass pipelines resources -> SwapchainResources
fSwapchainResources
getMinImageCount :: Frame renderpass pipelines resources -> "image index" ::: Word32
getMinImageCount = forall a. HasSwapchain a => a -> "image index" ::: Word32
getMinImageCount forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall renderpass pipelines resources.
Frame renderpass pipelines resources -> SwapchainResources
fSwapchainResources
getImageCount :: Frame renderpass pipelines resources -> "image index" ::: Word32
getImageCount = forall a. HasSwapchain a => a -> "image index" ::: Word32
getImageCount forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall renderpass pipelines resources.
Frame renderpass pipelines resources -> SwapchainResources
fSwapchainResources
{-# INLINE getSurfaceExtent #-}
{-# INLINE getSurfaceFormat #-}
{-# INLINE getDepthFormat #-}
{-# INLINE getMultisample #-}
{-# INLINE getAnisotropy #-}
{-# INLINE getSwapchainViews #-}
{-# INLINE getMinImageCount #-}
{-# INLINE getImageCount #-}
type GPUWork =
( "host semaphore" ::: Vk.Semaphore
, "frame index" ::: Word64
)
data RecycledResources a = RecycledResources
{ forall a. RecycledResources a -> Semaphore
rrImageAvailableSemaphore :: Vk.Semaphore
, forall a. RecycledResources a -> Semaphore
rrRenderFinishedSemaphore :: Vk.Semaphore
, forall a. RecycledResources a -> Queues CommandPool
rrQueues :: Vulkan.Queues Vk.CommandPool
, forall a. RecycledResources a -> a
rrData :: a
}
instance HasLogFunc env => HasLogFunc (env, Frame rp p rr) where
logFuncL :: Lens' (env, Frame rp p rr) LogFunc
logFuncL = forall s t a b. Field1 s t a b => Lens s t a b
_1 forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall env. HasLogFunc env => Lens' env LogFunc
logFuncL
instance MonadResource (RIO (env, Frame rp p rr)) where
{-# INLINE liftResourceT #-}
liftResourceT :: forall a. ResourceT IO a -> RIO (env, Frame rp p rr) a
liftResourceT ResourceT IO a
rt =
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks (forall a b. (a, b) -> b
snd forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall renderpass pipelines resources.
Frame renderpass pipelines resources -> (ReleaseKey, InternalState)
fResources forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> b
snd) forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>=
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (m :: * -> *) a. ResourceT m a -> InternalState -> m a
ResourceT.runInternalState ResourceT IO a
rt
type HKD :: (Type -> Type) -> Type -> Type
type family HKD f a where
HKD Identity a = a
HKD f a = f a