module Render.ImGui
( allocate
, allocateWithFonts
, allocateWith
, renderWith
, allocateLoop
, beforeLoop
, afterLoop
, capturingKeyboard
, capturingMouse
, mkDrawData
, draw
) where
import RIO
import Control.Monad.Trans.Resource (ReleaseKey, ResourceT, register, release)
import DearImGui qualified as ImGui
import DearImGui.FontAtlas qualified as FontAtlas
import DearImGui.GLFW (glfwNewFrame, glfwShutdown)
import DearImGui.GLFW.Vulkan (glfwInitForVulkan)
import DearImGui.Vulkan (InitInfo(..))
import DearImGui.Vulkan qualified as ImGui
import Engine.Stage.Component qualified as Stage
import Engine.Types (GlobalHandles(..), StageRIO)
import Engine.Vulkan.Types (HasRenderPass(..), HasSwapchain(..), Queues(..), getDevice, getMultisample)
import Resource.CommandBuffer qualified as CommandBuffer
import Resource.Region qualified as Region
import Resource.Vulkan.DescriptorPool qualified as DescriptorPool
import RIO.App (appEnv)
import Vulkan.Core10 qualified as Vk
import Vulkan.Exception (VulkanException(..))
import Vulkan.NamedType (type (:::))
import Vulkan.Utils.QueueAssignment (QueueFamilyIndex(..))
allocate
:: ( HasSwapchain swapchain
, HasRenderPass renderpass
)
=> swapchain
-> renderpass
-> Word32
-> ResourceT (StageRIO st) ReleaseKey
allocate :: forall swapchain renderpass st.
(HasSwapchain swapchain, HasRenderPass renderpass) =>
swapchain
-> renderpass -> Word32 -> ResourceT (StageRIO st) ReleaseKey
allocate swapchain
swapchain renderpass
renderpass Word32
subpassIx =
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a b. (a, b) -> a
fst forall a b. (a -> b) -> a -> b
$
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 forall a b. (a -> b) -> a -> b
$
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
allocateWithFonts
:: ( HasSwapchain swapchain
, HasRenderPass renderpass
, Traversable t
)
=> swapchain
-> renderpass
-> Word32
-> t FontAtlas.FontSource
-> ResourceT (StageRIO st) (ReleaseKey, t ImGui.Font)
allocateWithFonts :: forall swapchain renderpass (t :: * -> *) st.
(HasSwapchain swapchain, HasRenderPass renderpass,
Traversable t) =>
swapchain
-> renderpass
-> Word32
-> t FontSource
-> ResourceT (StageRIO st) (ReleaseKey, t Font)
allocateWithFonts swapchain
swapchain renderpass
renderpass Word32
subpassIx t FontSource
fonts =
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 do
t Font
loaded <- forall (m :: * -> *) (t :: * -> *).
(MonadIO m, Traversable t) =>
t FontSource -> m (t Font)
FontAtlas.rebuild t FontSource
fonts
ReleaseKey
_atlasKey <- forall (m :: * -> *). MonadResource m => IO () -> m ReleaseKey
register forall (m :: * -> *). MonadIO m => m ()
FontAtlas.clear
pure t Font
loaded
allocateWith
:: ( HasSwapchain swapchain
, HasRenderPass renderpass
)
=> swapchain
-> renderpass
-> Word32
-> ResourceT (StageRIO st) a
-> ResourceT (StageRIO st) (ReleaseKey, a)
allocateWith :: 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) a
action = do
forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logDebug Utf8Builder
"Initializing DearImGui"
IO ()
debugReleaseFinished <- forall (m :: * -> *) a. MonadUnliftIO m => m a -> m (IO a)
toIO (forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logDebug Utf8Builder
"Released DearImGui")
forall (f :: * -> *) a. Functor f => f a -> f ()
void forall a b. (a -> b) -> a -> b
$! forall (m :: * -> *). MonadResource m => IO () -> m ReleaseKey
register IO ()
debugReleaseFinished
Context
ctx <- forall (m :: * -> *). MonadIO m => m Context
ImGui.createContext
forall (m :: * -> *). MonadUnliftIO m => IO () -> ResourceT m ()
Region.register_ forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *). MonadIO m => Context -> m ()
ImGui.destroyContext Context
ctx
context :: GlobalHandles
context@GlobalHandles{Window
Allocator
Var Extent2D
StageSwitchVar
SurfaceKHR
Device
Instance
PhysicalDevice
Queues (QueueFamilyIndex, Queue)
Options
PhysicalDeviceInfo
$sel:ghWindow:GlobalHandles :: GlobalHandles -> Window
$sel:ghSurface:GlobalHandles :: GlobalHandles -> SurfaceKHR
$sel:ghStageSwitch:GlobalHandles :: GlobalHandles -> StageSwitchVar
$sel:ghScreenVar:GlobalHandles :: GlobalHandles -> Var Extent2D
$sel:ghQueues:GlobalHandles :: GlobalHandles -> Queues (QueueFamilyIndex, Queue)
$sel:ghPhysicalDeviceInfo:GlobalHandles :: GlobalHandles -> PhysicalDeviceInfo
$sel:ghPhysicalDevice:GlobalHandles :: GlobalHandles -> PhysicalDevice
$sel:ghOptions:GlobalHandles :: GlobalHandles -> Options
$sel:ghInstance:GlobalHandles :: GlobalHandles -> Instance
$sel:ghDevice:GlobalHandles :: GlobalHandles -> Device
$sel:ghAllocator:GlobalHandles :: GlobalHandles -> Allocator
ghStageSwitch :: StageSwitchVar
ghScreenVar :: Var Extent2D
ghQueues :: Queues (QueueFamilyIndex, Queue)
ghAllocator :: Allocator
ghDevice :: Device
ghPhysicalDeviceInfo :: PhysicalDeviceInfo
ghPhysicalDevice :: PhysicalDevice
ghInstance :: Instance
ghSurface :: SurfaceKHR
ghWindow :: Window
ghOptions :: Options
..} <- forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks forall env st. App env st -> env
appEnv
let (QueueFamilyIndex Word32
queueFamily, Queue
queue) = forall q. Queues q -> q
qGraphics Queues (QueueFamilyIndex, Queue)
ghQueues
DescriptorPool
pool <- forall (m :: * -> *) a.
MonadResource m =>
m (ReleaseKey, a) -> ResourceT m a
Region.local forall a b. (a -> b) -> a -> b
$
forall env (m :: * -> *).
(MonadVulkan env m, MonadResource m) =>
Maybe Text
-> Word32
-> [(DescriptorType, Word32)]
-> m (ReleaseKey, DescriptorPool)
DescriptorPool.allocate (forall a. a -> Maybe a
Just Text
"ImGui") Word32
1 [(DescriptorType, Word32)]
dsSizes
let
initInfo :: InitInfo
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 = forall a. HasSwapchain a => a -> Word32
getMinImageCount swapchain
swapchain
, imageCount :: Word32
imageCount = forall a. HasSwapchain a => a -> Word32
getImageCount swapchain
swapchain
, msaaSamples :: SampleCountFlagBits
msaaSamples = forall a. HasSwapchain a => a -> SampleCountFlagBits
getMultisample swapchain
swapchain
, subpass :: Word32
subpass = Word32
subpassIx
, pipelineCache :: PipelineCache
pipelineCache = forall a. IsHandle a => a
Vk.NULL_HANDLE
, descriptorPool :: DescriptorPool
descriptorPool = DescriptorPool
pool
, mbAllocator :: Maybe AllocationCallbacks
mbAllocator = forall a. Maybe a
Nothing
, checkResult :: Result -> IO ()
checkResult = \case { Result
Vk.SUCCESS -> forall (f :: * -> *) a. Applicative f => a -> f a
pure (); Result
e -> forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwM forall a b. (a -> b) -> a -> b
$ Result -> VulkanException
VulkanException Result
e }
}
res :: (FunPtr (Result -> IO ()), Bool)
res@(FunPtr (Result -> IO ())
_cb, Bool
initOk) <- forall (m :: * -> *).
MonadIO m =>
InitInfo -> RenderPass -> m (FunPtr (Result -> IO ()), Bool)
ImGui.vulkanInit InitInfo
initInfo (forall a. HasRenderPass a => a -> RenderPass
getRenderPass renderpass
renderpass)
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless Bool
initOk do
forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logError Utf8Builder
"DearImGui vulkan initialization failed"
forall (m :: * -> *) a. MonadIO m => m a
exitFailure
ReleaseKey
key <- forall (m :: * -> *). MonadResource m => IO () -> m ReleaseKey
register forall a b. (a -> b) -> a -> b
$ 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) <- forall context (m :: * -> *).
(HasVulkan context, MonadResource m) =>
context -> m (ReleaseKey, Queues CommandPool)
CommandBuffer.allocatePools GlobalHandles
context
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 <- forall (m :: * -> *). MonadIO m => CommandBuffer -> m Bool
ImGui.vulkanCreateFontsTexture CommandBuffer
cb
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless Bool
fontsOk do
forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logError Utf8Builder
"ImGui.vulkanCreateFontsTexture failed"
forall (m :: * -> *) a. MonadIO m => m a
exitFailure
forall (m :: * -> *). MonadIO m => ReleaseKey -> m ()
release ReleaseKey
oneshotPoolKey
forall (m :: * -> *). MonadIO m => m ()
ImGui.vulkanDestroyFontUploadObjects
IO ()
debugReleaseStart <- forall (m :: * -> *) a. MonadUnliftIO m => m a -> m (IO a)
toIO (forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logDebug Utf8Builder
"Releasing DearImGui")
forall (f :: * -> *) a. Functor f => f a -> f ()
void forall a b. (a -> b) -> a -> b
$! forall (m :: * -> *). MonadResource m => IO () -> m ReleaseKey
register IO ()
debugReleaseStart
pure (ReleaseKey
key, a
actionRes)
dsSizes :: [(Vk.DescriptorType, Word32)]
dsSizes :: [(DescriptorType, Word32)]
dsSizes = 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
]
allocateLoop :: Bool -> ResourceT (StageRIO st) ()
allocateLoop :: forall st. Bool -> ResourceT (StageRIO st) ()
allocateLoop Bool
installCallbacks = do
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ forall st. Bool -> StageRIO st ()
beforeLoop Bool
installCallbacks
IO ()
shutdownImGui <- forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a. MonadUnliftIO m => m a -> m (IO a)
toIO forall st. StageRIO st ()
afterLoop
forall (f :: * -> *) a. Functor f => f a -> f ()
void forall a b. (a -> b) -> a -> b
$! forall (m :: * -> *). MonadResource m => IO () -> m ReleaseKey
register IO ()
shutdownImGui
beforeLoop :: Bool -> StageRIO st ()
beforeLoop :: forall st. Bool -> StageRIO st ()
beforeLoop Bool
installCallbacks = do
forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logDebug Utf8Builder
"glfwInitForVulkan"
Window
window <- forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks forall a b. (a -> b) -> a -> b
$ GlobalHandles -> Window
ghWindow forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall env st. App env st -> env
appEnv
Bool
success <- forall (m :: * -> *). MonadIO m => Window -> Bool -> m Bool
glfwInitForVulkan Window
window Bool
installCallbacks
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless Bool
success do
forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logWarn Utf8Builder
"glfwInitForVulkan failed"
afterLoop :: StageRIO st ()
afterLoop :: forall st. StageRIO st ()
afterLoop = do
forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logDebug Utf8Builder
"glfwShutdown"
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks forall a. HasVulkan a => a -> Device
getDevice forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall (io :: * -> *). MonadIO io => Device -> io ()
Vk.deviceWaitIdle
forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logDebug Utf8Builder
"glfwShutdown: Device idle"
forall (m :: * -> *). MonadIO m => m ()
glfwShutdown
forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logDebug Utf8Builder
"glfwShutdown finished"
mkDrawData :: MonadIO m => m a -> m (a, ImGui.DrawData)
mkDrawData :: forall (m :: * -> *) a. MonadIO m => m a -> m (a, DrawData)
mkDrawData m a
action = do
forall (m :: * -> *). MonadIO m => m ()
ImGui.vulkanNewFrame
forall (m :: * -> *). MonadIO m => m ()
glfwNewFrame
forall (m :: * -> *). MonadIO m => m ()
ImGui.newFrame
a
result <- m a
action
forall (m :: * -> *). MonadIO m => m ()
ImGui.render
DrawData
drawData <- forall (m :: * -> *). MonadIO m => m DrawData
ImGui.getDrawData
pure (a
result, DrawData
drawData)
draw :: MonadIO m => ImGui.DrawData -> Vk.CommandBuffer -> m ()
draw :: forall (m :: * -> *).
MonadIO m =>
DrawData -> CommandBuffer -> m ()
draw DrawData
drawData CommandBuffer
commandBuffer = do
forall (m :: * -> *).
MonadIO m =>
DrawData -> CommandBuffer -> Maybe Pipeline -> m ()
ImGui.vulkanRenderDrawData DrawData
drawData CommandBuffer
commandBuffer forall a. Maybe a
Nothing
capturingKeyboard :: MonadIO m => m () -> m ()
capturingKeyboard :: forall (m :: * -> *). MonadIO m => m () -> m ()
capturingKeyboard m ()
action =
forall (m :: * -> *). MonadIO m => m Bool
ImGui.wantCaptureKeyboard forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
`unless` m ()
action)
capturingMouse :: MonadIO m => m () -> m ()
capturingMouse :: forall (m :: * -> *). MonadIO m => m () -> m ()
capturingMouse m ()
action =
forall (m :: * -> *). MonadIO m => m Bool
ImGui.wantCaptureMouse forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
`unless` m ()
action)
renderWith
:: HasRenderPass renderpass
=> (t -> renderpass)
-> "subpass index" ::: Word32
-> Stage.Rendering t p st
-> Stage.Rendering t p st
renderWith :: forall renderpass t p st.
HasRenderPass renderpass =>
(t -> renderpass) -> Word32 -> Rendering t p st -> Rendering t p st
renderWith t -> renderpass
getRP Word32
subpassIx Stage.Rendering{SwapchainResources -> ResourceT (StageRIO st) t
SwapchainResources -> t -> ResourceT (StageRIO st) p
$sel:rAllocateRP:Rendering :: forall rp p st.
Rendering rp p st
-> SwapchainResources -> ResourceT (StageRIO st) rp
$sel:rAllocateP:Rendering :: forall rp p st.
Rendering rp p st
-> SwapchainResources -> rp -> ResourceT (StageRIO st) p
rAllocateP :: SwapchainResources -> t -> ResourceT (StageRIO st) p
rAllocateRP :: SwapchainResources -> ResourceT (StageRIO st) t
..} = Stage.Rendering
{ SwapchainResources -> ResourceT (StageRIO st) t
$sel:rAllocateRP:Rendering :: SwapchainResources -> ResourceT (StageRIO st) t
rAllocateRP :: SwapchainResources -> ResourceT (StageRIO st) t
rAllocateRP
, $sel:rAllocateP:Rendering :: SwapchainResources -> t -> ResourceT (StageRIO st) p
rAllocateP = \SwapchainResources
swapchain t
rps -> do
forall (f :: * -> *) a. Functor f => f a -> f ()
void forall a b. (a -> b) -> a -> b
$! forall swapchain renderpass st.
(HasSwapchain swapchain, HasRenderPass renderpass) =>
swapchain
-> renderpass -> Word32 -> ResourceT (StageRIO st) ReleaseKey
allocate SwapchainResources
swapchain (t -> renderpass
getRP t
rps) Word32
subpassIx
SwapchainResources -> t -> ResourceT (StageRIO st) p
rAllocateP SwapchainResources
swapchain t
rps
}