module Render.ImGui
( allocate
, allocateWith
, beforeLoop
, afterLoop
, capturingKeyboard
, capturingMouse
, mkDrawData
, draw
) where
import RIO
import Control.Monad.Trans.Resource (ReleaseKey, ResourceT, register, release)
import DearImGui.Vulkan (InitInfo(..))
import DearImGui.Vulkan qualified as ImGui
import DearImGui qualified as ImGui
import DearImGui.GLFW (glfwNewFrame, glfwShutdown)
import DearImGui.GLFW.Vulkan (glfwInitForVulkan)
import RIO.App (appEnv)
import Vulkan.Core10 qualified as Vk
import Vulkan.Exception (VulkanException(..))
import Vulkan.Utils.QueueAssignment (QueueFamilyIndex(..))
import Engine.Types (GlobalHandles(..), StageRIO)
import Engine.Vulkan.Types (HasRenderPass(..), HasSwapchain(..), Queues(..), getMultisample)
import Resource.CommandBuffer qualified as CommandBuffer
import Resource.DescriptorSet qualified as DescriptorSet
allocate
:: ( HasSwapchain swapchain
, HasRenderPass renderpass
)
=> swapchain
-> renderpass
-> Word32
-> ResourceT (StageRIO st) ReleaseKey
allocate :: swapchain
-> renderpass -> Word32 -> ResourceT (StageRIO st) ReleaseKey
allocate swapchain
swapchain renderpass
renderpass Word32
subpassIx =
((ReleaseKey, ()) -> ReleaseKey)
-> ResourceT (StageRIO st) (ReleaseKey, ())
-> ResourceT (StageRIO st) ReleaseKey
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (ReleaseKey, ()) -> ReleaseKey
forall a b. (a, b) -> a
fst (ResourceT (StageRIO st) (ReleaseKey, ())
-> ResourceT (StageRIO st) ReleaseKey)
-> ResourceT (StageRIO st) (ReleaseKey, ())
-> ResourceT (StageRIO st) ReleaseKey
forall a b. (a -> b) -> a -> b
$
swapchain
-> renderpass
-> Word32
-> ResourceT (StageRIO st) ()
-> ResourceT (StageRIO st) (ReleaseKey, ())
forall swapchain renderpass st a.
(HasSwapchain swapchain, HasRenderPass renderpass) =>
swapchain
-> renderpass
-> Word32
-> ResourceT (StageRIO st) a
-> ResourceT (StageRIO st) (ReleaseKey, a)
allocateWith swapchain
swapchain renderpass
renderpass Word32
subpassIx (ResourceT (StageRIO st) ()
-> ResourceT (StageRIO st) (ReleaseKey, ()))
-> ResourceT (StageRIO st) ()
-> ResourceT (StageRIO st) (ReleaseKey, ())
forall a b. (a -> b) -> a -> b
$
() -> ResourceT (StageRIO st) ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
allocateWith
:: ( HasSwapchain swapchain
, HasRenderPass renderpass
)
=> swapchain
-> renderpass
-> Word32
-> ResourceT (StageRIO st) a
-> ResourceT (StageRIO st) (ReleaseKey, a)
allocateWith :: swapchain
-> renderpass
-> Word32
-> ResourceT (StageRIO st) a
-> ResourceT (StageRIO st) (ReleaseKey, a)
allocateWith swapchain
swapchain renderpass
renderpass Word32
subpassIx ResourceT (StageRIO st) a
action = do
Utf8Builder -> ResourceT (StageRIO st) ()
forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logDebug Utf8Builder
"Initializing DearImGui"
IO ()
debugReleaseFinished <- ResourceT (StageRIO st) () -> ResourceT (StageRIO st) (IO ())
forall (m :: * -> *) a. MonadUnliftIO m => m a -> m (IO a)
toIO (Utf8Builder -> ResourceT (StageRIO st) ()
forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logDebug Utf8Builder
"Released DearImGui")
ResourceT (StageRIO st) ReleaseKey -> ResourceT (StageRIO st) ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (ResourceT (StageRIO st) ReleaseKey -> ResourceT (StageRIO st) ())
-> ResourceT (StageRIO st) ReleaseKey -> ResourceT (StageRIO st) ()
forall a b. (a -> b) -> a -> b
$! IO () -> ResourceT (StageRIO st) ReleaseKey
forall (m :: * -> *). MonadResource m => IO () -> m ReleaseKey
register IO ()
debugReleaseFinished
Context
ctx <- ResourceT (StageRIO st) Context
forall (m :: * -> *). MonadIO m => m Context
ImGui.createContext
ReleaseKey
_ctxKey <- IO () -> ResourceT (StageRIO st) ReleaseKey
forall (m :: * -> *). MonadResource m => IO () -> m ReleaseKey
register (IO () -> ResourceT (StageRIO st) ReleaseKey)
-> IO () -> ResourceT (StageRIO st) ReleaseKey
forall a b. (a -> b) -> a -> b
$ Context -> IO ()
forall (m :: * -> *). MonadIO m => Context -> m ()
ImGui.destroyContext Context
ctx
context :: GlobalHandles
context@GlobalHandles{StageSwitchVar
Instance
PhysicalDevice
Device
Window
SurfaceKHR
Allocator
PhysicalDeviceInfo
Queues (QueueFamilyIndex, Queue)
ProjectionProcess
$sel:ghWindow:GlobalHandles :: GlobalHandles -> Window
$sel:ghSurface:GlobalHandles :: GlobalHandles -> SurfaceKHR
$sel:ghStageSwitch:GlobalHandles :: GlobalHandles -> StageSwitchVar
$sel:ghScreenP:GlobalHandles :: GlobalHandles -> ProjectionProcess
$sel:ghQueues:GlobalHandles :: GlobalHandles -> Queues (QueueFamilyIndex, Queue)
$sel:ghPhysicalDeviceInfo:GlobalHandles :: GlobalHandles -> PhysicalDeviceInfo
$sel:ghPhysicalDevice:GlobalHandles :: GlobalHandles -> PhysicalDevice
$sel:ghInstance:GlobalHandles :: GlobalHandles -> Instance
$sel:ghDevice:GlobalHandles :: GlobalHandles -> Device
$sel:ghAllocator:GlobalHandles :: GlobalHandles -> Allocator
ghStageSwitch :: StageSwitchVar
ghScreenP :: ProjectionProcess
ghQueues :: Queues (QueueFamilyIndex, Queue)
ghAllocator :: Allocator
ghDevice :: Device
ghPhysicalDeviceInfo :: PhysicalDeviceInfo
ghPhysicalDevice :: PhysicalDevice
ghInstance :: Instance
ghSurface :: SurfaceKHR
ghWindow :: Window
..} <- (App GlobalHandles st -> GlobalHandles)
-> ResourceT (StageRIO st) GlobalHandles
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks App GlobalHandles st -> GlobalHandles
forall env st. App env st -> env
appEnv
let (QueueFamilyIndex Word32
queueFamily, Queue
queue) = Queues (QueueFamilyIndex, Queue) -> (QueueFamilyIndex, Queue)
forall q. Queues q -> q
qGraphics Queues (QueueFamilyIndex, Queue)
ghQueues
(ReleaseKey
_poolKey, DescriptorPool
pool) <- Word32
-> TypeMap Word32
-> ResourceT (StageRIO st) (ReleaseKey, DescriptorPool)
forall (m :: * -> *) env.
(MonadResource m, MonadReader env m, HasVulkan env) =>
Word32 -> TypeMap Word32 -> m (ReleaseKey, DescriptorPool)
DescriptorSet.allocatePool Word32
1 TypeMap Word32
dsSizes
let
initInfo :: InitInfo
initInfo = InitInfo :: Instance
-> PhysicalDevice
-> Device
-> Word32
-> Queue
-> PipelineCache
-> DescriptorPool
-> Word32
-> Word32
-> Word32
-> SampleCountFlagBits
-> Maybe AllocationCallbacks
-> (Result -> IO ())
-> InitInfo
InitInfo
{ instance' :: Instance
instance' = Instance
ghInstance
, physicalDevice :: PhysicalDevice
physicalDevice = PhysicalDevice
ghPhysicalDevice
, device :: Device
device = Device
ghDevice
, queueFamily :: Word32
queueFamily = Word32
queueFamily
, queue :: Queue
queue = Queue
queue
, minImageCount :: Word32
minImageCount = swapchain -> Word32
forall a. HasSwapchain a => a -> Word32
getMinImageCount swapchain
swapchain
, imageCount :: Word32
imageCount = swapchain -> Word32
forall a. HasSwapchain a => a -> Word32
getImageCount swapchain
swapchain
, msaaSamples :: SampleCountFlagBits
msaaSamples = swapchain -> SampleCountFlagBits
forall a. HasSwapchain a => a -> SampleCountFlagBits
getMultisample swapchain
swapchain
, subpass :: Word32
subpass = Word32
subpassIx
, pipelineCache :: PipelineCache
pipelineCache = PipelineCache
forall a. IsHandle a => a
Vk.NULL_HANDLE
, descriptorPool :: DescriptorPool
descriptorPool = DescriptorPool
pool
, mbAllocator :: Maybe AllocationCallbacks
mbAllocator = Maybe AllocationCallbacks
forall a. Maybe a
Nothing
, checkResult :: Result -> IO ()
checkResult = \case { Result
Vk.SUCCESS -> () -> IO ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure (); Result
e -> VulkanException -> IO ()
forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwM (VulkanException -> IO ()) -> VulkanException -> IO ()
forall a b. (a -> b) -> a -> b
$ Result -> VulkanException
VulkanException Result
e }
}
res :: (FunPtr (Result -> IO ()), Bool)
res@(FunPtr (Result -> IO ())
_cb, Bool
initOk) <- InitInfo
-> RenderPass
-> ResourceT (StageRIO st) (FunPtr (Result -> IO ()), Bool)
forall (m :: * -> *).
MonadIO m =>
InitInfo -> RenderPass -> m (FunPtr (Result -> IO ()), Bool)
ImGui.vulkanInit InitInfo
initInfo (renderpass -> RenderPass
forall a. HasRenderPass a => a -> RenderPass
getRenderPass renderpass
renderpass)
Bool -> ResourceT (StageRIO st) () -> ResourceT (StageRIO st) ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless Bool
initOk do
Utf8Builder -> ResourceT (StageRIO st) ()
forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logError Utf8Builder
"DearImGui vulkan initialization failed"
ResourceT (StageRIO st) ()
forall (m :: * -> *) a. MonadIO m => m a
exitFailure
ReleaseKey
key <- IO () -> ResourceT (StageRIO st) ReleaseKey
forall (m :: * -> *). MonadResource m => IO () -> m ReleaseKey
register (IO () -> ResourceT (StageRIO st) ReleaseKey)
-> IO () -> ResourceT (StageRIO st) ReleaseKey
forall a b. (a -> b) -> a -> b
$ (FunPtr (Result -> IO ()), Bool) -> IO ()
forall (m :: * -> *) a b. MonadIO m => (FunPtr a, b) -> m ()
ImGui.vulkanShutdown (FunPtr (Result -> IO ()), Bool)
res
a
actionRes <- ResourceT (StageRIO st) a
action
(ReleaseKey
oneshotPoolKey, Queues CommandPool
oneshotPool) <- GlobalHandles
-> ResourceT (StageRIO st) (ReleaseKey, Queues CommandPool)
forall context (m :: * -> *).
(HasVulkan context, MonadResource m) =>
context -> m (ReleaseKey, Queues CommandPool)
CommandBuffer.allocatePools GlobalHandles
context
GlobalHandles
-> Queues CommandPool
-> (forall q. Queues q -> q)
-> (CommandBuffer -> ResourceT (StageRIO st) ())
-> ResourceT (StageRIO st) ()
forall context (m :: * -> *).
(HasVulkan context, MonadUnliftIO m) =>
context
-> Queues CommandPool
-> (forall q. Queues q -> q)
-> (CommandBuffer -> m ())
-> m ()
CommandBuffer.oneshot_ GlobalHandles
context Queues CommandPool
oneshotPool forall q. Queues q -> q
qGraphics \CommandBuffer
cb -> do
Bool
fontsOk <- CommandBuffer -> ResourceT (StageRIO st) Bool
forall (m :: * -> *). MonadIO m => CommandBuffer -> m Bool
ImGui.vulkanCreateFontsTexture CommandBuffer
cb
Bool -> ResourceT (StageRIO st) () -> ResourceT (StageRIO st) ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless Bool
fontsOk do
Utf8Builder -> ResourceT (StageRIO st) ()
forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logError Utf8Builder
"ImGui.vulkanCreateFontsTexture failed"
ResourceT (StageRIO st) ()
forall (m :: * -> *) a. MonadIO m => m a
exitFailure
ReleaseKey -> ResourceT (StageRIO st) ()
forall (m :: * -> *). MonadIO m => ReleaseKey -> m ()
release ReleaseKey
oneshotPoolKey
ResourceT (StageRIO st) ()
forall (m :: * -> *). MonadIO m => m ()
ImGui.vulkanDestroyFontUploadObjects
IO ()
debugReleaseStart <- ResourceT (StageRIO st) () -> ResourceT (StageRIO st) (IO ())
forall (m :: * -> *) a. MonadUnliftIO m => m a -> m (IO a)
toIO (Utf8Builder -> ResourceT (StageRIO st) ()
forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logDebug Utf8Builder
"Releasing DearImGui")
ResourceT (StageRIO st) ReleaseKey -> ResourceT (StageRIO st) ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (ResourceT (StageRIO st) ReleaseKey -> ResourceT (StageRIO st) ())
-> ResourceT (StageRIO st) ReleaseKey -> ResourceT (StageRIO st) ()
forall a b. (a -> b) -> a -> b
$! IO () -> ResourceT (StageRIO st) ReleaseKey
forall (m :: * -> *). MonadResource m => IO () -> m ReleaseKey
register IO ()
debugReleaseStart
pure (ReleaseKey
key, a
actionRes)
dsSizes :: DescriptorSet.TypeMap Word32
dsSizes :: TypeMap Word32
dsSizes = (DescriptorType -> (DescriptorType, Word32))
-> [DescriptorType] -> TypeMap Word32
forall a b. (a -> b) -> [a] -> [b]
map (, Word32
100)
[ DescriptorType
Vk.DESCRIPTOR_TYPE_SAMPLER
, DescriptorType
Vk.DESCRIPTOR_TYPE_COMBINED_IMAGE_SAMPLER
, DescriptorType
Vk.DESCRIPTOR_TYPE_SAMPLED_IMAGE
, DescriptorType
Vk.DESCRIPTOR_TYPE_STORAGE_IMAGE
, DescriptorType
Vk.DESCRIPTOR_TYPE_UNIFORM_TEXEL_BUFFER
, DescriptorType
Vk.DESCRIPTOR_TYPE_STORAGE_TEXEL_BUFFER
, DescriptorType
Vk.DESCRIPTOR_TYPE_UNIFORM_BUFFER
, DescriptorType
Vk.DESCRIPTOR_TYPE_STORAGE_BUFFER
, DescriptorType
Vk.DESCRIPTOR_TYPE_UNIFORM_BUFFER_DYNAMIC
, DescriptorType
Vk.DESCRIPTOR_TYPE_STORAGE_BUFFER_DYNAMIC
, DescriptorType
Vk.DESCRIPTOR_TYPE_INPUT_ATTACHMENT
]
beforeLoop :: Bool -> StageRIO st ()
beforeLoop :: Bool -> StageRIO st ()
beforeLoop Bool
installCallbacks = do
Utf8Builder -> StageRIO st ()
forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logDebug Utf8Builder
"Setting up ImGui"
Window
window <- (App GlobalHandles st -> Window)
-> RIO (App GlobalHandles st) Window
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks ((App GlobalHandles st -> Window)
-> RIO (App GlobalHandles st) Window)
-> (App GlobalHandles st -> Window)
-> RIO (App GlobalHandles st) Window
forall a b. (a -> b) -> a -> b
$ GlobalHandles -> Window
ghWindow (GlobalHandles -> Window)
-> (App GlobalHandles st -> GlobalHandles)
-> App GlobalHandles st
-> Window
forall b c a. (b -> c) -> (a -> b) -> a -> c
. App GlobalHandles st -> GlobalHandles
forall env st. App env st -> env
appEnv
Bool
success <- Window -> Bool -> RIO (App GlobalHandles st) Bool
forall (m :: * -> *). MonadIO m => Window -> Bool -> m Bool
glfwInitForVulkan Window
window Bool
installCallbacks
Bool -> StageRIO st () -> StageRIO st ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless Bool
success do
Utf8Builder -> StageRIO st ()
forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logWarn Utf8Builder
"glfwInitForVulkan failed"
afterLoop :: StageRIO st ()
afterLoop :: StageRIO st ()
afterLoop = do
Utf8Builder -> StageRIO st ()
forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logDebug Utf8Builder
"Shutting down ImGui"
StageRIO st ()
forall (m :: * -> *). MonadIO m => m ()
glfwShutdown
mkDrawData :: MonadIO m => m a -> m (a, ImGui.DrawData)
mkDrawData :: m a -> m (a, DrawData)
mkDrawData m a
action = do
m ()
forall (m :: * -> *). MonadIO m => m ()
ImGui.vulkanNewFrame
m ()
forall (m :: * -> *). MonadIO m => m ()
glfwNewFrame
m ()
forall (m :: * -> *). MonadIO m => m ()
ImGui.newFrame
a
result <- m a
action
m ()
forall (m :: * -> *). MonadIO m => m ()
ImGui.render
DrawData
drawData <- m DrawData
forall (m :: * -> *). MonadIO m => m DrawData
ImGui.getDrawData
pure (a
result, DrawData
drawData)
draw :: MonadIO m => ImGui.DrawData -> Vk.CommandBuffer -> m ()
draw :: DrawData -> CommandBuffer -> m ()
draw DrawData
drawData CommandBuffer
commandBuffer = do
DrawData -> CommandBuffer -> Maybe Pipeline -> m ()
forall (m :: * -> *).
MonadIO m =>
DrawData -> CommandBuffer -> Maybe Pipeline -> m ()
ImGui.vulkanRenderDrawData DrawData
drawData CommandBuffer
commandBuffer Maybe Pipeline
forall a. Maybe a
Nothing
capturingKeyboard :: MonadIO m => m () -> m ()
capturingKeyboard :: m () -> m ()
capturingKeyboard m ()
action =
m Bool
forall (m :: * -> *). MonadIO m => m Bool
ImGui.wantCaptureKeyboard m Bool -> (Bool -> m ()) -> m ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
`unless` m ()
action)
capturingMouse :: MonadIO m => m () -> m ()
capturingMouse :: m () -> m ()
capturingMouse m ()
action =
m Bool
forall (m :: * -> *). MonadIO m => m Bool
ImGui.wantCaptureMouse m Bool -> (Bool -> m ()) -> m ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
`unless` m ()
action)