14 Commits

16 changed files with 1030 additions and 75 deletions

3
.gitmodules vendored
View File

@ -1,3 +1,4 @@
[submodule "imgui"]
path = imgui
url = https://github.com/ocornut/imgui
url = https://github.com/Drezil/imgui
branch = textAlign

View File

@ -1,5 +1,17 @@
# 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]
- Added `DearImGui.FontAtlas` and related `DearImGui.Raw.Font.*` bits.
@ -7,7 +19,7 @@
## [1.2.2]
- `imgui` updated to 1.85.
- `imgui` updated to [1.85].
## [1.2.1]
@ -29,7 +41,7 @@
## [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.
- Added GLFW backend callbacks.
- Added more withXXX wrappers.
@ -44,7 +56,7 @@
## [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.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.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.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
name: dear-imgui
version: 1.3.0
version: 1.4.0
author: Oliver Charles
maintainer: ollie@ocharles.org.uk, aenor.realm@gmail.com
license: BSD-3-Clause
@ -24,7 +24,7 @@ extra-source-files:
imgui/imconfig.h,
imgui/LICENSE.txt
common build-flags
common exe-flags
if flag(debug)
if os(linux)
ghc-options: -Wall -g -rtsopts -dcore-lint -debug
@ -50,7 +50,6 @@ common build-flags
ghc-options: -Wall -O2
cc-options: -O2
source-repository head
type: git
location: https://github.com/haskell-game/dear-imgui.hs
@ -111,6 +110,22 @@ flag examples
manual:
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
build-depends:
base
@ -157,6 +172,13 @@ library
, unliftio
, 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)
exposed-modules:
DearImGui.OpenGL2
@ -273,7 +295,7 @@ library dear-imgui-generator
>= 0.2.11 && < 0.3
executable test
import: common, build-flags
import: common, exe-flags
main-is: Main.hs
default-language: Haskell2010
if (!flag(examples) || !flag(sdl) || !flag(opengl2))
@ -282,7 +304,7 @@ executable test
build-depends: base, sdl2, gl, dear-imgui, vector
executable glfw
import: common, build-flags
import: common, exe-flags
main-is: Main.hs
hs-source-dirs: examples/glfw
default-language: Haskell2010
@ -292,7 +314,7 @@ executable glfw
build-depends: base, GLFW-b, gl, dear-imgui, managed
executable readme
import: common, build-flags
import: common, exe-flags
main-is: Readme.hs
hs-source-dirs: examples
build-depends: sdl2, gl, dear-imgui, managed
@ -300,7 +322,7 @@ executable readme
buildable: False
executable fonts
import: common, build-flags
import: common, exe-flags
main-is: Main.hs
hs-source-dirs: examples/fonts
build-depends: sdl2, gl, dear-imgui, managed
@ -308,7 +330,7 @@ executable fonts
buildable: False
executable image
import: common, build-flags
import: common, exe-flags
main-is: Image.hs
hs-source-dirs: examples/sdl
build-depends: sdl2, gl, dear-imgui, managed, vector
@ -316,7 +338,7 @@ executable image
buildable: False
executable vulkan
import: common, build-flags
import: common, exe-flags
main-is: Main.hs
other-modules: Attachments, Backend, Input, Util
hs-source-dirs: examples/vulkan
@ -350,3 +372,5 @@ executable vulkan
^>= 3.9
, vulkan-utils
^>= 0.4.1
, VulkanMemoryAllocator
, JuicyPixels

View File

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

View File

@ -24,7 +24,9 @@ import Control.Arrow
import Control.Exception
( throw )
import Control.Monad
( unless, void )
( unless, void, when )
import Data.Bits
( (.|.) )
import Data.Foldable
( traverse_ )
import Data.String
@ -62,11 +64,13 @@ import qualified Data.Vector as Boxed
( Vector )
import qualified Data.Vector as Boxed.Vector
( (!), head, singleton, unzip )
import qualified Data.Vector.Storable as Storable.Vector
-- vulkan
import qualified Vulkan
import qualified Vulkan.Exception as Vulkan
import qualified Vulkan.Zero as Vulkan
import qualified Vulkan.Exception as Vulkan
import qualified Vulkan.Zero as Vulkan
import qualified VulkanMemoryAllocator as VMA
-- dear-imgui
import Attachments
@ -76,6 +80,13 @@ import qualified DearImGui as ImGui
import qualified DearImGui.Vulkan as ImGui.Vulkan
import qualified DearImGui.SDL as ImGui.SDL
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) )
instance MonadResource ( LoggingT LogMessage (ResourceT IO) )
gui :: MonadIO m => m ImGui.DrawData
gui = do
gui :: MonadUnliftIO m => (ImGui.Raw.ImVec2, Ptr ()) -> m ImGui.DrawData
gui texture = do
-- Prepare frame
ImGui.Vulkan.vulkanNewFrame
ImGui.SDL.sdl2NewFrame
@ -92,6 +103,25 @@ gui = do
-- Run your windows
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
ImGui.render
@ -275,6 +305,80 @@ app = do
logDebug "Allocating command buffers"
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.
@ -308,23 +412,96 @@ app = do
logDebug "Creating fence"
( fenceKey, fence ) <- createFence device
logDebug "Allocating one-shot command buffer"
( fontUploadCommandBufferKey, fontUploadCommandBuffer ) <-
( oneshotCommandBufferKey, oneshotCommandBuffer ) <-
second Boxed.Vector.head <$>
allocatePrimaryCommandBuffers device commandPool 1
logDebug "Recording one-shot commands"
beginCommandBuffer fontUploadCommandBuffer
_ <- ImGui.Vulkan.vulkanCreateFontsTexture fontUploadCommandBuffer
endCommandBuffer fontUploadCommandBuffer
beginCommandBuffer oneshotCommandBuffer
_ <- ImGui.Vulkan.vulkanCreateFontsTexture oneshotCommandBuffer
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"
submitCommandBuffer queue fontUploadCommandBuffer [] [] ( Just fence )
submitCommandBuffer queue oneshotCommandBuffer [] [] ( Just fence )
waitForFences device ( WaitAll [ fence ] )
logDebug "Finished uploading font objects"
logDebug "Cleaning up one-shot commands"
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
mainLoop :: AppState m -> m ()
@ -364,7 +541,7 @@ app = do
beginCommandBuffer commandBuffer
cmdBeginRenderPass commandBuffer imGuiRenderPass framebuffer clearValues swapchainExtent
drawData <- gui
drawData <- gui texture
ImGui.Vulkan.vulkanRenderDrawData drawData commandBuffer Nothing
cmdEndRenderPass commandBuffer

View File

@ -1,4 +1,7 @@
{-# LANGUAGE BlockArguments #-}
{-# LANGUAGE CPP #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE ScopedTypeVariables #-}
module Util where
@ -12,6 +15,10 @@ import Data.Functor.Identity
( Identity(..) )
import Data.Traversable
( for )
#if MIN_VERSION_VulkanMemoryAllocator(0,8,0)
import Foreign
( castFunPtr )
#endif
-- transformers
import Control.Monad.Trans.State.Strict
@ -19,6 +26,16 @@ import Control.Monad.Trans.State.Strict
import Control.Monad.Trans.Writer.Strict
( 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
@ -38,3 +55,19 @@ ifor i0 upd ta f = (`evalState` i0) . getCompose $ result
where
result :: Compose (State i) f (t b)
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

@ -146,6 +146,8 @@ headers = do
_ <- skipManyTill anySingle ( namedSection "Viewports" )
_ <- skipManyTill anySingle ( namedSection "Platform Dependent Interfaces" ) -- XXX: since 1.87
_ <- skipManyTill anySingle ( namedSection "Obsolete functions and types" )
let
@ -254,13 +256,21 @@ patternNameAndValue enumName =
where
count :: StateT EnumState m Integer
count = do
_ <- single ( Identifier $ enumName <> "COUNT" )
let idName = enumName <> "COUNT"
_ <- single ( Identifier idName )
mbVal <- optional do
_ <- reservedSymbol '='
integerExpression
case mbVal of
EnumState{enumValues} <- get
integerExpression enumValues
countVal <- case mbVal of
Nothing -> currEnumTag <$> get
Just ct -> pure ct
modify' ( \ st -> st { enumValues = HashMap.insert idName countVal ( enumValues st ) } )
pure countVal
value :: StateT EnumState m ( Text, Integer )
value = do
name <- identifier
@ -271,13 +281,16 @@ patternNameAndValue enumName =
patternRHS =
( do
reservedSymbol '='
try integerExpression <|> try disjunction
EnumState{enumValues} <- get
try disjunction <|> try (integerExpression enumValues)
)
<|> ( currEnumTag <$> get )
disjunction :: StateT EnumState m Integer
disjunction = do
( summands :: [Text] ) <- identifier `sepBy1` symbol "|"
initial <- identifier <* symbol "|"
( rest :: [Text] ) <- identifier `sepBy1` symbol "|"
let summands = initial : rest
valsMap <- enumValues <$> get
let
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
<?> ( Text.unpack s <> " (symbol)" )
integerExpression :: MonadParsec e [ Tok ] m => m Integer
integerExpression = try integerPower <|> 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"
integerExpression :: MonadParsec e [ Tok ] m => HashMap Text Integer -> m Integer
integerExpression enums = try integerPower <|> try integerAdd <|> try integerSub <|> integer
where
mkSign :: m ( Integer -> Integer )
mkSign = ( symbol "+" $> id ) <|> ( symbol "-" $> negate )
integerPower :: MonadParsec e [ Tok ] m => m Integer
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 =

2
imgui

Submodule imgui updated: 55d35d8387...db20d38864

View File

@ -183,6 +183,37 @@ module DearImGui
, colorPicker3
, colorButton
-- ** Tables
, beginTable
, Raw.endTable
, withTable
, TableOptions(..)
, defTableOptions
, tableNextRow
, tableNextRowWith
, TableRowOptions(..)
, defTableRowOptions
, Raw.tableNextColumn
, tableSetColumnIndex
, tableSetupColumn
, TableColumnOptions(..)
, defTableColumnOptions
, tableSetupScrollFreeze
, Raw.tableHeadersRow
, Raw.tableHeader
, withSortableTable
, TableSortingSpecs(..)
, tableGetColumnCount
, tableGetColumnIndex
, tableGetRowIndex
, tableGetColumnName
, tableGetColumnFlags
, tableSetColumnEnabled
, tableSetBgColor
-- ** Trees
, treeNode
, treePush
@ -190,6 +221,9 @@ module DearImGui
-- ** Selectables
, selectable
, selectableWith
, SelectableOptions(..)
, defSelectableOptions
-- ** List Boxes
, listBox
@ -234,19 +268,46 @@ module DearImGui
, Raw.endTooltip
-- * Popups/Modals
-- ** Generic
, withPopup
, withPopupOpen
, beginPopup
, Raw.endPopup
-- ** Modal
, withPopupModal
, withPopupModalOpen
, beginPopupModal
, Raw.endPopup
-- ** Item context
, itemContextPopup
, withPopupContextItemOpen
, withPopupContextItem
, beginPopupContextItem
-- ** Window context
, windowContextPopup
, withPopupContextWindowOpen
, withPopupContextWindow
, beginPopupContextWindow
-- ** Void context
, voidContextPopup
, withPopupContextVoidOpen
, withPopupContextVoid
, beginPopupContextVoid
-- ** Manual
, openPopup
, openPopupOnItemClick
, Raw.closeCurrentPopup
-- ** Queries
, isCurrentPopupOpen
, isAnyPopupOpen
, isAnyLevelPopupOpen
-- * Item/Widgets Utilities
, Raw.isItemHovered
, Raw.wantCaptureMouse
@ -1244,6 +1305,203 @@ colorButton desc ref = liftIO do
return changed
data TableOptions = TableOptions
{ tableFlags :: ImGuiTableFlags
, outerSize :: ImVec2
, innerWidth :: Float
} deriving Show
defTableOptions :: TableOptions
defTableOptions = TableOptions (ImGuiTableFlags 0) (ImVec2 0 0) 0
-- | Wraps @ImGui::BeginTable()@.
beginTable :: MonadIO m => TableOptions -> String -> Int -> m Bool
beginTable (TableOptions flags outer inner) label columns = liftIO do
withCString label $ \l ->
with outer $ \o ->
Raw.beginTable l (fromIntegral columns) flags o (CFloat inner)
-- | Create a table.
--
-- The action will get 'False' if the entry is not visible.
--
-- ==== __Example usage:__
--
-- > withTable defTableOptions "MyTable" 2 $ \case
-- > False -> return ()
-- > True -> do
-- > tableSetupColumn "Hello"
-- > tableSetupColumn "World"
-- > tableHeadersRow
-- > forM_ [("a","1"),("b","2")] $\(a,b)
-- > tableNextRow
-- > whenM tableNextColumn (text a)
-- > whenM tableNextColumn (text b)
--
-- Displays:
--
-- @
-- | Hello | World |
-- +-------+-------+
-- | a | 1 |
-- | b | 2 |
-- @
--
withTable :: MonadUnliftIO m => TableOptions -> String -> Int -> (Bool -> m a) -> m a
withTable options label columns =
bracket (beginTable options label columns) (`when` Raw.endTable)
-- | Wraps @ImGui::TableNextRow()@ with 'defTableRowOptions'.
-- append into the first cell of a new row.
tableNextRow :: MonadIO m => m ()
tableNextRow = tableNextRowWith defTableRowOptions
data TableRowOptions = TableRowOptions
{ tableRowFlags :: ImGuiTableRowFlags
, minRowHeight :: Float
} deriving Show
defTableRowOptions :: TableRowOptions
defTableRowOptions = TableRowOptions (ImGuiTableRowFlags 0) 0
-- | Wraps @ImGui::TableNextRow()@ with explicit options.
tableNextRowWith :: MonadIO m => TableRowOptions -> m ()
tableNextRowWith (TableRowOptions flags minHeight) = liftIO do
Raw.tableNextRow flags (CFloat minHeight)
-- | Wraps @ImGui::TableSetColumnIndex()@.
-- append into the specified column. Return true when column is visible.
tableSetColumnIndex :: MonadIO m => Int -> m Bool
tableSetColumnIndex column = liftIO do
Raw.tableSetColumnIndex (fromIntegral column)
data TableColumnOptions = TableColumnOptions
{ tableColumnFlags :: ImGuiTableColumnFlags
, initWidthOrWeight :: Float
, userId :: ImGuiID
} deriving Show
defTableColumnOptions :: TableColumnOptions
defTableColumnOptions = TableColumnOptions (ImGuiTableColumnFlags 0) 0 0
-- | Wraps @ImGui::TableSetupColumn()@ using 'defTableColumnOptions'.
tableSetupColumn :: MonadIO m => String -> m ()
tableSetupColumn = tableSetupColumnWith defTableColumnOptions
-- | Wraps @ImGui::TableSetupColumn() with explicit options@.
tableSetupColumnWith :: MonadIO m => TableColumnOptions -> String -> m ()
tableSetupColumnWith (TableColumnOptions flags weight userId) label = liftIO do
withCString label $ \l ->
Raw.tableSetupColumn l flags (CFloat weight) userId
-- | Wraps @ImGui::TableSetupScrollFreeze()@.
-- lock columns/rows so they stay visible when scrolled.
tableSetupScrollFreeze :: MonadIO m => Int -> Int -> m ()
tableSetupScrollFreeze cols rows = liftIO do
Raw.tableSetupScrollFreeze (fromIntegral cols) (fromIntegral rows)
data TableSortingSpecs = TableSortingSpecs
{ tableSortingId :: ImGuiID -- ^ User id of the column (if specified by a TableSetupColumn() call)
, tableSortingColumn :: Int -- ^ Index of the column, starting at 0
, dableSortingOrder :: Int -- ^ Index within parent ImGuiTableSortSpecs (always stored in order starting from 0, tables sorted on a single criteria will always have a 0 here).
-- On 'ImGuiTableFlags_SortMulti' this is the order in which should be sorted.
, tableSortingDirection :: ImGuiSortDirection -- ^ 'ImGuiSortDirection_Ascending' or 'ImGuiSortDirection_Descending'. Should not be 'ImGuiSortDirection_None'
} deriving (Show, Eq)
-- | High-Level sorting. Returns of the underlying data should be sorted
-- and to what specification. Number of Specifications is mostly 0 or 1, but
-- can be more if 'ImGuiTableFlags_SortMulti' is enabled on the table.
--
-- The Bool only fires true for one frame on each sorting event and resets
-- automatically.
--
-- Must be called AFTER all columns are set up with 'tableSetupColumn'
--
-- Hint: Don't forget to set 'ImGuiTableFlags_Sortable' to enable sorting
-- on tables.
--
-- ==== __Example usage:__
--
-- > withTable defTableOptions "MyTable" 2 $ \case
-- > False -> return ()
-- > True -> do
-- > tableSetupColumn "Hello"
-- > tableSetupColumn "World"
-- > withSortableTable $ \(mustSort, sortSpecs) do
-- > when mustSort $
-- > -- ... do your sorting here & cache it. Dont sort every frame.
-- > tableHeadersRow
-- > forM_ [("a","1"),("b","2")] $\(a,b) -- use sorted data here.
-- > tableNextRow
-- > whenM tableNextColumn (text a)
-- > whenM tableNextColumn (text b)
withSortableTable :: MonadIO m => ((Bool,[TableSortingSpecs]) -> m a) -> m a
withSortableTable action = do
specsPtr <- liftIO $ Raw.tableGetSortSpecs
case specsPtr of
Nothing -> action (False, [])
Just ptr -> do
specs <- liftIO $ peek ptr
cSpecs <- liftIO $ peekArray (fromIntegral $ imGuiTableSortSpecsCount specs) (imGuiTableColumnSortSpecs specs)
-- just map singed 16-bit-int to something nice for the end-user
let cSpecs' = (\(ImGuiTableColumnSortSpecs a b c d) -> TableSortingSpecs a (fromIntegral b) (fromIntegral c) d) <$> cSpecs
result <- action (imGuiTableSortSpecsDirty specs /= 0, cSpecs')
-- set dirty to 0 after everything is done.
liftIO $ poke (ptr `plusPtr` (sizeOf (imGuiTableColumnSortSpecs specs)) `plusPtr` (sizeOf (imGuiTableSortSpecsCount specs))) (0 :: CInt)
return result
-- | Wraps @ImGui::TableGetColumnCount()@.
-- return number of columns (value passed to BeginTable)
tableGetColumnCount :: MonadIO m => m Int
tableGetColumnCount =
fromIntegral <$> Raw.tableGetColumnCount
-- | Wraps @ImGui::TableGetColumnIndex()@.
-- return current column index.
tableGetColumnIndex :: MonadIO m => m Int
tableGetColumnIndex =
fromIntegral <$> Raw.tableGetColumnIndex
-- | Wraps @ImGui::TableGetRowIndex()@.
-- return current row index
tableGetRowIndex :: MonadIO m => m Int
tableGetRowIndex =
fromIntegral <$> Raw.tableGetRowIndex
-- | Wraps @ImGui::TableGetColumnName
-- returns "" if column didn't have a name declared by TableSetupColumn
-- 'Nothing' returns the current column name
tableGetColumnName :: MonadIO m => Maybe Int -> m String
tableGetColumnName c = liftIO do
Raw.tableGetColumnName (fromIntegral <$> c) >>= peekCString
-- | Wraps @ImGui::TableGetRowIndex()@.
-- return column flags so you can query their Enabled/Visible/Sorted/Hovered
-- status flags.
-- 'Nothing' returns the current column flags
tableGetColumnFlags :: MonadIO m => Maybe Int -> m ImGuiTableColumnFlags
tableGetColumnFlags =
Raw.tableGetColumnFlags . fmap fromIntegral
-- | Wraps @ImGui::TableSetColumnEnabled()@.
-- change user accessible enabled/disabled state of a column. Set to false to
-- hide the column. User can use the context menu to change this themselves
-- (right-click in headers, or right-click in columns body with
-- 'ImGuiTableFlags_ContextMenuInBody')
tableSetColumnEnabled :: MonadIO m => Int -> Bool -> m ()
tableSetColumnEnabled column_n v =
Raw.tableSetColumnEnabled (fromIntegral column_n) (bool 0 1 v)
-- | Wraps @ImGui::TableSetBgColor()@.
-- change the color of a cell, row, or column.
-- See 'ImGuiTableBgTarget' flags for details.
-- 'Nothing' sets the current row/column color
tableSetBgColor :: MonadIO m => ImGuiTableBgTarget -> ImU32 -> Maybe Int -> m ()
tableSetBgColor target color column_n =
Raw.tableSetBgColor target color (fromIntegral <$> column_n)
-- | Wraps @ImGui::TreeNode()@.
treeNode :: MonadIO m => String -> m Bool
@ -1257,10 +1515,25 @@ treePush label = liftIO do
withCString label Raw.treePush
-- | Wraps @ImGui::Selectable()@.
-- | Wraps @ImGui::Selectable()@ with default options.
selectable :: MonadIO m => String -> m Bool
selectable label = liftIO do
withCString label Raw.selectable
selectable = selectableWith defSelectableOptions
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
@ -1479,6 +1752,52 @@ withPopupModalOpen :: MonadUnliftIO m => String -> m () -> m ()
withPopupModalOpen popupId 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!).
--
-- Wraps @ImGui::OpenPopup()@
@ -1486,6 +1805,37 @@ openPopup :: MonadIO m => String -> m ()
openPopup popupId = liftIO do
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 Nothing k = k nullPtr

View File

@ -34,6 +34,7 @@ imguiContext = mempty
, ( TypeName "ImVec3", [t| ImVec3 |] )
, ( TypeName "ImVec4", [t| ImVec4 |] )
, ( TypeName "ImU32", [t| ImU32 |] )
, ( TypeName "ImGuiID", [t| ImGuiID |] )
, ( TypeName "ImWchar", [t| ImWchar |] )
, ( TypeName "ImDrawList", [t| ImDrawList |] )
, ( TypeName "ImGuiContext", [t| ImGuiContext |] )
@ -41,5 +42,6 @@ imguiContext = mempty
, ( TypeName "ImFontConfig", [t| ImFontConfig |] )
, ( TypeName "ImFontGlyphRangesBuilder", [t| ImFontGlyphRangesBuilder |] )
, ( TypeName "ImGuiListClipper", [t| ImGuiListClipper |] )
, ( TypeName "ImGuiTableSortSpecs", [t| ImGuiTableSortSpecs |] )
]
}

View File

@ -23,6 +23,7 @@ module DearImGui.GLFW (
-- $callbacks
, glfwWindowFocusCallback
, glfwCursorEnterCallback
, glfwCursorPosCallback
, glfwMouseButtonCallback
, glfwScrollCallback
, glfwKeyCallback
@ -108,6 +109,20 @@ glfwCursorEnterCallback window entered = liftIO do
where
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 window button action mods = liftIO do
[C.exp| void {

View File

@ -157,6 +157,28 @@ module DearImGui.Raw
, colorPicker3
, colorButton
-- * Tables
, beginTable
, endTable
, tableNextRow
, tableNextColumn
, tableSetColumnIndex
, tableSetupColumn
, tableSetupScrollFreeze
, tableHeadersRow
, tableHeader
, tableGetSortSpecs
, tableGetColumnCount
, tableGetColumnIndex
, tableGetRowIndex
, tableGetColumnName
, tableGetColumnFlags
, tableSetColumnEnabled
, tableSetBgColor
-- * Trees
, treeNode
, treePush
@ -197,7 +219,12 @@ module DearImGui.Raw
, beginPopupModal
, endPopup
, openPopup
, openPopupOnItemClick
, closeCurrentPopup
, beginPopupContextItem
, beginPopupContextWindow
, beginPopupContextVoid
, isPopupOpen
-- * ID stack/scopes
, pushIDInt
@ -1063,6 +1090,122 @@ colorButton descPtr refPtr = liftIO do
(0 /=) <$> [C.exp| bool { ColorButton( $(char* descPtr), *$(ImVec4* refPtr) ) } |]
-- | Wraps @ImGui::BeginTable()@.
beginTable :: MonadIO m => CString -> CInt -> ImGuiTableFlags -> Ptr ImVec2 -> CFloat -> m Bool
beginTable labelPtr column flags outerSizePtr innerWidth = liftIO do
(0 /=) <$> [C.exp| bool { BeginTable($(char* labelPtr), $(int column), $(ImGuiTableFlags flags), *$(ImVec2* outerSizePtr), $(float innerWidth)) } |]
-- | Only call 'endTable' if 'beginTable' returns true!
--
-- Wraps @ImGui::EndTable()@.
endTable :: MonadIO m => m ()
endTable = liftIO do
[C.exp| void { EndTable() } |]
-- | Wraps @ImGui::TableNextRow()@.
-- append into the first cell of a new row.
tableNextRow :: MonadIO m => ImGuiTableRowFlags -> CFloat -> m ()
tableNextRow flags minRowHeight = liftIO do
[C.exp| void { TableNextRow($(ImGuiTableRowFlags flags), $(float minRowHeight)) } |]
-- | Wraps @ImGui::TableNextColumn()@.
-- append into the next column (or first column of next row if currently in
-- last column). Return true when column is visible.
tableNextColumn :: MonadIO m => m Bool
tableNextColumn = liftIO do
(0 /=) <$> [C.exp| bool { TableNextColumn() } |]
-- | Wraps @ImGui::TableSetColumnIndex()@.
-- append into the specified column. Return true when column is visible.
tableSetColumnIndex :: MonadIO m => CInt -> m Bool
tableSetColumnIndex column= liftIO do
(0 /=) <$> [C.exp| bool { TableSetColumnIndex($(int column)) } |]
-- | Wraps @ImGui::TableSetupColumn()@.
tableSetupColumn :: MonadIO m => CString -> ImGuiTableColumnFlags -> CFloat -> ImGuiID-> m ()
tableSetupColumn labelPtr flags initWidthOrWeight userId = liftIO do
[C.exp| void { TableSetupColumn($(char* labelPtr), $(ImGuiTableColumnFlags flags), $(float initWidthOrWeight), $(ImGuiID userId)) } |]
-- | Wraps @ImGui::TableSetupScrollFreeze()@.
tableSetupScrollFreeze :: MonadIO m => CInt -> CInt -> m ()
tableSetupScrollFreeze cols rows = liftIO do
[C.exp| void { TableSetupScrollFreeze($(int cols), $(int rows)) } |]
-- | Wraps @ImGui::TableHeadersRow()@.
-- submit all headers cells based on data provided to 'tableSetupColumn'
-- + submit context menu
tableHeadersRow :: MonadIO m => m ()
tableHeadersRow = liftIO do
[C.exp| void { TableHeadersRow() } |]
-- | Wraps @ImGui::TableHeader()@.
-- submit one header cell manually (rarely used)
tableHeader :: MonadIO m => CString -> m ()
tableHeader labelPtr = liftIO do
[C.exp| void { TableHeader($(char* labelPtr)) } |]
-- | Wraps @ImGui::TableGetSortSpecs()@.
-- Low-level-Function. Better use the wrapper that outomatically conform
-- to the things described below
--
-- Tables: Sorting
-- - Call TableGetSortSpecs() to retrieve latest sort specs for the table.
-- NULL when not sorting.
-- - When 'SpecsDirty == true' you should sort your data. It will be true when
-- sorting specs have changed since last call, or the first time. Make sure
-- to set 'SpecsDirty = false' after sorting, else you may wastefully sort
-- your data every frame!
-- - Lifetime: don't hold on this pointer over multiple frames or past any
-- subsequent call to BeginTable().
tableGetSortSpecs :: MonadIO m => m (Maybe (Ptr ImGuiTableSortSpecs))
tableGetSortSpecs = liftIO do
ptr <- [C.exp| ImGuiTableSortSpecs* { TableGetSortSpecs() } |]
if ptr == nullPtr then
return Nothing
else
return $ Just ptr
-- | Wraps @ImGui::TableGetColumnCount()@.
tableGetColumnCount :: MonadIO m => m CInt
tableGetColumnCount = liftIO do
[C.exp| int { TableGetColumnCount() } |]
-- | Wraps @ImGui::TableGetColumnIndex()@.
tableGetColumnIndex :: MonadIO m => m CInt
tableGetColumnIndex = liftIO do
[C.exp| int { TableGetColumnIndex() } |]
-- | Wraps @ImGui::TableGetRowIndex()@.
tableGetRowIndex :: MonadIO m => m CInt
tableGetRowIndex = liftIO do
[C.exp| int { TableGetRowIndex() } |]
-- | Wraps @ImGui::TableGetColumnName
-- 'Nothing' returns the current column name
tableGetColumnName :: MonadIO m => Maybe CInt -> m CString
tableGetColumnName Nothing = tableGetColumnName (Just (-1))
tableGetColumnName (Just column_n) = liftIO do
[C.exp| const char* { TableGetColumnName($(int column_n)) } |]
-- | Wraps @ImGui::TableGetRowIndex()@.
-- 'Nothing' returns the current column flags
tableGetColumnFlags :: MonadIO m => Maybe CInt -> m ImGuiTableColumnFlags
tableGetColumnFlags Nothing = tableGetColumnFlags (Just (-1))
tableGetColumnFlags (Just column_n) = liftIO do
[C.exp| ImGuiTableColumnFlags { TableGetColumnFlags($(int column_n)) } |]
-- | Wraps @ImGui::TableSetColumnEnabled()@.
tableSetColumnEnabled :: MonadIO m => CInt -> CBool -> m ()
tableSetColumnEnabled column_n v = liftIO do
[C.exp| void { TableSetColumnEnabled($(int column_n), $(bool v)) } |]
-- | Wraps @ImGui::TableSetBgColor()@.
-- 'Nothing' sets the current row/column color
tableSetBgColor :: MonadIO m => ImGuiTableBgTarget -> ImU32 -> Maybe CInt -> m ()
tableSetBgColor target color Nothing = tableSetBgColor target color (Just (-1))
tableSetBgColor target color (Just column_n) = liftIO do
[C.exp| void { TableSetBgColor($(ImGuiTableBgTarget target), $(ImU32 color), $(int column_n)) } |]
-- | Wraps @ImGui::TreeNode()@.
treeNode :: (MonadIO m) => CString -> m Bool
treeNode labelPtr = liftIO do
@ -1081,10 +1224,17 @@ treePop = liftIO do
[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()@.
selectable :: (MonadIO m) => CString -> m Bool
selectable labelPtr = liftIO do
(0 /=) <$> [C.exp| bool { Selectable($(char* labelPtr)) } |]
selectable :: (MonadIO m) => CString -> CBool -> ImGuiSelectableFlags -> Ptr ImVec2 -> m Bool
selectable labelPtr selected flags size = liftIO do
(0 /=) <$> [C.exp| bool { Selectable($(char* labelPtr), $(bool selected), $(ImGuiSelectableFlags flags), *$(ImVec2 *size)) } |]
-- | Wraps @ImGui::ListBox()@.
@ -1253,6 +1403,16 @@ openPopup popupIdPtr = liftIO do
[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.
--
-- Wraps @ImGui::ClosePopup()@
@ -1260,6 +1420,36 @@ closeCurrentPopup :: (MonadIO m) => m ()
closeCurrentPopup = liftIO do
[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.).
--

View File

@ -412,8 +412,8 @@ addText_ (DrawList drawList) pos col text_begin text_end = liftIO do
}
|]
addText :: MonadIO m => DrawList -> Ptr ImFont -> CFloat -> Ptr ImVec2 -> ImU32 -> CString -> CString -> CFloat -> Ptr ImVec4 -> m ()
addText (DrawList drawList) fontPtr font_size pos col text_begin text_end wrap_width cpu_fine_clip_rect = liftIO do
addText :: MonadIO m => DrawList -> Ptr ImFont -> CFloat -> Ptr ImVec2 -> ImU32 -> CString -> CString -> CFloat -> CFloat -> Ptr ImVec4 -> m ()
addText (DrawList drawList) fontPtr font_size pos col text_begin text_end wrap_width text_align cpu_fine_clip_rect = liftIO do
[C.block|
void {
$(ImDrawList* drawList)->AddText(
@ -424,6 +424,7 @@ addText (DrawList drawList) fontPtr font_size pos col text_begin text_end wrap_w
$(char* text_begin),
$(char* text_end),
$(float wrap_width),
$(float text_align),
$(ImVec4* cpu_fine_clip_rect)
);
}

View File

@ -1,13 +1,23 @@
{-# LANGUAGE DuplicateRecordFields #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE CPP #-}
module DearImGui.Structs where
-- base
import Data.Word
( Word32, Word16 )
( Word32
#ifndef IMGUI_USE_WCHAR32
, Word16
#endif
)
import Foreign
( Storable(..), castPtr, plusPtr )
( Storable(..), castPtr, plusPtr, Ptr, Int16 )
import Foreign.C
( CInt, CBool )
import DearImGui.Enums
--------------------------------------------------------------------------------
data ImVec2 = ImVec2 { x, y :: {-# unpack #-} !Float }
@ -92,9 +102,85 @@ data ImDrawList
-- | 'DearImGui.Raw.ListClipper.ListClipper' pointer tag.
data ImGuiListClipper
-- | A unique ID used by widgets (typically the result of hashing a stack of string)
-- unsigned Integer (same as ImU32)
type ImGuiID = Word32
-- | 32-bit unsigned integer (often used to store packed colors).
type ImU32 = Word32
type ImS16 = Int16
-- | Single wide character (used mostly in glyph management)
#ifdef IMGUI_USE_WCHAR32
type ImWchar = Word32
#else
type ImWchar = Word16
-- FIXME: consider IMGUI_USE_WCHAR32
#endif
--------------------------------------------------------------------------------
-- | Sorting specifications for a table (often handling sort specs for a single column, occasionally more)
-- Obtained by calling TableGetSortSpecs().
-- When @SpecsDirty == true@ you can sort your data. It will be true with sorting specs have changed since last call, or the first time.
-- Make sure to set @SpecsDirty = false@ after sorting, else you may wastefully sort your data every frame!
data ImGuiTableSortSpecs = ImGuiTableSortSpecs
{ imGuiTableColumnSortSpecs :: Ptr ImGuiTableColumnSortSpecs
, imGuiTableSortSpecsCount :: CInt
, imGuiTableSortSpecsDirty :: CBool
}
instance Storable ImGuiTableSortSpecs where
sizeOf _ = sizeOf (undefined :: Ptr ImGuiTableColumnSortSpecs)
+ sizeOf (undefined :: CInt)
+ sizeOf (undefined :: CBool)
alignment _ = 0
poke ptr (ImGuiTableSortSpecs s c d) = do
poke ( castPtr ptr ) s
poke ( castPtr ptr `plusPtr` sizeOf s) c
poke ((castPtr ptr `plusPtr` sizeOf s)
`plusPtr` sizeOf c) d
peek ptr = do
s <- peek ( castPtr ptr )
c <- peek ( castPtr ptr `plusPtr` sizeOf s)
d <- peek ((castPtr ptr `plusPtr` sizeOf s)
`plusPtr` sizeOf c)
return (ImGuiTableSortSpecs s c d)
-- | Sorting specification for one column of a table
data ImGuiTableColumnSortSpecs = ImGuiTableColumnSortSpecs
{ imGuiTableColumnSortUserID :: ImGuiID -- ^ User id of the column (if specified by a TableSetupColumn() call)
, imGuiTableColumnSortColumnIndex :: ImS16 -- ^ Index of the column
, imGuiTableColumnSortOrder :: ImS16 -- ^ Index within parent ImGuiTableSortSpecs (always stored in order starting from 0, tables sorted on a single criteria will always have a 0 here)
, imGuiTableColumnSortDirection :: ImGuiSortDirection -- ^ 'ImGuiSortDirection_Ascending' or 'ImGuiSortDirection_Descending'
} deriving (Show, Eq)
instance Storable ImGuiTableColumnSortSpecs where
sizeOf _ = sizeOf (undefined :: ImGuiID)
+ sizeOf (undefined :: ImS16)
+ sizeOf (undefined :: ImS16)
+ sizeOf (undefined :: ImGuiSortDirection)
alignment _ = 0
poke ptr (ImGuiTableColumnSortSpecs a b c d) = do
poke ( castPtr ptr ) a
poke ( castPtr ptr `plusPtr` sizeOf a) b
poke (( castPtr ptr `plusPtr` sizeOf a)
`plusPtr` sizeOf b) c
poke (((castPtr ptr `plusPtr` sizeOf a)
`plusPtr` sizeOf b)
`plusPtr` sizeOf c) d
peek ptr = do
a <- peek ( castPtr ptr )
b <- peek ( castPtr ptr `plusPtr` sizeOf a)
c <- peek (( castPtr ptr `plusPtr` sizeOf a)
`plusPtr` sizeOf b)
d <- peek (((castPtr ptr `plusPtr` sizeOf a)
`plusPtr` sizeOf b)
`plusPtr` sizeOf c)
return (ImGuiTableColumnSortSpecs a b c d)

View File

@ -19,6 +19,8 @@ module DearImGui.Vulkan
, vulkanCreateFontsTexture
, vulkanDestroyFontUploadObjects
, vulkanSetMinImageCount
, vulkanAddTexture
)
where
@ -32,7 +34,7 @@ import Foreign.Marshal.Alloc
import Foreign.Ptr
( FunPtr, Ptr, freeHaskellFunPtr, nullPtr )
import Foreign.Storable
( Storable(poke) )
( poke )
-- inline-c
import qualified Language.C.Inline as C
@ -92,7 +94,7 @@ withVulkan initInfo renderPass action =
( \ ( _, initResult ) -> action initResult )
-- | Wraps @ImGui_ImplVulkan_Init@.
--
--
-- Use 'vulkanShutdown' to clean up on shutdown.
-- Prefer using 'withVulkan' when possible, as it automatically handles cleanup.
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 minImageCount = liftIO do
[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 "VkResult" , [t| Vulkan.Result |] )
, ( 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