mirror of
https://github.com/Drezil/dear-imgui.hs.git
synced 2025-11-03 22:51:07 +01:00
Vulkan backend (#2)
This commit adds the Vulkan backend and SDL2 integration, and provides the `vulkan` example project.
This commit is contained in:
sheaf
GitHub
@@ -1,3 +1,3 @@
|
||||
packages: *.cabal
|
||||
package dear-imgui
|
||||
flags: +sdl2 +opengl
|
||||
flags: +sdl2 +opengl +vulkan
|
||||
|
||||
@@ -11,6 +11,14 @@ flag opengl
|
||||
manual:
|
||||
False
|
||||
|
||||
flag vulkan
|
||||
description:
|
||||
Enable Vulkan backend.
|
||||
default:
|
||||
False
|
||||
manual:
|
||||
True
|
||||
|
||||
flag sdl
|
||||
description:
|
||||
Enable SDL backend.
|
||||
@@ -64,6 +72,27 @@ library
|
||||
extra-libraries:
|
||||
GL
|
||||
|
||||
if flag(vulkan)
|
||||
exposed-modules:
|
||||
DearImGui.Vulkan
|
||||
other-modules:
|
||||
DearImGui.Vulkan.Types
|
||||
build-depends:
|
||||
vulkan
|
||||
, unliftio
|
||||
cxx-sources:
|
||||
imgui/backends/imgui_impl_vulkan.cpp
|
||||
if os(windows)
|
||||
extra-libraries:
|
||||
vulkan-1
|
||||
else
|
||||
if os(darwin)
|
||||
extra-libraries:
|
||||
vulkan
|
||||
else
|
||||
pkgconfig-depends:
|
||||
vulkan
|
||||
|
||||
if flag(sdl)
|
||||
exposed-modules:
|
||||
DearImGui.SDL
|
||||
@@ -83,6 +112,10 @@ library
|
||||
exposed-modules:
|
||||
DearImGui.SDL.OpenGL
|
||||
|
||||
if flag(vulkan)
|
||||
exposed-modules:
|
||||
DearImGui.SDL.Vulkan
|
||||
|
||||
|
||||
executable test
|
||||
main-is: Main.hs
|
||||
@@ -97,3 +130,38 @@ executable readme
|
||||
default-language: Haskell2010
|
||||
build-depends: base, sdl2, gl, dear-imgui, managed
|
||||
ghc-options: -Wall
|
||||
|
||||
executable vulkan
|
||||
main-is: Main.hs
|
||||
other-modules: Attachments, Backend, Input, Util
|
||||
hs-source-dirs: examples/vulkan
|
||||
default-language: Haskell2010
|
||||
build-depends:
|
||||
dear-imgui
|
||||
, base
|
||||
>= 4.13 && < 4.16
|
||||
, bytestring
|
||||
>= 0.10.10.0 && < 0.12
|
||||
, containers
|
||||
^>= 0.6.2.1
|
||||
, logging-effect
|
||||
^>= 1.3.12
|
||||
, resourcet
|
||||
^>= 1.2.4.2
|
||||
, sdl2
|
||||
^>= 2.5.3.0
|
||||
, text-short
|
||||
^>= 0.1.3
|
||||
, transformers
|
||||
^>= 0.5.6.2
|
||||
, unliftio
|
||||
>= 0.2.13 && < 0.2.15
|
||||
, unliftio-core
|
||||
^>= 0.2.0.1
|
||||
, vector
|
||||
^>= 0.12.1.2
|
||||
, vulkan
|
||||
^>= 3.9
|
||||
, vulkan-utils
|
||||
^>= 0.4.1
|
||||
ghc-options: -Wall
|
||||
|
||||
246
examples/vulkan/Attachments.hs
Normal file
246
examples/vulkan/Attachments.hs
Normal file
@@ -0,0 +1,246 @@
|
||||
{-# LANGUAGE BlockArguments #-}
|
||||
{-# LANGUAGE DataKinds #-}
|
||||
{-# LANGUAGE DeriveTraversable #-}
|
||||
{-# LANGUAGE DerivingStrategies #-}
|
||||
{-# LANGUAGE PatternSynonyms #-}
|
||||
{-# LANGUAGE RecordWildCards #-}
|
||||
{-# LANGUAGE ScopedTypeVariables #-}
|
||||
{-# LANGUAGE TypeApplications #-}
|
||||
|
||||
module Attachments where
|
||||
|
||||
-- base
|
||||
import Data.Word
|
||||
( Word32 )
|
||||
|
||||
-- vector
|
||||
import qualified Data.Vector as Boxed
|
||||
( Vector )
|
||||
import qualified Data.Vector as Boxed.Vector
|
||||
( empty )
|
||||
|
||||
-- vulkan
|
||||
import qualified Vulkan
|
||||
import qualified Vulkan.Core10.Pass as Vulkan.AttachmentReference
|
||||
( AttachmentReference(..) )
|
||||
import qualified Vulkan.Zero as Vulkan
|
||||
|
||||
-- dear-imgui
|
||||
import Util
|
||||
( iunzipWith )
|
||||
|
||||
---------------------------------------------------------------
|
||||
-- Attachment types and their corresponding image layouts.
|
||||
|
||||
data AttachmentAccess
|
||||
= ReadAttachment
|
||||
| ReadWriteAttachment
|
||||
deriving stock ( Eq, Show )
|
||||
|
||||
data DepthStencilType =
|
||||
DepthStencilType
|
||||
{ depth :: Maybe AttachmentAccess
|
||||
, stencil :: Maybe AttachmentAccess
|
||||
}
|
||||
deriving stock ( Eq, Show )
|
||||
|
||||
data InputAttachmentType
|
||||
= ColorInputAttachment
|
||||
| DepthInputAttachment
|
||||
| StencilInputAttachment
|
||||
| DepthStencilInputAttachment
|
||||
deriving stock ( Eq, Show )
|
||||
|
||||
data AttachmentType
|
||||
= ColorAttachment
|
||||
| DepthStencilAttachment DepthStencilType
|
||||
| InputAttachment InputAttachmentType
|
||||
deriving stock ( Eq, Show )
|
||||
|
||||
data AttachmentUsage
|
||||
= UseAttachment
|
||||
| PreserveAttachment
|
||||
| ResolveAttachment
|
||||
deriving stock ( Eq, Show )
|
||||
|
||||
|
||||
depthStencilAttachmentLayout :: DepthStencilType -> Vulkan.ImageLayout
|
||||
depthStencilAttachmentLayout
|
||||
( DepthStencilType Nothing Nothing )
|
||||
= Vulkan.IMAGE_LAYOUT_GENERAL
|
||||
depthStencilAttachmentLayout
|
||||
( DepthStencilType (Just ReadAttachment) Nothing )
|
||||
= Vulkan.IMAGE_LAYOUT_DEPTH_READ_ONLY_OPTIMAL_KHR
|
||||
depthStencilAttachmentLayout
|
||||
( DepthStencilType (Just ReadWriteAttachment) Nothing )
|
||||
= Vulkan.IMAGE_LAYOUT_DEPTH_ATTACHMENT_OPTIMAL_KHR
|
||||
depthStencilAttachmentLayout
|
||||
( DepthStencilType Nothing (Just ReadAttachment) )
|
||||
= Vulkan.IMAGE_LAYOUT_STENCIL_READ_ONLY_OPTIMAL_KHR
|
||||
depthStencilAttachmentLayout
|
||||
( DepthStencilType Nothing (Just ReadWriteAttachment) )
|
||||
= Vulkan.IMAGE_LAYOUT_STENCIL_ATTACHMENT_OPTIMAL_KHR
|
||||
depthStencilAttachmentLayout
|
||||
( DepthStencilType (Just ReadAttachment) (Just ReadAttachment) )
|
||||
= Vulkan.IMAGE_LAYOUT_DEPTH_STENCIL_READ_ONLY_OPTIMAL
|
||||
depthStencilAttachmentLayout
|
||||
( DepthStencilType (Just ReadWriteAttachment) (Just ReadAttachment) )
|
||||
= Vulkan.IMAGE_LAYOUT_DEPTH_ATTACHMENT_STENCIL_READ_ONLY_OPTIMAL_KHR
|
||||
depthStencilAttachmentLayout
|
||||
( DepthStencilType (Just ReadAttachment) (Just ReadWriteAttachment) )
|
||||
= Vulkan.IMAGE_LAYOUT_DEPTH_READ_ONLY_STENCIL_ATTACHMENT_OPTIMAL_KHR
|
||||
depthStencilAttachmentLayout
|
||||
( DepthStencilType (Just ReadWriteAttachment) (Just ReadWriteAttachment) )
|
||||
= Vulkan.IMAGE_LAYOUT_DEPTH_STENCIL_ATTACHMENT_OPTIMAL
|
||||
|
||||
|
||||
inputAttachmentLayout :: InputAttachmentType -> Vulkan.ImageLayout
|
||||
inputAttachmentLayout ColorInputAttachment
|
||||
= Vulkan.IMAGE_LAYOUT_SHADER_READ_ONLY_OPTIMAL
|
||||
inputAttachmentLayout DepthInputAttachment
|
||||
= depthStencilAttachmentLayout ( DepthStencilType (Just ReadAttachment) Nothing )
|
||||
inputAttachmentLayout StencilInputAttachment
|
||||
= depthStencilAttachmentLayout ( DepthStencilType Nothing (Just ReadAttachment) )
|
||||
inputAttachmentLayout DepthStencilInputAttachment
|
||||
= depthStencilAttachmentLayout ( DepthStencilType (Just ReadAttachment) (Just ReadAttachment) )
|
||||
|
||||
attachmentLayout :: AttachmentType -> Vulkan.ImageLayout
|
||||
attachmentLayout ColorAttachment
|
||||
= Vulkan.IMAGE_LAYOUT_COLOR_ATTACHMENT_OPTIMAL
|
||||
attachmentLayout (DepthStencilAttachment depthStencilType)
|
||||
= depthStencilAttachmentLayout depthStencilType
|
||||
attachmentLayout (InputAttachment inputAttachmentType)
|
||||
= inputAttachmentLayout inputAttachmentType
|
||||
|
||||
---------------------------------------------------------------
|
||||
-- Some simple attachment descriptions, for convenience.
|
||||
|
||||
presentableColorAttachmentDescription :: Vulkan.Format -> ( Vulkan.AttachmentDescription, AttachmentType )
|
||||
presentableColorAttachmentDescription colorFormat =
|
||||
( description, ColorAttachment )
|
||||
where
|
||||
description =
|
||||
Vulkan.AttachmentDescription
|
||||
{ flags = Vulkan.zero
|
||||
, format = colorFormat
|
||||
, samples = Vulkan.SAMPLE_COUNT_1_BIT
|
||||
, loadOp = Vulkan.ATTACHMENT_LOAD_OP_CLEAR
|
||||
, storeOp = Vulkan.ATTACHMENT_STORE_OP_STORE
|
||||
, stencilLoadOp = Vulkan.ATTACHMENT_LOAD_OP_DONT_CARE
|
||||
, stencilStoreOp = Vulkan.ATTACHMENT_STORE_OP_DONT_CARE
|
||||
, initialLayout = Vulkan.IMAGE_LAYOUT_UNDEFINED
|
||||
, finalLayout = Vulkan.IMAGE_LAYOUT_PRESENT_SRC_KHR
|
||||
}
|
||||
|
||||
|
||||
depthAttachmentDescription :: Vulkan.Format -> ( Vulkan.AttachmentDescription, AttachmentType )
|
||||
depthAttachmentDescription depthFormat =
|
||||
( description, DepthStencilAttachment ( DepthStencilType (Just ReadWriteAttachment) Nothing ) )
|
||||
where
|
||||
description =
|
||||
Vulkan.AttachmentDescription
|
||||
{ flags = Vulkan.zero
|
||||
, format = depthFormat
|
||||
, samples = Vulkan.SAMPLE_COUNT_1_BIT
|
||||
, loadOp = Vulkan.ATTACHMENT_LOAD_OP_CLEAR
|
||||
, storeOp = Vulkan.ATTACHMENT_STORE_OP_STORE
|
||||
, stencilLoadOp = Vulkan.ATTACHMENT_LOAD_OP_DONT_CARE
|
||||
, stencilStoreOp = Vulkan.ATTACHMENT_STORE_OP_DONT_CARE
|
||||
, initialLayout = Vulkan.IMAGE_LAYOUT_UNDEFINED
|
||||
, finalLayout = Vulkan.IMAGE_LAYOUT_DEPTH_STENCIL_ATTACHMENT_OPTIMAL
|
||||
}
|
||||
|
||||
msDepthAttachmentDescription
|
||||
:: Vulkan.SampleCountFlagBits
|
||||
-> Vulkan.Format
|
||||
-> ( Vulkan.AttachmentDescription, AttachmentType )
|
||||
msDepthAttachmentDescription samples depthFormat =
|
||||
( description, DepthStencilAttachment ( DepthStencilType (Just ReadWriteAttachment) Nothing ) )
|
||||
where
|
||||
description =
|
||||
Vulkan.AttachmentDescription
|
||||
{ flags = Vulkan.zero
|
||||
, format = depthFormat
|
||||
, samples = samples
|
||||
, loadOp = Vulkan.ATTACHMENT_LOAD_OP_CLEAR
|
||||
, storeOp = Vulkan.ATTACHMENT_STORE_OP_STORE
|
||||
, stencilLoadOp = Vulkan.ATTACHMENT_LOAD_OP_DONT_CARE
|
||||
, stencilStoreOp = Vulkan.ATTACHMENT_STORE_OP_DONT_CARE
|
||||
, initialLayout = Vulkan.IMAGE_LAYOUT_UNDEFINED
|
||||
, finalLayout = Vulkan.IMAGE_LAYOUT_DEPTH_STENCIL_ATTACHMENT_OPTIMAL
|
||||
}
|
||||
|
||||
msColorAttachmentDescription
|
||||
:: Vulkan.SampleCountFlagBits
|
||||
-> Vulkan.Format
|
||||
-> ( Vulkan.AttachmentDescription, AttachmentType )
|
||||
msColorAttachmentDescription samples colorFormat =
|
||||
( description, ColorAttachment )
|
||||
where
|
||||
description =
|
||||
Vulkan.AttachmentDescription
|
||||
{ flags = Vulkan.zero
|
||||
, format = colorFormat
|
||||
, samples = samples
|
||||
, loadOp = Vulkan.ATTACHMENT_LOAD_OP_CLEAR
|
||||
, storeOp = Vulkan.ATTACHMENT_STORE_OP_STORE
|
||||
, stencilLoadOp = Vulkan.ATTACHMENT_LOAD_OP_DONT_CARE
|
||||
, stencilStoreOp = Vulkan.ATTACHMENT_STORE_OP_DONT_CARE
|
||||
, initialLayout = Vulkan.IMAGE_LAYOUT_UNDEFINED
|
||||
, finalLayout = Vulkan.IMAGE_LAYOUT_COLOR_ATTACHMENT_OPTIMAL
|
||||
}
|
||||
|
||||
---------------------------------------------------------------
|
||||
-- Set the attachments in a subpass.
|
||||
|
||||
data SubpassAttachments a
|
||||
= SubpassAttachments
|
||||
{ colorAttachments :: Boxed.Vector a
|
||||
, mbDepthStencilAttachment :: Maybe a
|
||||
, inputAttachments :: Boxed.Vector a
|
||||
, preserveAttachments :: Boxed.Vector a
|
||||
, resolveAttachments :: Boxed.Vector a
|
||||
} deriving stock ( Functor, Foldable, Traversable )
|
||||
|
||||
type SubpassAttachmentReferences = SubpassAttachments Vulkan.AttachmentReference
|
||||
|
||||
|
||||
noAttachments :: SubpassAttachments a
|
||||
noAttachments =
|
||||
SubpassAttachments
|
||||
Boxed.Vector.empty
|
||||
Nothing
|
||||
Boxed.Vector.empty
|
||||
Boxed.Vector.empty
|
||||
Boxed.Vector.empty
|
||||
|
||||
|
||||
createSubpass
|
||||
:: SubpassAttachmentReferences
|
||||
-> Vulkan.SubpassDescription
|
||||
createSubpass SubpassAttachments { .. } =
|
||||
Vulkan.SubpassDescription
|
||||
{ flags = Vulkan.zero
|
||||
, colorAttachments = colorAttachments
|
||||
, pipelineBindPoint = Vulkan.PIPELINE_BIND_POINT_GRAPHICS
|
||||
, depthStencilAttachment = mbDepthStencilAttachment
|
||||
, inputAttachments = inputAttachments
|
||||
, preserveAttachments = fmap Vulkan.AttachmentReference.attachment preserveAttachments
|
||||
, resolveAttachments = resolveAttachments
|
||||
}
|
||||
|
||||
attachmentReference :: Word32 -> AttachmentType -> Vulkan.AttachmentReference
|
||||
attachmentReference attachmentNumber attachmentType =
|
||||
Vulkan.AttachmentReference
|
||||
{ attachment = attachmentNumber
|
||||
, layout = attachmentLayout attachmentType
|
||||
}
|
||||
|
||||
attachmentReferencesAndDescriptions
|
||||
:: forall t. Traversable t
|
||||
=> t ( Vulkan.AttachmentDescription, AttachmentType )
|
||||
-> ( t Vulkan.AttachmentReference, [ Vulkan.AttachmentDescription ] )
|
||||
attachmentReferencesAndDescriptions =
|
||||
iunzipWith
|
||||
( \ i -> attachmentReference i . snd )
|
||||
( const fst )
|
||||
783
examples/vulkan/Backend.hs
Normal file
783
examples/vulkan/Backend.hs
Normal file
@@ -0,0 +1,783 @@
|
||||
{-# LANGUAGE BlockArguments #-}
|
||||
{-# LANGUAGE DataKinds #-}
|
||||
{-# LANGUAGE DeriveTraversable #-}
|
||||
{-# LANGUAGE DerivingStrategies #-}
|
||||
{-# LANGUAGE DuplicateRecordFields #-}
|
||||
{-# LANGUAGE FlexibleContexts #-}
|
||||
{-# LANGUAGE FlexibleInstances #-}
|
||||
{-# LANGUAGE LambdaCase #-}
|
||||
{-# LANGUAGE MonoLocalBinds #-}
|
||||
{-# LANGUAGE NamedFieldPuns #-}
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# LANGUAGE RecordWildCards #-}
|
||||
{-# LANGUAGE ScopedTypeVariables #-}
|
||||
{-# LANGUAGE TypeApplications #-}
|
||||
{-# LANGUAGE UndecidableInstances #-}
|
||||
|
||||
module Backend where
|
||||
|
||||
-- base
|
||||
import Control.Category
|
||||
( (>>>) )
|
||||
import Control.Monad
|
||||
( guard, unless, void )
|
||||
import Data.Bits
|
||||
( (.&.), (.|.) )
|
||||
import Data.Coerce
|
||||
( coerce )
|
||||
import Data.Foldable
|
||||
( toList )
|
||||
import Data.Functor
|
||||
( (<&>) )
|
||||
import Data.List
|
||||
( sortOn )
|
||||
import Data.Maybe
|
||||
( fromMaybe )
|
||||
import Data.Ord
|
||||
( Down(..) )
|
||||
import Data.Semigroup
|
||||
( First(..) )
|
||||
import Data.String
|
||||
( fromString )
|
||||
import Data.Traversable
|
||||
( for )
|
||||
import Data.Word
|
||||
( Word32 )
|
||||
import Foreign.C.String
|
||||
( CString )
|
||||
import Foreign.C.Types
|
||||
( CInt )
|
||||
import Foreign.Ptr
|
||||
( castPtr )
|
||||
|
||||
-- bytestring
|
||||
import Data.ByteString
|
||||
( ByteString )
|
||||
import qualified Data.ByteString.Short as ShortByteString
|
||||
( packCString )
|
||||
|
||||
-- containers
|
||||
import qualified Data.Map.Strict as Map
|
||||
( empty, insertWith, toList )
|
||||
|
||||
-- logging-effect
|
||||
import Control.Monad.Log
|
||||
( MonadLog, Severity(..), WithSeverity(..)
|
||||
, logDebug, logInfo
|
||||
)
|
||||
|
||||
-- resourcet
|
||||
import Control.Monad.Trans.Resource
|
||||
( MonadResource )
|
||||
import qualified Control.Monad.Trans.Resource as ResourceT
|
||||
( ReleaseKey, allocate )
|
||||
|
||||
-- sdl2
|
||||
import qualified SDL
|
||||
import qualified SDL.Raw
|
||||
import qualified SDL.Video.Vulkan
|
||||
|
||||
-- text-short
|
||||
import Data.Text.Short
|
||||
( ShortText )
|
||||
import qualified Data.Text.Short as ShortText
|
||||
( intercalate, pack, fromShortByteString, toByteString, unpack )
|
||||
|
||||
-- transformers
|
||||
import Control.Monad.IO.Class
|
||||
( MonadIO(liftIO) )
|
||||
|
||||
-- unliftio-core
|
||||
import Control.Monad.IO.Unlift
|
||||
( MonadUnliftIO )
|
||||
|
||||
-- vector
|
||||
import qualified Data.Vector as Boxed
|
||||
( Vector )
|
||||
import qualified Data.Vector as Boxed.Vector
|
||||
( (!?), empty, find, fromList, imap, imapMaybe, singleton, toList )
|
||||
|
||||
-- vulkan
|
||||
import qualified Vulkan
|
||||
import qualified Vulkan.CStruct.Extends as Vulkan
|
||||
import qualified Vulkan.Requirement as Vulkan
|
||||
import qualified Vulkan.Zero as Vulkan
|
||||
|
||||
-- vulkan-utils
|
||||
import qualified Vulkan.Utils.Initialization as Vulkan.Utils
|
||||
( createInstanceFromRequirements, createDebugInstanceFromRequirements
|
||||
, createDeviceFromRequirements
|
||||
)
|
||||
|
||||
-- dear-imgui
|
||||
import Attachments
|
||||
( AttachmentType, SubpassAttachments, SubpassAttachmentReferences
|
||||
, attachmentReferencesAndDescriptions
|
||||
, createSubpass
|
||||
)
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
|
||||
type LogMessage = WithSeverity ShortText
|
||||
class ( MonadUnliftIO m, MonadResource m, MonadLog LogMessage m ) => MonadVulkan m
|
||||
instance ( MonadUnliftIO m, MonadResource m, MonadLog LogMessage m ) => MonadVulkan m
|
||||
|
||||
----------------------------------------------------------------------------
|
||||
-- Logging.
|
||||
|
||||
logHandler :: MonadIO m => LogMessage -> m ()
|
||||
logHandler ( WithSeverity sev mess )
|
||||
= liftIO . putStrLn . ShortText.unpack $ showSeverity sev <> " " <> mess
|
||||
|
||||
showSeverity :: Severity -> ShortText
|
||||
showSeverity Emergency = "! PANIC !"
|
||||
showSeverity Alert = "! ALERT !"
|
||||
showSeverity Critical = "! CRIT !"
|
||||
showSeverity Error = "[ERR] "
|
||||
showSeverity Warning = "[WARN] "
|
||||
showSeverity Notice = "(note) "
|
||||
showSeverity Informational = "(info) "
|
||||
showSeverity Debug = "(debug)"
|
||||
|
||||
|
||||
data VulkanContext =
|
||||
VulkanContext
|
||||
{ instance' :: !Vulkan.Instance
|
||||
, physicalDevice :: !Vulkan.PhysicalDevice
|
||||
, device :: !Vulkan.Device
|
||||
, queueFamily :: !Word32
|
||||
, queue :: !Vulkan.Queue
|
||||
}
|
||||
|
||||
data InstanceType
|
||||
= NormalInstance
|
||||
| DebugInstance
|
||||
deriving stock Show
|
||||
|
||||
data VulkanRequirements =
|
||||
VulkanRequirements
|
||||
{ instanceRequirements :: [ Vulkan.InstanceRequirement ]
|
||||
, deviceRequirements :: [ Vulkan.DeviceRequirement ]
|
||||
, queueFlags :: Vulkan.QueueFlags
|
||||
}
|
||||
|
||||
data ValidationLayerName
|
||||
= LunarG
|
||||
| Khronos
|
||||
deriving stock ( Eq, Show )
|
||||
|
||||
initialiseVulkanContext :: MonadVulkan m => InstanceType -> ByteString -> VulkanRequirements -> m VulkanContext
|
||||
initialiseVulkanContext instanceType appName ( VulkanRequirements { instanceRequirements, deviceRequirements, queueFlags } ) = do
|
||||
logDebug "Creating Vulkan instance"
|
||||
instanceInfo <- vulkanInstanceInfo appName
|
||||
instance' <- case instanceType of
|
||||
NormalInstance -> Vulkan.Utils.createInstanceFromRequirements instanceRequirements [] instanceInfo
|
||||
DebugInstance -> Vulkan.Utils.createDebugInstanceFromRequirements instanceRequirements [] instanceInfo
|
||||
physicalDevice <- logDebug "Creating physical device" *> createPhysicalDevice instance'
|
||||
queueFamily <- logDebug "Finding suitable queue family" *> findQueueFamilyIndex physicalDevice queueFlags
|
||||
let
|
||||
queueCreateInfo :: Vulkan.DeviceQueueCreateInfo '[]
|
||||
queueCreateInfo = Vulkan.zero
|
||||
{ Vulkan.queueFamilyIndex = fromIntegral queueFamily
|
||||
, Vulkan.queuePriorities = Boxed.Vector.singleton ( 1.0 :: Float )
|
||||
}
|
||||
deviceCreateInfo :: Vulkan.DeviceCreateInfo '[]
|
||||
deviceCreateInfo = Vulkan.zero { Vulkan.queueCreateInfos = Boxed.Vector.singleton ( Vulkan.SomeStruct queueCreateInfo ) }
|
||||
swapchainDeviceRequirements :: [ Vulkan.DeviceRequirement ]
|
||||
swapchainDeviceRequirements
|
||||
= Vulkan.RequireDeviceExtension Nothing Vulkan.KHR_SWAPCHAIN_EXTENSION_NAME 0
|
||||
: deviceRequirements
|
||||
device <- logDebug "Creating logical device" *>
|
||||
Vulkan.Utils.createDeviceFromRequirements swapchainDeviceRequirements [] physicalDevice deviceCreateInfo
|
||||
queue <- Vulkan.getDeviceQueue device ( fromIntegral queueFamily ) 0
|
||||
|
||||
pure ( VulkanContext { .. } )
|
||||
|
||||
|
||||
|
||||
vulkanInstanceInfo
|
||||
:: MonadVulkan m
|
||||
=> ByteString
|
||||
-> m ( Vulkan.InstanceCreateInfo '[] )
|
||||
vulkanInstanceInfo appName = do
|
||||
|
||||
( availableLayers :: Boxed.Vector Vulkan.LayerProperties ) <- snd <$> Vulkan.enumerateInstanceLayerProperties
|
||||
|
||||
let
|
||||
validationLayer :: Maybe ValidationLayerName
|
||||
validationLayer
|
||||
= coerce
|
||||
. foldMap
|
||||
( ( Vulkan.layerName :: Vulkan.LayerProperties -> ByteString )
|
||||
>>> \case
|
||||
"VK_LAYER_LUNARG_standard_validation" -> Just ( First LunarG )
|
||||
"VK_LAYER_KHRONOS_validation" -> Just ( First Khronos )
|
||||
_ -> Nothing
|
||||
)
|
||||
$ availableLayers
|
||||
|
||||
enabledLayers :: [ ByteString ]
|
||||
enabledLayers = case validationLayer of
|
||||
Nothing -> []
|
||||
Just LunarG -> [ "VK_LAYER_LUNARG_standard_validation" ]
|
||||
Just Khronos -> [ "VK_LAYER_KHRONOS_validation" ]
|
||||
|
||||
appInfo :: Vulkan.ApplicationInfo
|
||||
appInfo =
|
||||
Vulkan.ApplicationInfo
|
||||
{ Vulkan.applicationName = Just appName
|
||||
, Vulkan.applicationVersion = 0
|
||||
, Vulkan.engineName = Nothing
|
||||
, Vulkan.engineVersion = 0
|
||||
, Vulkan.apiVersion = Vulkan.API_VERSION_1_2
|
||||
}
|
||||
|
||||
createInfo :: Vulkan.InstanceCreateInfo '[]
|
||||
createInfo =
|
||||
Vulkan.InstanceCreateInfo
|
||||
{ Vulkan.next = ()
|
||||
, Vulkan.flags = Vulkan.zero
|
||||
, Vulkan.applicationInfo = Just appInfo
|
||||
, Vulkan.enabledLayerNames = Boxed.Vector.fromList enabledLayers
|
||||
, Vulkan.enabledExtensionNames = mempty
|
||||
}
|
||||
|
||||
case validationLayer of
|
||||
Nothing -> logInfo "Validation layer unavailable. Is the Vulkan SDK installed?"
|
||||
Just _ -> logInfo ( "Enabled validation layers " <> ShortText.pack ( show enabledLayers ) )
|
||||
|
||||
pure createInfo
|
||||
|
||||
createPhysicalDevice :: MonadVulkan m => Vulkan.Instance -> m Vulkan.PhysicalDevice
|
||||
createPhysicalDevice vk = do
|
||||
physicalDevices <- snd <$> Vulkan.enumeratePhysicalDevices vk
|
||||
|
||||
typedDevices <-
|
||||
for physicalDevices \ physicalDevice -> do
|
||||
properties <- Vulkan.getPhysicalDeviceProperties physicalDevice
|
||||
pure ( physicalDevice, Vulkan.deviceType properties )
|
||||
|
||||
case Boxed.Vector.find ( isSuitableDeviceType . snd ) typedDevices of
|
||||
Nothing -> error "Could not find a suitable physical device"
|
||||
Just ( d, _ ) -> pure d
|
||||
|
||||
where
|
||||
isSuitableDeviceType :: Vulkan.PhysicalDeviceType -> Bool
|
||||
isSuitableDeviceType
|
||||
= flip elem
|
||||
[ Vulkan.PHYSICAL_DEVICE_TYPE_INTEGRATED_GPU
|
||||
, Vulkan.PHYSICAL_DEVICE_TYPE_DISCRETE_GPU
|
||||
]
|
||||
|
||||
findQueueFamilyIndex
|
||||
:: MonadIO m
|
||||
=> Vulkan.PhysicalDevice
|
||||
-> Vulkan.QueueFlags
|
||||
-> m Word32
|
||||
findQueueFamilyIndex physicalDevice requiredFlags = do
|
||||
queueFamilies <- Vulkan.getPhysicalDeviceQueueFamilyProperties physicalDevice
|
||||
let
|
||||
capableFamilyIndices :: Boxed.Vector Int
|
||||
capableFamilyIndices = ( `Boxed.Vector.imapMaybe` queueFamilies ) \ i queueFamily -> do
|
||||
guard ( Vulkan.queueFlags queueFamily .&. requiredFlags > Vulkan.zero )
|
||||
pure i
|
||||
case capableFamilyIndices Boxed.Vector.!? 0 of
|
||||
Nothing -> error "No queue family has sufficient capabilities"
|
||||
Just i -> pure ( fromIntegral i )
|
||||
|
||||
instanceExtensions :: [ ByteString ] -> [ Vulkan.InstanceRequirement ]
|
||||
instanceExtensions = map mkExtensionRequirement
|
||||
where
|
||||
mkExtensionRequirement :: ByteString -> Vulkan.InstanceRequirement
|
||||
mkExtensionRequirement extName =
|
||||
Vulkan.RequireInstanceExtension
|
||||
{ Vulkan.instanceExtensionLayerName = Nothing
|
||||
, Vulkan.instanceExtensionName = extName
|
||||
, Vulkan.instanceExtensionMinVersion = 0
|
||||
}
|
||||
|
||||
|
||||
initialiseWindow :: MonadVulkan m => WindowInfo -> m ( SDL.Window, [ ByteString ] )
|
||||
initialiseWindow ( WindowInfo { height, width, windowName, mouseMode } ) = do
|
||||
logDebug "Initializing SDL"
|
||||
SDL.Raw.logSetAllPriority SDL.Raw.SDL_LOG_PRIORITY_VERBOSE
|
||||
SDL.initialize [ SDL.InitVideo ]
|
||||
void ( SDL.setMouseLocationMode mouseMode )
|
||||
window <- logDebug "Creating SDL window" *> createWindow width height windowName
|
||||
neededExtensions <- logDebug "Loading needed extensions" *> SDL.Video.Vulkan.vkGetInstanceExtensions window
|
||||
extensionNames <- traverse ( liftIO . peekCString ) neededExtensions
|
||||
logInfo $ "Needed instance extensions are: " <> ShortText.intercalate ", " extensionNames
|
||||
pure ( window, map ShortText.toByteString extensionNames )
|
||||
|
||||
peekCString :: CString -> IO ShortText
|
||||
peekCString = fmap ( fromMaybe "???" . ShortText.fromShortByteString ) . ShortByteString.packCString
|
||||
|
||||
data WindowInfo
|
||||
= WindowInfo
|
||||
{ width :: CInt
|
||||
, height :: CInt
|
||||
, windowName :: ShortText
|
||||
, mouseMode :: SDL.LocationMode
|
||||
}
|
||||
|
||||
createWindow :: MonadVulkan m => CInt -> CInt -> ShortText -> m SDL.Window
|
||||
createWindow x y title =
|
||||
snd <$> ResourceT.allocate
|
||||
( SDL.createWindow
|
||||
( fromString ( ShortText.unpack title ) )
|
||||
SDL.defaultWindow
|
||||
{ SDL.windowGraphicsContext = SDL.VulkanContext
|
||||
, SDL.windowInitialSize = SDL.V2 x y
|
||||
, SDL.windowResizable = True
|
||||
}
|
||||
)
|
||||
SDL.destroyWindow
|
||||
|
||||
createSurface
|
||||
:: MonadVulkan m
|
||||
=> SDL.Window
|
||||
-> Vulkan.Instance
|
||||
-> m SDL.Video.Vulkan.VkSurfaceKHR
|
||||
createSurface window vulkanInstance =
|
||||
snd <$> ResourceT.allocate
|
||||
( SDL.Video.Vulkan.vkCreateSurface window ( castPtr $ Vulkan.instanceHandle vulkanInstance ) )
|
||||
( \ surf -> Vulkan.destroySurfaceKHR vulkanInstance ( Vulkan.SurfaceKHR surf ) Nothing )
|
||||
|
||||
assertSurfacePresentable
|
||||
:: MonadIO m
|
||||
=> Vulkan.PhysicalDevice
|
||||
-> Word32
|
||||
-> SDL.Video.Vulkan.VkSurfaceKHR
|
||||
-> m ()
|
||||
assertSurfacePresentable physicalDevice queueFamilyIndex surface = do
|
||||
isPresentable <-
|
||||
Vulkan.getPhysicalDeviceSurfaceSupportKHR
|
||||
physicalDevice
|
||||
queueFamilyIndex
|
||||
( Vulkan.SurfaceKHR surface )
|
||||
|
||||
unless isPresentable ( error "Surface is not presentable" )
|
||||
|
||||
|
||||
chooseSwapchainFormat
|
||||
:: MonadIO m
|
||||
=> Vulkan.SurfaceFormatKHR
|
||||
-> Vulkan.PhysicalDevice
|
||||
-> SDL.Video.Vulkan.VkSurfaceKHR
|
||||
-> m Vulkan.SurfaceFormatKHR
|
||||
chooseSwapchainFormat
|
||||
preferredFormat@( Vulkan.SurfaceFormatKHR fmt_p spc_p )
|
||||
physicalDevice
|
||||
surface
|
||||
= do
|
||||
surfaceFormats <- snd <$> Vulkan.getPhysicalDeviceSurfaceFormatsKHR physicalDevice ( Vulkan.SurfaceKHR surface )
|
||||
|
||||
case sortOn ( Down . score ) ( Boxed.Vector.toList surfaceFormats ) of
|
||||
[] -> error "No formats found."
|
||||
( best : _ )
|
||||
| Vulkan.FORMAT_UNDEFINED <- ( Vulkan.format :: Vulkan.SurfaceFormatKHR -> Vulkan.Format ) best
|
||||
-> pure preferredFormat
|
||||
| otherwise
|
||||
-> pure best
|
||||
|
||||
where
|
||||
match :: Eq a => a -> a -> Int
|
||||
match a b
|
||||
| a == b = 1
|
||||
| otherwise = 0
|
||||
|
||||
score :: Vulkan.SurfaceFormatKHR -> Int
|
||||
score ( Vulkan.SurfaceFormatKHR fmt spc )
|
||||
= match fmt fmt_p
|
||||
+ match spc spc_p
|
||||
|
||||
createSwapchain
|
||||
:: ( MonadIO m, MonadVulkan m )
|
||||
=> Vulkan.PhysicalDevice
|
||||
-> Vulkan.Device
|
||||
-> SDL.Video.Vulkan.VkSurfaceKHR
|
||||
-> Vulkan.SurfaceFormatKHR
|
||||
-> Vulkan.ImageUsageFlags
|
||||
-> Word32
|
||||
-> Maybe Vulkan.SwapchainKHR
|
||||
-> m ( ResourceT.ReleaseKey, Vulkan.SwapchainKHR, Vulkan.Extent2D )
|
||||
createSwapchain physicalDevice device surface surfaceFormat imageUsage imageCount oldSwapchain = do
|
||||
|
||||
surfaceCapabilities <- Vulkan.getPhysicalDeviceSurfaceCapabilitiesKHR physicalDevice ( Vulkan.SurfaceKHR surface )
|
||||
|
||||
( _, presentModes ) <- Vulkan.getPhysicalDeviceSurfacePresentModesKHR physicalDevice ( Vulkan.SurfaceKHR surface )
|
||||
|
||||
let
|
||||
presentMode :: Vulkan.PresentModeKHR
|
||||
presentMode
|
||||
| Vulkan.PRESENT_MODE_MAILBOX_KHR `elem` presentModes
|
||||
= Vulkan.PRESENT_MODE_MAILBOX_KHR
|
||||
| otherwise
|
||||
= Vulkan.PRESENT_MODE_FIFO_KHR
|
||||
|
||||
currentExtent :: Vulkan.Extent2D
|
||||
currentExtent = ( Vulkan.currentExtent :: Vulkan.SurfaceCapabilitiesKHR -> Vulkan.Extent2D ) surfaceCapabilities
|
||||
|
||||
currentTransform :: Vulkan.SurfaceTransformFlagBitsKHR
|
||||
currentTransform = ( Vulkan.currentTransform :: Vulkan.SurfaceCapabilitiesKHR -> Vulkan.SurfaceTransformFlagBitsKHR ) surfaceCapabilities
|
||||
|
||||
swapchainCreateInfo :: Vulkan.SwapchainCreateInfoKHR '[]
|
||||
swapchainCreateInfo =
|
||||
Vulkan.SwapchainCreateInfoKHR
|
||||
{ Vulkan.next = ()
|
||||
, Vulkan.flags = Vulkan.zero
|
||||
, Vulkan.surface = Vulkan.SurfaceKHR surface
|
||||
, Vulkan.minImageCount = imageCount
|
||||
, Vulkan.imageFormat = ( Vulkan.format :: Vulkan.SurfaceFormatKHR -> Vulkan.Format ) surfaceFormat
|
||||
, Vulkan.imageColorSpace = ( Vulkan.colorSpace :: Vulkan.SurfaceFormatKHR -> Vulkan.ColorSpaceKHR ) surfaceFormat
|
||||
, Vulkan.imageExtent = currentExtent
|
||||
, Vulkan.imageArrayLayers = 1
|
||||
, Vulkan.imageUsage = imageUsage
|
||||
, Vulkan.imageSharingMode = Vulkan.SHARING_MODE_EXCLUSIVE
|
||||
, Vulkan.queueFamilyIndices = Boxed.Vector.empty
|
||||
, Vulkan.preTransform = currentTransform
|
||||
, Vulkan.compositeAlpha = Vulkan.COMPOSITE_ALPHA_OPAQUE_BIT_KHR
|
||||
, Vulkan.presentMode = presentMode
|
||||
, Vulkan.clipped = True
|
||||
, Vulkan.oldSwapchain = fromMaybe Vulkan.NULL_HANDLE oldSwapchain
|
||||
}
|
||||
|
||||
( key, swapchain ) <- Vulkan.withSwapchainKHR device swapchainCreateInfo Nothing ResourceT.allocate
|
||||
pure ( key, swapchain, currentExtent )
|
||||
|
||||
|
||||
simpleRenderPass
|
||||
:: MonadVulkan m
|
||||
=> Vulkan.Device
|
||||
-> SubpassAttachments ( Vulkan.AttachmentDescription, AttachmentType )
|
||||
-> m ( ResourceT.ReleaseKey, Vulkan.RenderPass )
|
||||
simpleRenderPass dev attachments = Vulkan.withRenderPass dev createInfo Nothing ResourceT.allocate
|
||||
where
|
||||
|
||||
attachmentReferences :: SubpassAttachmentReferences
|
||||
attachmentDescriptions :: [ Vulkan.AttachmentDescription ]
|
||||
( attachmentReferences, attachmentDescriptions )
|
||||
= attachmentReferencesAndDescriptions attachments
|
||||
|
||||
subpass :: Vulkan.SubpassDescription
|
||||
subpass = createSubpass attachmentReferences
|
||||
|
||||
dependency1 :: Vulkan.SubpassDependency
|
||||
dependency1 =
|
||||
Vulkan.SubpassDependency
|
||||
{ Vulkan.srcSubpass = Vulkan.SUBPASS_EXTERNAL
|
||||
, Vulkan.dstSubpass = Vulkan.zero
|
||||
, Vulkan.srcStageMask = Vulkan.PIPELINE_STAGE_COLOR_ATTACHMENT_OUTPUT_BIT
|
||||
, Vulkan.srcAccessMask = Vulkan.zero
|
||||
, Vulkan.dstStageMask = Vulkan.PIPELINE_STAGE_COLOR_ATTACHMENT_OUTPUT_BIT
|
||||
, Vulkan.dstAccessMask = Vulkan.ACCESS_COLOR_ATTACHMENT_READ_BIT
|
||||
.|. Vulkan.ACCESS_COLOR_ATTACHMENT_WRITE_BIT
|
||||
, Vulkan.dependencyFlags = Vulkan.zero
|
||||
}
|
||||
|
||||
dependency2 :: Vulkan.SubpassDependency
|
||||
dependency2 =
|
||||
Vulkan.SubpassDependency
|
||||
{ Vulkan.srcSubpass = Vulkan.zero
|
||||
, Vulkan.dstSubpass = Vulkan.SUBPASS_EXTERNAL
|
||||
, Vulkan.srcStageMask = Vulkan.PIPELINE_STAGE_COLOR_ATTACHMENT_OUTPUT_BIT
|
||||
, Vulkan.srcAccessMask = Vulkan.ACCESS_COLOR_ATTACHMENT_READ_BIT
|
||||
.|. Vulkan.ACCESS_COLOR_ATTACHMENT_WRITE_BIT
|
||||
, Vulkan.dstStageMask = Vulkan.PIPELINE_STAGE_BOTTOM_OF_PIPE_BIT
|
||||
, Vulkan.dstAccessMask = Vulkan.zero
|
||||
, Vulkan.dependencyFlags = Vulkan.zero
|
||||
}
|
||||
|
||||
createInfo :: Vulkan.RenderPassCreateInfo '[]
|
||||
createInfo =
|
||||
Vulkan.RenderPassCreateInfo
|
||||
{ Vulkan.next = ()
|
||||
, Vulkan.flags = Vulkan.zero
|
||||
, Vulkan.attachments = Boxed.Vector.fromList attachmentDescriptions
|
||||
, Vulkan.subpasses = Boxed.Vector.singleton subpass
|
||||
, Vulkan.dependencies = Boxed.Vector.fromList [ dependency1, dependency2 ]
|
||||
}
|
||||
|
||||
cmdBeginRenderPass
|
||||
:: MonadIO m
|
||||
=> Vulkan.CommandBuffer
|
||||
-> Vulkan.RenderPass
|
||||
-> Vulkan.Framebuffer
|
||||
-> [ Vulkan.ClearValue ]
|
||||
-> Vulkan.Extent2D
|
||||
-> m ()
|
||||
cmdBeginRenderPass commandBuffer renderPass framebuffer clearValues extent =
|
||||
let
|
||||
zeroZero :: Vulkan.Offset2D
|
||||
zeroZero =
|
||||
Vulkan.Offset2D
|
||||
{ Vulkan.x = 0
|
||||
, Vulkan.y = 0
|
||||
}
|
||||
|
||||
renderArea :: Vulkan.Rect2D
|
||||
renderArea =
|
||||
Vulkan.Rect2D
|
||||
{ Vulkan.offset = zeroZero
|
||||
, Vulkan.extent = extent
|
||||
}
|
||||
|
||||
beginInfo :: Vulkan.RenderPassBeginInfo '[]
|
||||
beginInfo =
|
||||
Vulkan.RenderPassBeginInfo
|
||||
{ Vulkan.next = ()
|
||||
, Vulkan.renderPass = renderPass
|
||||
, Vulkan.framebuffer = framebuffer
|
||||
, Vulkan.renderArea = renderArea
|
||||
, Vulkan.clearValues = Boxed.Vector.fromList clearValues
|
||||
}
|
||||
in
|
||||
Vulkan.cmdBeginRenderPass
|
||||
commandBuffer
|
||||
beginInfo
|
||||
Vulkan.SUBPASS_CONTENTS_INLINE
|
||||
|
||||
cmdNextSubpass :: MonadIO m => Vulkan.CommandBuffer -> m ()
|
||||
cmdNextSubpass commandBuffer = Vulkan.cmdNextSubpass commandBuffer Vulkan.SUBPASS_CONTENTS_INLINE
|
||||
|
||||
cmdEndRenderPass :: MonadIO m => Vulkan.CommandBuffer -> m ()
|
||||
cmdEndRenderPass = Vulkan.cmdEndRenderPass
|
||||
|
||||
createImageView
|
||||
:: MonadVulkan m
|
||||
=> Vulkan.Device
|
||||
-> Vulkan.Image
|
||||
-> Vulkan.ImageViewType
|
||||
-> Vulkan.Format
|
||||
-> Vulkan.ImageAspectFlags
|
||||
-> m ( ResourceT.ReleaseKey, Vulkan.ImageView )
|
||||
createImageView dev image viewType fmt aspect = Vulkan.withImageView dev createInfo Nothing ResourceT.allocate
|
||||
where
|
||||
components :: Vulkan.ComponentMapping
|
||||
components =
|
||||
Vulkan.ComponentMapping
|
||||
{ Vulkan.r = Vulkan.COMPONENT_SWIZZLE_IDENTITY
|
||||
, Vulkan.g = Vulkan.COMPONENT_SWIZZLE_IDENTITY
|
||||
, Vulkan.b = Vulkan.COMPONENT_SWIZZLE_IDENTITY
|
||||
, Vulkan.a = Vulkan.COMPONENT_SWIZZLE_IDENTITY
|
||||
}
|
||||
|
||||
subResourceRange :: Vulkan.ImageSubresourceRange
|
||||
subResourceRange =
|
||||
Vulkan.ImageSubresourceRange
|
||||
{ Vulkan.aspectMask = aspect
|
||||
, Vulkan.baseMipLevel = 0
|
||||
, Vulkan.levelCount = 1
|
||||
, Vulkan.baseArrayLayer = 0
|
||||
, Vulkan.layerCount = 1
|
||||
}
|
||||
|
||||
createInfo :: Vulkan.ImageViewCreateInfo '[]
|
||||
createInfo =
|
||||
Vulkan.ImageViewCreateInfo
|
||||
{ Vulkan.next = ()
|
||||
, Vulkan.flags = Vulkan.zero
|
||||
, Vulkan.image = image
|
||||
, Vulkan.viewType = viewType
|
||||
, Vulkan.format = fmt
|
||||
, Vulkan.components = components
|
||||
, Vulkan.subresourceRange = subResourceRange
|
||||
}
|
||||
|
||||
createFramebuffer
|
||||
:: ( MonadVulkan m, Foldable f )
|
||||
=> Vulkan.Device
|
||||
-> Vulkan.RenderPass
|
||||
-> Vulkan.Extent2D
|
||||
-> f Vulkan.ImageView
|
||||
-> m ( ResourceT.ReleaseKey, Vulkan.Framebuffer )
|
||||
createFramebuffer dev renderPass extent attachments = Vulkan.withFramebuffer dev createInfo Nothing ResourceT.allocate
|
||||
where
|
||||
createInfo :: Vulkan.FramebufferCreateInfo '[]
|
||||
createInfo =
|
||||
Vulkan.FramebufferCreateInfo
|
||||
{ Vulkan.next = ()
|
||||
, Vulkan.flags = Vulkan.zero
|
||||
, Vulkan.renderPass = renderPass
|
||||
, Vulkan.attachments = Boxed.Vector.fromList . toList $ attachments
|
||||
, Vulkan.width = ( Vulkan.width :: Vulkan.Extent2D -> Word32 ) extent
|
||||
, Vulkan.height = ( Vulkan.height :: Vulkan.Extent2D -> Word32 ) extent
|
||||
, Vulkan.layers = 1
|
||||
}
|
||||
|
||||
createDescriptorPool
|
||||
:: MonadVulkan m
|
||||
=> Vulkan.Device
|
||||
-> Int
|
||||
-> [ ( Vulkan.DescriptorType, Int ) ]
|
||||
-> m ( ResourceT.ReleaseKey, Vulkan.DescriptorPool )
|
||||
createDescriptorPool device maxSets descTypes = Vulkan.withDescriptorPool device createInfo Nothing ResourceT.allocate
|
||||
|
||||
where
|
||||
poolSizes :: [ Vulkan.DescriptorPoolSize ]
|
||||
poolSizes =
|
||||
counts descTypes <&> \ ( descType, descCount ) ->
|
||||
Vulkan.DescriptorPoolSize
|
||||
{ Vulkan.type' = descType
|
||||
, Vulkan.descriptorCount = fromIntegral $ maxSets * descCount
|
||||
}
|
||||
createInfo :: Vulkan.DescriptorPoolCreateInfo '[]
|
||||
createInfo =
|
||||
Vulkan.DescriptorPoolCreateInfo
|
||||
{ Vulkan.next = ()
|
||||
, Vulkan.flags = Vulkan.DESCRIPTOR_POOL_CREATE_FREE_DESCRIPTOR_SET_BIT
|
||||
, Vulkan.poolSizes = Boxed.Vector.fromList poolSizes
|
||||
, Vulkan.maxSets = fromIntegral maxSets
|
||||
}
|
||||
|
||||
counts :: ( Ord a, Num i ) => [ ( a, i ) ] -> [ ( a, i ) ]
|
||||
counts = Map.toList . foldr ( uncurry $ Map.insertWith (+) ) Map.empty
|
||||
|
||||
createDescriptorSetLayout
|
||||
:: MonadVulkan m
|
||||
=> Vulkan.Device
|
||||
-> [ ( Vulkan.DescriptorType, Vulkan.ShaderStageFlags ) ]
|
||||
-> m ( ResourceT.ReleaseKey, Vulkan.DescriptorSetLayout )
|
||||
createDescriptorSetLayout device descriptorTypes = Vulkan.withDescriptorSetLayout device createInfo Nothing ResourceT.allocate
|
||||
|
||||
where
|
||||
bindings :: Boxed.Vector Vulkan.DescriptorSetLayoutBinding
|
||||
bindings = ( `Boxed.Vector.imap` Boxed.Vector.fromList descriptorTypes ) \ i ( descType, descStageFlags ) ->
|
||||
Vulkan.DescriptorSetLayoutBinding
|
||||
{ Vulkan.binding = fromIntegral i
|
||||
, Vulkan.descriptorType = descType
|
||||
, Vulkan.descriptorCount = 1
|
||||
, Vulkan.stageFlags = descStageFlags
|
||||
, Vulkan.immutableSamplers = Boxed.Vector.empty
|
||||
}
|
||||
createInfo :: Vulkan.DescriptorSetLayoutCreateInfo '[]
|
||||
createInfo =
|
||||
Vulkan.DescriptorSetLayoutCreateInfo
|
||||
{ Vulkan.next = ()
|
||||
, Vulkan.flags = Vulkan.zero
|
||||
, Vulkan.bindings = bindings
|
||||
}
|
||||
|
||||
createCommandPool
|
||||
:: MonadVulkan m
|
||||
=> Vulkan.Device
|
||||
-> Vulkan.CommandPoolCreateFlagBits
|
||||
-> Word32
|
||||
-> m Vulkan.CommandPool
|
||||
createCommandPool dev flags queueFamilyIndex = snd <$> Vulkan.withCommandPool dev createInfo Nothing ResourceT.allocate
|
||||
where
|
||||
createInfo :: Vulkan.CommandPoolCreateInfo
|
||||
createInfo =
|
||||
Vulkan.CommandPoolCreateInfo
|
||||
{ Vulkan.flags = flags
|
||||
, Vulkan.queueFamilyIndex = queueFamilyIndex
|
||||
}
|
||||
|
||||
allocatePrimaryCommandBuffers
|
||||
:: MonadVulkan m
|
||||
=> Vulkan.Device
|
||||
-> Vulkan.CommandPool
|
||||
-> Word32
|
||||
-> m ( ResourceT.ReleaseKey, Boxed.Vector Vulkan.CommandBuffer )
|
||||
allocatePrimaryCommandBuffers dev commandPool count = Vulkan.withCommandBuffers dev allocInfo ResourceT.allocate
|
||||
where
|
||||
allocInfo :: Vulkan.CommandBufferAllocateInfo
|
||||
allocInfo =
|
||||
Vulkan.CommandBufferAllocateInfo
|
||||
{ Vulkan.commandPool = commandPool
|
||||
, Vulkan.level = Vulkan.COMMAND_BUFFER_LEVEL_PRIMARY
|
||||
, Vulkan.commandBufferCount = count
|
||||
}
|
||||
|
||||
submitCommandBuffer
|
||||
:: MonadIO m
|
||||
=> Vulkan.Queue
|
||||
-> Vulkan.CommandBuffer
|
||||
-> [ ( Vulkan.Semaphore, Vulkan.PipelineStageFlags ) ]
|
||||
-> [ Vulkan.Semaphore ]
|
||||
-> Maybe Vulkan.Fence
|
||||
-> m ()
|
||||
submitCommandBuffer queue commandBuffer wait signal mbFence =
|
||||
Vulkan.queueSubmit queue ( Boxed.Vector.singleton $ Vulkan.SomeStruct submitInfo ) ( fromMaybe Vulkan.NULL_HANDLE mbFence )
|
||||
where
|
||||
submitInfo :: Vulkan.SubmitInfo '[]
|
||||
submitInfo =
|
||||
Vulkan.SubmitInfo
|
||||
{ Vulkan.next = ()
|
||||
, Vulkan.waitSemaphores = Boxed.Vector.fromList $ map fst wait
|
||||
, Vulkan.waitDstStageMask = Boxed.Vector.fromList $ map snd wait
|
||||
, Vulkan.commandBuffers = Boxed.Vector.singleton ( Vulkan.commandBufferHandle commandBuffer )
|
||||
, Vulkan.signalSemaphores = Boxed.Vector.fromList signal
|
||||
}
|
||||
|
||||
beginCommandBuffer :: MonadIO m => Vulkan.CommandBuffer -> m ()
|
||||
beginCommandBuffer commandBuffer = Vulkan.beginCommandBuffer commandBuffer commandBufferBeginInfo
|
||||
where
|
||||
commandBufferBeginInfo :: Vulkan.CommandBufferBeginInfo '[]
|
||||
commandBufferBeginInfo =
|
||||
Vulkan.CommandBufferBeginInfo
|
||||
{ Vulkan.next = ()
|
||||
, Vulkan.flags = Vulkan.zero
|
||||
, Vulkan.inheritanceInfo = Nothing
|
||||
}
|
||||
|
||||
endCommandBuffer :: MonadIO m => Vulkan.CommandBuffer -> m ()
|
||||
endCommandBuffer = Vulkan.endCommandBuffer
|
||||
|
||||
createFence :: MonadVulkan m => Vulkan.Device -> m ( ResourceT.ReleaseKey, Vulkan.Fence )
|
||||
createFence device = Vulkan.withFence device fenceCreateInfo Nothing ResourceT.allocate
|
||||
where
|
||||
fenceCreateInfo :: Vulkan.FenceCreateInfo '[]
|
||||
fenceCreateInfo =
|
||||
Vulkan.FenceCreateInfo
|
||||
{ Vulkan.next = ()
|
||||
, Vulkan.flags = Vulkan.zero
|
||||
}
|
||||
|
||||
data Wait a = WaitAll [a] | WaitAny [a]
|
||||
|
||||
waitForFences :: MonadIO m => Vulkan.Device -> Wait Vulkan.Fence -> m ()
|
||||
waitForFences device fences = void $ Vulkan.waitForFences device ( Boxed.Vector.fromList fenceList ) waitAll maxBound
|
||||
where
|
||||
waitAll :: Bool
|
||||
fenceList :: [Vulkan.Fence]
|
||||
(waitAll, fenceList) =
|
||||
case fences of
|
||||
WaitAll l -> ( True , l )
|
||||
WaitAny l -> ( False, l )
|
||||
|
||||
createPipelineLayout
|
||||
:: MonadVulkan m
|
||||
=> Vulkan.Device
|
||||
-> [ Vulkan.DescriptorSetLayout ]
|
||||
-> [ Vulkan.PushConstantRange ]
|
||||
-> m ( ResourceT.ReleaseKey, Vulkan.PipelineLayout )
|
||||
createPipelineLayout device layouts ranges =
|
||||
Vulkan.withPipelineLayout device pipelineLayoutCreateInfo Nothing ResourceT.allocate
|
||||
where
|
||||
pipelineLayoutCreateInfo :: Vulkan.PipelineLayoutCreateInfo
|
||||
pipelineLayoutCreateInfo =
|
||||
Vulkan.PipelineLayoutCreateInfo
|
||||
{ Vulkan.flags = Vulkan.zero
|
||||
, Vulkan.setLayouts = Boxed.Vector.fromList layouts
|
||||
, Vulkan.pushConstantRanges = Boxed.Vector.fromList ranges
|
||||
}
|
||||
|
||||
present
|
||||
:: MonadIO m
|
||||
=> Vulkan.Queue
|
||||
-> Vulkan.SwapchainKHR
|
||||
-> Word32
|
||||
-> [Vulkan.Semaphore]
|
||||
-> m Vulkan.Result
|
||||
present queue swapchain imageIndex wait = Vulkan.queuePresentKHR queue presentInfo
|
||||
where
|
||||
presentInfo :: Vulkan.PresentInfoKHR '[]
|
||||
presentInfo =
|
||||
Vulkan.PresentInfoKHR
|
||||
{ Vulkan.next = ()
|
||||
, Vulkan.waitSemaphores = Boxed.Vector.fromList wait
|
||||
, Vulkan.swapchains = Boxed.Vector.singleton swapchain
|
||||
, Vulkan.imageIndices = Boxed.Vector.singleton imageIndex
|
||||
, Vulkan.results = Vulkan.zero
|
||||
}
|
||||
61
examples/vulkan/Input.hs
Normal file
61
examples/vulkan/Input.hs
Normal file
@@ -0,0 +1,61 @@
|
||||
module Input where
|
||||
|
||||
-- base
|
||||
import Data.Int
|
||||
( Int32 )
|
||||
|
||||
-- sdl2
|
||||
import qualified SDL
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
|
||||
data Input = Input
|
||||
{ keysDown :: [ SDL.Scancode ]
|
||||
, keysPressed :: [ SDL.Scancode ]
|
||||
, mousePos :: ( Int32, Int32 )
|
||||
, mouseRel :: ( Int32, Int32 )
|
||||
, quitAction :: Bool
|
||||
}
|
||||
|
||||
nullInput :: Input
|
||||
nullInput
|
||||
= Input
|
||||
{ keysDown = []
|
||||
, keysPressed = []
|
||||
, mousePos = ( 0, 0 )
|
||||
, mouseRel = ( 0, 0 )
|
||||
, quitAction = False
|
||||
}
|
||||
|
||||
onSDLInput :: Input -> SDL.EventPayload -> Input
|
||||
onSDLInput input SDL.QuitEvent
|
||||
= input { quitAction = True }
|
||||
onSDLInput input (SDL.WindowClosedEvent _)
|
||||
= input { quitAction = True }
|
||||
onSDLInput input ( SDL.KeyboardEvent ev )
|
||||
= let keyCode = SDL.keysymScancode ( SDL.keyboardEventKeysym ev )
|
||||
in case SDL.keyboardEventKeyMotion ev of
|
||||
SDL.Pressed -> input { keysDown = keyCode : filter ( /= keyCode ) ( keysDown input )
|
||||
, keysPressed = keyCode : filter ( /= keyCode ) ( keysPressed input )
|
||||
}
|
||||
SDL.Released -> input { keysDown = filter ( /= keyCode ) ( keysDown input ) }
|
||||
onSDLInput input ( SDL.MouseMotionEvent ev )
|
||||
= input { mousePos = (px, py)
|
||||
, mouseRel = (rx, ry)
|
||||
}
|
||||
where
|
||||
SDL.P ( SDL.V2 px py ) = SDL.mouseMotionEventPos ev
|
||||
SDL.V2 rx ry = SDL.mouseMotionEventRelMotion ev
|
||||
onSDLInput input _ = input
|
||||
|
||||
onSDLInputs :: Input -> [ SDL.EventPayload ] -> Input
|
||||
onSDLInputs prevInput events = escapeQuits $ foldl onSDLInput zeroedInput events
|
||||
where
|
||||
zeroedInput :: Input
|
||||
zeroedInput = prevInput { keysPressed = [], mouseRel = ( 0, 0 ) }
|
||||
escapeQuits :: Input -> Input
|
||||
escapeQuits input
|
||||
| SDL.ScancodeEscape `elem` keysPressed input
|
||||
= input { quitAction = True }
|
||||
| otherwise
|
||||
= input
|
||||
425
examples/vulkan/Main.hs
Normal file
425
examples/vulkan/Main.hs
Normal file
@@ -0,0 +1,425 @@
|
||||
{-# LANGUAGE BlockArguments #-}
|
||||
{-# LANGUAGE DataKinds #-}
|
||||
{-# LANGUAGE DerivingVia #-}
|
||||
{-# LANGUAGE DuplicateRecordFields #-}
|
||||
{-# LANGUAGE FlexibleInstances #-}
|
||||
{-# LANGUAGE LambdaCase #-}
|
||||
{-# LANGUAGE MonoLocalBinds #-}
|
||||
{-# LANGUAGE NamedFieldPuns #-}
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# LANGUAGE RecordWildCards #-}
|
||||
{-# LANGUAGE ScopedTypeVariables #-}
|
||||
{-# LANGUAGE StandaloneDeriving #-}
|
||||
{-# LANGUAGE TupleSections #-}
|
||||
{-# LANGUAGE TypeApplications #-}
|
||||
|
||||
{-# OPTIONS_GHC -fno-warn-name-shadowing #-}
|
||||
{-# OPTIONS_GHC -fno-warn-orphans #-}
|
||||
|
||||
module Main where
|
||||
|
||||
-- base
|
||||
import Control.Arrow
|
||||
( second )
|
||||
import Control.Exception
|
||||
( throw )
|
||||
import Control.Monad
|
||||
( unless, void )
|
||||
import Data.Foldable
|
||||
( traverse_ )
|
||||
import Data.String
|
||||
( IsString )
|
||||
import Data.Traversable
|
||||
( for )
|
||||
import Data.Word
|
||||
( Word32 )
|
||||
|
||||
-- logging-effect
|
||||
import Control.Monad.Log
|
||||
( LoggingT(..), logDebug, runLoggingT )
|
||||
|
||||
-- resource-t
|
||||
import Control.Monad.Trans.Resource
|
||||
( ResourceT, MonadResource, runResourceT )
|
||||
import qualified Control.Monad.Trans.Resource as ResourceT
|
||||
( allocate, release )
|
||||
|
||||
-- sdl
|
||||
import qualified SDL
|
||||
|
||||
-- transformers
|
||||
import Control.Monad.Trans.Reader
|
||||
( ReaderT(..) )
|
||||
import Control.Monad.IO.Class
|
||||
( MonadIO(..) )
|
||||
|
||||
-- unliftio
|
||||
import UnliftIO.Exception
|
||||
( handleJust )
|
||||
|
||||
-- vector
|
||||
import qualified Data.Vector as Boxed
|
||||
( Vector )
|
||||
import qualified Data.Vector as Boxed.Vector
|
||||
( (!), head, singleton, unzip )
|
||||
|
||||
-- vulkan
|
||||
import qualified Vulkan
|
||||
import qualified Vulkan.Exception as Vulkan
|
||||
import qualified Vulkan.Zero as Vulkan
|
||||
|
||||
-- dear-imgui
|
||||
import Attachments
|
||||
import Backend
|
||||
import Input
|
||||
import qualified DearImGui as ImGui
|
||||
import qualified DearImGui.Vulkan as ImGui.Vulkan
|
||||
import qualified DearImGui.SDL as ImGui.SDL
|
||||
import qualified DearImGui.SDL.Vulkan as ImGui.SDL.Vulkan
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
|
||||
type Handler = LogMessage -> ResourceT IO ()
|
||||
deriving via ( ReaderT Handler (ResourceT IO) )
|
||||
instance MonadResource ( LoggingT LogMessage (ResourceT IO) )
|
||||
|
||||
main :: IO ()
|
||||
main = runResourceT . ( `runLoggingT` logHandler ) $ app @( LoggingT LogMessage ( ResourceT IO ) )
|
||||
|
||||
appName :: IsString a => a
|
||||
appName = "DearImGui - Vulkan"
|
||||
|
||||
app :: forall m. MonadVulkan m => m ()
|
||||
app = do
|
||||
|
||||
-------------------------------------------
|
||||
-- Initialise window, Vulkan and Dear ImGui contexts.
|
||||
|
||||
( window, windowExtensions ) <-
|
||||
initialiseWindow
|
||||
WindowInfo
|
||||
{ width = 1280
|
||||
, height = 720
|
||||
, windowName = appName
|
||||
, mouseMode = SDL.AbsoluteLocation
|
||||
}
|
||||
let
|
||||
vulkanReqs :: VulkanRequirements
|
||||
vulkanReqs =
|
||||
VulkanRequirements
|
||||
{ instanceRequirements = instanceExtensions windowExtensions
|
||||
, deviceRequirements = []
|
||||
, queueFlags = Vulkan.QUEUE_GRAPHICS_BIT
|
||||
}
|
||||
VulkanContext {..} <- initialiseVulkanContext NormalInstance appName vulkanReqs
|
||||
|
||||
surface <- logDebug "Creating SDL surface" *> createSurface window instance'
|
||||
assertSurfacePresentable physicalDevice queueFamily surface
|
||||
|
||||
void $ ResourceT.allocate
|
||||
ImGui.createContext
|
||||
ImGui.destroyContext
|
||||
|
||||
let
|
||||
preferredFormat :: Vulkan.SurfaceFormatKHR
|
||||
preferredFormat =
|
||||
Vulkan.SurfaceFormatKHR
|
||||
Vulkan.FORMAT_B8G8R8A8_UNORM
|
||||
Vulkan.COLOR_SPACE_SRGB_NONLINEAR_KHR
|
||||
surfaceUsage :: Vulkan.ImageUsageFlagBits
|
||||
surfaceUsage = Vulkan.IMAGE_USAGE_COLOR_ATTACHMENT_BIT
|
||||
|
||||
commandPool <- createCommandPool device Vulkan.COMMAND_POOL_CREATE_RESET_COMMAND_BUFFER_BIT queueFamily
|
||||
nextImageSem <- snd <$> Vulkan.withSemaphore device Vulkan.zero Nothing ResourceT.allocate
|
||||
submitted <- snd <$> Vulkan.withSemaphore device Vulkan.zero Nothing ResourceT.allocate
|
||||
|
||||
let
|
||||
imGuiDescriptorTypes :: [ ( Vulkan.DescriptorType, Int ) ]
|
||||
imGuiDescriptorTypes = map (, 1000)
|
||||
[ Vulkan.DESCRIPTOR_TYPE_SAMPLER
|
||||
, Vulkan.DESCRIPTOR_TYPE_COMBINED_IMAGE_SAMPLER
|
||||
, Vulkan.DESCRIPTOR_TYPE_SAMPLED_IMAGE
|
||||
, Vulkan.DESCRIPTOR_TYPE_STORAGE_IMAGE
|
||||
, Vulkan.DESCRIPTOR_TYPE_UNIFORM_TEXEL_BUFFER
|
||||
, Vulkan.DESCRIPTOR_TYPE_STORAGE_TEXEL_BUFFER
|
||||
, Vulkan.DESCRIPTOR_TYPE_UNIFORM_BUFFER
|
||||
, Vulkan.DESCRIPTOR_TYPE_STORAGE_BUFFER
|
||||
, Vulkan.DESCRIPTOR_TYPE_UNIFORM_BUFFER_DYNAMIC
|
||||
, Vulkan.DESCRIPTOR_TYPE_STORAGE_BUFFER_DYNAMIC
|
||||
, Vulkan.DESCRIPTOR_TYPE_INPUT_ATTACHMENT
|
||||
]
|
||||
|
||||
( _imGuiPoolKey, imGuiDescriptorPool ) <- createDescriptorPool device 1000 imGuiDescriptorTypes
|
||||
|
||||
---------------------------------------------------------------------------
|
||||
-- Handle swapchain creation (and resources that depend on the swapchain).
|
||||
|
||||
surfaceCapabilities <- Vulkan.getPhysicalDeviceSurfaceCapabilitiesKHR physicalDevice ( Vulkan.SurfaceKHR surface )
|
||||
|
||||
let
|
||||
minImageCount, maxImageCount, imageCount :: Word32
|
||||
minImageCount = ( Vulkan.minImageCount :: Vulkan.SurfaceCapabilitiesKHR -> Word32 ) surfaceCapabilities
|
||||
maxImageCount = ( Vulkan.maxImageCount :: Vulkan.SurfaceCapabilitiesKHR -> Word32 ) surfaceCapabilities
|
||||
imageCount
|
||||
| maxImageCount == 0 = minImageCount + 1
|
||||
| otherwise = ( minImageCount + 1 ) `min` maxImageCount
|
||||
|
||||
clearValues :: [ Vulkan.ClearValue ]
|
||||
clearValues = [ Vulkan.Color $ Vulkan.Float32 0.5 0.2 0 1.0 ]
|
||||
|
||||
swapchainResources :: Maybe SwapchainResources -> m ( m (), SwapchainResources )
|
||||
swapchainResources mbOldResources = do
|
||||
( surfaceFormat, imGuiRenderPass ) <- case mbOldResources of
|
||||
Nothing -> do
|
||||
logDebug "Choosing swapchain format & color space"
|
||||
surfaceFormat <- chooseSwapchainFormat preferredFormat physicalDevice surface
|
||||
let
|
||||
colFmt :: Vulkan.Format
|
||||
colFmt = ( Vulkan.format :: Vulkan.SurfaceFormatKHR -> Vulkan.Format ) surfaceFormat
|
||||
logDebug "Creating Dear ImGui render pass"
|
||||
( _, imGuiRenderPass ) <-
|
||||
simpleRenderPass device
|
||||
( noAttachments
|
||||
{ colorAttachments = Boxed.Vector.singleton $ presentableColorAttachmentDescription colFmt }
|
||||
)
|
||||
pure ( surfaceFormat, imGuiRenderPass )
|
||||
Just oldResources -> pure ( surfaceFormat oldResources, imGuiRenderPass oldResources )
|
||||
|
||||
let
|
||||
colFmt :: Vulkan.Format
|
||||
colFmt = ( Vulkan.format :: Vulkan.SurfaceFormatKHR -> Vulkan.Format ) surfaceFormat
|
||||
|
||||
logDebug "Creating swapchain"
|
||||
( swapchainKey, swapchain, swapchainExtent ) <-
|
||||
createSwapchain
|
||||
physicalDevice device
|
||||
surface surfaceFormat
|
||||
surfaceUsage
|
||||
imageCount
|
||||
( swapchain <$> mbOldResources )
|
||||
|
||||
logDebug "Getting swapchain images"
|
||||
swapchainImages <- snd <$> Vulkan.getSwapchainImagesKHR device swapchain
|
||||
|
||||
-------------------------------------------
|
||||
-- Create framebuffer attachments.
|
||||
|
||||
{-
|
||||
let
|
||||
width, height :: Num a => a
|
||||
width = fromIntegral $ ( Vulkan.width :: Vulkan.Extent2D -> Word32 ) swapchainExtent
|
||||
height = fromIntegral $ ( Vulkan.height :: Vulkan.Extent2D -> Word32 ) swapchainExtent
|
||||
|
||||
extent3D :: Vulkan.Extent3D
|
||||
extent3D
|
||||
= Vulkan.Extent3D
|
||||
{ Vulkan.width = width
|
||||
, Vulkan.height = height
|
||||
, Vulkan.depth = 1
|
||||
}
|
||||
-}
|
||||
|
||||
logDebug "Creating framebuffers"
|
||||
( fbKeys, framebuffersWithAttachments ) <-
|
||||
fmap Boxed.Vector.unzip . for swapchainImages $ \ swapchainImage -> do
|
||||
( imageViewKey, colorImageView )
|
||||
<- createImageView
|
||||
device swapchainImage
|
||||
Vulkan.IMAGE_VIEW_TYPE_2D
|
||||
colFmt
|
||||
Vulkan.IMAGE_ASPECT_COLOR_BIT
|
||||
let attachment = (swapchainImage, colorImageView)
|
||||
( framebufferKey, framebuffer ) <- createFramebuffer device imGuiRenderPass swapchainExtent [colorImageView]
|
||||
pure ( [ imageViewKey, framebufferKey ], ( framebuffer, attachment ) )
|
||||
|
||||
-------------------------------------------
|
||||
-- Create descriptor sets.
|
||||
|
||||
-- Application doesn't have any descriptor sets of its own yet.
|
||||
|
||||
-------------------------------------------
|
||||
-- Create pipelines.
|
||||
|
||||
-- Application doesn't have any pipelines of its own yet.
|
||||
|
||||
-------------------------------------------
|
||||
-- Return the resources and free method.
|
||||
|
||||
pure
|
||||
( do
|
||||
traverse_ ( traverse_ ResourceT.release ) fbKeys
|
||||
traverse_ ResourceT.release
|
||||
[ swapchainKey ]
|
||||
, SwapchainResources {..}
|
||||
)
|
||||
|
||||
( freeResources, resources@( SwapchainResources {..} ) ) <- swapchainResources Nothing
|
||||
let
|
||||
imageCount :: Word32
|
||||
imageCount = fromIntegral $ length swapchainImages
|
||||
|
||||
logDebug "Allocating command buffers"
|
||||
commandBuffers <- snd <$> allocatePrimaryCommandBuffers device commandPool imageCount
|
||||
|
||||
-------------------------------------------
|
||||
-- Initialise Dear ImGui.
|
||||
|
||||
let
|
||||
initInfo :: ImGui.Vulkan.InitInfo
|
||||
initInfo = ImGui.Vulkan.InitInfo
|
||||
{ instance'
|
||||
, physicalDevice
|
||||
, device
|
||||
, queueFamily
|
||||
, queue
|
||||
, pipelineCache = Vulkan.NULL_HANDLE
|
||||
, descriptorPool = imGuiDescriptorPool
|
||||
, subpass = 0
|
||||
, minImageCount
|
||||
, imageCount
|
||||
, msaaSamples = Vulkan.SAMPLE_COUNT_1_BIT
|
||||
, mbAllocator = Nothing
|
||||
, checkResult = \case { Vulkan.SUCCESS -> pure (); e -> throw $ Vulkan.VulkanException e }
|
||||
}
|
||||
|
||||
logDebug "Initialising ImGui SDL2 for Vulkan"
|
||||
void $ ResourceT.allocate
|
||||
( ImGui.SDL.Vulkan.sdl2InitForVulkan window )
|
||||
( const ImGui.SDL.sdl2Shutdown )
|
||||
|
||||
logDebug "Initialising ImGui for Vulkan"
|
||||
ImGui.Vulkan.withVulkan initInfo imGuiRenderPass \ _ -> do
|
||||
|
||||
logDebug "Running one-shot commands to upload ImGui textures"
|
||||
logDebug "Creating fence"
|
||||
( fenceKey, fence ) <- createFence device
|
||||
logDebug "Allocating one-shot command buffer"
|
||||
( fontUploadCommandBufferKey, fontUploadCommandBuffer ) <-
|
||||
second Boxed.Vector.head <$>
|
||||
allocatePrimaryCommandBuffers device commandPool 1
|
||||
|
||||
logDebug "Recording one-shot commands"
|
||||
beginCommandBuffer fontUploadCommandBuffer
|
||||
_ <- ImGui.Vulkan.vulkanCreateFontsTexture fontUploadCommandBuffer
|
||||
endCommandBuffer fontUploadCommandBuffer
|
||||
|
||||
logDebug "Submitting one-shot commands"
|
||||
submitCommandBuffer queue fontUploadCommandBuffer [] [] ( Just fence )
|
||||
waitForFences device ( WaitAll [ fence ] )
|
||||
|
||||
logDebug "Finished uploading font objects"
|
||||
logDebug "Cleaning up one-shot commands"
|
||||
ImGui.Vulkan.vulkanDestroyFontUploadObjects
|
||||
traverse_ ResourceT.release [ fenceKey, fontUploadCommandBufferKey ]
|
||||
|
||||
let
|
||||
mainLoop :: AppState m -> m ()
|
||||
mainLoop ( AppState {..} ) = do
|
||||
|
||||
( freeResources, resources@( SwapchainResources {..} ), freeOldResources ) <-
|
||||
if reloadSwapchain
|
||||
then do
|
||||
logDebug "Reloading swapchain and associated resources"
|
||||
( freeNewResources, newResources ) <- swapchainResources ( Just resources )
|
||||
pure ( freeNewResources, newResources, freeOldResources *> freeResources )
|
||||
else pure ( freeResources, resources, freeOldResources )
|
||||
|
||||
inputEvents <- map SDL.eventPayload <$> pollEventsWithImGui
|
||||
inputState <- pure $ onSDLInputs inputState inputEvents
|
||||
|
||||
unless ( quitAction inputState ) do
|
||||
( acquireResult, nextImageIndex ) <-
|
||||
handleJust vulkanException ( \ e -> pure ( e, 0 ) )
|
||||
( Vulkan.acquireNextImageKHR device swapchain maxBound nextImageSem Vulkan.NULL_HANDLE )
|
||||
let
|
||||
reloadSwapchain, quit :: Bool
|
||||
( reloadSwapchain, quit ) = reloadQuit acquireResult
|
||||
unless quit do
|
||||
( reloadSwapchain, quit ) <-
|
||||
if reloadSwapchain
|
||||
then do
|
||||
pure ( True, False )
|
||||
else
|
||||
handleJust vulkanException ( pure . reloadQuit ) do
|
||||
ImGui.Vulkan.vulkanNewFrame
|
||||
ImGui.SDL.sdl2NewFrame window
|
||||
ImGui.newFrame
|
||||
ImGui.showDemoWindow
|
||||
ImGui.render
|
||||
drawData <- ImGui.getDrawData
|
||||
let
|
||||
commandBuffer :: Vulkan.CommandBuffer
|
||||
commandBuffer = commandBuffers Boxed.Vector.! fromIntegral nextImageIndex
|
||||
framebuffer :: Vulkan.Framebuffer
|
||||
framebuffer = fst $ framebuffersWithAttachments Boxed.Vector.! fromIntegral nextImageIndex
|
||||
Vulkan.resetCommandBuffer commandBuffer Vulkan.zero
|
||||
beginCommandBuffer commandBuffer
|
||||
cmdBeginRenderPass commandBuffer imGuiRenderPass framebuffer clearValues swapchainExtent
|
||||
ImGui.Vulkan.vulkanRenderDrawData drawData commandBuffer Nothing
|
||||
cmdEndRenderPass commandBuffer
|
||||
endCommandBuffer commandBuffer
|
||||
submitCommandBuffer
|
||||
queue
|
||||
commandBuffer
|
||||
[ ( nextImageSem, Vulkan.PIPELINE_STAGE_COLOR_ATTACHMENT_OUTPUT_BIT ) ]
|
||||
[ submitted ]
|
||||
Nothing
|
||||
presentResult <- present queue swapchain nextImageIndex [submitted]
|
||||
Vulkan.queueWaitIdle queue
|
||||
pure ( reloadQuit presentResult )
|
||||
freeOldResources
|
||||
let
|
||||
freeOldResources :: m ()
|
||||
freeOldResources = pure ()
|
||||
unless quit $ mainLoop ( AppState {..} )
|
||||
|
||||
let
|
||||
reloadSwapchain :: Bool
|
||||
reloadSwapchain = False
|
||||
freeOldResources :: m ()
|
||||
freeOldResources = pure ()
|
||||
inputState :: Input
|
||||
inputState = nullInput
|
||||
|
||||
logDebug "Starting main loop."
|
||||
mainLoop ( AppState {..} )
|
||||
|
||||
|
||||
data SwapchainResources = SwapchainResources
|
||||
{ swapchain :: !Vulkan.SwapchainKHR
|
||||
, swapchainExtent :: !Vulkan.Extent2D
|
||||
, swapchainImages :: !( Boxed.Vector Vulkan.Image )
|
||||
, surfaceFormat :: !Vulkan.SurfaceFormatKHR
|
||||
, imGuiRenderPass :: !Vulkan.RenderPass
|
||||
, framebuffersWithAttachments :: !( Boxed.Vector ( Vulkan.Framebuffer, ( Vulkan.Image, Vulkan.ImageView ) ) )
|
||||
}
|
||||
|
||||
data AppState m
|
||||
= AppState
|
||||
{ reloadSwapchain :: !Bool
|
||||
, freeResources :: !( m () )
|
||||
, resources :: !SwapchainResources
|
||||
, freeOldResources :: !( m () )
|
||||
, inputState :: !Input
|
||||
}
|
||||
|
||||
pollEventsWithImGui :: MonadIO m => m [ SDL.Event ]
|
||||
pollEventsWithImGui = do
|
||||
e <- ImGui.SDL.pollEventWithImGui
|
||||
case e of
|
||||
Nothing -> pure []
|
||||
Just e' -> ( e' : ) <$> pollEventsWithImGui
|
||||
|
||||
vulkanException :: Vulkan.VulkanException -> Maybe Vulkan.Result
|
||||
vulkanException ( Vulkan.VulkanException e )
|
||||
| e >= Vulkan.SUCCESS
|
||||
= Nothing
|
||||
| otherwise
|
||||
= Just e
|
||||
|
||||
reloadQuit :: Vulkan.Result -> ( Bool, Bool )
|
||||
reloadQuit = \ case
|
||||
Vulkan.ERROR_OUT_OF_DATE_KHR -> ( True , False )
|
||||
Vulkan.SUBOPTIMAL_KHR -> ( True , False )
|
||||
e | e >= Vulkan.SUCCESS -> ( False, False )
|
||||
_ -> ( False, True )
|
||||
40
examples/vulkan/Util.hs
Normal file
40
examples/vulkan/Util.hs
Normal file
@@ -0,0 +1,40 @@
|
||||
{-# LANGUAGE BlockArguments #-}
|
||||
{-# LANGUAGE ScopedTypeVariables #-}
|
||||
|
||||
module Util where
|
||||
|
||||
-- base
|
||||
import Data.Coerce
|
||||
( coerce )
|
||||
import Data.Functor.Compose
|
||||
( Compose(..) )
|
||||
import Data.Functor.Identity
|
||||
( Identity(..) )
|
||||
import Data.Traversable
|
||||
( for )
|
||||
|
||||
-- transformers
|
||||
import Control.Monad.Trans.State.Strict
|
||||
( StateT(..), State, evalState )
|
||||
import Control.Monad.Trans.Writer.Strict
|
||||
( runWriter, tell )
|
||||
|
||||
---------------------------------------------------------------
|
||||
|
||||
iunzipWith
|
||||
:: (Traversable t, Num i, Enum i)
|
||||
=> (i -> a -> b) -> (i -> a -> c) -> t a -> ( t b, [c] )
|
||||
iunzipWith f g ta
|
||||
= runWriter
|
||||
$ ifor 0 succ ta \ i a -> do
|
||||
tell [g i a]
|
||||
pure ( f i a )
|
||||
|
||||
ifor
|
||||
:: forall t f i a b
|
||||
. ( Applicative f, Traversable t )
|
||||
=> i -> ( i -> i ) -> t a -> ( i -> a -> f b ) -> f (t b)
|
||||
ifor i0 upd ta f = (`evalState` i0) . getCompose $ result
|
||||
where
|
||||
result :: Compose (State i) f (t b)
|
||||
result = for ta \ a -> ( coerce ( \ i -> ( f i a, upd i ) ) )
|
||||
45
src/DearImGui/SDL/Vulkan.hs
Normal file
45
src/DearImGui/SDL/Vulkan.hs
Normal file
@@ -0,0 +1,45 @@
|
||||
{-# LANGUAGE BlockArguments #-}
|
||||
{-# LANGUAGE FlexibleContexts #-}
|
||||
{-# LANGUAGE NamedFieldPuns #-}
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# LANGUAGE PatternSynonyms #-}
|
||||
{-# LANGUAGE QuasiQuotes #-}
|
||||
{-# LANGUAGE TemplateHaskell #-}
|
||||
|
||||
{-|
|
||||
Module: DearImGui.SDL.Vulkan
|
||||
|
||||
Initialising the Vulkan backend for Dear ImGui using SDL2.
|
||||
-}
|
||||
|
||||
module DearImGui.SDL.Vulkan
|
||||
( sdl2InitForVulkan )
|
||||
where
|
||||
|
||||
-- inline-c
|
||||
import qualified Language.C.Inline as C
|
||||
|
||||
-- inline-c-cpp
|
||||
import qualified Language.C.Inline.Cpp as Cpp
|
||||
|
||||
-- sdl2
|
||||
import SDL.Internal.Types
|
||||
( Window(..) )
|
||||
|
||||
-- transformers
|
||||
import Control.Monad.IO.Class ( MonadIO, liftIO )
|
||||
|
||||
|
||||
C.context Cpp.cppCtx
|
||||
C.include "imgui.h"
|
||||
C.include "backends/imgui_impl_vulkan.h"
|
||||
C.include "backends/imgui_impl_sdl.h"
|
||||
C.include "SDL.h"
|
||||
C.include "SDL_vulkan.h"
|
||||
Cpp.using "namespace ImGui"
|
||||
|
||||
|
||||
-- | Wraps @ImGui_ImplSDL2_InitForVulkan@.
|
||||
sdl2InitForVulkan :: MonadIO m => Window -> m Bool
|
||||
sdl2InitForVulkan (Window windowPtr) = liftIO do
|
||||
( 0 /= ) <$> [C.exp| bool { ImGui_ImplSDL2_InitForVulkan((SDL_Window*)$(void* windowPtr)) } |]
|
||||
172
src/DearImGui/Vulkan.hs
Normal file
172
src/DearImGui/Vulkan.hs
Normal file
@@ -0,0 +1,172 @@
|
||||
{-# LANGUAGE BlockArguments #-}
|
||||
{-# LANGUAGE QuasiQuotes #-}
|
||||
{-# LANGUAGE RecordWildCards #-}
|
||||
{-# LANGUAGE TemplateHaskell #-}
|
||||
|
||||
{-|
|
||||
Module: DearImGui.Vulkan
|
||||
|
||||
Vulkan backend for Dear ImGui.
|
||||
-}
|
||||
|
||||
module DearImGui.Vulkan
|
||||
( InitInfo(..)
|
||||
, withVulkan
|
||||
, vulkanNewFrame
|
||||
, vulkanRenderDrawData
|
||||
, vulkanCreateFontsTexture
|
||||
, vulkanDestroyFontUploadObjects
|
||||
, vulkanSetMinImageCount
|
||||
)
|
||||
where
|
||||
|
||||
-- base
|
||||
import Data.Maybe
|
||||
( fromMaybe )
|
||||
import Data.Word
|
||||
( Word32 )
|
||||
import Foreign.Marshal.Alloc
|
||||
( alloca )
|
||||
import Foreign.Ptr
|
||||
( Ptr, freeHaskellFunPtr, nullPtr )
|
||||
import Foreign.Storable
|
||||
( Storable(poke) )
|
||||
|
||||
-- inline-c
|
||||
import qualified Language.C.Inline as C
|
||||
|
||||
-- inline-c-cpp
|
||||
import qualified Language.C.Inline.Cpp as Cpp
|
||||
|
||||
-- transformers
|
||||
import Control.Monad.IO.Class
|
||||
( MonadIO, liftIO )
|
||||
|
||||
-- unliftio
|
||||
import UnliftIO
|
||||
( MonadUnliftIO )
|
||||
import UnliftIO.Exception
|
||||
( bracket )
|
||||
|
||||
-- vulkan
|
||||
import qualified Vulkan
|
||||
|
||||
-- DearImGui
|
||||
import DearImGui
|
||||
( DrawData(..) )
|
||||
import DearImGui.Vulkan.Types
|
||||
( vulkanCtx )
|
||||
|
||||
|
||||
C.context ( Cpp.cppCtx <> C.funCtx <> vulkanCtx )
|
||||
C.include "imgui.h"
|
||||
C.include "backends/imgui_impl_vulkan.h"
|
||||
Cpp.using "namespace ImGui"
|
||||
|
||||
|
||||
data InitInfo =
|
||||
InitInfo
|
||||
{ instance' :: !Vulkan.Instance
|
||||
, physicalDevice :: !Vulkan.PhysicalDevice
|
||||
, device :: !Vulkan.Device
|
||||
, queueFamily :: !Word32
|
||||
, queue :: !Vulkan.Queue
|
||||
, pipelineCache :: !Vulkan.PipelineCache
|
||||
, descriptorPool :: !Vulkan.DescriptorPool
|
||||
, subpass :: !Word32
|
||||
, minImageCount :: !Word32
|
||||
, imageCount :: !Word32
|
||||
, msaaSamples :: !Vulkan.SampleCountFlagBits
|
||||
, mbAllocator :: Maybe Vulkan.AllocationCallbacks
|
||||
, checkResult :: Vulkan.Result -> IO ()
|
||||
}
|
||||
|
||||
-- | Wraps @ImGui_ImplVulkan_Init@ and @ImGui_ImplVulkan_Shutdown@.
|
||||
withVulkan :: MonadUnliftIO m => InitInfo -> Vulkan.RenderPass -> ( Bool -> m a ) -> m a
|
||||
withVulkan ( InitInfo {..} ) renderPass action = do
|
||||
let
|
||||
instancePtr :: Ptr Vulkan.Instance_T
|
||||
instancePtr = Vulkan.instanceHandle instance'
|
||||
physicalDevicePtr :: Ptr Vulkan.PhysicalDevice_T
|
||||
physicalDevicePtr = Vulkan.physicalDeviceHandle physicalDevice
|
||||
devicePtr :: Ptr Vulkan.Device_T
|
||||
devicePtr = Vulkan.deviceHandle device
|
||||
queuePtr :: Ptr Vulkan.Queue_T
|
||||
queuePtr = Vulkan.queueHandle queue
|
||||
withCallbacks :: ( Ptr Vulkan.AllocationCallbacks -> IO a ) -> IO a
|
||||
withCallbacks f = case mbAllocator of
|
||||
Nothing -> f nullPtr
|
||||
Just callbacks -> alloca ( \ ptr -> poke ptr callbacks *> f ptr )
|
||||
bracket
|
||||
( liftIO do
|
||||
checkResultFunPtr <- $( C.mkFunPtr [t| Vulkan.Result -> IO () |] ) checkResult
|
||||
initResult <- withCallbacks \ callbacksPtr ->
|
||||
[C.block| bool {
|
||||
ImGui_ImplVulkan_InitInfo initInfo;
|
||||
VkInstance instance = { $( VkInstance_T* instancePtr ) };
|
||||
initInfo.Instance = instance;
|
||||
VkPhysicalDevice physicalDevice = { $( VkPhysicalDevice_T* physicalDevicePtr ) };
|
||||
initInfo.PhysicalDevice = physicalDevice;
|
||||
VkDevice device = { $( VkDevice_T* devicePtr ) };
|
||||
initInfo.Device = device;
|
||||
initInfo.QueueFamily = $(uint32_t queueFamily);
|
||||
VkQueue queue = { $( VkQueue_T* queuePtr ) };
|
||||
initInfo.Queue = queue;
|
||||
initInfo.PipelineCache = $(VkPipelineCache pipelineCache);
|
||||
initInfo.DescriptorPool = $(VkDescriptorPool descriptorPool);
|
||||
initInfo.Subpass = $(uint32_t subpass);
|
||||
initInfo.MinImageCount = $(uint32_t minImageCount);
|
||||
initInfo.ImageCount = $(uint32_t imageCount);
|
||||
initInfo.MSAASamples = $(VkSampleCountFlagBits msaaSamples);
|
||||
initInfo.Allocator = $(VkAllocationCallbacks* callbacksPtr);
|
||||
initInfo.CheckVkResultFn = $( void (*checkResultFunPtr)(VkResult) );
|
||||
return ImGui_ImplVulkan_Init(&initInfo, $(VkRenderPass renderPass) );
|
||||
}|]
|
||||
pure ( checkResultFunPtr, initResult /= 0 )
|
||||
)
|
||||
( \ ( checkResultFunPtr, _ ) -> liftIO do
|
||||
[C.exp| void { ImGui_ImplVulkan_Shutdown(); } |]
|
||||
freeHaskellFunPtr checkResultFunPtr
|
||||
)
|
||||
( \ ( _, initResult ) -> action initResult )
|
||||
|
||||
-- | Wraps @ImGui_ImplVulkan_NewFrame@.
|
||||
vulkanNewFrame :: MonadIO m => m ()
|
||||
vulkanNewFrame = liftIO do
|
||||
[C.exp| void { ImGui_ImplVulkan_NewFrame(); } |]
|
||||
|
||||
-- | Wraps @ImGui_ImplVulkan_RenderDrawData@.
|
||||
vulkanRenderDrawData :: MonadIO m => DrawData -> Vulkan.CommandBuffer -> Maybe Vulkan.Pipeline -> m ()
|
||||
vulkanRenderDrawData (DrawData dataPtr) commandBuffer mbPipeline = liftIO do
|
||||
let
|
||||
commandBufferPtr :: Ptr Vulkan.CommandBuffer_T
|
||||
commandBufferPtr = Vulkan.commandBufferHandle commandBuffer
|
||||
pipeline :: Vulkan.Pipeline
|
||||
pipeline = fromMaybe Vulkan.NULL_HANDLE mbPipeline
|
||||
[C.block| void {
|
||||
VkCommandBuffer commandBuffer = { $( VkCommandBuffer_T* commandBufferPtr ) };
|
||||
ImGui_ImplVulkan_RenderDrawData((ImDrawData*) $(void* dataPtr), commandBuffer, $(VkPipeline pipeline));
|
||||
}|]
|
||||
|
||||
-- | Wraps @ImGui_ImplVulkan_CreateFontsTexture@.
|
||||
vulkanCreateFontsTexture :: MonadIO m => Vulkan.CommandBuffer -> m Bool
|
||||
vulkanCreateFontsTexture commandBuffer = liftIO do
|
||||
let
|
||||
commandBufferPtr :: Ptr Vulkan.CommandBuffer_T
|
||||
commandBufferPtr = Vulkan.commandBufferHandle commandBuffer
|
||||
res <-
|
||||
[C.block| bool {
|
||||
VkCommandBuffer commandBuffer = { $( VkCommandBuffer_T* commandBufferPtr ) };
|
||||
return ImGui_ImplVulkan_CreateFontsTexture(commandBuffer);
|
||||
}|]
|
||||
pure ( res /= 0 )
|
||||
|
||||
-- | Wraps @ImGui_ImplVulkan_DestroyFontUploadObjects@.
|
||||
vulkanDestroyFontUploadObjects :: MonadIO m => m ()
|
||||
vulkanDestroyFontUploadObjects = liftIO do
|
||||
[C.exp| void { ImGui_ImplVulkan_DestroyFontUploadObjects(); } |]
|
||||
|
||||
-- | Wraps @ImGui_ImplVulkan_SetMinImageCount@.
|
||||
vulkanSetMinImageCount :: MonadIO m => Word32 -> m ()
|
||||
vulkanSetMinImageCount minImageCount = liftIO do
|
||||
[C.exp| void { ImGui_ImplVulkan_SetMinImageCount($(uint32_t minImageCount)); } |]
|
||||
37
src/DearImGui/Vulkan/Types.hs
Normal file
37
src/DearImGui/Vulkan/Types.hs
Normal file
@@ -0,0 +1,37 @@
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# LANGUAGE QuasiQuotes #-}
|
||||
{-# LANGUAGE TemplateHaskell #-}
|
||||
|
||||
module DearImGui.Vulkan.Types
|
||||
( vulkanCtx )
|
||||
where
|
||||
|
||||
-- containers
|
||||
import qualified Data.Map.Strict as Map
|
||||
( fromList )
|
||||
|
||||
-- inline-c
|
||||
import qualified Language.C.Inline.Context as C
|
||||
import qualified Language.C.Types as C
|
||||
|
||||
-- vulkan
|
||||
import qualified Vulkan
|
||||
|
||||
vulkanTypesTable :: C.TypesTable
|
||||
vulkanTypesTable = Map.fromList
|
||||
[ ( C.TypeName "VkAllocationCallbacks", [t| Vulkan.AllocationCallbacks |] )
|
||||
, ( C.TypeName "VkCommandBuffer_T" , [t| Vulkan.CommandBuffer_T |] )
|
||||
, ( C.TypeName "VkDescriptorPool" , [t| Vulkan.DescriptorPool |] )
|
||||
, ( C.TypeName "VkDevice_T" , [t| Vulkan.Device_T |] )
|
||||
, ( C.TypeName "VkInstance_T" , [t| Vulkan.Instance_T |] )
|
||||
, ( C.TypeName "VkPhysicalDevice_T" , [t| Vulkan.PhysicalDevice_T |] )
|
||||
, ( C.TypeName "VkPipeline" , [t| Vulkan.Pipeline |] )
|
||||
, ( C.TypeName "VkPipelineCache" , [t| Vulkan.PipelineCache |] )
|
||||
, ( C.TypeName "VkQueue_T" , [t| Vulkan.Queue_T |] )
|
||||
, ( C.TypeName "VkRenderPass" , [t| Vulkan.RenderPass |] )
|
||||
, ( C.TypeName "VkResult" , [t| Vulkan.Result |] )
|
||||
, ( C.TypeName "VkSampleCountFlagBits", [t| Vulkan.SampleCountFlagBits |] )
|
||||
]
|
||||
|
||||
vulkanCtx :: C.Context
|
||||
vulkanCtx = mempty { C.ctxTypesTable = vulkanTypesTable }
|
||||
Reference in New Issue
Block a user