From 0b86356a49cbc57bb4d22ebca903e2218998efff Mon Sep 17 00:00:00 2001 From: sheaf Date: Tue, 26 Jan 2021 21:45:21 +0100 Subject: [PATCH] Vulkan backend (#2) This commit adds the Vulkan backend and SDL2 integration, and provides the `vulkan` example project. --- cabal.project | 2 +- dear-imgui.cabal | 68 +++ examples/vulkan/Attachments.hs | 246 +++++++++++ examples/vulkan/Backend.hs | 783 +++++++++++++++++++++++++++++++++ examples/vulkan/Input.hs | 61 +++ examples/vulkan/Main.hs | 425 ++++++++++++++++++ examples/vulkan/Util.hs | 40 ++ src/DearImGui/SDL/Vulkan.hs | 45 ++ src/DearImGui/Vulkan.hs | 172 ++++++++ src/DearImGui/Vulkan/Types.hs | 37 ++ 10 files changed, 1878 insertions(+), 1 deletion(-) create mode 100644 examples/vulkan/Attachments.hs create mode 100644 examples/vulkan/Backend.hs create mode 100644 examples/vulkan/Input.hs create mode 100644 examples/vulkan/Main.hs create mode 100644 examples/vulkan/Util.hs create mode 100644 src/DearImGui/SDL/Vulkan.hs create mode 100644 src/DearImGui/Vulkan.hs create mode 100644 src/DearImGui/Vulkan/Types.hs diff --git a/cabal.project b/cabal.project index 5179063..b19ede2 100644 --- a/cabal.project +++ b/cabal.project @@ -1,3 +1,3 @@ packages: *.cabal package dear-imgui - flags: +sdl2 +opengl \ No newline at end of file + flags: +sdl2 +opengl +vulkan diff --git a/dear-imgui.cabal b/dear-imgui.cabal index 9b78bd8..1de71bd 100644 --- a/dear-imgui.cabal +++ b/dear-imgui.cabal @@ -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 diff --git a/examples/vulkan/Attachments.hs b/examples/vulkan/Attachments.hs new file mode 100644 index 0000000..1439e1a --- /dev/null +++ b/examples/vulkan/Attachments.hs @@ -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 ) diff --git a/examples/vulkan/Backend.hs b/examples/vulkan/Backend.hs new file mode 100644 index 0000000..9707c99 --- /dev/null +++ b/examples/vulkan/Backend.hs @@ -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 + } diff --git a/examples/vulkan/Input.hs b/examples/vulkan/Input.hs new file mode 100644 index 0000000..d2622d9 --- /dev/null +++ b/examples/vulkan/Input.hs @@ -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 diff --git a/examples/vulkan/Main.hs b/examples/vulkan/Main.hs new file mode 100644 index 0000000..61cd63b --- /dev/null +++ b/examples/vulkan/Main.hs @@ -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 ) diff --git a/examples/vulkan/Util.hs b/examples/vulkan/Util.hs new file mode 100644 index 0000000..afdf64e --- /dev/null +++ b/examples/vulkan/Util.hs @@ -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 ) ) ) diff --git a/src/DearImGui/SDL/Vulkan.hs b/src/DearImGui/SDL/Vulkan.hs new file mode 100644 index 0000000..1aa7448 --- /dev/null +++ b/src/DearImGui/SDL/Vulkan.hs @@ -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)) } |] diff --git a/src/DearImGui/Vulkan.hs b/src/DearImGui/Vulkan.hs new file mode 100644 index 0000000..1207dbf --- /dev/null +++ b/src/DearImGui/Vulkan.hs @@ -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)); } |] diff --git a/src/DearImGui/Vulkan/Types.hs b/src/DearImGui/Vulkan/Types.hs new file mode 100644 index 0000000..e4fefb7 --- /dev/null +++ b/src/DearImGui/Vulkan/Types.hs @@ -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 }