keid-ui-dearimgui 0.1.3.2 → 0.1.5.0
raw patch · 4 files changed
+244/−23 lines, 4 filesdep +keid-frp-bananadep +reactive-bananadep ~dear-imguidep ~rio
Dependencies added: keid-frp-banana, reactive-banana
Dependency ranges changed: dear-imgui, rio
Files
- ChangeLog.md +10/−0
- keid-ui-dearimgui.cabal +9/−6
- src/Render/ImGui.hs +39/−17
- src/Render/ImGui/Widget.hs +186/−0
ChangeLog.md view
@@ -1,5 +1,15 @@ # Changelog for keid-dearimgui +## 0.1.5.0++- Bump upstream to `dear-imgui-2.5.0'.+ * Breaking change around DrawList API.++## 0.1.4.0++- Add `Render.ImGui.Widget`, building composable widgets on top of keid-frp-banana.+ * Mini-breaking by bringing in a whole new dependency set, but not much.+ ## 0.1.3.2 - Add `Render.ImGui.askWindowBox`, a helper to get a `Box` using dear-imgui coordinates.
keid-ui-dearimgui.cabal view
@@ -1,16 +1,16 @@ cabal-version: 1.12 --- This file has been generated from package.yaml by hpack version 0.38.0.+-- This file has been generated from package.yaml by hpack version 0.39.6. -- -- see: https://github.com/sol/hpack name: keid-ui-dearimgui-version: 0.1.3.2+version: 0.1.5.0 synopsis: DearImGui elements for Keid engine. category: Game Engine author: IC Rainbow-maintainer: keid@aenor.ru-copyright: 2024 IC Rainbow+maintainer: keid@haskell-game.dev+copyright: 2026 IC Rainbow license: BSD3 license-file: LICENSE build-type: Simple@@ -25,6 +25,7 @@ library exposed-modules: Render.ImGui+ Render.ImGui.Widget Render.ImGui.Window other-modules: Paths_keid_ui_dearimgui@@ -63,12 +64,14 @@ , base >=4.7 && <5 , binary , bytestring- , dear-imgui >=2.3.0 && <2.4+ , dear-imgui >=2.5.0 && <3 , geomancy , geomancy-layout , keid-core >=0.1.8.0+ , keid-frp-banana+ , reactive-banana , resourcet- , rio >=0.1.12.0+ , rio >=0.1.24.0 , rio-app , unliftio , vector
src/Render/ImGui.hs view
@@ -23,8 +23,9 @@ import RIO -import Control.Monad.Trans.Resource (ReleaseKey, ResourceT, register)-import Data.Type.Equality (type (~))+import Control.Monad.Trans.Resource (ReleaseKey, ResourceT, MonadResource)+import Control.Monad.Trans.Resource qualified as Resource+import Data.Vector qualified as Vector import DearImGui qualified as ImGui import DearImGui.FontAtlas qualified as FontAtlas import DearImGui.GLFW (glfwNewFrame, glfwShutdown)@@ -34,17 +35,18 @@ import Engine.Setup.Window qualified as Window import Engine.Stage.Component qualified as Stage import Engine.Types (GlobalHandles(..), StageFrameRIO, StageRIO, askWindowSize)-import Engine.Vulkan.Types (HasRenderPass(..), HasSwapchain(..), Queues(..), getDevice, getMultisample)+import Engine.Vulkan.Types (HasRenderPass(..), HasSwapchain(..), Queues(..), getDevice, getMultisample, MonadVulkan) import Engine.Worker qualified as Worker import Geomancy.Layout.Box as Box import Geomancy.Layout.View as View import RIO.App (appEnv) import Resource.Region qualified as Region-import Resource.Vulkan.DescriptorPool qualified as DescriptorPool+import Resource.Vulkan.Named qualified as Named import Vulkan.Core10 qualified as Vk import Vulkan.Exception (VulkanException(..)) import Vulkan.NamedType (type (:::)) import Vulkan.Utils.QueueAssignment (QueueFamilyIndex(..))+import Vulkan.Zero (zero) allocate :: ( HasSwapchain swapchain@@ -72,7 +74,7 @@ allocateWithFonts swapchain renderpass subpassIx fonts = allocateWith swapchain renderpass subpassIx do loaded <- FontAtlas.rebuild fonts- _atlasKey <- register FontAtlas.clear+ _atlasKey <- Resource.register FontAtlas.clear pure loaded allocateWith@@ -87,7 +89,7 @@ allocateWith swapchain renderpass subpassIx action = do logDebug "Initializing DearImGui" debugReleaseFinished <- toIO (logDebug "Released DearImGui")- void $! register debugReleaseFinished+ void $! Resource.register debugReleaseFinished ctx <- ImGui.createContext Region.register_ $ ImGui.destroyContext ctx@@ -96,8 +98,7 @@ let (QueueFamilyIndex queueFamily, queue) = qGraphics ghQueues - pool <- Region.local $- DescriptorPool.allocate (Just "ImGui") 1 dsSizes+ pool <- Region.local allocateDescPool let initInfo = InitInfo@@ -124,22 +125,43 @@ unless initOk do logError "DearImGui vulkan initialization failed" exitFailure- key <- register $ ImGui.vulkanShutdown res+ key <- Resource.register $ ImGui.vulkanShutdown res actionRes <- action - fontsOk <- ImGui.vulkanCreateFontsTexture- unless fontsOk do- logError "ImGui.vulkanCreateFontsTexture failed"- exitFailure- debugReleaseStart <- toIO (logDebug "Releasing DearImGui")- void $! register debugReleaseStart+ void $! Resource.register debugReleaseStart pure (key, actionRes) +allocateDescPool+ :: ( MonadVulkan env m+ , MonadResource m+ )+ => m (ReleaseKey, Vk.DescriptorPool)+allocateDescPool = do+ device <- asks getDevice+ res <- Vk.withDescriptorPool+ device+ poolCI+ Nothing+ Resource.allocate++ Named.object (snd res) "ImGui"+ pure res+ where+ poolCI = zero+ { Vk.flags =+ Vk.DESCRIPTOR_POOL_CREATE_FREE_DESCRIPTOR_SET_BIT+ , Vk.maxSets =+ 8+ , Vk.poolSizes =+ Vector.fromList $+ map (uncurry Vk.DescriptorPoolSize) dsSizes+ }+ dsSizes :: [(Vk.DescriptorType, Word32)]-dsSizes = map (, 100)+dsSizes = map (, 128) [ Vk.DESCRIPTOR_TYPE_SAMPLER , Vk.DESCRIPTOR_TYPE_COMBINED_IMAGE_SAMPLER , Vk.DESCRIPTOR_TYPE_SAMPLED_IMAGE@@ -157,7 +179,7 @@ allocateLoop installCallbacks = do lift $ beforeLoop installCallbacks shutdownImGui <- lift $ toIO afterLoop- void $! register shutdownImGui+ void $! Resource.register shutdownImGui {- | Initialize context to serve the draws in the current render loop.
+ src/Render/ImGui/Widget.hs view
@@ -0,0 +1,186 @@+module Render.ImGui.Widget+ ( separator+ , sliderFloat+ , sliderFloat2+ , sliderAngle+ , sliderUVec2+ , button+ , text+ , render_+ ) where++import RIO++-- import Engine.Types (HKD)+-- import Data.These (These(..))+-- import Data.These.Combinators (justHere, justThere)+import DearImGui.Internal.Text (withCString)+import DearImGui.Raw qualified+import Engine.ReactiveBanana.Widget (Widget(..), Widget', draw_)+import Foreign (withForeignPtr, mallocForeignPtr)+import Foreign qualified+import Foreign.C.Types (CFloat(..))+import Geomancy (Vec2, UVec2)+import Reactive.Banana qualified as RB+import Reactive.Banana.Frameworks qualified as RBF+import DearImGui qualified++separator :: Widget Void ()+separator = draw_ DearImGui.Raw.separator++sliderFloat+ :: MonadIO m+ => Text+ -> Float+ -> (Float, Float) -- TODO: use Behavior somehow+ -> m (Widget' Float)+sliderFloat label initial (start, end) = liftIO do+ (ah, fire) <- RBF.newAddHandler++ ref <- mallocForeignPtr+ withForeignPtr ref \ptr ->+ Foreign.poke ptr (CFloat initial)++ pure Widget+ { plug = do+ event <- RBF.fromAddHandler ah+ beh <- RB.stepper initial event+ pure (event, beh)+ , draw =+ withCString label \labelPtr -> -- FIXME: make this static+ withForeignPtr ref \refPtr -> do+ changed <- DearImGui.Raw.sliderFloat+ labelPtr+ refPtr+ (CFloat start)+ (CFloat end)+ Foreign.nullPtr+ when changed do+ CFloat current <- Foreign.peek refPtr+ fire current+ }++sliderFloat2+ :: MonadIO m+ => Text+ -> Vec2+ -> (Float, Float)+ -> m (Widget' Vec2)+sliderFloat2 label initial (start, end) = liftIO do+ (ah, fire) <- RBF.newAddHandler++ ref <- mallocForeignPtr+ withForeignPtr ref \ptr ->+ Foreign.poke ptr initial++ pure Widget+ { plug = do+ event <- RBF.fromAddHandler ah+ beh <- RB.stepper initial event+ pure (event, beh)+ , draw =+ withCString label \labelPtr -> -- FIXME: make this static+ withForeignPtr ref \refPtr -> do+ changed <- DearImGui.Raw.sliderFloat2+ labelPtr+ (Foreign.castPtr refPtr)+ (CFloat start)+ (CFloat end)+ Foreign.nullPtr+ when changed do+ current <- Foreign.peek refPtr+ fire current+ }++sliderAngle+ :: MonadIO m+ => Text+ -> Float+ -> (Float, Float)+ -> m (Widget' Float)+sliderAngle label initial (start, end) = liftIO do+ (ah, fire) <- RBF.newAddHandler++ ref <- mallocForeignPtr+ withForeignPtr ref \ptr ->+ Foreign.poke ptr (CFloat initial)++ pure Widget+ { plug = do+ event <- RBF.fromAddHandler ah+ beh <- RB.stepper initial event+ pure (event, beh)+ , draw =+ withCString label \labelPtr -> -- FIXME: make this static+ withForeignPtr ref \refPtr -> do+ changed <- DearImGui.Raw.sliderAngle+ labelPtr+ refPtr+ (CFloat start)+ (CFloat end)+ Foreign.nullPtr+ DearImGui.Raw.ImGuiSliderFlags_None+ when changed do+ CFloat current <- Foreign.peek refPtr+ fire current+ }++sliderUVec2+ :: MonadIO m+ => Text+ -> UVec2+ -> (Word32, Word32)+ -> m (Widget' UVec2)+sliderUVec2 label initial (start, end) = liftIO do+ (ah, fire) <- RBF.newAddHandler++ ref <- mallocForeignPtr+ withForeignPtr ref \ptr ->+ Foreign.poke ptr initial++ pure Widget+ { plug = do+ event <- RBF.fromAddHandler ah+ beh <- RB.stepper initial event+ pure (event, beh)+ , draw =+ withCString label \labelPtr -> -- FIXME: make this static+ withForeignPtr ref \refPtr -> do+ changed <- DearImGui.Raw.sliderInt2+ labelPtr+ (Foreign.castPtr refPtr)+ (fromIntegral start)+ (fromIntegral end)+ Foreign.nullPtr+ DearImGui.Raw.ImGuiSliderFlags_None+ when changed do+ current <- Foreign.peek refPtr+ fire current+ }++button+ :: MonadIO m+ => Text+ -> m (Widget' ())+button label = liftIO do+ (ah, fire) <- RBF.newAddHandler+ pure Widget+ { plug = do+ event <- RBF.fromAddHandler ah+ pure (event, pure ())+ , draw =+ withCString label \labelPtr -> do+ clicked <- DearImGui.Raw.button labelPtr+ when clicked do+ fire ()+ }++text :: RB.Event Text -> RBF.MomentIO (Widget Void ())+text bodyE = render_ bodyE DearImGui.text++-- | Lift rendering fuction into 'Event' handler and wrap in a 'Widget'.+render_ :: RB.Event a -> (a -> IO ()) -> RBF.MomentIO (Widget Void ())+render_ srcE f = do+ drawer <- newIORef $ pure ()+ RBF.reactimate $ srcE <&> writeIORef drawer . f+ pure $ draw_ (join $ readIORef drawer)