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

  -- TODO: oneshots
  (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

{- | Initialize context to serve the draws in the current render loop.

You will need to trigger callbacks from DearImGui.GLFW if you're opting out of them here.

DearImgui will run your previously installed GLFW callbacks.
-}
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
  }