mirror of
https://github.com/Drezil/dear-imgui.hs.git
synced 2024-11-22 08:56:59 +00:00
611 lines
22 KiB
Haskell
611 lines
22 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, when )
|
|
import Data.Bits
|
|
( (.|.) )
|
|
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 )
|
|
import qualified Data.Vector.Storable as Storable.Vector
|
|
|
|
-- vulkan
|
|
import qualified Vulkan
|
|
import qualified Vulkan.Exception as Vulkan
|
|
import qualified Vulkan.Zero as Vulkan
|
|
import qualified VulkanMemoryAllocator as VMA
|
|
|
|
-- 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
|
|
import Util (vmaVulkanFunctions)
|
|
import Foreign (Ptr, castPtr, copyBytes, with, withForeignPtr, wordPtrToPtr)
|
|
import qualified DearImGui.Raw as ImGui.Raw
|
|
import UnliftIO (MonadUnliftIO)
|
|
import qualified Vulkan.CStruct.Extends as Vulkan
|
|
|
|
import qualified Codec.Picture as Picture
|
|
|
|
--------------------------------------------------------------------------------
|
|
|
|
type Handler = LogMessage -> ResourceT IO ()
|
|
deriving via ( ReaderT Handler (ResourceT IO) )
|
|
instance MonadResource ( LoggingT LogMessage (ResourceT IO) )
|
|
|
|
gui :: MonadUnliftIO m => (ImGui.Raw.ImVec2, Ptr ()) -> m ImGui.DrawData
|
|
gui texture = do
|
|
-- Prepare frame
|
|
ImGui.Vulkan.vulkanNewFrame
|
|
ImGui.SDL.sdl2NewFrame
|
|
ImGui.newFrame
|
|
|
|
-- Run your windows
|
|
ImGui.showDemoWindow
|
|
ImGui.withWindowOpen "Vulkan demo" do
|
|
clicked <- liftIO do
|
|
with (fst texture) \sizePtr ->
|
|
with (ImGui.Raw.ImVec2 0 0) \uv0Ptr ->
|
|
with (ImGui.Raw.ImVec2 1 1) \uv1Ptr ->
|
|
with (ImGui.Raw.ImVec4 1 1 1 1) \tintColPtr ->
|
|
with (ImGui.Raw.ImVec4 1 1 1 1) \bgColPtr ->
|
|
ImGui.Raw.imageButton
|
|
(snd texture)
|
|
sizePtr
|
|
uv0Ptr
|
|
uv1Ptr
|
|
(-1)
|
|
bgColPtr
|
|
tintColPtr
|
|
|
|
when clicked $
|
|
ImGui.text "clicky click!"
|
|
|
|
|
|
-- Process ImGui state into draw commands
|
|
ImGui.render
|
|
ImGui.getDrawData
|
|
|
|
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
|
|
Vulkan.SurfaceCapabilitiesKHR{minImageCount, maxImageCount} = 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
|
|
( colFmt, surfaceFormat, imGuiRenderPass ) <- case mbOldResources of
|
|
Nothing -> do
|
|
logDebug "Choosing swapchain format & color space"
|
|
surfaceFormat <- chooseSwapchainFormat preferredFormat physicalDevice surface
|
|
let Vulkan.SurfaceFormatKHR{format=colFmt} = surfaceFormat
|
|
logDebug "Creating Dear ImGui render pass"
|
|
( _, imGuiRenderPass ) <-
|
|
simpleRenderPass device
|
|
( noAttachments
|
|
{ colorAttachments = Boxed.Vector.singleton $ presentableColorAttachmentDescription colFmt }
|
|
)
|
|
pure ( colFmt, surfaceFormat, imGuiRenderPass )
|
|
Just oldResources -> do
|
|
let surFmt = surfaceFormat oldResources
|
|
let Vulkan.SurfaceFormatKHR{format=colFmt} = surFmt
|
|
pure ( colFmt, surFmt, imGuiRenderPass oldResources )
|
|
|
|
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
|
|
|
|
logDebug "Allocating VMA"
|
|
(_key, vma) <- VMA.withAllocator
|
|
Vulkan.zero
|
|
{ VMA.instance' = Vulkan.instanceHandle instance'
|
|
, VMA.device = Vulkan.deviceHandle device
|
|
, VMA.physicalDevice = Vulkan.physicalDeviceHandle physicalDevice
|
|
, VMA.vulkanFunctions = Just $ vmaVulkanFunctions device instance'
|
|
}
|
|
ResourceT.allocate
|
|
|
|
logDebug "Loading image data"
|
|
picture <- liftIO (Picture.readImage "Example.png") >>= either error (pure . Picture.convertRGBA8)
|
|
|
|
logDebug "Allocating image"
|
|
let textureWidth = Picture.imageWidth picture
|
|
let textureHeight = Picture.imageHeight picture
|
|
|
|
(_key, (image, _imageAllocation, _imageAllocationInfo)) <- VMA.withImage
|
|
vma
|
|
( Vulkan.zero
|
|
{ Vulkan.imageType = Vulkan.IMAGE_TYPE_2D
|
|
, Vulkan.mipLevels = 1
|
|
, Vulkan.arrayLayers = 1
|
|
, Vulkan.format = Vulkan.FORMAT_R8G8B8A8_SRGB
|
|
, Vulkan.extent = Vulkan.Extent3D (fromIntegral textureWidth) (fromIntegral textureHeight) 1
|
|
, Vulkan.tiling = Vulkan.IMAGE_TILING_OPTIMAL
|
|
, Vulkan.initialLayout = Vulkan.IMAGE_LAYOUT_UNDEFINED
|
|
, Vulkan.usage = Vulkan.IMAGE_USAGE_SAMPLED_BIT .|. Vulkan.IMAGE_USAGE_TRANSFER_DST_BIT
|
|
, Vulkan.sharingMode = Vulkan.SHARING_MODE_EXCLUSIVE
|
|
, Vulkan.samples = Vulkan.SAMPLE_COUNT_1_BIT
|
|
}
|
|
)
|
|
( Vulkan.zero
|
|
{ VMA.flags = Vulkan.zero
|
|
, VMA.usage = VMA.MEMORY_USAGE_GPU_ONLY
|
|
, VMA.requiredFlags = Vulkan.MEMORY_PROPERTY_DEVICE_LOCAL_BIT
|
|
}
|
|
)
|
|
ResourceT.allocate
|
|
|
|
let (pictureF, pictureSize) = Storable.Vector.unsafeToForeignPtr0 (Picture.imageData picture)
|
|
|
|
let stageBufferCI = Vulkan.zero
|
|
{ Vulkan.size = fromIntegral pictureSize
|
|
, Vulkan.usage = Vulkan.BUFFER_USAGE_TRANSFER_SRC_BIT
|
|
, Vulkan.sharingMode = Vulkan.SHARING_MODE_EXCLUSIVE
|
|
}
|
|
let stageAllocationCI = Vulkan.zero
|
|
{ VMA.flags = VMA.ALLOCATION_CREATE_MAPPED_BIT
|
|
, VMA.usage = VMA.MEMORY_USAGE_CPU_TO_GPU
|
|
, VMA.requiredFlags = Vulkan.MEMORY_PROPERTY_HOST_VISIBLE_BIT
|
|
}
|
|
|
|
(stageKey, (stage, stageAllocation, stageAllocationInfo)) <- VMA.withBuffer
|
|
vma
|
|
stageBufferCI
|
|
stageAllocationCI
|
|
ResourceT.allocate
|
|
|
|
liftIO $ withForeignPtr pictureF \srcPtr ->
|
|
copyBytes (VMA.mappedData stageAllocationInfo) (castPtr srcPtr) pictureSize
|
|
|
|
VMA.flushAllocation vma stageAllocation 0 Vulkan.WHOLE_SIZE
|
|
|
|
logDebug "Allocating sampler"
|
|
(_key, sampler) <- Vulkan.withSampler device Vulkan.zero Nothing ResourceT.allocate
|
|
logDebug "Allocating image view"
|
|
(_key, imageView) <- createImageView
|
|
device
|
|
image
|
|
Vulkan.IMAGE_VIEW_TYPE_2D
|
|
Vulkan.FORMAT_R8G8B8A8_SRGB
|
|
Vulkan.IMAGE_ASPECT_COLOR_BIT
|
|
|
|
-------------------------------------------
|
|
-- 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"
|
|
( oneshotCommandBufferKey, oneshotCommandBuffer ) <-
|
|
second Boxed.Vector.head <$>
|
|
allocatePrimaryCommandBuffers device commandPool 1
|
|
|
|
logDebug "Recording one-shot commands"
|
|
beginCommandBuffer oneshotCommandBuffer
|
|
_ <- ImGui.Vulkan.vulkanCreateFontsTexture oneshotCommandBuffer
|
|
|
|
logDebug "Uploading texture"
|
|
let textureSubresource = Vulkan.ImageSubresourceRange
|
|
{ Vulkan.aspectMask = Vulkan.IMAGE_ASPECT_COLOR_BIT
|
|
, Vulkan.baseMipLevel = 0
|
|
, Vulkan.levelCount = 1
|
|
, Vulkan.baseArrayLayer = 0
|
|
, Vulkan.layerCount = 1
|
|
}
|
|
|
|
let uploadBarrier = Vulkan.zero
|
|
{ Vulkan.srcAccessMask = Vulkan.zero
|
|
, Vulkan.dstAccessMask = Vulkan.ACCESS_TRANSFER_WRITE_BIT
|
|
, Vulkan.oldLayout = Vulkan.IMAGE_LAYOUT_UNDEFINED
|
|
, Vulkan.newLayout = Vulkan.IMAGE_LAYOUT_TRANSFER_DST_OPTIMAL
|
|
, Vulkan.srcQueueFamilyIndex = Vulkan.QUEUE_FAMILY_IGNORED
|
|
, Vulkan.dstQueueFamilyIndex = Vulkan.QUEUE_FAMILY_IGNORED
|
|
, Vulkan.image = image
|
|
, Vulkan.subresourceRange = textureSubresource
|
|
} :: Vulkan.ImageMemoryBarrier '[]
|
|
Vulkan.cmdPipelineBarrier
|
|
oneshotCommandBuffer
|
|
Vulkan.PIPELINE_STAGE_TOP_OF_PIPE_BIT
|
|
Vulkan.PIPELINE_STAGE_TRANSFER_BIT
|
|
Vulkan.zero
|
|
mempty
|
|
mempty
|
|
(Boxed.Vector.singleton $ Vulkan.SomeStruct uploadBarrier)
|
|
|
|
Vulkan.cmdCopyBufferToImage oneshotCommandBuffer stage image Vulkan.IMAGE_LAYOUT_TRANSFER_DST_OPTIMAL $
|
|
Boxed.Vector.singleton Vulkan.BufferImageCopy
|
|
{ Vulkan.bufferOffset = 0
|
|
, Vulkan.bufferRowLength = Vulkan.zero
|
|
, Vulkan.bufferImageHeight = Vulkan.zero
|
|
, Vulkan.imageSubresource = Vulkan.ImageSubresourceLayers
|
|
{ aspectMask = Vulkan.IMAGE_ASPECT_COLOR_BIT
|
|
, mipLevel = 0
|
|
, baseArrayLayer = 0
|
|
, layerCount = 1
|
|
}
|
|
, Vulkan.imageOffset = Vulkan.zero
|
|
, Vulkan.imageExtent = Vulkan.Extent3D
|
|
{ width = fromIntegral textureWidth
|
|
, height = fromIntegral textureHeight
|
|
, depth = 1
|
|
}
|
|
}
|
|
|
|
logDebug "Transitioning texture"
|
|
let transitionBarrier = Vulkan.zero
|
|
{ Vulkan.srcAccessMask = Vulkan.ACCESS_TRANSFER_WRITE_BIT
|
|
, Vulkan.dstAccessMask = Vulkan.ACCESS_SHADER_READ_BIT
|
|
, Vulkan.oldLayout = Vulkan.IMAGE_LAYOUT_TRANSFER_DST_OPTIMAL
|
|
, Vulkan.newLayout = Vulkan.IMAGE_LAYOUT_SHADER_READ_ONLY_OPTIMAL
|
|
, Vulkan.srcQueueFamilyIndex = Vulkan.QUEUE_FAMILY_IGNORED
|
|
, Vulkan.dstQueueFamilyIndex = Vulkan.QUEUE_FAMILY_IGNORED
|
|
, Vulkan.image = image
|
|
, Vulkan.subresourceRange = textureSubresource
|
|
} :: Vulkan.ImageMemoryBarrier '[]
|
|
Vulkan.cmdPipelineBarrier
|
|
oneshotCommandBuffer
|
|
Vulkan.PIPELINE_STAGE_TRANSFER_BIT
|
|
Vulkan.PIPELINE_STAGE_FRAGMENT_SHADER_BIT
|
|
Vulkan.zero
|
|
mempty
|
|
mempty
|
|
(Boxed.Vector.singleton $ Vulkan.SomeStruct transitionBarrier)
|
|
|
|
endCommandBuffer oneshotCommandBuffer
|
|
|
|
logDebug "Submitting one-shot commands"
|
|
submitCommandBuffer queue oneshotCommandBuffer [] [] ( Just fence )
|
|
waitForFences device ( WaitAll [ fence ] )
|
|
|
|
logDebug "Finished uploading font objects"
|
|
logDebug "Cleaning up one-shot commands"
|
|
ImGui.Vulkan.vulkanDestroyFontUploadObjects
|
|
traverse_ ResourceT.release [ fenceKey, oneshotCommandBufferKey, stageKey ]
|
|
|
|
logDebug "Adding imgui texture"
|
|
Vulkan.DescriptorSet ds <- ImGui.Vulkan.vulkanAddTexture sampler imageView Vulkan.IMAGE_LAYOUT_SHADER_READ_ONLY_OPTIMAL
|
|
let textureSize = ImGui.Raw.ImVec2 (fromIntegral textureWidth) (fromIntegral textureHeight)
|
|
let texture = (textureSize, wordPtrToPtr $ fromIntegral ds)
|
|
|
|
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
|
|
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
|
|
|
|
drawData <- gui texture
|
|
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 )
|