mirror of
https://github.com/Drezil/dear-imgui.hs.git
synced 2024-11-23 01:07:00 +00:00
0b86356a49
This commit adds the Vulkan backend and SDL2 integration, and provides the `vulkan` example project.
426 lines
15 KiB
Haskell
426 lines
15 KiB
Haskell
{-# 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 )
|