dear-imgui.hs/examples/vulkan/Main.hs

{-# 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
    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

  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  )