12 Commits

19 changed files with 785 additions and 73 deletions

3
.gitmodules vendored
View File

@ -1,3 +1,6 @@
[submodule "imgui"] [submodule "imgui"]
path = imgui path = imgui
url = https://github.com/ocornut/imgui url = https://github.com/ocornut/imgui
[submodule "implot"]
path = implot
url = https://github.com/epezent/implot.git

View File

@ -1,5 +1,17 @@
# Changelog for dear-imgui # Changelog for dear-imgui
## [1.4.0]
- `imgui` updated to [1.87].
- Added `DearImGui.Vulkan.vulkanAddTexture`.
- Added `DearImGui.GLFW.glfwCursorPosCallback`.
* Apps that don't install backend callbacks, *must* call it themselves.
- Added flags `use-wchar32` (default on) and `disable-obsolete` (default off).
## [1.3.1]
- `imgui` updated to [1.86].
## [1.3.0] ## [1.3.0]
- Added `DearImGui.FontAtlas` and related `DearImGui.Raw.Font.*` bits. - Added `DearImGui.FontAtlas` and related `DearImGui.Raw.Font.*` bits.
@ -7,7 +19,7 @@
## [1.2.2] ## [1.2.2]
- `imgui` updated to 1.85. - `imgui` updated to [1.85].
## [1.2.1] ## [1.2.1]
@ -29,7 +41,7 @@
## [1.1.0] ## [1.1.0]
- `imgui` updated to 1.84.2. - `imgui` updated to [1.84.2].
- Removed unused Window argument from SDL `newFrame` to match 1.84. - Removed unused Window argument from SDL `newFrame` to match 1.84.
- Added GLFW backend callbacks. - Added GLFW backend callbacks.
- Added more withXXX wrappers. - Added more withXXX wrappers.
@ -44,7 +56,7 @@
## [1.0.0] ## [1.0.0]
Initial Hackage release based on 1.83. Initial Hackage release based on [1.83].
[1.0.0]: https://github.com/haskell-game/dear-imgui.hs/tree/v1.0.0 [1.0.0]: https://github.com/haskell-game/dear-imgui.hs/tree/v1.0.0
[1.0.1]: https://github.com/haskell-game/dear-imgui.hs/tree/v1.0.1 [1.0.1]: https://github.com/haskell-game/dear-imgui.hs/tree/v1.0.1
@ -54,3 +66,11 @@ Initial Hackage release based on 1.83.
[1.2.1]: https://github.com/haskell-game/dear-imgui.hs/tree/v1.2.1 [1.2.1]: https://github.com/haskell-game/dear-imgui.hs/tree/v1.2.1
[1.2.2]: https://github.com/haskell-game/dear-imgui.hs/tree/v1.2.2 [1.2.2]: https://github.com/haskell-game/dear-imgui.hs/tree/v1.2.2
[1.3.0]: https://github.com/haskell-game/dear-imgui.hs/tree/v1.3.0 [1.3.0]: https://github.com/haskell-game/dear-imgui.hs/tree/v1.3.0
[1.3.1]: https://github.com/haskell-game/dear-imgui.hs/tree/v1.3.1
[1.4.0]: https://github.com/haskell-game/dear-imgui.hs/tree/v1.4.0
[1.87]: https://github.com/ocornut/imgui/releases/tag/v1.87
[1.86]: https://github.com/ocornut/imgui/releases/tag/v1.86
[1.85]: https://github.com/ocornut/imgui/releases/tag/v1.85
[1.84.2]: https://github.com/ocornut/imgui/releases/tag/v1.84.2
[1.83]: https://github.com/ocornut/imgui/releases/tag/v1.83

View File

@ -1,7 +1,7 @@
cabal-version: 3.0 cabal-version: 3.0
name: dear-imgui name: dear-imgui
version: 1.3.0 version: 1.4.0
author: Oliver Charles author: Oliver Charles
maintainer: ollie@ocharles.org.uk, aenor.realm@gmail.com maintainer: ollie@ocharles.org.uk, aenor.realm@gmail.com
license: BSD-3-Clause license: BSD-3-Clause
@ -22,9 +22,11 @@ extra-source-files:
imgui/backends/*.h, imgui/backends/*.h,
imgui/backends/*.mm, imgui/backends/*.mm,
imgui/imconfig.h, imgui/imconfig.h,
imgui/LICENSE.txt imgui/LICENSE.txt,
implot/*.h,
implot/LICENSE
common build-flags common exe-flags
if flag(debug) if flag(debug)
if os(linux) if os(linux)
ghc-options: -Wall -g -rtsopts -dcore-lint -debug ghc-options: -Wall -g -rtsopts -dcore-lint -debug
@ -50,7 +52,6 @@ common build-flags
ghc-options: -Wall -O2 ghc-options: -Wall -O2
cc-options: -O2 cc-options: -O2
source-repository head source-repository head
type: git type: git
location: https://github.com/haskell-game/dear-imgui.hs location: https://github.com/haskell-game/dear-imgui.hs
@ -111,6 +112,22 @@ flag examples
manual: manual:
True True
flag disable-obsolete
description:
Don't define obsolete functions/enums/behaviors. Consider enabling from time to time after updating to avoid using soon-to-be obsolete function/names.
default:
False
manual:
True
flag use-wchar32
description:
Use 32-bit for ImWchar (default is 16-bit) to support unicode planes 1-16. (e.g. point beyond 0xFFFF like emoticons, dingbats, symbols, shapes, ancient languages, etc...)
default:
True
manual:
True
common common common common
build-depends: build-depends:
base base
@ -125,6 +142,7 @@ library
exposed-modules: exposed-modules:
DearImGui DearImGui
DearImGui.FontAtlas DearImGui.FontAtlas
DearImGui.Plot
DearImGui.Raw DearImGui.Raw
DearImGui.Raw.DrawList DearImGui.Raw.DrawList
DearImGui.Raw.Font DearImGui.Raw.Font
@ -132,6 +150,7 @@ library
DearImGui.Raw.Font.GlyphRanges DearImGui.Raw.Font.GlyphRanges
DearImGui.Raw.ListClipper DearImGui.Raw.ListClipper
DearImGui.Raw.IO DearImGui.Raw.IO
DearImGui.Raw.Plot
other-modules: other-modules:
DearImGui.Context DearImGui.Context
DearImGui.Enums DearImGui.Enums
@ -143,10 +162,14 @@ library
imgui/imgui_draw.cpp imgui/imgui_draw.cpp
imgui/imgui_tables.cpp imgui/imgui_tables.cpp
imgui/imgui_widgets.cpp imgui/imgui_widgets.cpp
implot/implot.cpp
implot/implot_demo.cpp
implot/implot_items.cpp
extra-libraries: extra-libraries:
stdc++ stdc++
include-dirs: include-dirs:
imgui imgui
implot
build-depends: build-depends:
dear-imgui-generator dear-imgui-generator
, containers , containers
@ -157,6 +180,13 @@ library
, unliftio , unliftio
, vector , vector
if flag(disable-obsolete)
cxx-options: -DIMGUI_DISABLE_OBSOLETE_FUNCTIONS
if flag(use-wchar32)
cxx-options: -DIMGUI_USE_WCHAR32
cpp-options: -DIMGUI_USE_WCHAR32
if flag(opengl2) if flag(opengl2)
exposed-modules: exposed-modules:
DearImGui.OpenGL2 DearImGui.OpenGL2
@ -273,7 +303,7 @@ library dear-imgui-generator
>= 0.2.11 && < 0.3 >= 0.2.11 && < 0.3
executable test executable test
import: common, build-flags import: common, exe-flags
main-is: Main.hs main-is: Main.hs
default-language: Haskell2010 default-language: Haskell2010
if (!flag(examples) || !flag(sdl) || !flag(opengl2)) if (!flag(examples) || !flag(sdl) || !flag(opengl2))
@ -282,7 +312,7 @@ executable test
build-depends: base, sdl2, gl, dear-imgui, vector build-depends: base, sdl2, gl, dear-imgui, vector
executable glfw executable glfw
import: common, build-flags import: common, exe-flags
main-is: Main.hs main-is: Main.hs
hs-source-dirs: examples/glfw hs-source-dirs: examples/glfw
default-language: Haskell2010 default-language: Haskell2010
@ -292,7 +322,7 @@ executable glfw
build-depends: base, GLFW-b, gl, dear-imgui, managed build-depends: base, GLFW-b, gl, dear-imgui, managed
executable readme executable readme
import: common, build-flags import: common, exe-flags
main-is: Readme.hs main-is: Readme.hs
hs-source-dirs: examples hs-source-dirs: examples
build-depends: sdl2, gl, dear-imgui, managed build-depends: sdl2, gl, dear-imgui, managed
@ -300,7 +330,7 @@ executable readme
buildable: False buildable: False
executable fonts executable fonts
import: common, build-flags import: common, exe-flags
main-is: Main.hs main-is: Main.hs
hs-source-dirs: examples/fonts hs-source-dirs: examples/fonts
build-depends: sdl2, gl, dear-imgui, managed build-depends: sdl2, gl, dear-imgui, managed
@ -308,7 +338,7 @@ executable fonts
buildable: False buildable: False
executable image executable image
import: common, build-flags import: common, exe-flags
main-is: Image.hs main-is: Image.hs
hs-source-dirs: examples/sdl hs-source-dirs: examples/sdl
build-depends: sdl2, gl, dear-imgui, managed, vector build-depends: sdl2, gl, dear-imgui, managed, vector
@ -316,7 +346,7 @@ executable image
buildable: False buildable: False
executable vulkan executable vulkan
import: common, build-flags import: common, exe-flags
main-is: Main.hs main-is: Main.hs
other-modules: Attachments, Backend, Input, Util other-modules: Attachments, Backend, Input, Util
hs-source-dirs: examples/vulkan hs-source-dirs: examples/vulkan
@ -350,3 +380,5 @@ executable vulkan
^>= 3.9 ^>= 3.9
, vulkan-utils , vulkan-utils
^>= 0.4.1 ^>= 0.4.1
, VulkanMemoryAllocator
, JuicyPixels

View File

@ -64,9 +64,14 @@ mainLoop win = do
text "Hello, ImGui!" text "Hello, ImGui!"
-- Add a button widget, and call 'putStrLn' when it's clicked -- Add a button widget, and call 'putStrLn' when it's clicked
button "Clickety Click" >>= \case clicking <- button "Clickety Click"
False -> return () when clicking $
True -> putStrLn "Ow!" putStrLn "Ow!"
itemContextPopup do
text "pop!"
button "ok" >>= \clicked ->
when clicked $
closeCurrentPopup
-- Show the ImGui demo window -- Show the ImGui demo window
showDemoWindow showDemoWindow

View File

@ -24,7 +24,9 @@ import Control.Arrow
import Control.Exception import Control.Exception
( throw ) ( throw )
import Control.Monad import Control.Monad
( unless, void ) ( unless, void, when )
import Data.Bits
( (.|.) )
import Data.Foldable import Data.Foldable
( traverse_ ) ( traverse_ )
import Data.String import Data.String
@ -62,11 +64,13 @@ import qualified Data.Vector as Boxed
( Vector ) ( Vector )
import qualified Data.Vector as Boxed.Vector import qualified Data.Vector as Boxed.Vector
( (!), head, singleton, unzip ) ( (!), head, singleton, unzip )
import qualified Data.Vector.Storable as Storable.Vector
-- vulkan -- vulkan
import qualified Vulkan import qualified Vulkan
import qualified Vulkan.Exception as Vulkan import qualified Vulkan.Exception as Vulkan
import qualified Vulkan.Zero as Vulkan import qualified Vulkan.Zero as Vulkan
import qualified VulkanMemoryAllocator as VMA
-- dear-imgui -- dear-imgui
import Attachments import Attachments
@ -76,6 +80,13 @@ import qualified DearImGui as ImGui
import qualified DearImGui.Vulkan as ImGui.Vulkan import qualified DearImGui.Vulkan as ImGui.Vulkan
import qualified DearImGui.SDL as ImGui.SDL import qualified DearImGui.SDL as ImGui.SDL
import qualified DearImGui.SDL.Vulkan as ImGui.SDL.Vulkan import qualified DearImGui.SDL.Vulkan as ImGui.SDL.Vulkan
import Util (vmaVulkanFunctions)
import Foreign (Ptr, castPtr, copyBytes, with, withForeignPtr, wordPtrToPtr)
import qualified DearImGui.Raw as ImGui.Raw
import UnliftIO (MonadUnliftIO)
import qualified Vulkan.CStruct.Extends as Vulkan
import qualified Codec.Picture as Picture
-------------------------------------------------------------------------------- --------------------------------------------------------------------------------
@ -83,8 +94,8 @@ type Handler = LogMessage -> ResourceT IO ()
deriving via ( ReaderT Handler (ResourceT IO) ) deriving via ( ReaderT Handler (ResourceT IO) )
instance MonadResource ( LoggingT LogMessage (ResourceT IO) ) instance MonadResource ( LoggingT LogMessage (ResourceT IO) )
gui :: MonadIO m => m ImGui.DrawData gui :: MonadUnliftIO m => (ImGui.Raw.ImVec2, Ptr ()) -> m ImGui.DrawData
gui = do gui texture = do
-- Prepare frame -- Prepare frame
ImGui.Vulkan.vulkanNewFrame ImGui.Vulkan.vulkanNewFrame
ImGui.SDL.sdl2NewFrame ImGui.SDL.sdl2NewFrame
@ -92,6 +103,25 @@ gui = do
-- Run your windows -- Run your windows
ImGui.showDemoWindow ImGui.showDemoWindow
ImGui.withWindowOpen "Vulkan demo" do
clicked <- liftIO do
with (fst texture) \sizePtr ->
with (ImGui.Raw.ImVec2 0 0) \uv0Ptr ->
with (ImGui.Raw.ImVec2 1 1) \uv1Ptr ->
with (ImGui.Raw.ImVec4 1 1 1 1) \tintColPtr ->
with (ImGui.Raw.ImVec4 1 1 1 1) \bgColPtr ->
ImGui.Raw.imageButton
(snd texture)
sizePtr
uv0Ptr
uv1Ptr
(-1)
bgColPtr
tintColPtr
when clicked $
ImGui.text "clicky click!"
-- Process ImGui state into draw commands -- Process ImGui state into draw commands
ImGui.render ImGui.render
@ -275,6 +305,80 @@ app = do
logDebug "Allocating command buffers" logDebug "Allocating command buffers"
commandBuffers <- snd <$> allocatePrimaryCommandBuffers device commandPool imageCount commandBuffers <- snd <$> allocatePrimaryCommandBuffers device commandPool imageCount
logDebug "Allocating VMA"
(_key, vma) <- VMA.withAllocator
Vulkan.zero
{ VMA.instance' = Vulkan.instanceHandle instance'
, VMA.device = Vulkan.deviceHandle device
, VMA.physicalDevice = Vulkan.physicalDeviceHandle physicalDevice
, VMA.vulkanFunctions = Just $ vmaVulkanFunctions device instance'
}
ResourceT.allocate
logDebug "Loading image data"
picture <- liftIO (Picture.readImage "Example.png") >>= either error (pure . Picture.convertRGBA8)
logDebug "Allocating image"
let textureWidth = Picture.imageWidth picture
let textureHeight = Picture.imageHeight picture
(_key, (image, _imageAllocation, _imageAllocationInfo)) <- VMA.withImage
vma
( Vulkan.zero
{ Vulkan.imageType = Vulkan.IMAGE_TYPE_2D
, Vulkan.mipLevels = 1
, Vulkan.arrayLayers = 1
, Vulkan.format = Vulkan.FORMAT_R8G8B8A8_SRGB
, Vulkan.extent = Vulkan.Extent3D (fromIntegral textureWidth) (fromIntegral textureHeight) 1
, Vulkan.tiling = Vulkan.IMAGE_TILING_OPTIMAL
, Vulkan.initialLayout = Vulkan.IMAGE_LAYOUT_UNDEFINED
, Vulkan.usage = Vulkan.IMAGE_USAGE_SAMPLED_BIT .|. Vulkan.IMAGE_USAGE_TRANSFER_DST_BIT
, Vulkan.sharingMode = Vulkan.SHARING_MODE_EXCLUSIVE
, Vulkan.samples = Vulkan.SAMPLE_COUNT_1_BIT
}
)
( Vulkan.zero
{ VMA.flags = Vulkan.zero
, VMA.usage = VMA.MEMORY_USAGE_GPU_ONLY
, VMA.requiredFlags = Vulkan.MEMORY_PROPERTY_DEVICE_LOCAL_BIT
}
)
ResourceT.allocate
let (pictureF, pictureSize) = Storable.Vector.unsafeToForeignPtr0 (Picture.imageData picture)
let stageBufferCI = Vulkan.zero
{ Vulkan.size = fromIntegral pictureSize
, Vulkan.usage = Vulkan.BUFFER_USAGE_TRANSFER_SRC_BIT
, Vulkan.sharingMode = Vulkan.SHARING_MODE_EXCLUSIVE
}
let stageAllocationCI = Vulkan.zero
{ VMA.flags = VMA.ALLOCATION_CREATE_MAPPED_BIT
, VMA.usage = VMA.MEMORY_USAGE_CPU_TO_GPU
, VMA.requiredFlags = Vulkan.MEMORY_PROPERTY_HOST_VISIBLE_BIT
}
(stageKey, (stage, stageAllocation, stageAllocationInfo)) <- VMA.withBuffer
vma
stageBufferCI
stageAllocationCI
ResourceT.allocate
liftIO $ withForeignPtr pictureF \srcPtr ->
copyBytes (VMA.mappedData stageAllocationInfo) (castPtr srcPtr) pictureSize
VMA.flushAllocation vma stageAllocation 0 Vulkan.WHOLE_SIZE
logDebug "Allocating sampler"
(_key, sampler) <- Vulkan.withSampler device Vulkan.zero Nothing ResourceT.allocate
logDebug "Allocating image view"
(_key, imageView) <- createImageView
device
image
Vulkan.IMAGE_VIEW_TYPE_2D
Vulkan.FORMAT_R8G8B8A8_SRGB
Vulkan.IMAGE_ASPECT_COLOR_BIT
------------------------------------------- -------------------------------------------
-- Initialise Dear ImGui. -- Initialise Dear ImGui.
@ -308,23 +412,96 @@ app = do
logDebug "Creating fence" logDebug "Creating fence"
( fenceKey, fence ) <- createFence device ( fenceKey, fence ) <- createFence device
logDebug "Allocating one-shot command buffer" logDebug "Allocating one-shot command buffer"
( fontUploadCommandBufferKey, fontUploadCommandBuffer ) <- ( oneshotCommandBufferKey, oneshotCommandBuffer ) <-
second Boxed.Vector.head <$> second Boxed.Vector.head <$>
allocatePrimaryCommandBuffers device commandPool 1 allocatePrimaryCommandBuffers device commandPool 1
logDebug "Recording one-shot commands" logDebug "Recording one-shot commands"
beginCommandBuffer fontUploadCommandBuffer beginCommandBuffer oneshotCommandBuffer
_ <- ImGui.Vulkan.vulkanCreateFontsTexture fontUploadCommandBuffer _ <- ImGui.Vulkan.vulkanCreateFontsTexture oneshotCommandBuffer
endCommandBuffer fontUploadCommandBuffer
logDebug "Uploading texture"
let textureSubresource = Vulkan.ImageSubresourceRange
{ Vulkan.aspectMask = Vulkan.IMAGE_ASPECT_COLOR_BIT
, Vulkan.baseMipLevel = 0
, Vulkan.levelCount = 1
, Vulkan.baseArrayLayer = 0
, Vulkan.layerCount = 1
}
let uploadBarrier = Vulkan.zero
{ Vulkan.srcAccessMask = Vulkan.zero
, Vulkan.dstAccessMask = Vulkan.ACCESS_TRANSFER_WRITE_BIT
, Vulkan.oldLayout = Vulkan.IMAGE_LAYOUT_UNDEFINED
, Vulkan.newLayout = Vulkan.IMAGE_LAYOUT_TRANSFER_DST_OPTIMAL
, Vulkan.srcQueueFamilyIndex = Vulkan.QUEUE_FAMILY_IGNORED
, Vulkan.dstQueueFamilyIndex = Vulkan.QUEUE_FAMILY_IGNORED
, Vulkan.image = image
, Vulkan.subresourceRange = textureSubresource
} :: Vulkan.ImageMemoryBarrier '[]
Vulkan.cmdPipelineBarrier
oneshotCommandBuffer
Vulkan.PIPELINE_STAGE_TOP_OF_PIPE_BIT
Vulkan.PIPELINE_STAGE_TRANSFER_BIT
Vulkan.zero
mempty
mempty
(Boxed.Vector.singleton $ Vulkan.SomeStruct uploadBarrier)
Vulkan.cmdCopyBufferToImage oneshotCommandBuffer stage image Vulkan.IMAGE_LAYOUT_TRANSFER_DST_OPTIMAL $
Boxed.Vector.singleton Vulkan.BufferImageCopy
{ Vulkan.bufferOffset = 0
, Vulkan.bufferRowLength = Vulkan.zero
, Vulkan.bufferImageHeight = Vulkan.zero
, Vulkan.imageSubresource = Vulkan.ImageSubresourceLayers
{ aspectMask = Vulkan.IMAGE_ASPECT_COLOR_BIT
, mipLevel = 0
, baseArrayLayer = 0
, layerCount = 1
}
, Vulkan.imageOffset = Vulkan.zero
, Vulkan.imageExtent = Vulkan.Extent3D
{ width = fromIntegral textureWidth
, height = fromIntegral textureHeight
, depth = 1
}
}
logDebug "Transitioning texture"
let transitionBarrier = Vulkan.zero
{ Vulkan.srcAccessMask = Vulkan.ACCESS_TRANSFER_WRITE_BIT
, Vulkan.dstAccessMask = Vulkan.ACCESS_SHADER_READ_BIT
, Vulkan.oldLayout = Vulkan.IMAGE_LAYOUT_TRANSFER_DST_OPTIMAL
, Vulkan.newLayout = Vulkan.IMAGE_LAYOUT_SHADER_READ_ONLY_OPTIMAL
, Vulkan.srcQueueFamilyIndex = Vulkan.QUEUE_FAMILY_IGNORED
, Vulkan.dstQueueFamilyIndex = Vulkan.QUEUE_FAMILY_IGNORED
, Vulkan.image = image
, Vulkan.subresourceRange = textureSubresource
} :: Vulkan.ImageMemoryBarrier '[]
Vulkan.cmdPipelineBarrier
oneshotCommandBuffer
Vulkan.PIPELINE_STAGE_TRANSFER_BIT
Vulkan.PIPELINE_STAGE_FRAGMENT_SHADER_BIT
Vulkan.zero
mempty
mempty
(Boxed.Vector.singleton $ Vulkan.SomeStruct transitionBarrier)
endCommandBuffer oneshotCommandBuffer
logDebug "Submitting one-shot commands" logDebug "Submitting one-shot commands"
submitCommandBuffer queue fontUploadCommandBuffer [] [] ( Just fence ) submitCommandBuffer queue oneshotCommandBuffer [] [] ( Just fence )
waitForFences device ( WaitAll [ fence ] ) waitForFences device ( WaitAll [ fence ] )
logDebug "Finished uploading font objects" logDebug "Finished uploading font objects"
logDebug "Cleaning up one-shot commands" logDebug "Cleaning up one-shot commands"
ImGui.Vulkan.vulkanDestroyFontUploadObjects ImGui.Vulkan.vulkanDestroyFontUploadObjects
traverse_ ResourceT.release [ fenceKey, fontUploadCommandBufferKey ] traverse_ ResourceT.release [ fenceKey, oneshotCommandBufferKey, stageKey ]
logDebug "Adding imgui texture"
Vulkan.DescriptorSet ds <- ImGui.Vulkan.vulkanAddTexture sampler imageView Vulkan.IMAGE_LAYOUT_SHADER_READ_ONLY_OPTIMAL
let textureSize = ImGui.Raw.ImVec2 (fromIntegral textureWidth) (fromIntegral textureHeight)
let texture = (textureSize, wordPtrToPtr $ fromIntegral ds)
let let
mainLoop :: AppState m -> m () mainLoop :: AppState m -> m ()
@ -364,7 +541,7 @@ app = do
beginCommandBuffer commandBuffer beginCommandBuffer commandBuffer
cmdBeginRenderPass commandBuffer imGuiRenderPass framebuffer clearValues swapchainExtent cmdBeginRenderPass commandBuffer imGuiRenderPass framebuffer clearValues swapchainExtent
drawData <- gui drawData <- gui texture
ImGui.Vulkan.vulkanRenderDrawData drawData commandBuffer Nothing ImGui.Vulkan.vulkanRenderDrawData drawData commandBuffer Nothing
cmdEndRenderPass commandBuffer cmdEndRenderPass commandBuffer

View File

@ -1,4 +1,7 @@
{-# LANGUAGE BlockArguments #-} {-# LANGUAGE BlockArguments #-}
{-# LANGUAGE CPP #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE ScopedTypeVariables #-}
module Util where module Util where
@ -12,6 +15,10 @@ import Data.Functor.Identity
( Identity(..) ) ( Identity(..) )
import Data.Traversable import Data.Traversable
( for ) ( for )
#if MIN_VERSION_VulkanMemoryAllocator(0,8,0)
import Foreign
( castFunPtr )
#endif
-- transformers -- transformers
import Control.Monad.Trans.State.Strict import Control.Monad.Trans.State.Strict
@ -19,6 +26,16 @@ import Control.Monad.Trans.State.Strict
import Control.Monad.Trans.Writer.Strict import Control.Monad.Trans.Writer.Strict
( runWriter, tell ) ( runWriter, tell )
-- vulkan
import qualified Vulkan
#if MIN_VERSION_VulkanMemoryAllocator(0,8,0)
import qualified Vulkan.Dynamic as VkDynamic
#endif
import Vulkan.Zero (zero)
-- VulkanMemoryAllocator
import qualified VulkanMemoryAllocator as VMA
--------------------------------------------------------------- ---------------------------------------------------------------
iunzipWith iunzipWith
@ -38,3 +55,19 @@ ifor i0 upd ta f = (`evalState` i0) . getCompose $ result
where where
result :: Compose (State i) f (t b) result :: Compose (State i) f (t b)
result = for ta \ a -> ( coerce ( \ i -> ( f i a, upd i ) ) ) result = for ta \ a -> ( coerce ( \ i -> ( f i a, upd i ) ) )
vmaVulkanFunctions
:: Vulkan.Device
-> Vulkan.Instance
-> VMA.VulkanFunctions
#if MIN_VERSION_VulkanMemoryAllocator(0,8,0)
vmaVulkanFunctions Vulkan.Device{deviceCmds} Vulkan.Instance{instanceCmds} =
zero
{ VMA.vkGetInstanceProcAddr =
castFunPtr $ VkDynamic.pVkGetInstanceProcAddr instanceCmds
, VMA.vkGetDeviceProcAddr =
castFunPtr $ VkDynamic.pVkGetDeviceProcAddr deviceCmds
}
#else
vmaVulkanFunctions _device _instance = zero
#endif

View File

@ -74,9 +74,15 @@ headers = $( do
basicHeaders <- TH.runIO do basicHeaders <- TH.runIO do
headersPath <- canonicalizePath ( takeDirectory currentPath <> "/../../imgui/imgui.h" ) headersPath <- canonicalizePath ( takeDirectory currentPath <> "/../../imgui/imgui.h" )
headersSource <- Text.readFile headersPath headersSource <- Text.readFile headersPath
tokens <- case tokenise headersSource of tokensImGui <- case tokenise headersSource of
Left err -> error ( "Couldn't tokenise Dear ImGui headers:\n\n" <> show err ) Left err -> error ( "Couldn't tokenise Dear ImGui headers:\n\n" <> show err )
Right toks -> pure toks Right toks -> pure toks
headersPath <- canonicalizePath ( takeDirectory currentPath <> "/../../implot/implot.h" )
headersSource <- Text.readFile headersPath
tokensImPlot <- case tokenise headersSource of
Left err -> error ( "Couldn't tokenise Dear ImPlot headers:\n\n" <> show err )
Right toks -> pure toks
let tokens = tokensImGui<>tokensImPlot
case Megaparsec.parse Parser.headers "" tokens of case Megaparsec.parse Parser.headers "" tokens of
Left err -> do Left err -> do
let let

View File

@ -146,6 +146,8 @@ headers = do
_ <- skipManyTill anySingle ( namedSection "Viewports" ) _ <- skipManyTill anySingle ( namedSection "Viewports" )
_ <- skipManyTill anySingle ( namedSection "Platform Dependent Interfaces" ) -- XXX: since 1.87
_ <- skipManyTill anySingle ( namedSection "Obsolete functions and types" ) _ <- skipManyTill anySingle ( namedSection "Obsolete functions and types" )
let let
@ -254,13 +256,21 @@ patternNameAndValue enumName =
where where
count :: StateT EnumState m Integer count :: StateT EnumState m Integer
count = do count = do
_ <- single ( Identifier $ enumName <> "COUNT" ) let idName = enumName <> "COUNT"
_ <- single ( Identifier idName )
mbVal <- optional do mbVal <- optional do
_ <- reservedSymbol '=' _ <- reservedSymbol '='
integerExpression EnumState{enumValues} <- get
case mbVal of integerExpression enumValues
countVal <- case mbVal of
Nothing -> currEnumTag <$> get Nothing -> currEnumTag <$> get
Just ct -> pure ct Just ct -> pure ct
modify' ( \ st -> st { enumValues = HashMap.insert idName countVal ( enumValues st ) } )
pure countVal
value :: StateT EnumState m ( Text, Integer ) value :: StateT EnumState m ( Text, Integer )
value = do value = do
name <- identifier name <- identifier
@ -271,13 +281,16 @@ patternNameAndValue enumName =
patternRHS = patternRHS =
( do ( do
reservedSymbol '=' reservedSymbol '='
try integerExpression <|> try disjunction EnumState{enumValues} <- get
try disjunction <|> try (integerExpression enumValues)
) )
<|> ( currEnumTag <$> get ) <|> ( currEnumTag <$> get )
disjunction :: StateT EnumState m Integer disjunction :: StateT EnumState m Integer
disjunction = do disjunction = do
( summands :: [Text] ) <- identifier `sepBy1` symbol "|" initial <- identifier <* symbol "|"
( rest :: [Text] ) <- identifier `sepBy1` symbol "|"
let summands = initial : rest
valsMap <- enumValues <$> get valsMap <- enumValues <$> get
let let
res :: Either [ Text ] Integer res :: Either [ Text ] Integer
@ -327,34 +340,53 @@ symbol :: MonadParsec e [ Tok ] m => Text -> m ()
symbol s = token ( \ case { Symbolic s' | s == s' -> Just (); _ -> Nothing } ) mempty symbol s = token ( \ case { Symbolic s' | s == s' -> Just (); _ -> Nothing } ) mempty
<?> ( Text.unpack s <> " (symbol)" ) <?> ( Text.unpack s <> " (symbol)" )
integerExpression :: MonadParsec e [ Tok ] m => m Integer integerExpression :: MonadParsec e [ Tok ] m => HashMap Text Integer -> m Integer
integerExpression = try integerPower <|> integer integerExpression enums = try integerPower <|> try integerAdd <|> try integerSub <|> integer
integerPower :: MonadParsec e [ Tok ] m => m Integer
integerPower = do
a <- integer
_ <- symbol "<<"
i <- integer
pure ( a `shiftL` fromIntegral i )
integer :: forall e m. MonadParsec e [ Tok ] m => m Integer
integer =
option id mkSign <*>
token
( \ case {
Number i suff
| Just _ <- toBoundedInteger @Int64 i
, Right i' <- floatingOrInteger @Float @Integer i
, not ( Text.any ( (== 'f' ) . toLower ) suff )
-> Just i';
_ -> Nothing
}
)
mempty
<?> "integer"
where where
mkSign :: m ( Integer -> Integer ) integerPower :: MonadParsec e [ Tok ] m => m Integer
mkSign = ( symbol "+" $> id ) <|> ( symbol "-" $> negate ) integerPower = do
a <- integer
_ <- symbol "<<"
i <- integer
pure ( a `shiftL` fromIntegral i )
integerAdd :: MonadParsec e [ Tok ] m => m Integer
integerAdd = do
a <- integer
_ <- symbol "+"
i <- integer
pure ( a + i )
integerSub :: MonadParsec e [ Tok ] m => m Integer
integerSub = do
a <- integer
_ <- symbol "-"
i <- integer
pure ( a - i )
integer :: forall e m. MonadParsec e [ Tok ] m => m Integer
integer =
option id mkSign <*>
token
( \case
Number i suff
| Just _ <- toBoundedInteger @Int64 i
, Right i' <- floatingOrInteger @Float @Integer i
, not ( Text.any ( (== 'f' ) . toLower ) suff )
->
Just i'
Identifier name ->
HashMap.lookup name enums
_ ->
Nothing
)
mempty
<?> "integer"
where
mkSign :: m ( Integer -> Integer )
mkSign = ( symbol "+" $> id ) <|> ( symbol "-" $> negate )
section :: MonadParsec e [ Tok ] m => m [Text] section :: MonadParsec e [ Tok ] m => m [Text]
section = section =

2
imgui

Submodule imgui updated: 55d35d8387...c71a50deb5

1
implot Submodule

Submodule implot added at b47c8bacdb

View File

@ -190,6 +190,9 @@ module DearImGui
-- ** Selectables -- ** Selectables
, selectable , selectable
, selectableWith
, SelectableOptions(..)
, defSelectableOptions
-- ** List Boxes -- ** List Boxes
, listBox , listBox
@ -234,19 +237,46 @@ module DearImGui
, Raw.endTooltip , Raw.endTooltip
-- * Popups/Modals -- * Popups/Modals
-- ** Generic
, withPopup , withPopup
, withPopupOpen , withPopupOpen
, beginPopup , beginPopup
, Raw.endPopup
-- ** Modal
, withPopupModal , withPopupModal
, withPopupModalOpen , withPopupModalOpen
, beginPopupModal , beginPopupModal
, Raw.endPopup -- ** Item context
, itemContextPopup
, withPopupContextItemOpen
, withPopupContextItem
, beginPopupContextItem
-- ** Window context
, windowContextPopup
, withPopupContextWindowOpen
, withPopupContextWindow
, beginPopupContextWindow
-- ** Void context
, voidContextPopup
, withPopupContextVoidOpen
, withPopupContextVoid
, beginPopupContextVoid
-- ** Manual
, openPopup , openPopup
, openPopupOnItemClick
, Raw.closeCurrentPopup , Raw.closeCurrentPopup
-- ** Queries
, isCurrentPopupOpen
, isAnyPopupOpen
, isAnyLevelPopupOpen
-- * Item/Widgets Utilities -- * Item/Widgets Utilities
, Raw.isItemHovered , Raw.isItemHovered
, Raw.wantCaptureMouse , Raw.wantCaptureMouse
@ -264,6 +294,9 @@ module DearImGui
, Raw.getForegroundDrawList , Raw.getForegroundDrawList
, Raw.imCol32 , Raw.imCol32
-- * Plotting
, module DearImGui.Plot
-- * Types -- * Types
, module DearImGui.Enums , module DearImGui.Enums
, module DearImGui.Structs , module DearImGui.Structs
@ -285,6 +318,7 @@ import System.IO
-- dear-imgui -- dear-imgui
import DearImGui.Enums import DearImGui.Enums
import DearImGui.Structs import DearImGui.Structs
import DearImGui.Plot
import qualified DearImGui.Raw as Raw import qualified DearImGui.Raw as Raw
import qualified DearImGui.Raw.Font as Raw.Font import qualified DearImGui.Raw.Font as Raw.Font
import qualified DearImGui.Raw.ListClipper as Raw.ListClipper import qualified DearImGui.Raw.ListClipper as Raw.ListClipper
@ -1257,10 +1291,25 @@ treePush label = liftIO do
withCString label Raw.treePush withCString label Raw.treePush
-- | Wraps @ImGui::Selectable()@. -- | Wraps @ImGui::Selectable()@ with default options.
selectable :: MonadIO m => String -> m Bool selectable :: MonadIO m => String -> m Bool
selectable label = liftIO do selectable = selectableWith defSelectableOptions
withCString label Raw.selectable
data SelectableOptions = SelectableOptions
{ selected :: Bool
, flags :: ImGuiSelectableFlags
, size :: ImVec2
} deriving Show
defSelectableOptions :: SelectableOptions
defSelectableOptions = SelectableOptions False (ImGuiSelectableFlags 0) (ImVec2 0 0)
-- | Wraps @ImGui::Selectable()@ with explicit options.
selectableWith :: MonadIO m => SelectableOptions -> String -> m Bool
selectableWith (SelectableOptions selected flags size) label = liftIO do
with size $ \sizePtr ->
withCString label $ \labelPtr ->
Raw.selectable labelPtr (bool 0 1 selected) flags sizePtr
listBox :: (MonadIO m, HasGetter ref Int, HasSetter ref Int) => String -> ref -> [String] -> m Bool listBox :: (MonadIO m, HasGetter ref Int, HasSetter ref Int) => String -> ref -> [String] -> m Bool
@ -1479,6 +1528,52 @@ withPopupModalOpen :: MonadUnliftIO m => String -> m () -> m ()
withPopupModalOpen popupId action = withPopupModalOpen popupId action =
withPopupModal popupId (`when` action) withPopupModal popupId (`when` action)
beginPopupContextItem :: MonadIO m => Maybe String -> ImGuiPopupFlags -> m Bool
beginPopupContextItem itemId flags = liftIO do
withCStringOrNull itemId \popupIdPtr ->
Raw.beginPopupContextItem popupIdPtr flags
withPopupContextItem :: MonadUnliftIO m => Maybe String -> ImGuiPopupFlags -> (Bool -> m a) -> m a
withPopupContextItem popupId flags = bracket (beginPopupContextItem popupId flags) (`when` Raw.endPopup)
withPopupContextItemOpen :: MonadUnliftIO m => Maybe String -> ImGuiPopupFlags -> m () -> m ()
withPopupContextItemOpen popupId flags action = withPopupContextItem popupId flags (`when` action)
-- | Attach item context popup to right mouse button click on a last item.
itemContextPopup :: MonadUnliftIO m => m () -> m ()
itemContextPopup = withPopupContextItemOpen Nothing ImGuiPopupFlags_MouseButtonRight
beginPopupContextWindow :: MonadIO m => Maybe String -> ImGuiPopupFlags -> m Bool
beginPopupContextWindow popupId flags = liftIO do
withCStringOrNull popupId \popupIdPtr ->
Raw.beginPopupContextWindow popupIdPtr flags
withPopupContextWindow :: MonadUnliftIO m => Maybe String -> ImGuiPopupFlags -> (Bool -> m a) -> m a
withPopupContextWindow popupId flags = bracket (beginPopupContextWindow popupId flags) (`when` Raw.endPopup)
withPopupContextWindowOpen :: MonadUnliftIO m => Maybe String -> ImGuiPopupFlags -> m () -> m ()
withPopupContextWindowOpen popupId flags action = withPopupContextWindow popupId flags (`when` action)
-- | Attach item context popup to right mouse button click on a current window.
windowContextPopup :: MonadUnliftIO m => m () -> m ()
windowContextPopup = withPopupContextWindowOpen Nothing ImGuiPopupFlags_MouseButtonRight
beginPopupContextVoid :: MonadIO m => Maybe String -> ImGuiPopupFlags -> m Bool
beginPopupContextVoid popupId flags = liftIO do
withCStringOrNull popupId \popupIdPtr ->
Raw.beginPopupContextVoid popupIdPtr flags
withPopupContextVoid :: MonadUnliftIO m => Maybe String -> ImGuiPopupFlags -> (Bool -> m a) -> m a
withPopupContextVoid popupId flags = bracket (beginPopupContextVoid popupId flags) (`when` Raw.endPopup)
withPopupContextVoidOpen :: MonadUnliftIO m => Maybe String -> ImGuiPopupFlags -> m () -> m ()
withPopupContextVoidOpen popupId flags action = withPopupContextVoid popupId flags (`when` action)
-- | Attach item context popup to right mouse button click outside of any windows.
voidContextPopup :: MonadUnliftIO m => m () -> m ()
voidContextPopup = withPopupContextWindowOpen Nothing ImGuiPopupFlags_MouseButtonRight
-- | Call to mark popup as open (don't call every frame!). -- | Call to mark popup as open (don't call every frame!).
-- --
-- Wraps @ImGui::OpenPopup()@ -- Wraps @ImGui::OpenPopup()@
@ -1486,6 +1581,37 @@ openPopup :: MonadIO m => String -> m ()
openPopup popupId = liftIO do openPopup popupId = liftIO do
withCString popupId Raw.openPopup withCString popupId Raw.openPopup
-- | Opens a defined popup (i.e. defined with 'withPopup') on defined action.
--
-- Example:
--
-- > openPopupOnItemClick "myPopup" ImGuiPopupFlags_MouseButtonRight
--
-- Wraps @ImGui::OpenPopup()@
openPopupOnItemClick :: MonadIO m => String -> ImGuiPopupFlags -> m ()
openPopupOnItemClick popupId flags = liftIO do
withCString popupId $ \idPtr ->
Raw.openPopupOnItemClick idPtr flags
-- | Check if the popup is open at the current 'beginPopup' level of the popup stack.
isCurrentPopupOpen :: MonadIO m => String -> m Bool
isCurrentPopupOpen popupId = liftIO do
withCString popupId $ \idPtr ->
Raw.isPopupOpen idPtr ImGuiPopupFlags_None
-- | Check if *any* popup is open at the current 'beginPopup' level of the popup stack.
isAnyPopupOpen :: MonadIO m => String -> m Bool
isAnyPopupOpen popupId = liftIO do
withCString popupId $ \idPtr ->
Raw.isPopupOpen idPtr ImGuiPopupFlags_AnyPopupId
-- | Check if *any* popup is open at any level of the popup stack.
isAnyLevelPopupOpen :: MonadIO m => String -> m Bool
isAnyLevelPopupOpen popupId = liftIO do
withCString popupId $ \idPtr ->
Raw.isPopupOpen idPtr $
ImGuiPopupFlags_AnyPopupId .|. ImGuiPopupFlags_AnyPopupLevel
withCStringOrNull :: Maybe String -> (Ptr CChar -> IO a) -> IO a withCStringOrNull :: Maybe String -> (Ptr CChar -> IO a) -> IO a
withCStringOrNull Nothing k = k nullPtr withCStringOrNull Nothing k = k nullPtr

View File

@ -43,3 +43,11 @@ imguiContext = mempty
, ( TypeName "ImGuiListClipper", [t| ImGuiListClipper |] ) , ( TypeName "ImGuiListClipper", [t| ImGuiListClipper |] )
] ]
} }
implotContext :: Context
implotContext = mempty
{ ctxTypesTable =
Map.fromList
[ ( TypeName "ImPlotContext", [t| ImPlotContext |] )
]
}

View File

@ -23,6 +23,7 @@ module DearImGui.GLFW (
-- $callbacks -- $callbacks
, glfwWindowFocusCallback , glfwWindowFocusCallback
, glfwCursorEnterCallback , glfwCursorEnterCallback
, glfwCursorPosCallback
, glfwMouseButtonCallback , glfwMouseButtonCallback
, glfwScrollCallback , glfwScrollCallback
, glfwKeyCallback , glfwKeyCallback
@ -108,6 +109,20 @@ glfwCursorEnterCallback window entered = liftIO do
where where
windowPtr = castPtr $ unWindow window windowPtr = castPtr $ unWindow window
glfwCursorPosCallback :: MonadIO m => Window -> CDouble -> CDouble -> m ()
glfwCursorPosCallback window x y = liftIO do
[C.exp| void {
ImGui_ImplGlfw_CursorPosCallback(
static_cast<GLFWwindow *>(
$(void * windowPtr)
),
$(double x),
$(double y)
);
} |]
where
windowPtr = castPtr $ unWindow window
glfwMouseButtonCallback :: MonadIO m => Window -> CInt -> CInt -> CInt -> m () glfwMouseButtonCallback :: MonadIO m => Window -> CInt -> CInt -> CInt -> m ()
glfwMouseButtonCallback window button action mods = liftIO do glfwMouseButtonCallback window button action mods = liftIO do
[C.exp| void { [C.exp| void {

71
src/DearImGui/Plot.hs Normal file
View File

@ -0,0 +1,71 @@
{-# LANGUAGE BlockArguments #-}
{-# LANGUAGE DuplicateRecordFields #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE PatternSynonyms #-}
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE TemplateHaskell #-}
{-|
Module: DearImGui.Plot
Main ImPlot module, exporting the functions to make plots happen in Gui.
-}
module DearImGui.Plot
( -- * Context Creation and Access
Raw.Plot.PlotContext(..)
, Raw.Plot.createPlotContext
, Raw.Plot.destroyPlotContext
, Raw.Plot.getCurrentPlotContext
, Raw.Plot.setCurrentPlotContext
-- * Demo so you can play with all features
, Raw.Plot.showPlotDemoWindow
)
where
-- base
import Control.Monad
( when )
import Data.Bool
import Data.Foldable
( foldl' )
import Foreign
import Foreign.C
import qualified GHC.Foreign as Foreign
import System.IO
( utf8 )
-- dear-imgui
import DearImGui.Enums
import DearImGui.Structs
import qualified DearImGui.Raw as Raw
import qualified DearImGui.Raw.Plot as Raw.Plot
import qualified DearImGui.Raw.Font as Raw.Font
import qualified DearImGui.Raw.ListClipper as Raw.ListClipper
-- managed
import qualified Control.Monad.Managed as Managed
-- StateVar
import Data.StateVar
( HasGetter(get), HasSetter, ($=!) )
-- transformers
import Control.Monad.IO.Class
( MonadIO, liftIO )
-- unliftio
import UnliftIO (MonadUnliftIO)
import UnliftIO.Exception (bracket, bracket_)
-- vector
import qualified Data.Vector as V
import qualified Data.Vector.Storable as VS
import qualified Data.Vector.Unboxed as VU

View File

@ -197,7 +197,12 @@ module DearImGui.Raw
, beginPopupModal , beginPopupModal
, endPopup , endPopup
, openPopup , openPopup
, openPopupOnItemClick
, closeCurrentPopup , closeCurrentPopup
, beginPopupContextItem
, beginPopupContextWindow
, beginPopupContextVoid
, isPopupOpen
-- * ID stack/scopes -- * ID stack/scopes
, pushIDInt , pushIDInt
@ -1081,10 +1086,17 @@ treePop = liftIO do
[C.exp| void { TreePop() } |] [C.exp| void { TreePop() } |]
-- -- | Wraps @ImGui::Selectable()@.
-- selectable :: (MonadIO m) => CString -> m Bool
-- selectable labelPtr = liftIO do
-- (0 /=) <$> [C.exp| bool { Selectable($(char* labelPtr)) } |]
-- | Wraps @ImGui::Selectable()@. -- | Wraps @ImGui::Selectable()@.
selectable :: (MonadIO m) => CString -> m Bool selectable :: (MonadIO m) => CString -> CBool -> ImGuiSelectableFlags -> Ptr ImVec2 -> m Bool
selectable labelPtr = liftIO do selectable labelPtr selected flags size = liftIO do
(0 /=) <$> [C.exp| bool { Selectable($(char* labelPtr)) } |] (0 /=) <$> [C.exp| bool { Selectable($(char* labelPtr), $(bool selected), $(ImGuiSelectableFlags flags), *$(ImVec2 *size)) } |]
-- | Wraps @ImGui::ListBox()@. -- | Wraps @ImGui::ListBox()@.
@ -1253,6 +1265,16 @@ openPopup popupIdPtr = liftIO do
[C.exp| void { OpenPopup($(char* popupIdPtr)) } |] [C.exp| void { OpenPopup($(char* popupIdPtr)) } |]
-- | Open popup when clicked on last item.
--
-- Note: actually triggers on the mouse _released_ event to be consistent with popup behaviors.
--
-- Wraps @ImGui::OpenPopupOnItemClick()@
openPopupOnItemClick :: (MonadIO m) => CString -> ImGuiPopupFlags-> m ()
openPopupOnItemClick popupIdPtr flags = liftIO do
[C.exp| void { OpenPopupOnItemClick($(char* popupIdPtr), $(ImGuiPopupFlags flags)) } |]
-- | Manually close the popup we have begin-ed into. -- | Manually close the popup we have begin-ed into.
-- --
-- Wraps @ImGui::ClosePopup()@ -- Wraps @ImGui::ClosePopup()@
@ -1260,6 +1282,36 @@ closeCurrentPopup :: (MonadIO m) => m ()
closeCurrentPopup = liftIO do closeCurrentPopup = liftIO do
[C.exp| void { CloseCurrentPopup() } |] [C.exp| void { CloseCurrentPopup() } |]
-- | Open+begin popup when clicked on last item.
--
-- Use str_id==NULL to associate the popup to previous item.
--
-- If you want to use that on a non-interactive item such as 'text' you need to pass in an explicit ID here.
beginPopupContextItem :: (MonadIO m) => CString -> ImGuiPopupFlags-> m Bool
beginPopupContextItem popupIdPtr flags = liftIO do
(0 /=) <$> [C.exp| bool { BeginPopupContextItem($(char* popupIdPtr), $(ImGuiPopupFlags flags)) } |]
-- | Open+begin popup when clicked on current window.
beginPopupContextWindow :: (MonadIO m) => CString -> ImGuiPopupFlags-> m Bool
beginPopupContextWindow popupIdPtr flags = liftIO do
(0 /=) <$> [C.exp| bool { BeginPopupContextWindow($(char* popupIdPtr), $(ImGuiPopupFlags flags)) } |]
-- | Open+begin popup when clicked in void (where there are no windows).
beginPopupContextVoid :: (MonadIO m) => CString -> ImGuiPopupFlags-> m Bool
beginPopupContextVoid popupIdPtr flags = liftIO do
(0 /=) <$> [C.exp| bool { BeginPopupContextVoid($(char* popupIdPtr), $(ImGuiPopupFlags flags)) } |]
-- | Query popup status
--
-- - return 'True' if the popup is open at the current 'beginPopup' level of the popup stack.
-- - with 'ImGuiPopupFlags_AnyPopupId': return 'True' if any popup is open at the current 'beginPopup' level of the popup stack.
-- - with 'ImGuiPopupFlags_AnyPopupId' | 'ImGuiPopupFlags_AnyPopupLevel': return 'True' if any popup is open.
--
-- Wraps @ImGui::IsPopupOpen()@
isPopupOpen :: (MonadIO m) => CString -> ImGuiPopupFlags-> m Bool
isPopupOpen popupIdPtr flags = liftIO do
(0 /=) <$> [C.exp| bool { IsPopupOpen($(char* popupIdPtr), $(ImGuiPopupFlags flags)) } |]
-- | Is the last item hovered? (and usable, aka not blocked by a popup, etc.). -- | Is the last item hovered? (and usable, aka not blocked by a popup, etc.).
-- --

83
src/DearImGui/Raw/Plot.hs Normal file
View File

@ -0,0 +1,83 @@
{-# LANGUAGE BlockArguments #-}
{-# LANGUAGE DuplicateRecordFields #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE PatternSynonyms #-}
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE ViewPatterns #-}
{-|
Module: DearImGui.Raw.Plot
Main ImPlot Raw module.
-}
module DearImGui.Raw.Plot
( PlotContext(..)
, createPlotContext
, destroyPlotContext
, getCurrentPlotContext
, setCurrentPlotContext
, showPlotDemoWindow
) where
-- base
import Control.Monad.IO.Class
( MonadIO, liftIO )
import Foreign
import Foreign.C
import System.IO.Unsafe
( unsafePerformIO )
-- dear-imgui
import DearImGui.Context
( imguiContext, implotContext )
import DearImGui.Enums
import DearImGui.Structs
import DearImGui.Raw.DrawList (DrawList(..))
-- inline-c
import qualified Language.C.Inline as C
-- inline-c-cpp
import qualified Language.C.Inline.Cpp as Cpp
C.context (Cpp.cppCtx <> C.bsCtx <> imguiContext <> implotContext)
C.include "imgui.h"
C.include "implot.h"
Cpp.using "namespace ImPlot"
-- | Wraps @ImPlotContext*@.
newtype PlotContext = PlotContext (Ptr ImPlotContext)
-- | Wraps @ImPlot::CreateContext()@.
createPlotContext :: (MonadIO m) => m PlotContext
createPlotContext = liftIO do
PlotContext <$> [C.exp| ImPlotContext* { CreateContext() } |]
-- | Wraps @ImPlot::DestroyPlotContext()@.
destroyPlotContext :: (MonadIO m) => PlotContext -> m ()
destroyPlotContext (PlotContext contextPtr) = liftIO do
[C.exp| void { DestroyContext($(ImPlotContext* contextPtr)); } |]
-- | Wraps @ImPlot::GetCurrentPlotContext()@.
getCurrentPlotContext :: MonadIO m => m PlotContext
getCurrentPlotContext = liftIO do
PlotContext <$> [C.exp| ImPlotContext* { GetCurrentContext() } |]
-- | Wraps @ImPlot::SetCurrentPlotContext()@.
setCurrentPlotContext :: MonadIO m => PlotContext -> m ()
setCurrentPlotContext (PlotContext contextPtr) = liftIO do
[C.exp| void { SetCurrentContext($(ImPlotContext* contextPtr)) } |]
-- | Create demo window. Demonstrate most ImGui features. Call this to learn
-- about the library! Try to make it always available in your application!
showPlotDemoWindow :: (MonadIO m) => m ()
showPlotDemoWindow = liftIO do
[C.exp| void { ShowDemoWindow(); } |]

View File

@ -1,11 +1,17 @@
{-# LANGUAGE DuplicateRecordFields #-} {-# LANGUAGE DuplicateRecordFields #-}
{-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE CPP #-}
module DearImGui.Structs where module DearImGui.Structs where
-- base -- base
import Data.Word import Data.Word
( Word32, Word16 ) ( Word32
#ifndef IMGUI_USE_WCHAR32
, Word16
#endif
)
import Foreign import Foreign
( Storable(..), castPtr, plusPtr ) ( Storable(..), castPtr, plusPtr )
@ -96,5 +102,28 @@ data ImGuiListClipper
type ImU32 = Word32 type ImU32 = Word32
-- | Single wide character (used mostly in glyph management) -- | Single wide character (used mostly in glyph management)
#ifdef IMGUI_USE_WCHAR32
type ImWchar = Word32
#else
type ImWchar = Word16 type ImWchar = Word16
-- FIXME: consider IMGUI_USE_WCHAR32 #endif
--------------------------------------------------------------------------------
-- | DearImPlot context handle
data ImPlotContext
-- | Double precision version of ImVec2 used by ImPlot. Extensible by end users
data ImPlotPoint
-- | Range defined by a min/max value.
data ImPlotRange
-- | Combination of two range limits for X and Y axes. Also an AABB defined by Min()/Max().
data ImPlotRect
-- | Plot style structure
data ImPlotStyle
-- | Input mapping structure. Default values listed. See also MapInputDefault, MapInputReverse.
data ImPlotInputMap

View File

@ -19,6 +19,8 @@ module DearImGui.Vulkan
, vulkanCreateFontsTexture , vulkanCreateFontsTexture
, vulkanDestroyFontUploadObjects , vulkanDestroyFontUploadObjects
, vulkanSetMinImageCount , vulkanSetMinImageCount
, vulkanAddTexture
) )
where where
@ -32,7 +34,7 @@ import Foreign.Marshal.Alloc
import Foreign.Ptr import Foreign.Ptr
( FunPtr, Ptr, freeHaskellFunPtr, nullPtr ) ( FunPtr, Ptr, freeHaskellFunPtr, nullPtr )
import Foreign.Storable import Foreign.Storable
( Storable(poke) ) ( poke )
-- inline-c -- inline-c
import qualified Language.C.Inline as C import qualified Language.C.Inline as C
@ -92,7 +94,7 @@ withVulkan initInfo renderPass action =
( \ ( _, initResult ) -> action initResult ) ( \ ( _, initResult ) -> action initResult )
-- | Wraps @ImGui_ImplVulkan_Init@. -- | Wraps @ImGui_ImplVulkan_Init@.
-- --
-- Use 'vulkanShutdown' to clean up on shutdown. -- Use 'vulkanShutdown' to clean up on shutdown.
-- Prefer using 'withVulkan' when possible, as it automatically handles cleanup. -- Prefer using 'withVulkan' when possible, as it automatically handles cleanup.
vulkanInit :: MonadIO m => InitInfo -> Vulkan.RenderPass -> m (FunPtr (Vulkan.Result -> IO ()), Bool) vulkanInit :: MonadIO m => InitInfo -> Vulkan.RenderPass -> m (FunPtr (Vulkan.Result -> IO ()), Bool)
@ -184,3 +186,16 @@ vulkanDestroyFontUploadObjects = liftIO do
vulkanSetMinImageCount :: MonadIO m => Word32 -> m () vulkanSetMinImageCount :: MonadIO m => Word32 -> m ()
vulkanSetMinImageCount minImageCount = liftIO do vulkanSetMinImageCount minImageCount = liftIO do
[C.exp| void { ImGui_ImplVulkan_SetMinImageCount($(uint32_t minImageCount)); } |] [C.exp| void { ImGui_ImplVulkan_SetMinImageCount($(uint32_t minImageCount)); } |]
-- | Wraps @ImGui_ImplVulkan_AddTexture@.
vulkanAddTexture :: MonadIO m => Vulkan.Sampler -> Vulkan.ImageView -> Vulkan.ImageLayout -> m Vulkan.DescriptorSet
vulkanAddTexture sampler imageView imageLayout = liftIO do
[C.block|
VkDescriptorSet {
return ImGui_ImplVulkan_AddTexture(
$(VkSampler sampler),
$(VkImageView imageView),
$(VkImageLayout imageLayout)
);
}
|]

View File

@ -31,6 +31,10 @@ vulkanTypesTable = Map.fromList
, ( C.TypeName "VkRenderPass" , [t| Vulkan.RenderPass |] ) , ( C.TypeName "VkRenderPass" , [t| Vulkan.RenderPass |] )
, ( C.TypeName "VkResult" , [t| Vulkan.Result |] ) , ( C.TypeName "VkResult" , [t| Vulkan.Result |] )
, ( C.TypeName "VkSampleCountFlagBits", [t| Vulkan.SampleCountFlagBits |] ) , ( C.TypeName "VkSampleCountFlagBits", [t| Vulkan.SampleCountFlagBits |] )
, ( C.TypeName "VkSampler" , [t| Vulkan.Sampler |] )
, ( C.TypeName "VkImageView" , [t| Vulkan.ImageView |] )
, ( C.TypeName "VkImageLayout" , [t| Vulkan.ImageLayout |] )
, ( C.TypeName "VkDescriptorSet" , [t| Vulkan.DescriptorSet |] )
] ]
vulkanCtx :: C.Context vulkanCtx :: C.Context