Vulkan backend (#2)

This commit adds the Vulkan backend and SDL2 integration, and provides the `vulkan` example project.

cabal.project

@@ -1,3 +1,3 @@
 packages: *.cabal
 package dear-imgui
-  flags: +sdl2 +opengl
+  flags: +sdl2 +opengl +vulkan

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

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 )

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
+        }

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

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  )

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 ) ) )

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)) } |]

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)); } |]

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 }