{-# LANGUAGE BlockArguments #-}
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE TemplateHaskell #-}
module DearImGui.Vulkan
( InitInfo(..)
, withVulkan
, vulkanInit
, vulkanShutdown
, vulkanNewFrame
, vulkanRenderDrawData
, vulkanCreateFontsTexture
, vulkanDestroyFontsTexture
, vulkanSetMinImageCount
, vulkanAddTexture
)
where
import Data.Maybe
( fromMaybe )
import Data.Either
( isRight )
import Data.Word
( Word32 )
import Foreign.Marshal.Alloc
( alloca )
import Foreign.Marshal.Utils
( fromBool )
import Foreign.Ptr
( FunPtr, Ptr, freeHaskellFunPtr, nullPtr )
import Foreign.Storable
( poke )
import qualified Language.C.Inline as C
import qualified Language.C.Inline.Cpp as Cpp
import Control.Monad.IO.Class
( MonadIO, liftIO )
import UnliftIO
( MonadUnliftIO )
import UnliftIO.Exception
( bracket )
import qualified Vulkan
import Vulkan.Zero
( zero )
import DearImGui
( DrawData(..) )
import DearImGui.Vulkan.Types
( vulkanCtx )
C.context ( Cpp.cppCtx <> C.funCtx <> vulkanCtx )
C.include "string.h"
C.include "imgui.h"
C.include "backends/imgui_impl_vulkan.h"
Cpp.using "namespace ImGui"
data InitInfo =
InitInfo
{ InitInfo -> Instance
instance' :: !Vulkan.Instance
, InitInfo -> PhysicalDevice
physicalDevice :: !Vulkan.PhysicalDevice
, InitInfo -> Device
device :: !Vulkan.Device
, InitInfo -> Word32
queueFamily :: !Word32
, InitInfo -> Queue
queue :: !Vulkan.Queue
, InitInfo -> PipelineCache
pipelineCache :: !Vulkan.PipelineCache
, InitInfo -> DescriptorPool
descriptorPool :: !Vulkan.DescriptorPool
, InitInfo -> Word32
subpass :: !Word32
, InitInfo -> Word32
minImageCount :: !Word32
, InitInfo -> Word32
imageCount :: !Word32
, InitInfo -> SampleCountFlagBits
msaaSamples :: !Vulkan.SampleCountFlagBits
, InitInfo -> Either RenderPass PipelineRenderingCreateInfo
rendering :: Either Vulkan.RenderPass Vulkan.PipelineRenderingCreateInfo
, InitInfo -> Maybe AllocationCallbacks
mbAllocator :: Maybe Vulkan.AllocationCallbacks
, InitInfo -> Result -> IO ()
checkResult :: Vulkan.Result -> IO ()
}
withVulkan :: MonadUnliftIO m => InitInfo -> ( Bool -> m a ) -> m a
withVulkan :: forall (m :: * -> *) a.
MonadUnliftIO m =>
InitInfo -> (Bool -> m a) -> m a
withVulkan InitInfo
initInfo Bool -> m a
action =
m (FunPtr (Result -> IO ()), Bool)
-> ((FunPtr (Result -> IO ()), Bool) -> m ())
-> ((FunPtr (Result -> IO ()), Bool) -> m a)
-> m a
forall (m :: * -> *) a b c.
MonadUnliftIO m =>
m a -> (a -> m b) -> (a -> m c) -> m c
bracket
( InitInfo -> m (FunPtr (Result -> IO ()), Bool)
forall (m :: * -> *).
MonadIO m =>
InitInfo -> m (FunPtr (Result -> IO ()), Bool)
vulkanInit InitInfo
initInfo )
(FunPtr (Result -> IO ()), Bool) -> m ()
forall (m :: * -> *) a b. MonadIO m => (FunPtr a, b) -> m ()
vulkanShutdown
( \ ( FunPtr (Result -> IO ())
_, Bool
initResult ) -> Bool -> m a
action Bool
initResult )
vulkanInit :: MonadIO m => InitInfo -> m (FunPtr (Vulkan.Result -> IO ()), Bool)
vulkanInit :: forall (m :: * -> *).
MonadIO m =>
InitInfo -> m (FunPtr (Result -> IO ()), Bool)
vulkanInit ( InitInfo {Maybe AllocationCallbacks
Word32
Either RenderPass PipelineRenderingCreateInfo
SampleCountFlagBits
Queue
PipelineCache
PhysicalDevice
Instance
Device
DescriptorPool
Result -> IO ()
instance' :: InitInfo -> Instance
physicalDevice :: InitInfo -> PhysicalDevice
device :: InitInfo -> Device
queueFamily :: InitInfo -> Word32
queue :: InitInfo -> Queue
pipelineCache :: InitInfo -> PipelineCache
descriptorPool :: InitInfo -> DescriptorPool
subpass :: InitInfo -> Word32
minImageCount :: InitInfo -> Word32
imageCount :: InitInfo -> Word32
msaaSamples :: InitInfo -> SampleCountFlagBits
rendering :: InitInfo -> Either RenderPass PipelineRenderingCreateInfo
mbAllocator :: InitInfo -> Maybe AllocationCallbacks
checkResult :: InitInfo -> Result -> IO ()
instance' :: Instance
physicalDevice :: PhysicalDevice
device :: Device
queueFamily :: Word32
queue :: Queue
pipelineCache :: PipelineCache
descriptorPool :: DescriptorPool
subpass :: Word32
minImageCount :: Word32
imageCount :: Word32
msaaSamples :: SampleCountFlagBits
rendering :: Either RenderPass PipelineRenderingCreateInfo
mbAllocator :: Maybe AllocationCallbacks
checkResult :: Result -> IO ()
..} ) = IO (FunPtr (Result -> IO ()), Bool)
-> m (FunPtr (Result -> IO ()), Bool)
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO do
let
instancePtr :: Ptr Vulkan.Instance_T
instancePtr :: Ptr Instance_T
instancePtr = Instance -> Ptr Instance_T
Vulkan.instanceHandle Instance
instance'
physicalDevicePtr :: Ptr Vulkan.PhysicalDevice_T
physicalDevicePtr :: Ptr PhysicalDevice_T
physicalDevicePtr = PhysicalDevice -> Ptr PhysicalDevice_T
Vulkan.physicalDeviceHandle PhysicalDevice
physicalDevice
devicePtr :: Ptr Vulkan.Device_T
devicePtr :: Ptr Device_T
devicePtr = Device -> Ptr Device_T
Vulkan.deviceHandle Device
device
queuePtr :: Ptr Vulkan.Queue_T
queuePtr :: Ptr Queue_T
queuePtr = Queue -> Ptr Queue_T
Vulkan.queueHandle Queue
queue
withCallbacks :: ( Ptr Vulkan.AllocationCallbacks -> IO a ) -> IO a
withCallbacks :: forall a. (Ptr AllocationCallbacks -> IO a) -> IO a
withCallbacks Ptr AllocationCallbacks -> IO a
f = case Maybe AllocationCallbacks
mbAllocator of
Maybe AllocationCallbacks
Nothing -> Ptr AllocationCallbacks -> IO a
f Ptr AllocationCallbacks
forall a. Ptr a
nullPtr
Just AllocationCallbacks
callbacks -> (Ptr AllocationCallbacks -> IO a) -> IO a
forall a b. Storable a => (Ptr a -> IO b) -> IO b
alloca ( \ Ptr AllocationCallbacks
ptr -> Ptr AllocationCallbacks -> AllocationCallbacks -> IO ()
forall a. Storable a => Ptr a -> a -> IO ()
poke Ptr AllocationCallbacks
ptr AllocationCallbacks
callbacks IO () -> IO a -> IO a
forall a b. IO a -> IO b -> IO b
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Ptr AllocationCallbacks -> IO a
f Ptr AllocationCallbacks
ptr )
useDynamicRendering' :: Cpp.CBool
useDynamicRendering' :: CBool
useDynamicRendering' = Bool -> CBool
forall a. Num a => Bool -> a
fromBool (Either RenderPass PipelineRenderingCreateInfo -> Bool
forall a b. Either a b -> Bool
isRight Either RenderPass PipelineRenderingCreateInfo
rendering)
renderPass :: Vulkan.RenderPass
renderPass :: RenderPass
renderPass = (RenderPass -> RenderPass)
-> (PipelineRenderingCreateInfo -> RenderPass)
-> Either RenderPass PipelineRenderingCreateInfo
-> RenderPass
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either RenderPass -> RenderPass
forall a. a -> a
id (RenderPass -> PipelineRenderingCreateInfo -> RenderPass
forall a b. a -> b -> a
const RenderPass
forall a. Zero a => a
zero) Either RenderPass PipelineRenderingCreateInfo
rendering
PipelineRenderingCreateInfo
-> (Ptr PipelineRenderingCreateInfo
-> IO (FunPtr (Result -> IO ()), Bool))
-> IO (FunPtr (Result -> IO ()), Bool)
forall a b. ToCStruct a => a -> (Ptr a -> IO b) -> IO b
forall b.
PipelineRenderingCreateInfo
-> (Ptr PipelineRenderingCreateInfo -> IO b) -> IO b
Vulkan.withCStruct ((RenderPass -> PipelineRenderingCreateInfo)
-> (PipelineRenderingCreateInfo -> PipelineRenderingCreateInfo)
-> Either RenderPass PipelineRenderingCreateInfo
-> PipelineRenderingCreateInfo
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (PipelineRenderingCreateInfo
-> RenderPass -> PipelineRenderingCreateInfo
forall a b. a -> b -> a
const PipelineRenderingCreateInfo
forall a. Zero a => a
zero) PipelineRenderingCreateInfo -> PipelineRenderingCreateInfo
forall a. a -> a
id Either RenderPass PipelineRenderingCreateInfo
rendering) \Ptr PipelineRenderingCreateInfo
pipelineRenderingCIPtr -> do
FunPtr (Result -> IO ())
checkResultFunPtr <- $( C.mkFunPtr [t| Vulkan.Result -> IO () |] ) Result -> IO ()
checkResult
CBool
initResult <- (Ptr AllocationCallbacks -> IO CBool) -> IO CBool
forall a. (Ptr AllocationCallbacks -> IO a) -> IO a
withCallbacks \ Ptr AllocationCallbacks
callbacksPtr -> do
[C.block| bool {
ImGui_ImplVulkan_InitInfo initInfo = {0,};
#ifdef IMGUI_IMPL_VULKAN_HAS_DYNAMIC_RENDERING
VkPipelineRenderingCreateInfoKHR pipelineRenderingCI;
memset(&pipelineRenderingCI, 0, sizeof(VkPipelineRenderingCreateInfoKHR));
#endif
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) );
initInfo.UseDynamicRendering = $(bool useDynamicRendering');
initInfo.RenderPass = $(VkRenderPass renderPass);
if ($(VkPipelineRenderingCreateInfo* pipelineRenderingCIPtr))
memcpy(&initInfo.PipelineRenderingCreateInfo, $(VkPipelineRenderingCreateInfo* pipelineRenderingCIPtr), sizeof(VkPipelineRenderingCreateInfo));
return ImGui_ImplVulkan_Init(&initInfo);
}|]
(FunPtr (Result -> IO ()), Bool)
-> IO (FunPtr (Result -> IO ()), Bool)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ( FunPtr (Result -> IO ())
checkResultFunPtr, CBool
initResult CBool -> CBool -> Bool
forall a. Eq a => a -> a -> Bool
/= CBool
0 )
vulkanShutdown :: MonadIO m => (FunPtr a, b) -> m ()
vulkanShutdown :: forall (m :: * -> *) a b. MonadIO m => (FunPtr a, b) -> m ()
vulkanShutdown ( FunPtr a
checkResultFunPtr, b
_ ) = IO () -> m ()
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO do
IO ()
[C.exp| void { ImGui_ImplVulkan_Shutdown(); } |]
FunPtr a -> IO ()
forall a. FunPtr a -> IO ()
freeHaskellFunPtr FunPtr a
checkResultFunPtr
vulkanNewFrame :: MonadIO m => m ()
vulkanNewFrame :: forall (m :: * -> *). MonadIO m => m ()
vulkanNewFrame = IO () -> m ()
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO do
IO ()
[C.exp| void { ImGui_ImplVulkan_NewFrame(); } |]
vulkanRenderDrawData :: MonadIO m => DrawData -> Vulkan.CommandBuffer -> Maybe Vulkan.Pipeline -> m ()
vulkanRenderDrawData :: forall (m :: * -> *).
MonadIO m =>
DrawData -> CommandBuffer -> Maybe Pipeline -> m ()
vulkanRenderDrawData (DrawData Ptr ()
dataPtr) CommandBuffer
commandBuffer Maybe Pipeline
mbPipeline = IO () -> m ()
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO do
let
commandBufferPtr :: Ptr Vulkan.CommandBuffer_T
commandBufferPtr :: Ptr CommandBuffer_T
commandBufferPtr = CommandBuffer -> Ptr CommandBuffer_T
Vulkan.commandBufferHandle CommandBuffer
commandBuffer
pipeline :: Vulkan.Pipeline
pipeline :: Pipeline
pipeline = Pipeline -> Maybe Pipeline -> Pipeline
forall a. a -> Maybe a -> a
fromMaybe Pipeline
forall a. IsHandle a => a
Vulkan.NULL_HANDLE Maybe Pipeline
mbPipeline
[C.block| void {
VkCommandBuffer commandBuffer = { $( VkCommandBuffer_T* commandBufferPtr ) };
ImGui_ImplVulkan_RenderDrawData((ImDrawData*) $(void* dataPtr), commandBuffer, $(VkPipeline pipeline));
}|]
vulkanCreateFontsTexture :: MonadIO m => m Bool
vulkanCreateFontsTexture :: forall (m :: * -> *). MonadIO m => m Bool
vulkanCreateFontsTexture = IO Bool -> m Bool
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO do
CBool
res <-
IO CBool
[C.block| bool {
return ImGui_ImplVulkan_CreateFontsTexture();
}|]
Bool -> IO Bool
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ( CBool
res CBool -> CBool -> Bool
forall a. Eq a => a -> a -> Bool
/= CBool
0 )
vulkanDestroyFontsTexture :: MonadIO m => m ()
vulkanDestroyFontsTexture :: forall (m :: * -> *). MonadIO m => m ()
vulkanDestroyFontsTexture = IO () -> m ()
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO do
IO ()
[C.block| void {
return ImGui_ImplVulkan_DestroyFontsTexture();
}|]
vulkanSetMinImageCount :: MonadIO m => Word32 -> m ()
vulkanSetMinImageCount :: forall (m :: * -> *). MonadIO m => Word32 -> m ()
vulkanSetMinImageCount Word32
minImageCount = IO () -> m ()
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO do
[C.exp| void { ImGui_ImplVulkan_SetMinImageCount($(uint32_t minImageCount)); } |]
vulkanAddTexture :: MonadIO m => Vulkan.Sampler -> Vulkan.ImageView -> Vulkan.ImageLayout -> m Vulkan.DescriptorSet
vulkanAddTexture :: forall (m :: * -> *).
MonadIO m =>
Sampler -> ImageView -> ImageLayout -> m DescriptorSet
vulkanAddTexture Sampler
sampler ImageView
imageView ImageLayout
imageLayout = IO DescriptorSet -> m DescriptorSet
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO do
[C.block|
VkDescriptorSet {
return ImGui_ImplVulkan_AddTexture(
$(VkSampler sampler),
$(VkImageView imageView),
$(VkImageLayout imageLayout)
);
}
|]