Compare commits

..

57 Commits
v1.2.1 ... main

Author SHA1 Message Date
Jason Shipman
b48ef7904b
Link against system-cxx-std-lib for GHC 9.4+ (#197)
* Link against system-cxx-std-lib for GHC 9.4+

* Drop OS checks for linking with stdc++ when GHC < 9.4
2024-02-23 14:43:53 +02:00
Jason Shipman
f6cad45dab
Add support for disabled blocks (#196) 2024-02-20 19:20:46 +00:00
Jason Shipman
49f7bb245e
Add support for dispatching raw SDL events to Dear ImGui (#195) 2024-02-20 21:16:37 +02:00
svært
47402c1a93
Update README (#194) 2024-02-04 18:24:06 +00:00
Jason Shipman
4d1c66e9a1
Add support for SDL2 Renderer backend (#193)
* Add DearImGui.Raw.framerate
* Add DearImGui.withCloseableWindow
* Closes #191: Add support for SDL2 Renderer backend
* Add sdl-renderer flag to protect against older SDL versions that do not have SDL_RenderGeometry
2023-12-15 15:31:04 +02:00
Alexander Bondarenko
7ec260c359
Bump megaparsec (#190) 2023-09-10 18:55:24 +00:00
Alexander Bondarenko
bab4d769ea
V2.2.0 (#189)
* Upgrade upstream and prepare 2.2.0
* Update vulkan example
2023-09-10 13:24:33 +00:00
Alexander Bondarenko
eec8b57ce8
Use FIFO for vulkan demo (#188) 2023-09-04 10:10:10 +00:00
Carter Tazio Schonwald
d40fa4f6db
fix intem->item (#184) 2023-08-09 13:03:43 +03:00
Alexander Bondarenko
8df98e075c
Fix TabItem flags type (#183)
Resolves #175
2023-07-20 16:42:11 +00:00
Alexander Bondarenko
6dbb455d62
Fix vulkan init wrapper (#180)
`init_info` got dynamic render flag, which is a breaking change with its default value.
Setting it to `false` will fix validation errors coming from misconfiguration.
2023-07-20 16:25:02 +00:00
ddaf41bf88
Upgrade imgui to v1.89.7 2023-07-17 19:13:23 +03:00
Tristan de Cacqueray
8368192370
Allow base-4.19 for ghc-9.6 (#177)
Co-authored-by: Alexander Bondarenko <486682+dpwiz@users.noreply.github.com>
2023-07-02 21:54:03 +00:00
Tristan de Cacqueray
ea3ad959f9
Add getCursorPos (#176) 2023-07-03 00:48:44 +03:00
Tristan de Cacqueray
0cc654f190
Update bound for ghc-9.6 (#174)
* Update bound for ghc-9.6

* Update ci action versions
2023-05-07 17:44:13 +03:00
romes
8697aa3a0a
Expose DearImGui.Raw.Context (#172) 2023-01-15 15:27:15 +02:00
Alexander Bondarenko
802bdb72fe
Fix cabal flag for image example (#170) 2022-12-24 12:21:51 +02:00
Alexander Bondarenko
69a463d98b
Fix vulkan versions to a fresh set (#168)
vulkan, vulkan-utils and VMA can be too old/new for each other.
This cuts a fresh, known-to-work set of lower bounds.
2022-12-12 18:33:48 +00:00
Alexander Bondarenko
9bb66f0113
Fix the text fix and prepare 2.1.3 (#167) 2022-12-12 19:57:54 +02:00
romes
68e30d98ad
Fix off-by-one bug in string null termination (#166)
Backport withCString fix and use text version when available
2022-12-12 18:20:39 +03:00
Tristan de Cacqueray
52142bbf7e
Add formatPtr to Raw.dragFloat* and Raw.sliderFloat* (#165) 2022-12-05 17:47:21 +03:00
Tristan de Cacqueray
d933248a2c
This change fixes the high level API to use the right Raw call (#164) 2022-12-02 17:50:04 +02:00
Alexander Bondarenko
258777f8c7
Fix sdl flag in cabal.project (#163) 2022-11-30 17:08:06 +00:00
Alexander Bondarenko
cd99938f97
Prepare v2.1.2 (#162) 2022-11-30 16:32:44 +00:00
Tristan de Cacqueray
48486ee8c2
Add setNextItemOpen (#161)
This change enables starting a new TreeNode open.
2022-11-28 15:56:27 +03:00
Tristan de Cacqueray
a2feb73fa5
Fix the glfw example build condition (#159)
The example needs the opengl2 flag.
2022-11-22 21:13:18 +02:00
Tristan de Cacqueray
051a17a1c5
Add plotLines (#158) 2022-11-20 17:57:15 +02:00
Alexander Bondarenko
9dac0f9fbe
Prepare 2.1.1 (#157) 2022-08-30 21:13:04 +00:00
Axis Sivitz
dab5937eee
Fix compilation on MacOS / GHC 8.10.7 (#156)
Fixes errors along the lines of:
dear-imgui  > [ 2 of 17] Compiling DearImGui.GLFW
dear-imgui  > error: unknown type name 'constexpr'

So the "-std=c++11" option is not being passed to the C++ compiler on
MacOS.
The issue seems related to https://github.com/haskell/cabal/issues/6421
2022-08-30 21:57:08 +03:00
Alexander Bondarenko
7795b3d838
Prepare 2.1.0 (#153)
Breaking change in upstream.
2022-07-25 18:14:21 +00:00
Alexander Bondarenko
3a5abb2037
Update to 1.88 (#152) 2022-07-25 17:58:22 +00:00
06eb052cc5
added flag_ImDrawIdx (#151)
Co-authored-by: Stefan Dresselhaus <stefan@dresselhaus.cloud>
2022-07-23 15:42:13 +03:00
Alexander Bondarenko
cf87988336
Prepare 2.0.0 (#148) 2022-05-15 23:37:43 +03:00
Alexander Bondarenko
3c1d381c14
Replace String arguments with Text (#138)
Shave a few allocations and pointer-chasing due to conversion.
2022-05-15 22:41:10 +03:00
Alexander Bondarenko
04fe618871
Prepare 1.5.0 (#140) 2022-03-28 13:22:11 +00:00
Alexander Bondarenko
08d4b423ad
Fix GHC-9.2 build (#145) 2022-03-28 13:04:22 +00:00
Alexander Bondarenko
7d4f3a8b93
Make value and read-only range types distinct (#143)
Fixes #142
2022-03-23 21:22:05 +03:00
Alexander Bondarenko
bc590d97c5
Tweak tables and add an example (#139)
Previously: #135
2022-03-22 22:36:19 +03:00
e5969f6b35
implementation of ImGui Tables (#135) 2022-03-11 16:48:11 +03:00
f066d03017
added options to selectable (#137) 2022-03-10 15:17:42 +00:00
Alexander Bondarenko
fc307a4d6e
Add remaining popup wrappers (#136)
- BeginPopupContextItem
- BeginPopupContextWindow
- BeginPopupContextVoid

For #132
2022-03-10 11:34:13 +03:00
Alexander Bondarenko
4517af8123
Add isPopupOpen and wrappers (#134) 2022-03-09 21:08:54 +03:00
b837d583a5
added openPopupOnItemClick (#133) 2022-02-25 17:28:53 +00:00
Alexander Bondarenko
67e169dc35
Prepare 1.4.0 (#129) 2022-02-13 19:31:45 +03:00
Alexander Bondarenko
ae3fdb8bc3
Add new GLFW callback from 1.87 (#128) 2022-02-13 16:12:15 +00:00
Alexander Bondarenko
ccdff36774
Add wchar32 and disable-obsolete flags (#127) 2022-02-13 16:05:49 +00:00
Alexander Bondarenko
af6ba9e989
Add image support for vulkan backend (#126) 2022-02-13 14:24:08 +00:00
Alexander Bondarenko
dc11fad07f
Update to 1.87 (#125) 2022-02-13 00:26:39 +03:00
Alexander Bondarenko
265d143261
Prepare 1.3.1 (#123) 2022-01-31 10:56:12 +03:00
Alexander Bondarenko
0877843619
Update upstream to 1.86 (#122) 2022-01-19 23:36:33 +03:00
Alexander Bondarenko
a95d95bb65
Prepare 1.3.0 (#120) 2021-12-22 17:40:24 +03:00
Alexander Bondarenko
23efa7cb02
Fill in changelog for 1.2.1 (#119) 2021-12-22 11:56:55 +00:00
Mikhail Chekan
bb94341ad5
Extended font & glyph support (#114)
* Separate font utils, add glyph support (#113)
* Implement font glyph ranges builder
* Implement raw font config binds
* Implement font atlas module
* Rewrite font altas rebuilder in Managed
2021-12-22 13:28:46 +03:00
Alexander Bondarenko
13e68242a1
Update unordered-containers upper limit (#117) 2021-12-19 18:25:11 +03:00
Vladimir Serov
2469623f2e
Fix CI (#118) 2021-12-19 17:32:28 +03:00
Alexander Bondarenko
3087a99044
Allow megaparsec 9.2 (#112)
Closes #106
2021-10-30 18:57:15 +00:00
Alexander Bondarenko
f74cd218c5
Bump imgui to 1.85 (#111)
Closes #110
2021-10-30 18:49:39 +00:00
36 changed files with 3482 additions and 587 deletions

View File

@ -4,18 +4,19 @@ jobs:
build:
runs-on: ubuntu-latest
steps:
- uses: actions/checkout@v2.3.4
- uses: actions/checkout@v2.4.0
with:
persist-credentials: false
submodules: true
- uses: cachix/install-nix-action@v12
- uses: cachix/install-nix-action@v20
with:
nix_path: nixpkgs=channel:nixos-unstable
- uses: cachix/cachix-action@v8
- uses: cachix/cachix-action@v12
with:
name: hs-dear-imgui
authToken: '${{ secrets.CACHIX_AUTH_TOKEN }}'
- run: nix-build --version
- run: nix-build -A hsPkgs.dear-imgui.components.exes

View File

@ -1,8 +1,72 @@
# Changelog for dear-imgui
## [2.2.0]
- `imgui` updated to [1.89.9].
- Update bounds for ghc-9.6.
- Exposed `DearImGui.Raw.Context`.
- Added `getCursorPos``.
- Fix TabItem flags type.
## [2.1.3]
- Fixed off-by-1 in internal Text wrapper.
- Fixed sliderFloat* Raw calls
- Added `formatPtr` to Raw.dragFloat* and Raw.sliderFloat*
## [2.1.2]
- Fixed glfw example build flags.
- Added `plotLines`.
- Added `setNextItemOpen`.
## [2.1.1]
- Build flag fix for MacOS.
## [2.1.0]
- `imgui` updated to [1.88].
* Breaking: `ImGuiKeyModFlags` renamed to `ImGuiModFlags`.
## [2.0.0]
- `String` arguments replaced with `Text`.
* Upgrading to `text-2` recommended to reap the UTF-8 benefits.
## [1.5.0]
- Added table wrappers.
- Added popup wrappers.
- Added `selectableWith`/`SelectableOptions` to expose optional arguments.
- Fix GHC-9.2 compatibility.
## [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.
- Removed old font atlas functions from `DearImGui` and `DearImGui.Raw`.
## [1.2.2]
- `imgui` updated to [1.85].
## [1.2.1]
- Added `DearImGui.Raw.DrawList` for drawing primitives.
- Added `DearImGui.Raw.IO` with attribute setters.
- Added `DearImGui.Raw.ListClipper` for efficient list viewports.
## [1.2.0]
@ -18,7 +82,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.
@ -33,10 +97,29 @@
## [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
[1.0.2]: https://github.com/haskell-game/dear-imgui.hs/tree/v1.0.2
[1.1.0]: https://github.com/haskell-game/dear-imgui.hs/tree/v1.1.0
[1.2.0]: https://github.com/haskell-game/dear-imgui.hs/tree/v1.2.0
[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.5.0]: https://github.com/haskell-game/dear-imgui.hs/tree/v1.5.0
[2.0.0]: https://github.com/haskell-game/dear-imgui.hs/tree/v2.0.0
[2.1.0]: https://github.com/haskell-game/dear-imgui.hs/tree/v2.1.0
[2.1.1]: https://github.com/haskell-game/dear-imgui.hs/tree/v2.1.1
[2.1.2]: https://github.com/haskell-game/dear-imgui.hs/tree/v2.1.2
[2.1.3]: https://github.com/haskell-game/dear-imgui.hs/tree/v2.1.3
[2.2.0]: https://github.com/haskell-game/dear-imgui.hs/tree/v2.2.0
[1.89.9]: https://github.com/ocornut/imgui/releases/tag/v1.89.9
[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

11
Main.hs
View File

@ -10,6 +10,7 @@ import Data.IORef
import qualified Data.Vector as Vector
import DearImGui
import DearImGui.OpenGL3
import DearImGui.Internal.Text (pack)
import DearImGui.SDL
import DearImGui.SDL.OpenGL
import Control.Exception
@ -78,10 +79,10 @@ loop window checked color slider r pos size' selected tab1Ref tab2Ref = do
text "Hello!"
beginTabBar "My tab bar" ImGuiTabBarFlags_Reorderable >>= whenTrue do
beginTabItem "Tab 1" tab1Ref ImGuiTabBarFlags_None >>= whenTrue do
beginTabItem "Tab 1" tab1Ref ImGuiTabItemFlags_None >>= whenTrue do
text "Tab 1 is currently selected."
endTabItem
beginTabItem "Tab 2" tab2Ref ImGuiTabBarFlags_None >>= whenTrue do
beginTabItem "Tab 2" tab2Ref ImGuiTabItemFlags_None >>= whenTrue do
text "Tab 2 is selected now."
endTabItem
reOpen <- tabItemButton "ReopenTabs" ImGuiTabItemFlags_Trailing
@ -134,18 +135,18 @@ loop window checked color slider r pos size' selected tab1Ref tab2Ref = do
text "ListClipper"
withChildOpen "##fixed" (ImVec2 0 200) True ImGuiWindowFlags_None do
let lotsOfItems = Vector.generate 50 (mappend "Item " . show)
let lotsOfItems = Vector.generate 50 (pack . mappend "Item " . show)
withListClipper Nothing lotsOfItems text
text "ListClipper, Haskell-powered"
withChildOpen "##infinite" (ImVec2 0 200) True ImGuiWindowFlags_None do
let infiniteItems = map (mappend "Item " . show) [0 :: Int ..]
let infiniteItems = map (pack . mappend "Item " . show) [0 :: Int ..]
withListClipper Nothing infiniteItems text
text "Ethereal ListClipper"
withChildOpen "##ethereal" (ImVec2 0 200) True ImGuiWindowFlags_None do
withListClipper Nothing (ClipRange (0 :: Int) 1000) $
text . mappend "Item " . show
text . pack . mappend "Item " . show
plotHistogram "A histogram" [ 10, 10, 20, 30, 90 ]

View File

@ -31,29 +31,30 @@ package dear-imgui
With this done, the following module is the "Hello, World!" of ImGui:
``` haskell
{-# language BlockArguments #-}
{-# language LambdaCase #-}
{-# language OverloadedStrings #-}
module Main ( main ) where
import Control.Exception
import Control.Monad.IO.Class
import Control.Monad.Managed
import DearImGui
import DearImGui.OpenGL2
import DearImGui.OpenGL3
import DearImGui.SDL
import DearImGui.SDL.OpenGL
import Graphics.GL
import SDL
import Control.Monad.Managed
import Control.Monad.IO.Class ()
import Control.Monad (when, unless)
import Control.Exception (bracket, bracket_)
main :: IO ()
main = do
-- Initialize SDL
initializeAll
runManaged do
-- Create a window using SDL. As we're using OpenGL, we need to enable OpenGL too.
runManaged $ do
-- Create a window using SDL; as we're using OpenGL, we enable OpenGL too
window <- do
let title = "Hello, Dear ImGui!"
let config = defaultWindow { windowGraphicsContext = OpenGLContext defaultOpenGL }
@ -61,64 +62,59 @@ main = do
-- Create an OpenGL context
glContext <- managed $ bracket (glCreateContext window) glDeleteContext
-- Create an ImGui context
_ <- managed $ bracket createContext destroyContext
-- Initialize ImGui's SDL2 backend
_ <- managed_ $ bracket_ (sdl2InitForOpenGL window glContext) sdl2Shutdown
managed_ $ bracket_ (sdl2InitForOpenGL window glContext) sdl2Shutdown
-- Initialize ImGui's OpenGL backend
_ <- managed_ $ bracket_ openGL2Init openGL2Shutdown
managed_ $ bracket_ openGL3Init openGL3Shutdown
liftIO $ mainLoop window
mainLoop :: Window -> IO ()
mainLoop window = unlessQuit do
mainLoop window = unlessQuit $ do
-- Tell ImGui we're starting a new frame
openGL2NewFrame
openGL3NewFrame
sdl2NewFrame
newFrame
-- Build the GUI
withWindowOpen "Hello, ImGui!" do
withWindowOpen "Hello, ImGui!" $ do
-- Add a text widget
text "Hello, ImGui!"
-- Add a button widget, and call 'putStrLn' when it's clicked
button "Clickety Click" >>= \case
False -> return ()
True -> putStrLn "Ow!"
button "Clickety Click" >>= \clicked ->
when clicked $ putStrLn "Ow!"
-- Show the ImGui demo window
showDemoWindow
-- Render
glClear GL_COLOR_BUFFER_BIT
render
openGL2RenderDrawData =<< getDrawData
openGL3RenderDrawData =<< getDrawData
glSwapWindow window
mainLoop window
where
-- Process the event loop
unlessQuit action = do
shouldQuit <- checkEvents
if shouldQuit then pure () else action
-- Process the event loop
unlessQuit action = do
shouldQuit <- gotQuitEvent
unless shouldQuit action
checkEvents = do
pollEventWithImGui >>= \case
Nothing ->
return False
Just event ->
(isQuit event ||) <$> checkEvents
gotQuitEvent = do
ev <- pollEventWithImGui
isQuit event =
SDL.eventPayload event == SDL.QuitEvent
case ev of
Nothing ->
return False
Just event ->
(isQuit event ||) <$> gotQuitEvent
isQuit event =
eventPayload event == QuitEvent
```
# Hacking

View File

@ -1,4 +1,4 @@
packages: *.cabal
package dear-imgui
flags: +sdl2 +glfw +opengl2 +opengl3 +vulkan +examples
flags: +sdl +glfw +opengl2 +opengl3 +vulkan +examples
ghc-options: -Wall -Wcompat -fno-warn-unused-do-bind

View File

@ -1,7 +1,7 @@
cabal-version: 3.0
name: dear-imgui
version: 1.2.1
version: 2.2.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
@ -95,6 +94,15 @@ flag sdl
manual:
True
flag sdl-renderer
description:
Enable SDL Renderer backend (requires the SDL_RenderGeometry function available in SDL 2.0.18+).
The sdl configuration flag must also be enabled when using this flag.
default:
False
manual:
True
flag glfw
description:
Enable GLFW backend.
@ -111,10 +119,37 @@ 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
flag use-ImDrawIdx32
description:
Use 32-bit vertex indices (default is 16-bit) is one way to allow large meshes with more than 64K vertices.
Your renderer backend will need to support it (most example renderer backends support both 16/32-bit indices).
Another way to allow large meshes while keeping 16-bit indices is to handle ImDrawCmd::VtxOffset in your renderer.
Read about ImGuiBackendFlags_RendererHasVtxOffset for details.
default:
True
manual:
True
common common
build-depends:
base
>= 4.12 && < 4.17
>= 4.12 && < 4.19
default-language:
Haskell2010
@ -124,12 +159,17 @@ library
src
exposed-modules:
DearImGui
DearImGui.FontAtlas
DearImGui.Internal.Text
DearImGui.Raw
DearImGui.Raw.DrawList
DearImGui.Raw.ListClipper
DearImGui.Raw.Font
DearImGui.Raw.Font.Config
DearImGui.Raw.Font.GlyphRanges
DearImGui.Raw.IO
DearImGui.Raw.ListClipper
DearImGui.Raw.Context
other-modules:
DearImGui.Context
DearImGui.Enums
DearImGui.Structs
cxx-options: -std=c++11
@ -139,8 +179,10 @@ library
imgui/imgui_draw.cpp
imgui/imgui_tables.cpp
imgui/imgui_widgets.cpp
extra-libraries:
stdc++
if impl(ghc >= 9.4)
build-depends: system-cxx-std-lib
else
extra-libraries: stdc++
include-dirs:
imgui
build-depends:
@ -152,6 +194,22 @@ library
, StateVar
, unliftio
, vector
, text
if os(darwin)
ghc-options:
-optcxx-std=c++11
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(use-ImDrawIdx32)
cxx-options: "-DImDrawIdx=unsigned int"
cpp-options: "-DImDrawIdx=unsigned int"
if flag(opengl2)
exposed-modules:
@ -196,7 +254,7 @@ library
build-depends:
sdl2
cxx-sources:
imgui/backends/imgui_impl_sdl.cpp
imgui/backends/imgui_impl_sdl2.cpp
if os(windows) || os(darwin)
extra-libraries:
@ -213,6 +271,12 @@ library
exposed-modules:
DearImGui.SDL.Vulkan
if flag(sdl-renderer)
exposed-modules:
DearImGui.SDL.Renderer
cxx-sources:
imgui/backends/imgui_impl_sdlrenderer2.cpp
if flag(glfw)
exposed-modules:
DearImGui.GLFW
@ -244,7 +308,7 @@ library dear-imgui-generator
, DearImGui.Generator.Types
build-depends:
template-haskell
>= 2.15 && < 2.19
>= 2.15 && < 2.21
, containers
^>= 0.6.2.1
, directory
@ -254,22 +318,22 @@ library dear-imgui-generator
, inline-c
>= 0.9.0.0 && < 0.10
, megaparsec
>= 9.0 && < 9.1
>= 9.0 && < 9.4
, parser-combinators
>= 1.2.0 && < 1.4
, scientific
>= 0.3.6.2 && < 0.3.8
, text
>= 1.2.4 && < 1.3
>= 1.2.4 && < 2.1
, th-lift
>= 0.7 && < 0.9
, transformers
>= 0.5.6 && < 0.6
>= 0.5.6 && < 0.7
, unordered-containers
>= 0.2.11 && < 0.2.15
>= 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))
@ -278,33 +342,49 @@ 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
if (!flag(examples) || !flag(glfw) || !flag(opengl2))
buildable: False
else
build-depends: base, GLFW-b, gl, dear-imgui, managed
build-depends: base, GLFW-b, gl, dear-imgui, managed, text
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
if (!flag(examples) || !flag(sdl) || !flag(opengl2))
buildable: False
executable image
import: common, build-flags
main-is: Image.hs
hs-source-dirs: examples/sdl
build-depends: sdl2, gl, dear-imgui, managed, vector
executable fonts
import: common, exe-flags
main-is: Main.hs
hs-source-dirs: examples/fonts
build-depends: sdl2, gl, dear-imgui, managed
if (!flag(examples) || !flag(sdl) || !flag(opengl2))
buildable: False
executable image
import: common, exe-flags
main-is: Image.hs
hs-source-dirs: examples/sdl
build-depends: sdl2, gl, dear-imgui, managed, vector
if (!flag(examples) || !flag(sdl) || !flag(opengl3))
buildable: False
executable sdlrenderer
import: common, exe-flags
main-is: Renderer.hs
hs-source-dirs: examples/sdl
build-depends: sdl2, dear-imgui, managed, text
if (!flag(examples) || !flag(sdl) || !flag(sdl-renderer))
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
@ -315,26 +395,29 @@ executable vulkan
build-depends:
dear-imgui
, bytestring
>= 0.10.10.0 && < 0.12
>= 0.10.10.0 && < 0.13
, containers
^>= 0.6.2.1
>= 0.6.2.1 && < 0.7
, logging-effect
^>= 1.3.12
>= 1.3.12 && < 1.5
, resourcet
^>= 1.2.4.2
>= 1.2.4.2 && < 1.3
, sdl2
^>= 2.5.3.0
, text-short
^>= 0.1.3
>= 2.5.3.0 && < 2.6
, text
>= 1.2.4 && < 2.1
, transformers
^>= 0.5.6.2
>= 0.5.6 && < 0.7
, unliftio
>= 0.2.13 && < 0.2.19
>= 0.2.13 && < 0.3
, unliftio-core
^>= 0.2.0.1
>= 0.2.0.1 && < 0.3
, vector
^>= 0.12.1.2
>= 0.12.1.2 && < 0.14
, vulkan
^>= 3.9
>= 3.12
, vulkan-utils
^>= 0.4.1
>= 0.5
, VulkanMemoryAllocator
>= 0.7.1
, JuicyPixels

View File

@ -1,29 +1,30 @@
-- NOTE: If this is file is edited, please also copy and paste it into
-- README.md.
{-# language BlockArguments #-}
{-# language LambdaCase #-}
{-# language OverloadedStrings #-}
module Main ( main ) where
import Control.Exception
import Control.Monad.IO.Class
import Control.Monad.Managed
import DearImGui
import DearImGui.OpenGL2
import DearImGui.OpenGL3
import DearImGui.SDL
import DearImGui.SDL.OpenGL
import Graphics.GL
import SDL
import Control.Monad.Managed
import Control.Monad.IO.Class ()
import Control.Monad (when, unless)
import Control.Exception (bracket, bracket_)
main :: IO ()
main = do
-- Initialize SDL
initializeAll
runManaged do
-- Create a window using SDL. As we're using OpenGL, we need to enable OpenGL too.
runManaged $ do
-- Create a window using SDL; as we're using OpenGL, we enable OpenGL too
window <- do
let title = "Hello, Dear ImGui!"
let config = defaultWindow { windowGraphicsContext = OpenGLContext defaultOpenGL }
@ -31,61 +32,56 @@ main = do
-- Create an OpenGL context
glContext <- managed $ bracket (glCreateContext window) glDeleteContext
-- Create an ImGui context
_ <- managed $ bracket createContext destroyContext
-- Initialize ImGui's SDL2 backend
_ <- managed_ $ bracket_ (sdl2InitForOpenGL window glContext) sdl2Shutdown
managed_ $ bracket_ (sdl2InitForOpenGL window glContext) sdl2Shutdown
-- Initialize ImGui's OpenGL backend
_ <- managed_ $ bracket_ openGL2Init openGL2Shutdown
managed_ $ bracket_ openGL3Init openGL3Shutdown
liftIO $ mainLoop window
mainLoop :: Window -> IO ()
mainLoop window = unlessQuit do
mainLoop window = unlessQuit $ do
-- Tell ImGui we're starting a new frame
openGL2NewFrame
openGL3NewFrame
sdl2NewFrame
newFrame
-- Build the GUI
withWindowOpen "Hello, ImGui!" do
withWindowOpen "Hello, ImGui!" $ do
-- Add a text widget
text "Hello, ImGui!"
-- Add a button widget, and call 'putStrLn' when it's clicked
button "Clickety Click" >>= \case
False -> return ()
True -> putStrLn "Ow!"
button "Clickety Click" >>= \clicked ->
when clicked $ putStrLn "Ow!"
-- Show the ImGui demo window
showDemoWindow
-- Render
glClear GL_COLOR_BUFFER_BIT
render
openGL2RenderDrawData =<< getDrawData
openGL3RenderDrawData =<< getDrawData
glSwapWindow window
mainLoop window
where
-- Process the event loop
unlessQuit action = do
shouldQuit <- checkEvents
if shouldQuit then pure () else action
-- Process the event loop
unlessQuit action = do
shouldQuit <- gotQuitEvent
unless shouldQuit action
checkEvents = do
pollEventWithImGui >>= \case
Nothing ->
return False
Just event ->
(isQuit event ||) <$> checkEvents
gotQuitEvent = do
ev <- pollEventWithImGui
isQuit event =
SDL.eventPayload event == SDL.QuitEvent
case ev of
Nothing ->
return False
Just event ->
(isQuit event ||) <$> gotQuitEvent
isQuit event =
eventPayload event == QuitEvent

150
examples/fonts/Main.hs Normal file
View File

@ -0,0 +1,150 @@
{-# language BlockArguments #-}
{-# language LambdaCase #-}
{-# language OverloadedStrings #-}
{-# language RecordWildCards #-}
{-# language NamedFieldPuns #-}
{-# language DeriveTraversable #-}
{- | Font usage example.
Loads two non-standard fonts
This example uses NotoSansJP-Regular.otf from Google Fonts
Licensed under the SIL Open Font License, Version 1.1
https://fonts.google.com/noto/specimen/Noto+Sans+JP
-}
module Main ( main ) where
import Control.Exception
import Control.Monad
import Control.Monad.IO.Class
import Control.Monad.Managed
import Data.IORef
import DearImGui
import qualified DearImGui.FontAtlas as FontAtlas
import DearImGui.OpenGL2
import DearImGui.SDL
import DearImGui.SDL.OpenGL
import Graphics.GL
import SDL
-- Rebuild syntax enables us to keep fonts in any
-- traversable type, so let's make our life a little easier.
-- But feel free to use lists or maps.
data FontSet a = FontSet
{ droidFont :: a
, defaultFont :: a
, notoFont :: a
}
deriving (Functor, Foldable, Traversable)
main :: IO ()
main = do
-- Window initialization is similar to another examples.
initializeAll
runManaged do
window <- do
let title = "Hello, Dear ImGui!"
let config = defaultWindow { windowGraphicsContext = OpenGLContext defaultOpenGL }
managed $ bracket (createWindow title config) destroyWindow
glContext <- managed $ bracket (glCreateContext window) glDeleteContext
_ <- managed $ bracket createContext destroyContext
_ <- managed_ $ bracket_ (sdl2InitForOpenGL window glContext) sdl2Shutdown
_ <- managed_ $ bracket_ openGL2Init openGL2Shutdown
-- We use high-level syntax to build font atlas and
-- get handles to use in the main loop.
fontSet <- FontAtlas.rebuild FontSet
{ -- The first mentioned font is loaded first
-- and set as a global default.
droidFont =
FontAtlas.FromTTF
"./imgui/misc/fonts/DroidSans.ttf"
15
Nothing
FontAtlas.Cyrillic
-- You also may use a default hardcoded font for
-- some purposes (i.e. as fallback)
, defaultFont =
FontAtlas.DefaultFont
-- To optimize atlas size, use ranges builder and
-- provide source localization data.
, notoFont =
FontAtlas.FromTTF
"./examples/fonts/NotoSansJP-Regular.otf"
20
Nothing
( FontAtlas.RangesBuilder $ mconcat
[ FontAtlas.addRanges FontAtlas.Latin
, FontAtlas.addText "私をクリックしてください"
, FontAtlas.addText "こんにちは"
]
)
}
liftIO $ do
fontFlag <- newIORef False
mainLoop window do
let FontSet{..} = fontSet
withWindowOpen "Hello, ImGui!" do
-- To use a font for widget text, you may either put it
-- into a 'withFont' block:
withFont defaultFont do
text "Hello, ImGui!"
text "Привет, ImGui!"
-- ...or you can explicitly push and pop a font.
-- Though it's not recommended.
toggled <- readIORef fontFlag
when toggled $
pushFont notoFont
-- Some of those are only present in Noto font range
-- and will render as `?`s.
text "こんにちは, ImGui!"
let buttonText = if toggled then "私をクリックしてください" else "Click Me!"
button buttonText >>= \clicked ->
when clicked $
modifyIORef' fontFlag not
when toggled
popFont
showDemoWindow
mainLoop :: Window -> IO () -> IO ()
mainLoop window frameAction = loop
where
loop = unlessQuit do
openGL2NewFrame
sdl2NewFrame
newFrame
frameAction
glClear GL_COLOR_BUFFER_BIT
render
openGL2RenderDrawData =<< getDrawData
glSwapWindow window
loop
unlessQuit action = do
shouldQuit <- checkEvents
if shouldQuit then pure () else action
checkEvents = do
pollEventWithImGui >>= \case
Nothing ->
return False
Just event ->
(isQuit event ||) <$> checkEvents
isQuit event =
SDL.eventPayload event == SDL.QuitEvent

Binary file not shown.

View File

@ -1,6 +1,7 @@
{-# language BlockArguments #-}
{-# language LambdaCase #-}
{-# language OverloadedStrings #-}
{-# language RecordWildCards #-}
module Main ( main ) where
@ -8,6 +9,12 @@ import Control.Exception
import Control.Monad
import Control.Monad.IO.Class
import Control.Monad.Managed
import Data.Bits ((.|.))
import Data.IORef
import Data.List (sortBy)
import Data.Foldable (traverse_)
import Data.Text (Text, pack)
import DearImGui
import DearImGui.OpenGL2
import DearImGui.GLFW
@ -40,14 +47,23 @@ main = do
-- Initialize ImGui's OpenGL backend
_ <- managed_ $ bracket_ openGL2Init openGL2Shutdown
liftIO $ mainLoop win
tableRef <- liftIO $ newIORef
[ (1, "foo")
, (2, "bar")
, (3, "baz")
, (10, "spam")
, (11, "spam")
, (12, "spam")
]
liftIO $ mainLoop win tableRef
Nothing -> do
error "GLFW createWindow failed"
GLFW.terminate
mainLoop :: Window -> IO ()
mainLoop win = do
mainLoop :: Window -> IORef [(Integer, Text)] -> IO ()
mainLoop win tableRef = do
-- Process the event loop
GLFW.pollEvents
close <- GLFW.windowShouldClose win
@ -64,12 +80,18 @@ 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
newLine
mkTable tableRef
-- Render
glClear GL_COLOR_BUFFER_BIT
@ -79,4 +101,41 @@ mainLoop win = do
GLFW.swapBuffers win
mainLoop win
mainLoop win tableRef
mkTable :: IORef [(Integer, Text)] -> IO ()
mkTable tableRef =
withTableOpen sortable "MyTable" 3 $ do
tableSetupColumn "Hello"
tableSetupColumnWith defTableColumnOptions "World"
withSortableTable \isDirty sortSpecs ->
when (isDirty && not (null sortSpecs)) do
-- XXX: do your sorting & cache it. Dont sort every frame.
putStrLn "So dirty!"
print sortSpecs
modifyIORef' tableRef . sortBy $
foldMap mkCompare sortSpecs
tableHeadersRow
readIORef tableRef >>=
traverse_ \(ix, title) -> do
tableNextRow
tableNextColumn $ text (pack $ show ix)
tableNextColumn $ text title
tableNextColumn $ void (button "")
where
mkCompare TableSortingSpecs{..} a b =
let
dir = if tableSortingReverse then flip else id
in
case tableSortingColumn of
0 -> dir compare (fst a) (fst b)
1 -> dir compare (snd a) (snd b)
_ -> EQ
sortable = defTableOptions
{ tableFlags =
ImGuiTableFlags_Sortable .|.
ImGuiTableFlags_SortMulti
}

146
examples/sdl/Renderer.hs Normal file
View File

@ -0,0 +1,146 @@
{-# language BlockArguments #-}
{-# language LambdaCase #-}
{-# language OverloadedStrings #-}
-- | Port of [example_sdl2_sdlrenderer2](https://github.com/ocornut/imgui/blob/54c1bdecebf3c9bb9259c07c5f5666bb4bd5c3ea/examples/example_sdl2_sdlrenderer2/main.cpp).
--
-- Minor differences:
-- - No changing of the clear color via @ImGui::ColorEdit3@ as a Haskell binding
-- doesn't yet exist for this function.
-- - No high DPI renderer scaling as this seems to be in flux [upstream](https://github.com/ocornut/imgui/issues/6065)
module Main ( main ) where
import Control.Exception (bracket, bracket_)
import Control.Monad.IO.Class (MonadIO(liftIO))
import Control.Monad.Managed (managed, managed_, runManaged)
import Data.IORef (IORef, newIORef)
import Data.Text (pack)
import DearImGui
import DearImGui.SDL (pollEventWithImGui, sdl2NewFrame, sdl2Shutdown)
import DearImGui.SDL.Renderer
( sdl2InitForSDLRenderer, sdlRendererInit, sdlRendererNewFrame, sdlRendererRenderDrawData
, sdlRendererShutdown
)
import SDL (V4(V4), ($=), ($~), get)
import Text.Printf (printf)
import qualified SDL
main :: IO ()
main = do
-- Initialize SDL2
SDL.initializeAll
runManaged do
-- Create a window using SDL2
window <- do
let title = "ImGui + SDL2 Renderer"
let config = SDL.defaultWindow
{ SDL.windowInitialSize = SDL.V2 1280 720
, SDL.windowResizable = True
, SDL.windowPosition = SDL.Centered
}
managed $ bracket (SDL.createWindow title config) SDL.destroyWindow
-- Create an SDL2 renderer
renderer <- managed do
bracket
(SDL.createRenderer window (-1) SDL.defaultRenderer)
SDL.destroyRenderer
-- Create an ImGui context
_ <- managed $ bracket createContext destroyContext
-- Initialize ImGui's SDL2 backend
_ <- managed_ do
bracket_ (sdl2InitForSDLRenderer window renderer) sdl2Shutdown
-- Initialize ImGui's SDL2 renderer backend
_ <- managed_ $ bracket_ (sdlRendererInit renderer) sdlRendererShutdown
liftIO $ mainLoop renderer
mainLoop :: SDL.Renderer -> IO ()
mainLoop renderer = do
refs <- newRefs
go refs
where
go refs = unlessQuit do
-- Tell ImGui we're starting a new frame
sdlRendererNewFrame
sdl2NewFrame
newFrame
-- Show the ImGui demo window
get (refsShowDemoWindow refs) >>= \case
False -> pure ()
True -> showDemoWindow
withWindowOpen "Hello, world!" do
text "This is some useful text."
_ <- checkbox "Demo Window" $ refsShowDemoWindow refs
_ <- checkbox "Another Window" $ refsShowAnotherWindow refs
_ <- sliderFloat "float" (refsFloat refs) 0 1
button "Button" >>= \case
False -> pure ()
True -> refsCounter refs $~ succ
sameLine
counter <- get $ refsCounter refs
text $ "counter = " <> pack (show counter)
fr <- framerate
text
$ pack
$ printf "Application average %.3f ms/frame (%.1f FPS)" (1000 / fr) fr
get (refsShowAnotherWindow refs) >>= \case
False -> pure ()
True ->
withCloseableWindow "Another Window" (refsShowAnotherWindow refs) do
text "Hello from another window!"
button "Close Me" >>= \case
False -> pure ()
True -> refsShowAnotherWindow refs $= False
-- Render
SDL.rendererDrawColor renderer $= V4 0 0 0 255
SDL.clear renderer
render
sdlRendererRenderDrawData =<< getDrawData
SDL.present renderer
go refs
-- Process the event loop
unlessQuit action = do
shouldQuit <- checkEvents
if shouldQuit then pure () else action
checkEvents = do
pollEventWithImGui >>= \case
Nothing ->
return False
Just event ->
(isQuit event ||) <$> checkEvents
isQuit event =
SDL.eventPayload event == SDL.QuitEvent
data Refs = Refs
{ refsShowDemoWindow :: IORef Bool
, refsShowAnotherWindow :: IORef Bool
, refsFloat :: IORef Float
, refsCounter :: IORef Int
}
newRefs :: IO Refs
newRefs =
Refs
<$> newIORef True
<*> newIORef False
<*> newIORef 0
<*> newIORef 0

View File

@ -44,7 +44,7 @@ import Data.Traversable
import Data.Word
( Word32 )
import Foreign.C.String
( CString )
( peekCString )
import Foreign.C.Types
( CInt )
import Foreign.Ptr
@ -53,8 +53,6 @@ import Foreign.Ptr
-- bytestring
import Data.ByteString
( ByteString )
import qualified Data.ByteString.Short as ShortByteString
( packCString )
-- containers
import qualified Data.Map.Strict as Map
@ -77,11 +75,13 @@ import qualified SDL
import qualified SDL.Raw
import qualified SDL.Video.Vulkan
-- text-short
import Data.Text.Short
( ShortText )
import qualified Data.Text.Short as ShortText
( intercalate, pack, fromShortByteString, toByteString, unpack )
-- text
import Data.Text
( Text )
import qualified Data.Text as Text
( intercalate, pack, unpack )
import Data.Text.Encoding
( encodeUtf8 )
-- transformers
import Control.Monad.IO.Class
@ -118,7 +118,7 @@ import Attachments
--------------------------------------------------------------------------------
type LogMessage = WithSeverity ShortText
type LogMessage = WithSeverity Text
class ( MonadUnliftIO m, MonadResource m, MonadLog LogMessage m ) => MonadVulkan m
instance ( MonadUnliftIO m, MonadResource m, MonadLog LogMessage m ) => MonadVulkan m
@ -127,9 +127,9 @@ instance ( MonadUnliftIO m, MonadResource m, MonadLog LogMessage m ) => MonadVul
logHandler :: MonadIO m => LogMessage -> m ()
logHandler ( WithSeverity sev mess )
= liftIO . putStrLn . ShortText.unpack $ showSeverity sev <> " " <> mess
= liftIO . putStrLn . Text.unpack $ showSeverity sev <> " " <> mess
showSeverity :: Severity -> ShortText
showSeverity :: Severity -> Text
showSeverity Emergency = "! PANIC !"
showSeverity Alert = "! ALERT !"
showSeverity Critical = "! CRIT !"
@ -190,9 +190,9 @@ initialiseVulkanContext instanceType appName ( VulkanRequirements { instanceRequ
device <- logDebug "Creating logical device" *>
Vulkan.Utils.createDeviceFromRequirements swapchainDeviceRequirements [] physicalDevice deviceCreateInfo
queue <- Vulkan.getDeviceQueue device ( fromIntegral queueFamily ) 0
pure ( VulkanContext { .. } )
vulkanInstanceInfo
@ -206,7 +206,7 @@ vulkanInstanceInfo appName = do
let
validationLayer :: Maybe ValidationLayerName
validationLayer
= coerce
= coerce
. foldMap
( ( Vulkan.layerName :: Vulkan.LayerProperties -> ByteString )
>>> \case
@ -244,7 +244,7 @@ vulkanInstanceInfo appName = do
case validationLayer of
Nothing -> logInfo "Validation layer unavailable. Is the Vulkan SDK installed?"
Just _ -> logInfo ( "Enabled validation layers " <> ShortText.pack ( show enabledLayers ) )
Just _ -> logInfo ( "Enabled validation layers " <> Text.pack ( show enabledLayers ) )
pure createInfo
@ -305,26 +305,23 @@ initialiseWindow ( WindowInfo { height, width, windowName, mouseMode } ) = do
void ( SDL.setMouseLocationMode mouseMode )
window <- logDebug "Creating SDL window" *> createWindow width height windowName
neededExtensions <- logDebug "Loading needed extensions" *> SDL.Video.Vulkan.vkGetInstanceExtensions window
extensionNames <- traverse ( liftIO . peekCString ) neededExtensions
logInfo $ "Needed instance extensions are: " <> ShortText.intercalate ", " extensionNames
pure ( window, map ShortText.toByteString extensionNames )
peekCString :: CString -> IO ShortText
peekCString = fmap ( fromMaybe "???" . ShortText.fromShortByteString ) . ShortByteString.packCString
extensionNames <- traverse ( liftIO . fmap fromString . peekCString ) neededExtensions
logInfo $ "Needed instance extensions are: " <> Text.intercalate ", " extensionNames
pure ( window, map encodeUtf8 extensionNames )
data WindowInfo
= WindowInfo
{ width :: CInt
, height :: CInt
, windowName :: ShortText
, windowName :: Text
, mouseMode :: SDL.LocationMode
}
createWindow :: MonadVulkan m => CInt -> CInt -> ShortText -> m SDL.Window
createWindow :: MonadVulkan m => CInt -> CInt -> Text -> m SDL.Window
createWindow x y title =
snd <$> ResourceT.allocate
( SDL.createWindow
( fromString ( ShortText.unpack title ) )
( fromString ( Text.unpack title ) )
SDL.defaultWindow
{ SDL.windowGraphicsContext = SDL.VulkanContext
, SDL.windowInitialSize = SDL.V2 x y
@ -374,11 +371,10 @@ chooseSwapchainFormat
case sortOn ( Down . score ) ( Boxed.Vector.toList surfaceFormats ) of
[] -> error "No formats found."
( best : _ )
| Vulkan.FORMAT_UNDEFINED <- ( Vulkan.format :: Vulkan.SurfaceFormatKHR -> Vulkan.Format ) best
-> pure preferredFormat
| otherwise
-> pure best
Vulkan.SurfaceFormatKHR{format=Vulkan.FORMAT_UNDEFINED} : _rest ->
pure preferredFormat
best : _rest
-> pure best
where
match :: Eq a => a -> a -> Int
@ -405,21 +401,14 @@ createSwapchain physicalDevice device surface surfaceFormat imageUsage imageCoun
surfaceCapabilities <- Vulkan.getPhysicalDeviceSurfaceCapabilitiesKHR physicalDevice ( Vulkan.SurfaceKHR surface )
( _, presentModes ) <- Vulkan.getPhysicalDeviceSurfacePresentModesKHR physicalDevice ( Vulkan.SurfaceKHR surface )
let
presentMode :: Vulkan.PresentModeKHR
presentMode
| Vulkan.PRESENT_MODE_MAILBOX_KHR `elem` presentModes
= Vulkan.PRESENT_MODE_MAILBOX_KHR
| otherwise
= Vulkan.PRESENT_MODE_FIFO_KHR
presentMode =
Vulkan.PRESENT_MODE_FIFO_KHR -- run at presentation rate
-- Vulkan.PRESENT_MODE_MAILBOX_KHR -- max-FPS alternative for benchmarks, input lag debugging, etc.
currentExtent :: Vulkan.Extent2D
currentExtent = ( Vulkan.currentExtent :: Vulkan.SurfaceCapabilitiesKHR -> Vulkan.Extent2D ) surfaceCapabilities
currentTransform :: Vulkan.SurfaceTransformFlagBitsKHR
currentTransform = ( Vulkan.currentTransform :: Vulkan.SurfaceCapabilitiesKHR -> Vulkan.SurfaceTransformFlagBitsKHR ) surfaceCapabilities
Vulkan.SurfaceCapabilitiesKHR{currentExtent, currentTransform} = surfaceCapabilities
Vulkan.SurfaceFormatKHR{format=fmt, colorSpace=csp} = surfaceFormat
swapchainCreateInfo :: Vulkan.SwapchainCreateInfoKHR '[]
swapchainCreateInfo =
@ -428,8 +417,8 @@ createSwapchain physicalDevice device surface surfaceFormat imageUsage imageCoun
, Vulkan.flags = Vulkan.zero
, Vulkan.surface = Vulkan.SurfaceKHR surface
, Vulkan.minImageCount = imageCount
, Vulkan.imageFormat = ( Vulkan.format :: Vulkan.SurfaceFormatKHR -> Vulkan.Format ) surfaceFormat
, Vulkan.imageColorSpace = ( Vulkan.colorSpace :: Vulkan.SurfaceFormatKHR -> Vulkan.ColorSpaceKHR ) surfaceFormat
, Vulkan.imageFormat = fmt
, Vulkan.imageColorSpace = csp
, Vulkan.imageExtent = currentExtent
, Vulkan.imageArrayLayers = 1
, Vulkan.imageUsage = imageUsage
@ -494,7 +483,7 @@ simpleRenderPass dev attachments = Vulkan.withRenderPass dev createInfo Nothing
{ Vulkan.next = ()
, Vulkan.flags = Vulkan.zero
, Vulkan.attachments = Boxed.Vector.fromList attachmentDescriptions
, Vulkan.subpasses = Boxed.Vector.singleton subpass
, Vulkan.subpasses = Boxed.Vector.singleton subpass
, Vulkan.dependencies = Boxed.Vector.fromList [ dependency1, dependency2 ]
}
@ -591,7 +580,7 @@ createFramebuffer
-> Vulkan.Extent2D
-> f Vulkan.ImageView
-> m ( ResourceT.ReleaseKey, Vulkan.Framebuffer )
createFramebuffer dev renderPass extent attachments = Vulkan.withFramebuffer dev createInfo Nothing ResourceT.allocate
createFramebuffer dev renderPass Vulkan.Extent2D{width, height} attachments = Vulkan.withFramebuffer dev createInfo Nothing ResourceT.allocate
where
createInfo :: Vulkan.FramebufferCreateInfo '[]
createInfo =
@ -600,8 +589,8 @@ createFramebuffer dev renderPass extent attachments = Vulkan.withFramebuffer dev
, Vulkan.flags = Vulkan.zero
, Vulkan.renderPass = renderPass
, Vulkan.attachments = Boxed.Vector.fromList . toList $ attachments
, Vulkan.width = ( Vulkan.width :: Vulkan.Extent2D -> Word32 ) extent
, Vulkan.height = ( Vulkan.height :: Vulkan.Extent2D -> Word32 ) extent
, Vulkan.width = width
, Vulkan.height = height
, Vulkan.layers = 1
}

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
@ -134,12 +164,6 @@ app = do
ImGui.createContext
ImGui.destroyContext
logDebug "Adding fonts"
ImGui.clearFontAtlas
_default <- ImGui.addFontDefault
_custom <- ImGui.addFontFromFileTTF "imgui/misc/fonts/ProggyTiny.ttf" 10
ImGui.buildFontAtlas
let
preferredFormat :: Vulkan.SurfaceFormatKHR
preferredFormat =
@ -177,9 +201,7 @@ app = do
surfaceCapabilities <- Vulkan.getPhysicalDeviceSurfaceCapabilitiesKHR physicalDevice ( Vulkan.SurfaceKHR surface )
let
minImageCount, maxImageCount, imageCount :: Word32
minImageCount = ( Vulkan.minImageCount :: Vulkan.SurfaceCapabilitiesKHR -> Word32 ) surfaceCapabilities
maxImageCount = ( Vulkan.maxImageCount :: Vulkan.SurfaceCapabilitiesKHR -> Word32 ) surfaceCapabilities
Vulkan.SurfaceCapabilitiesKHR{minImageCount, maxImageCount} = surfaceCapabilities
imageCount
| maxImageCount == 0 = minImageCount + 1
| otherwise = ( minImageCount + 1 ) `min` maxImageCount
@ -189,31 +211,30 @@ app = do
swapchainResources :: Maybe SwapchainResources -> m ( m (), SwapchainResources )
swapchainResources mbOldResources = do
( surfaceFormat, imGuiRenderPass ) <- case mbOldResources of
( colFmt, surfaceFormat, imGuiRenderPass ) <- case mbOldResources of
Nothing -> do
logDebug "Choosing swapchain format & color space"
surfaceFormat <- chooseSwapchainFormat preferredFormat physicalDevice surface
let
colFmt :: Vulkan.Format
colFmt = ( Vulkan.format :: Vulkan.SurfaceFormatKHR -> Vulkan.Format ) surfaceFormat
let Vulkan.SurfaceFormatKHR{format=colFmt} = surfaceFormat
logDebug "Creating Dear ImGui render pass"
( _, imGuiRenderPass ) <-
simpleRenderPass device
( noAttachments
{ colorAttachments = Boxed.Vector.singleton $ presentableColorAttachmentDescription colFmt }
)
pure ( surfaceFormat, imGuiRenderPass )
Just oldResources -> pure ( surfaceFormat oldResources, imGuiRenderPass oldResources )
let
colFmt :: Vulkan.Format
colFmt = ( Vulkan.format :: Vulkan.SurfaceFormatKHR -> Vulkan.Format ) surfaceFormat
pure ( colFmt, surfaceFormat, imGuiRenderPass )
Just oldResources -> do
let surFmt = surfaceFormat oldResources
let Vulkan.SurfaceFormatKHR{format=colFmt} = surFmt
pure ( colFmt, surFmt, imGuiRenderPass oldResources )
logDebug "Creating swapchain"
( swapchainKey, swapchain, swapchainExtent ) <-
createSwapchain
physicalDevice device
surface surfaceFormat
physicalDevice
device
surface
surfaceFormat
surfaceUsage
imageCount
( swapchain <$> mbOldResources )
@ -281,6 +302,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.
@ -314,23 +409,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 ()
@ -370,7 +538,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

@ -24,6 +24,10 @@ import Data.Traversable
( for )
import Foreign.Storable
( Storable )
#if MIN_VERSION_template_haskell(2,18,0)
import Data.Coerce
( coerce )
#endif
-- containers
import Data.Map.Strict
@ -171,7 +175,7 @@ declareEnumeration finiteEnumName countName ( Enumeration {..} ) = do
else
\ nm args dir pat ->
TH.patSynD_doc nm args dir pat
( Just $ Text.unpack patDoc ) []
( Just $ Text.unpack _patDoc ) []
)
#else
TH.patSynD

View File

@ -60,7 +60,7 @@ import Data.Text
( Text )
import qualified Data.Text as Text
( all, any, breakOn, drop, dropWhile, dropWhileEnd
, length, stripPrefix, unlines, unpack
, length, stripPrefix, unlines, unpack, pack
)
-- transformers
@ -81,6 +81,8 @@ import DearImGui.Generator.Tokeniser
import DearImGui.Generator.Types
( Comment(..), Enumeration(..), Headers(..) )
import qualified Text.Show as Text
--------------------------------------------------------------------------------
-- Parse error type.
@ -90,7 +92,9 @@ data CustomParseError
, problems :: ![Text]
}
| MissingForwardDeclaration
{ enumName :: !Text }
{ enumName :: !Text
, library :: HashMap Text ( TH.Name, Comment )
}
| UnexpectedSection
{ sectionName :: !Text
, problem :: ![Text]
@ -101,8 +105,9 @@ instance ShowErrorComponent CustomParseError where
showErrorComponent ( Couldn'tLookupEnumValues { enumName, problems } ) = Text.unpack $
"Couldn't lookup the following values in enum " <> enumName <> ":\n"
<> Text.unlines ( map ( " - " <> ) problems )
showErrorComponent ( MissingForwardDeclaration { enumName } ) = Text.unpack $
"Missing forward declaration for enum named " <> enumName
showErrorComponent ( MissingForwardDeclaration { enumName, library } ) = Text.unpack $
"Missing forward declaration for enum named " <> enumName <> "\n"
<> "In Library: " <> Text.pack ( Text.show library)
showErrorComponent ( UnexpectedSection { sectionName, problem } ) = Text.unpack $
"Unexpected section name.\n\
\Expected: " <> sectionName <> "\n\
@ -124,6 +129,7 @@ headers = do
( _defines, basicEnums ) <- partitionEithers <$>
manyTill
( ( Left <$> try ignoreDefine )
<|> ( Left <$> try cppConditional )
<|> ( Right <$> enumeration enumNamesAndTypes )
)
( namedSection "Helpers: Memory allocations macros, ImVector<>" )
@ -134,7 +140,7 @@ headers = do
_ <- skipManyTill anySingle ( namedSection "Misc data structures" )
_ <- skipManyTill anySingle ( namedSection "Helpers (ImGuiOnceUponAFrame, ImGuiTextFilter, ImGuiTextBuffer, ImGuiStorage, ImGuiListClipper, ImColor)" )
_ <- skipManyTill anySingle ( namedSection "Helpers (ImGuiOnceUponAFrame, ImGuiTextFilter, ImGuiTextBuffer, ImGuiStorage, ImGuiListClipper, Math Operators, ImColor)" )
_ <- skipManyTill anySingle ( namedSection "Drawing API (ImDrawCmd, ImDrawIdx, ImDrawVert, ImDrawChannel, ImDrawListSplitter, ImDrawListFlags, ImDrawList, ImDrawData)" )
skipManyTill anySingle ( try . lookAhead $ many comment *> keyword "enum" )
@ -146,6 +152,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
@ -169,14 +177,24 @@ forwardDeclarations = do
pure ( structName, doc )
_ <- many comment
enums <- many do
keyword "enum"
enumName <- identifier
symbol ":"
ty <- cTypeName
reservedSymbol ';'
doc <- commentText <$> comment
pure ( enumName, ( ty, CommentText <$> Text.drop 2 . snd $ Text.breakOn "//" doc ) )
_ <- many comment
typedefs <- many do
keyword "typedef"
ty <- cTypeName
enumName <- identifier
reservedSymbol ';'
doc <- commentText <$> comment
_ <- many comment
pure ( enumName, ( ty, CommentText <$> Text.drop 2 . snd $ Text.breakOn "//" doc ) )
-- Stopping after simple structs and enums for now.
pure ( HashMap.fromList structs, HashMap.fromList enums )
pure ( HashMap.fromList structs, HashMap.fromList (enums <> typedefs) )
cTypeName :: MonadParsec e [Tok] m => m TH.Name
cTypeName = keyword "int" $> ''CInt
@ -198,6 +216,7 @@ enumeration enumNamesAndTypes = do
keyword "enum"
pure inlineDocs
fullEnumName <- identifier
_ <- try $ (symbol ":" >> cTypeName >> pure ()) <|> pure ()
let
enumName :: Text
enumName = Text.dropWhileEnd ( == '_' ) fullEnumName
@ -205,7 +224,7 @@ enumeration enumNamesAndTypes = do
enumTypeName = ()
( underlyingType, forwardDoc ) <- case HashMap.lookup enumName enumNamesAndTypes of
Just res -> pure res
Nothing -> customFailure ( MissingForwardDeclaration { enumName } )
Nothing -> customFailure ( MissingForwardDeclaration { enumName, library=enumNamesAndTypes } )
let
docs :: [Comment]
docs = forwardDoc : CommentText "" : inlineDocs
@ -254,13 +273,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 +298,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 +357,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

@ -1 +1 @@
Subproject commit e3e1fbcf025cf83413815751f7c33500e1314d57
Subproject commit c6e0284ac58b3f205c95365478888f7b53b077e2

File diff suppressed because it is too large Load Diff

503
src/DearImGui/FontAtlas.hs Normal file
View File

@ -0,0 +1,503 @@
{-# LANGUAGE BlockArguments #-}
{-# LANGUAGE DuplicateRecordFields #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE PatternSynonyms #-}
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE TemplateHaskell #-}
{-|
Module: DearImGui.FontAtlas
Font atlas builder, accompanied with lower-level functions.
@
import qualified DearImGui.FontAtlas as FontAtlas
prepareAtlas =
FontAtlas.rebuild
[ FontAtlas.FileTTF "comic-sans-mono.ttf" 13 csOptions csRanges
, FontAtlas.Default
]
where
csOptions = mconcat
[ FontAtlas.fontNo 1
, FontAtlas.glyphOffset (0, -1)
]
csRanges = RangeBuilder $ mconcat
[ FontAtlas.addText "Hello world"
, FontRanges.addChar 'Ꙑ'
, FontRanges.addRanges FontRanges.Korean
]
@
-}
module DearImGui.FontAtlas
( -- * Main types
Raw.Font(..)
, FontSource(..)
-- * Building atlas
, rebuild
-- ** Configuring sources
, ConfigSetup(..)
, fontDataOwnedByAtlas
, fontNo
, sizePixels
, oversampleH
, oversampleV
, pixelSnapH
, glyphExtraSpacing
, glyphOffset
, glyphRanges
, glyphMinAdvanceX
, glyphMaxAdvanceX
, mergeMode
, fontBuilderFlags
, rasterizerMultiply
, ellipsisChar
-- ** Configuring ranges
, Ranges(..)
, RangesBuilderSetup(..)
, addChar
, addText
, addRanges
, addRangesRaw
, pattern Latin
, pattern Korean
, pattern Japanese
, pattern ChineseFull
, pattern ChineseSimplifiedCommon
, pattern Cyrillic
, pattern Thai
, pattern Vietnamese
-- * Lower level types and functions
-- , Raw.FontConfig(..)
-- , Raw.GlyphRanges(..)
, build
, clear
, setupFont
, setupRanges
, withRanges
, withConfig
, addFontFromFileTTF
, addFontFromFileTTF_
)
where
-- base
import Data.Bool (bool)
import Data.Maybe (fromMaybe)
import Foreign
import Foreign.C
-- transformers
import Control.Monad.IO.Class
( MonadIO, liftIO )
-- managed
import Control.Monad.Managed
( MonadManaged, managed )
import qualified Control.Monad.Managed as Managed
-- unlift
import UnliftIO (MonadUnliftIO)
import UnliftIO.Exception (bracket)
-- dear-imgui
import DearImGui.Raw.Font (Font(..))
import qualified DearImGui.Raw.Font as Raw
import DearImGui.Raw.Font.Config (FontConfig(..))
import qualified DearImGui.Raw.Font.Config as FontConfig
import DearImGui.Raw.Font.GlyphRanges (GlyphRanges(..), GlyphRangesBuilder(..))
import qualified DearImGui.Raw.Font.GlyphRanges as GlyphRanges
import DearImGui.Internal.Text (Text)
import qualified DearImGui.Internal.Text as Text
import DearImGui.Structs (ImVec2(..), ImWchar)
-- | Font setup data
data FontSource
= DefaultFont
| FromTTF FilePath Float (Maybe ConfigSetup) Ranges
-- TODO: FromMemory
-- | Font config monoid interface to be used in 'FontSource'.
--
-- @
-- mergeMode True <> fontNo 1
-- @
newtype ConfigSetup = ConfigSetup
{ applyToConfig :: FontConfig -> IO ()
}
instance Semigroup ConfigSetup where
ConfigSetup f <> ConfigSetup g =
ConfigSetup \fc -> f fc >> g fc
instance Monoid ConfigSetup where
mempty = ConfigSetup (const mempty)
-- | Glyph ranges settings, from presets to builder configuration.
data Ranges
= RangesRaw GlyphRanges
| RangesBuiltin GlyphRanges.Builtin
| RangesBuilder RangesBuilderSetup
-- | Basic Latin, Extended Latin
pattern Latin :: Ranges
pattern Latin = RangesBuiltin GlyphRanges.Latin
-- | Default + Korean characters
pattern Korean :: Ranges
pattern Korean = RangesBuiltin GlyphRanges.Korean
-- | Default + Hiragana, Katakana, Half-Width, Selection of 2999 Ideographs
pattern Japanese :: Ranges
pattern Japanese = RangesBuiltin GlyphRanges.Japanese
-- | Default + Half-Width + Japanese Hiragana/Katakana + full set of about 21000 CJK Unified Ideographs
pattern ChineseFull :: Ranges
pattern ChineseFull = RangesBuiltin GlyphRanges.ChineseFull
-- | Default + Half-Width + Japanese Hiragana/Katakana + set of 2500 CJK Unified Ideographs for common simplified Chinese
pattern ChineseSimplifiedCommon :: Ranges
pattern ChineseSimplifiedCommon = RangesBuiltin GlyphRanges.ChineseSimplifiedCommon
-- | Default + about 400 Cyrillic characters
pattern Cyrillic :: Ranges
pattern Cyrillic = RangesBuiltin GlyphRanges.Cyrillic
-- | Default + Thai characters
pattern Thai :: Ranges
pattern Thai = RangesBuiltin GlyphRanges.Thai
-- | Default + Vietnamese characters
pattern Vietnamese :: Ranges
pattern Vietnamese = RangesBuiltin GlyphRanges.Vietnamese
-- | Ranges builder monoid interface to be executed through 'buildRanges'.
--
-- @
-- addRanges FontRanges.DefaultRanges <> addText "Привет"
-- @
newtype RangesBuilderSetup = RangesBuilderSetup
{ applyToBuilder :: GlyphRangesBuilder -> IO ()
}
instance Semigroup RangesBuilderSetup where
RangesBuilderSetup f <> RangesBuilderSetup g =
RangesBuilderSetup \fc -> f fc >> g fc
instance Monoid RangesBuilderSetup where
mempty = RangesBuilderSetup (const mempty)
-- | Rebuild font atlas with provided configuration
-- and return corresponding structure of font handles
-- to be used with 'withFont'.
--
-- Accepts any 'Traversable' instance, so you are free to use
-- lists, maps or custom structures.
rebuild :: (MonadIO m, Traversable t) => t FontSource -> m (t Font)
rebuild sources = liftIO $ Managed.with action pure
where
action = do
clear
fonts <- traverse setupFont sources
build
return fonts
-- | Reset font atlas, clearing internal data
--
-- Alias for 'Raw.clearFontAtlas'
clear :: (MonadIO m) => m ()
clear = Raw.clearFontAtlas
-- | Build font atlas
--
-- Alias for 'Raw.buildFontAtlas'
build :: (MonadIO m) => m ()
build = Raw.buildFontAtlas
-- | Load a font from TTF file.
--
-- Specify font path and atlas glyph size.
--
-- Use 'Raw.addFontDefault' if you want to retain built-in font too.
--
-- Call 'build' after adding all the fonts,
-- particularly if you're loading them from memory or use custom glyphs.
-- Or stick to `rebuild` function.
--
-- Call backend-specific `CreateFontsTexture` before using 'newFrame'.
addFontFromFileTTF :: MonadIO m
=> FilePath -- ^ Font file path
-> Float -- ^ Font size in pixels
-> Maybe FontConfig -- ^ Configuration data
-> Maybe GlyphRanges -- ^ Glyph ranges to use
-> m (Maybe Font) -- ^ Returns font handle, if added successfully
addFontFromFileTTF font size config ranges = liftIO do
res@(Font ptr) <- withCString font \fontPtr ->
Raw.addFontFromFileTTF
fontPtr
(CFloat size)
(fromMaybe (FontConfig nullPtr) config)
(fromMaybe (GlyphRanges nullPtr) ranges)
pure $
if castPtr ptr == nullPtr
then Nothing
else Just res
-- FIXME: turn off asserts, so it would work
addFontFromFileTTF_ :: MonadIO m
=> FilePath -- ^ Font file path
-> Float -- ^ Font size in pixels
-> m (Maybe Raw.Font) -- ^ Returns font handle, if added successfully
addFontFromFileTTF_ font size =
addFontFromFileTTF font size Nothing Nothing
-- | Load a font with provided configuration, return its handle
-- and defer range builder and config destructors, if needed.
setupFont :: (MonadManaged m) => FontSource -> m Font
setupFont = \case
DefaultFont ->
Raw.addFontDefault
FromTTF path size configSetup ranges -> do
glyphRanges' <- setupRanges ranges
config <- managed (withConfig configSetup)
mFont <- addFontFromFileTTF path size config glyphRanges'
case mFont of
Nothing ->
liftIO . fail $ "Couldn't load font from " <> path
Just font ->
pure font
-- | Configure glyph ranges with provided configuration, return a handle
-- and defer builder destructors, if needed.
setupRanges :: (MonadManaged m) => Ranges -> m (Maybe GlyphRanges)
setupRanges = \case
RangesRaw ranges ->
pure $ Just ranges
RangesBuiltin builtin ->
pure $ GlyphRanges.builtinSetup builtin
RangesBuilder settings -> do
built <- managed $ withRanges settings
pure $ Just built
-- | Perform glyph ranges build based on provided configuration,
-- and execute a computation with built glyph ranges.
withRanges :: (MonadUnliftIO m) => RangesBuilderSetup -> (GlyphRanges -> m a) -> m a
withRanges (RangesBuilderSetup setup) fn =
bracket acquire release execute
where
acquire = do
builder <- GlyphRanges.new
liftIO $ setup builder
rangesVec <- GlyphRanges.buildRangesVector builder
return (rangesVec, builder)
release (rangesVec, builder) = do
GlyphRanges.destroyRangesVector rangesVec
GlyphRanges.destroy builder
execute (rangesVec, _) =
fn (GlyphRanges.fromRangesVector rangesVec)
-- | Configure font config with provided setup,
-- and execute a computation with built object.
-- return its handle and list of resource destructors.
withConfig :: (MonadUnliftIO m) => Maybe ConfigSetup -> (Maybe FontConfig -> m a) -> m a
withConfig mSetup action =
case mSetup of
Nothing ->
action Nothing
Just (ConfigSetup setup) ->
bracket acquire (FontConfig.destroy) (action . Just)
where
acquire = do
config <- FontConfig.new
liftIO $ setup config
return config
-- | Single Unicode character
addChar :: ImWchar -> RangesBuilderSetup
addChar char =
RangesBuilderSetup \builder ->
GlyphRanges.addChar builder char
-- | UTF-8 string
addText :: Text -> RangesBuilderSetup
addText str =
RangesBuilderSetup \builder ->
Text.withCString str (GlyphRanges.addText builder)
-- | Existing ranges (as is)
addRangesRaw :: GlyphRanges -> RangesBuilderSetup
addRangesRaw ranges =
RangesBuilderSetup \builder ->
GlyphRanges.addRanges builder ranges
-- | Existing ranges (through settings interface)
addRanges :: Ranges -> RangesBuilderSetup
addRanges = \case
RangesRaw ranges ->
addRangesRaw ranges
RangesBuilder settings ->
settings
RangesBuiltin builtin ->
addRangesRaw (GlyphRanges.getBuiltin builtin)
-- | TTF/OTF data ownership taken by the container ImFontAtlas (will delete memory itself).
--
-- By default, it is @true@
fontDataOwnedByAtlas :: Bool -> ConfigSetup
fontDataOwnedByAtlas value =
ConfigSetup \fc ->
FontConfig.setFontDataOwnedByAtlas fc (bool 0 1 value)
-- | Index of font within TTF/OTF file.
--
-- By default, it is @0@
fontNo :: Int -> ConfigSetup
fontNo value =
ConfigSetup \fc ->
FontConfig.setFontNo fc (fromIntegral value)
-- | Size in pixels for rasterizer
--
-- More or less maps to the resulting font height.
--
-- Implicitly set by @addFont...@ functions.
sizePixels :: Float -> ConfigSetup
sizePixels value =
ConfigSetup \fc ->
FontConfig.setSizePixels fc (CFloat value)
-- | Rasterize at higher quality for sub-pixel positioning.
--
-- Note: the difference between 2 and 3 is minimal so you can reduce this to 2 to save memory.
-- Read https://github.com/nothings/stb/blob/master/tests/oversample/README.md for details.
--
-- By default, it is @3@
oversampleH :: Int -> ConfigSetup
oversampleH value =
ConfigSetup \fc ->
FontConfig.setOversampleH fc (fromIntegral value)
-- | Rasterize at higher quality for sub-pixel positioning.
--
-- This is not really useful as we don't use sub-pixel positions on the Y axis.
--
-- By default, it is @1@
oversampleV :: Int -> ConfigSetup
oversampleV value =
ConfigSetup \fc ->
FontConfig.setOversampleV fc (fromIntegral value)
-- | Align every glyph to pixel boundary.
--
-- Useful if you are merging a non-pixel aligned font with the default font.
-- If enabled, you can set OversampleH/V to 1.
--
-- By default, it is @false@
pixelSnapH :: Bool -> ConfigSetup
pixelSnapH value =
ConfigSetup \fc ->
FontConfig.setPixelSnapH fc (bool 0 1 value)
-- | Extra spacing (in pixels) between glyphs.
--
-- Only X axis is supported for now.
--
-- By default, it is @0, 0@
glyphExtraSpacing :: (Float, Float) -> ConfigSetup
glyphExtraSpacing (x, y) =
ConfigSetup \fc ->
Foreign.with (ImVec2 x y) (FontConfig.setGlyphExtraSpacing fc)
-- | Offset all glyphs from this font input.
--
-- By default, it is @0, 0@
glyphOffset :: (Float, Float) -> ConfigSetup
glyphOffset (x, y) =
ConfigSetup \fc ->
Foreign.with (ImVec2 x y) (FontConfig.setGlyphOffset fc)
-- | Pointer to a user-provided list of Unicode range.
--
-- 2 values per range, inclusive. Zero-terminated list.
--
-- THE ARRAY DATA NEEDS TO PERSIST AS LONG AS THE FONT IS ALIVE.
--
-- By default, it is @NULL@
glyphRanges :: GlyphRanges -> ConfigSetup
glyphRanges value =
ConfigSetup \fc ->
FontConfig.setGlyphRanges fc value
-- | Minimum AdvanceX for glyphs.
--
-- Set Min to align font icons, set both Min/Max to enforce mono-space font.
--
-- By default, it is @0@
glyphMinAdvanceX :: Float -> ConfigSetup
glyphMinAdvanceX value =
ConfigSetup \fc ->
FontConfig.setGlyphMinAdvanceX fc (CFloat value)
-- | Maximum AdvanceX for glyphs.
--
-- By default, it is @FLT_MAX@.
glyphMaxAdvanceX :: Float -> ConfigSetup
glyphMaxAdvanceX value =
ConfigSetup \fc ->
FontConfig.setGlyphMaxAdvanceX fc (CFloat value)
-- | Merge into previous ImFont, so you can combine multiple inputs font into one ImFont.
--
-- e.g. ASCII font + icons + Japanese glyphs.
-- You may want to use @GlyphOffset.y@ when merging font of different heights.
--
-- By default, it is @false@
mergeMode :: Bool -> ConfigSetup
mergeMode value =
ConfigSetup \fc ->
FontConfig.setMergeMode fc (bool 0 1 value)
-- | Settings for custom font GlyphRanges.
--
-- THIS IS BUILDER IMPLEMENTATION DEPENDENT.
--
-- By default, it is @0@. Leave it so if unsure.
fontBuilderFlags :: Int -> ConfigSetup
fontBuilderFlags value =
ConfigSetup \fc ->
FontConfig.setFontBuilderFlags fc (fromIntegral value)
-- | Brighten (>1.0f) or darken (<1.0f) font output.
--
-- Brightening small fonts may be a good workaround to make them more readable.
--
-- By default, it is @1.0f@.
rasterizerMultiply :: Float -> ConfigSetup
rasterizerMultiply value =
ConfigSetup \fc ->
FontConfig.setRasterizerMultiply fc (CFloat value)
-- | Explicitly specify unicode codepoint of ellipsis character.
--
-- When fonts are being merged first specified ellipsis will be used.
--
-- By default, it is @-1@
ellipsisChar :: ImWchar -> ConfigSetup
ellipsisChar value =
ConfigSetup \fc ->
FontConfig.setEllipsisChar fc value

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

@ -0,0 +1,76 @@
{-# LANGUAGE CPP #-}
module DearImGui.Internal.Text
( withCString
, withCStringOrNull
, withCStringLen
, withCStringEnd
, peekCString
, Text
, pack
, unpack
) where
-- base
import Foreign (nullPtr, plusPtr)
import Foreign.C.String (CString)
import qualified GHC.Foreign as Foreign
import System.IO (utf8)
-- text
import Data.Text (Text, pack, unpack)
import Data.Text.Foreign (withCStringLen)
-- unliftio-core
import UnliftIO (MonadUnliftIO, UnliftIO(..), withUnliftIO)
#if MIN_VERSION_text(2,0,1)
-- XXX: just wrap the provided combinator
import qualified Data.Text.Foreign as Text
withCString :: MonadUnliftIO m => Text -> (CString -> m a) -> m a
withCString text action =
withUnliftIO $ \(UnliftIO unlift) ->
Text.withCString text $ \buf ->
unlift $ action buf
#elif MIN_VERSION_text(2,0,0)
-- XXX: the text is UTF-8, alas no withCString is available
import Data.Text.Foreign (lengthWord8, unsafeCopyToPtr)
import Data.Word (Word8)
import Foreign (allocaBytes, castPtr, pokeByteOff)
withCString :: MonadUnliftIO m => Text -> (CString -> m a) -> m a
withCString t@(Text _arr _off len) action =
withUnliftIO $ \(UnliftIO unlift) ->
allocaBytes (len + 1) $ \buf -> do
unsafeCopyToPtr t buf
pokeByteOff buf len (0 :: Word8)
unlift $ action (castPtr buf)
#else
-- XXX: the text is UTF-16, let GHC do it
withCString :: MonadUnliftIO m => Text -> (CString -> m a) -> m a
withCString t action = do
withUnliftIO $ \(UnliftIO unlift) ->
Foreign.withCString utf8 (unpack t) $ \textPtr ->
unlift $ action textPtr
#endif
peekCString :: CString -> IO Text
peekCString = fmap pack . Foreign.peekCString utf8
withCStringOrNull :: Maybe Text -> (CString -> IO a) -> IO a
withCStringOrNull Nothing k = k nullPtr
withCStringOrNull (Just s) k = withCString s k
withCStringEnd :: MonadUnliftIO m => Text -> (CString -> CString -> m a) -> m a
withCStringEnd t action =
withUnliftIO $ \(UnliftIO unlift) ->
withCStringLen t $ \(textPtr, size) ->
unlift $ action textPtr (textPtr `plusPtr` size)

View File

@ -6,6 +6,7 @@
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE PatternSynonyms #-}
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE ViewPatterns #-}
@ -64,6 +65,8 @@ module DearImGui.Raw
, setNextWindowSizeConstraints
, setNextWindowCollapsed
, setNextWindowBgAlpha
, beginDisabled
, endDisabled
-- ** Child Windows
, beginChild
@ -89,6 +92,7 @@ module DearImGui.Raw
, popItemWidth
, beginGroup
, endGroup
, getCursorPos
, setCursorPos
, getCursorScreenPos
, alignTextToFramePadding
@ -157,10 +161,34 @@ module DearImGui.Raw
, colorPicker3
, colorButton
-- * Tables
, beginTable
, endTable
, tableNextRow
, tableNextColumn
, tableSetColumnIndex
, tableSetupColumn
, tableSetupScrollFreeze
, tableHeadersRow
, tableHeader
, tableGetSortSpecs
, tableClearSortSpecsDirty
, tableGetColumnCount
, tableGetColumnIndex
, tableGetRowIndex
, tableGetColumnName
, tableGetColumnFlags
, tableSetColumnEnabled
, tableSetBgColor
-- * Trees
, treeNode
, treePush
, treePop
, setNextItemOpen
-- ** Selectables
, selectable
@ -169,6 +197,7 @@ module DearImGui.Raw
, listBox
-- * Data Plotting
, plotLines
, plotHistogram
-- ** Menus
@ -197,7 +226,12 @@ module DearImGui.Raw
, beginPopupModal
, endPopup
, openPopup
, openPopupOnItemClick
, closeCurrentPopup
, beginPopupContextItem
, beginPopupContextWindow
, beginPopupContextVoid
, isPopupOpen
-- * ID stack/scopes
, pushIDInt
@ -211,20 +245,13 @@ module DearImGui.Raw
, wantCaptureMouse
, wantCaptureKeyboard
-- * Fonts in default font atlas
, Font(..)
, addFontDefault
, addFontFromFileTTF
, addFontFromMemoryTTF
, buildFontAtlas
, clearFontAtlas
-- * Utilities
-- ** Miscellaneous
, getBackgroundDrawList
, getForegroundDrawList
, imCol32
, framerate
-- * Types
, module DearImGui.Enums
@ -241,7 +268,7 @@ import System.IO.Unsafe
( unsafePerformIO )
-- dear-imgui
import DearImGui.Context
import DearImGui.Raw.Context
( imguiContext )
import DearImGui.Enums
import DearImGui.Structs
@ -670,27 +697,27 @@ combo labelPtr iPtr itemsPtr itemsLen = liftIO do
-- | Wraps @ImGui::DragFloat()@
dragFloat :: (MonadIO m) => CString -> Ptr CFloat -> CFloat -> CFloat -> CFloat -> m Bool
dragFloat descPtr floatPtr speed minValue maxValue = liftIO do
(0 /=) <$> [C.exp| bool { DragFloat( $(char* descPtr), $(float* floatPtr), $(float speed), $(float minValue), $(float maxValue)) } |]
dragFloat :: (MonadIO m) => CString -> Ptr CFloat -> CFloat -> CFloat -> CFloat -> CString -> m Bool
dragFloat descPtr floatPtr speed minValue maxValue formatPtr = liftIO do
(0 /=) <$> [C.exp| bool { DragFloat( $(char* descPtr), $(float* floatPtr), $(float speed), $(float minValue), $(float maxValue), $(char* formatPtr)) } |]
-- | Wraps @ImGui::DragFloat2()@
dragFloat2 :: (MonadIO m) => CString -> Ptr CFloat -> CFloat -> CFloat -> CFloat -> m Bool
dragFloat2 descPtr floatPtr speed minValue maxValue = liftIO do
(0 /=) <$> [C.exp| bool { DragFloat2( $(char* descPtr), $(float* floatPtr), $(float speed), $(float minValue), $(float maxValue)) } |]
dragFloat2 :: (MonadIO m) => CString -> Ptr CFloat -> CFloat -> CFloat -> CFloat -> CString -> m Bool
dragFloat2 descPtr floatPtr speed minValue maxValue formatPtr = liftIO do
(0 /=) <$> [C.exp| bool { DragFloat2( $(char* descPtr), $(float* floatPtr), $(float speed), $(float minValue), $(float maxValue), $(char* formatPtr)) } |]
-- | Wraps @ImGui::DragFloat3()@
dragFloat3 :: (MonadIO m) => CString -> Ptr CFloat -> CFloat -> CFloat -> CFloat -> m Bool
dragFloat3 descPtr floatPtr speed minValue maxValue = liftIO do
(0 /=) <$> [C.exp| bool { DragFloat3( $(char* descPtr), $(float* floatPtr), $(float speed), $(float minValue), $(float maxValue)) } |]
dragFloat3 :: (MonadIO m) => CString -> Ptr CFloat -> CFloat -> CFloat -> CFloat -> CString -> m Bool
dragFloat3 descPtr floatPtr speed minValue maxValue formatPtr = liftIO do
(0 /=) <$> [C.exp| bool { DragFloat3( $(char* descPtr), $(float* floatPtr), $(float speed), $(float minValue), $(float maxValue), $(char* formatPtr)) } |]
-- | Wraps @ImGui::DragFloat4()@
dragFloat4 :: (MonadIO m) => CString -> Ptr CFloat -> CFloat -> CFloat -> CFloat -> m Bool
dragFloat4 descPtr floatPtr speed minValue maxValue = liftIO do
(0 /=) <$> [C.exp| bool { DragFloat4( $(char* descPtr), $(float* floatPtr), $(float speed), $(float minValue), $(float maxValue)) } |]
dragFloat4 :: (MonadIO m) => CString -> Ptr CFloat -> CFloat -> CFloat -> CFloat -> CString -> m Bool
dragFloat4 descPtr floatPtr speed minValue maxValue formatPtr = liftIO do
(0 /=) <$> [C.exp| bool { DragFloat4( $(char* descPtr), $(float* floatPtr), $(float speed), $(float minValue), $(float maxValue), $(char* formatPtr)) } |]
-- | Wraps @ImGui::DragFloatRange2()@
@ -830,27 +857,27 @@ dragScalarN labelPtr dataType dataPtr components vSpeed minPtr maxPtr formatPtr
maxPtr_ = castPtr maxPtr
-- | Wraps @ImGui::SliderFloat()@
sliderFloat :: (MonadIO m) => CString -> Ptr CFloat -> CFloat -> CFloat -> m Bool
sliderFloat descPtr floatPtr minValue maxValue = liftIO do
(0 /=) <$> [C.exp| bool { SliderFloat( $(char* descPtr), $(float* floatPtr), $(float minValue), $(float maxValue)) } |]
sliderFloat :: (MonadIO m) => CString -> Ptr CFloat -> CFloat -> CFloat -> CString -> m Bool
sliderFloat descPtr floatPtr minValue maxValue formatPtr = liftIO do
(0 /=) <$> [C.exp| bool { SliderFloat( $(char* descPtr), $(float* floatPtr), $(float minValue), $(float maxValue), $(char* formatPtr)) } |]
-- | Wraps @ImGui::SliderFloat2()@
sliderFloat2 :: (MonadIO m) => CString -> Ptr CFloat -> CFloat -> CFloat -> m Bool
sliderFloat2 descPtr floatPtr minValue maxValue = liftIO do
(0 /=) <$> [C.exp| bool { SliderFloat2( $(char* descPtr), $(float* floatPtr), $(float minValue), $(float maxValue)) } |]
sliderFloat2 :: (MonadIO m) => CString -> Ptr CFloat -> CFloat -> CFloat -> CString -> m Bool
sliderFloat2 descPtr floatPtr minValue maxValue formatPtr = liftIO do
(0 /=) <$> [C.exp| bool { SliderFloat2( $(char* descPtr), $(float* floatPtr), $(float minValue), $(float maxValue), $(char* formatPtr)) } |]
-- | Wraps @ImGui::SliderFloat3()@
sliderFloat3 :: (MonadIO m) => CString -> Ptr CFloat -> CFloat -> CFloat -> m Bool
sliderFloat3 descPtr floatPtr minValue maxValue = liftIO do
(0 /=) <$> [C.exp| bool { SliderFloat3( $(char* descPtr), $(float* floatPtr), $(float minValue), $(float maxValue)) } |]
sliderFloat3 :: (MonadIO m) => CString -> Ptr CFloat -> CFloat -> CFloat -> CString -> m Bool
sliderFloat3 descPtr floatPtr minValue maxValue formatPtr = liftIO do
(0 /=) <$> [C.exp| bool { SliderFloat3( $(char* descPtr), $(float* floatPtr), $(float minValue), $(float maxValue), $(char* formatPtr)) } |]
-- | Wraps @ImGui::SliderFloat4()@
sliderFloat4 :: (MonadIO m) => CString -> Ptr CFloat -> CFloat -> CFloat -> m Bool
sliderFloat4 descPtr floatPtr minValue maxValue = liftIO do
(0 /=) <$> [C.exp| bool { SliderFloat4( $(char* descPtr), $(float* floatPtr), $(float minValue), $(float maxValue)) } |]
sliderFloat4 :: (MonadIO m) => CString -> Ptr CFloat -> CFloat -> CFloat -> CString -> m Bool
sliderFloat4 descPtr floatPtr minValue maxValue formatPtr = liftIO do
(0 /=) <$> [C.exp| bool { SliderFloat4( $(char* descPtr), $(float* floatPtr), $(float minValue), $(float maxValue), $(char* formatPtr)) } |]
-- | Wraps @ImGui::SliderAngle()@
sliderAngle :: (MonadIO m) => CString -> Ptr CFloat -> CFloat -> CFloat -> CString -> ImGuiSliderFlags -> m Bool
@ -1071,6 +1098,128 @@ 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
tableClearSortSpecsDirty :: MonadIO m => Ptr ImGuiTableSortSpecs -> m ()
tableClearSortSpecsDirty specsPtr = liftIO do
[C.block| void {
$(ImGuiTableSortSpecs* specsPtr)->SpecsDirty = false;
} |]
-- | 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
@ -1089,10 +1238,22 @@ treePop = liftIO do
[C.exp| void { TreePop() } |]
-- | Wraps @ImGui::SetNextItemOpen()@.
setNextItemOpen :: (MonadIO m) => CBool -> m ()
setNextItemOpen is_open = liftIO do
[C.exp| void { SetNextItemOpen($(bool is_open)) } |]
-- -- | 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()@.
@ -1100,6 +1261,10 @@ listBox :: (MonadIO m) => CString -> Ptr CInt -> Ptr CString -> CInt -> m Bool
listBox labelPtr iPtr itemsPtr itemsLen = liftIO do
(0 /=) <$> [C.exp| bool { ListBox($(char* labelPtr), $(int* iPtr), $(char** itemsPtr), $(int itemsLen)) }|]
-- | Wraps @ImGui::PlotLines()@.
plotLines :: (MonadIO m) => CString -> Ptr CFloat -> CInt -> m ()
plotLines labelPtr valuesPtr valuesLen = liftIO do
[C.exp| void { PlotLines($(char* labelPtr), $(float* valuesPtr), $(int valuesLen)) } |]
-- | Wraps @ImGui::PlotHistogram()@.
plotHistogram :: (MonadIO m) => CString -> Ptr CFloat -> CInt -> m ()
@ -1184,9 +1349,9 @@ endTabBar = liftIO do
-- | Create a new tab. Returns @True@ if the tab is selected.
--
-- Wraps @ImGui::BeginTabItem@.
beginTabItem :: (MonadIO m) => CString -> Ptr CBool -> ImGuiTabBarFlags -> m Bool
beginTabItem :: (MonadIO m) => CString -> Ptr CBool -> ImGuiTabItemFlags -> m Bool
beginTabItem namePtr refPtr flags = liftIO do
(0 /=) <$> [C.exp| bool { BeginTabItem($(char* namePtr), $(bool* refPtr), $(ImGuiTabBarFlags flags) ) } |]
(0 /=) <$> [C.exp| bool { BeginTabItem($(char* namePtr), $(bool* refPtr), $(ImGuiTabItemFlags flags) ) } |]
-- | Finish appending elements to a tab. Only call if 'beginTabItem' returns @True@.
@ -1261,6 +1426,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()@
@ -1268,6 +1443,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.).
--
@ -1379,6 +1584,29 @@ setNextWindowBgAlpha alpha = liftIO do
[C.exp| void { SetNextWindowBgAlpha($(float alpha)) } |]
-- | Begin a block that may be disabled. This disables all user interactions
-- and dims item visuals.
--
-- Always call a matching 'endDisabled' for each 'beginDisabled' call.
--
-- The boolean argument is only intended to facilitate use of boolean
-- expressions. If you can avoid calling @beginDisabled 0@ altogether,
-- that should be preferred.
--
-- Wraps @ImGui::BeginDisabled()@
beginDisabled :: (MonadIO m) => CBool -> m ()
beginDisabled disabled = liftIO do
[C.exp| void { BeginDisabled($(bool disabled)) } |]
-- | Ends a block that may be disabled.
--
-- Wraps @ImGui::EndDisabled()@
endDisabled :: (MonadIO m) => m ()
endDisabled = liftIO do
[C.exp| void { EndDisabled() } |]
-- | undo a sameLine or force a new line when in an horizontal-layout context.
--
-- Wraps @ImGui::NewLine()@
@ -1470,6 +1698,20 @@ setCursorPos :: (MonadIO m) => Ptr ImVec2 -> m ()
setCursorPos posPtr = liftIO do
[C.exp| void { SetCursorPos(*$(ImVec2* posPtr)) } |]
-- | Get cursor position in window-local coordinates.
--
-- Useful to overlap draw using 'setCursorPos'.
--
-- Wraps @ImGui::SetCursorPos()@
getCursorPos :: (MonadIO m) => m ImVec2
getCursorPos = liftIO do
C.withPtr_ \ptr ->
[C.block|
void {
*$(ImVec2 * ptr) = GetCursorPos();
}
|]
-- | Cursor position in absolute coordinates.
--
-- Useful to work with 'DrawList' API.
@ -1563,57 +1805,11 @@ wantCaptureKeyboard :: MonadIO m => m Bool
wantCaptureKeyboard = liftIO do
(0 /=) <$> [C.exp| bool { GetIO().WantCaptureKeyboard } |]
-- | Wraps @ImFont*@.
newtype Font = Font (Ptr ImFont)
addFontDefault :: MonadIO m => m Font
addFontDefault = liftIO do
Font <$> [C.block|
ImFont* {
return GetIO().Fonts->AddFontDefault();
}
|]
addFontFromFileTTF :: MonadIO m => CString -> CFloat -> m Font
addFontFromFileTTF filenamePtr sizePixels = liftIO do
Font <$> [C.block|
ImFont* {
return GetIO().Fonts->AddFontFromFileTTF(
$(char* filenamePtr),
$(float sizePixels));
}
|]
-- | Transfer a buffer with TTF data to font atlas builder.
addFontFromMemoryTTF :: MonadIO m => CStringLen -> CFloat -> m Font
addFontFromMemoryTTF (castPtr -> fontDataPtr, fromIntegral -> fontSize) sizePixels = liftIO do
Font <$> [C.block|
ImFont* {
return GetIO().Fonts->AddFontFromMemoryTTF(
$(void* fontDataPtr),
$(int fontSize),
$(float sizePixels)
);
}
|]
buildFontAtlas :: MonadIO m => m ()
buildFontAtlas = liftIO do
[C.block|
void {
GetIO().Fonts->Build();
}
|]
clearFontAtlas :: MonadIO m => m ()
clearFontAtlas = liftIO do
[C.block|
void {
GetIO().Fonts->Clear();
}
|]
-- | Estimate of application framerate (rolling average over 60 frames), in
-- frame per second. Solely for convenience.
framerate :: MonadIO m => m Float
framerate = liftIO do
realToFrac <$> [C.exp| float { GetIO().Framerate } |]
-- | This draw list will be the first rendering one.
--

View File

@ -6,7 +6,7 @@
{-# language PatternSynonyms #-}
{-# language TemplateHaskell #-}
module DearImGui.Context where
module DearImGui.Raw.Context where
-- containers
import qualified Data.Map.Strict as Map
@ -34,9 +34,14 @@ 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 |] )
, ( TypeName "ImFont", [t| ImFont |] )
, ( TypeName "ImFontConfig", [t| ImFontConfig |] )
, ( TypeName "ImFontGlyphRangesBuilder", [t| ImFontGlyphRangesBuilder |] )
, ( TypeName "ImGuiListClipper", [t| ImGuiListClipper |] )
, ( TypeName "ImGuiTableSortSpecs", [t| ImGuiTableSortSpecs |] )
]
}

View File

@ -115,7 +115,7 @@ import Foreign hiding (new)
import Foreign.C
-- dear-imgui
import DearImGui.Context
import DearImGui.Raw.Context
( imguiContext )
import DearImGui.Enums
import DearImGui.Structs

141
src/DearImGui/Raw/Font.hs Normal file
View File

@ -0,0 +1,141 @@
{-# LANGUAGE BlockArguments #-}
{-# LANGUAGE DuplicateRecordFields #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE PatternSynonyms #-}
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE ViewPatterns #-}
{-| Fonts
It includes default atlas management, font configuration and glyph ranges.
-}
module DearImGui.Raw.Font
( -- * Types
Font(..)
, GlyphRanges(..)
-- * Adding fonts
, addFontDefault
, addFontFromFileTTF
, addFontFromMemoryTTF
-- * Using fonts
, pushFont
, popFont
-- * Atlas management
, clearFontAtlas
, buildFontAtlas
)
where
-- base
import Control.Monad.IO.Class
( MonadIO, liftIO )
import Foreign ( Ptr, castPtr )
import Foreign.C
-- dear-imgui
import DearImGui.Raw.Context
( imguiContext )
import DearImGui.Structs
import DearImGui.Raw.Font.Config
( FontConfig(..) )
import DearImGui.Raw.Font.GlyphRanges
( GlyphRanges(..) )
-- 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)
C.include "imgui.h"
Cpp.using "namespace ImGui"
-- | Font runtime data handle
--
-- Wraps @ImFont*@.
newtype Font = Font (Ptr ImFont)
-- | Add the default font (@ProggyClean.ttf@, 13 px) to the atlas.
addFontDefault :: MonadIO m
=> m Font -- ^ Returns font handle for future usage
addFontDefault = liftIO do
Font <$> [C.block|
ImFont* {
return GetIO().Fonts->AddFontDefault();
}
|]
-- | Add a custom OTF/TTF font from a file.
addFontFromFileTTF :: MonadIO m
=> CString -- ^ Font file path
-> CFloat -- ^ Font size in pixels
-> FontConfig -- ^ Configuration data
-> GlyphRanges -- ^ Glyph ranges to use
-> m Font -- ^ Returns font handle for future usage
addFontFromFileTTF filenamePtr sizePixels (FontConfig fontConfig) (GlyphRanges glyphRanges) = liftIO do
Font <$> [C.block|
ImFont* {
return GetIO().Fonts->AddFontFromFileTTF(
$(char* filenamePtr),
$(float sizePixels),
$(ImFontConfig* fontConfig),
$(ImWchar* glyphRanges));
}
|]
-- | Transfer a buffer with TTF data to font atlas builder.
addFontFromMemoryTTF :: MonadIO m => CStringLen -> CFloat -> FontConfig -> GlyphRanges -> m Font
addFontFromMemoryTTF (castPtr -> fontDataPtr, fromIntegral -> fontSize) sizePixels (FontConfig fontConfig) (GlyphRanges glyphRanges) = liftIO do
Font <$> [C.block|
ImFont* {
return GetIO().Fonts->AddFontFromMemoryTTF(
$(void* fontDataPtr),
$(int fontSize),
$(float sizePixels),
$(ImFontConfig* fontConfig),
$(ImWchar* glyphRanges)
);
}
|]
-- | Pushes a font into the parameters stack,
-- so ImGui would render following text using it.
pushFont :: MonadIO m => Font -> m ()
pushFont (Font font) = liftIO do
[C.exp| void { PushFont($(ImFont* font)); } |]
-- | Pops a font pushed into the parameters stack
--
-- Should be called only after a corresponding 'pushFont' call.
popFont :: MonadIO m => m ()
popFont = liftIO do
[C.exp| void { PopFont(); } |]
-- | Explicitly build pixels data for the atlas.
buildFontAtlas :: MonadIO m => m ()
buildFontAtlas = liftIO do
[C.block|
void {
GetIO().Fonts->Build();
}
|]
-- | Clear all font atlas input and output data
clearFontAtlas :: MonadIO m => m ()
clearFontAtlas = liftIO do
[C.block|
void {
GetIO().Fonts->Clear();
}
|]

View File

@ -0,0 +1,256 @@
{-# LANGUAGE BlockArguments #-}
{-# LANGUAGE DuplicateRecordFields #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE PatternSynonyms #-}
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE ViewPatterns #-}
{-| Font configuration
IO functions to modify font config values.
-}
module DearImGui.Raw.Font.Config
( FontConfig(..)
, new
, destroy
-- * Changing settings
, setFontDataOwnedByAtlas
, setFontNo
, setSizePixels
, setOversampleH
, setOversampleV
, setPixelSnapH
, setGlyphExtraSpacing
, setGlyphOffset
, setGlyphRanges
, setGlyphMinAdvanceX
, setGlyphMaxAdvanceX
, setMergeMode
, setFontBuilderFlags
, setRasterizerMultiply
, setEllipsisChar
)
where
-- base
import Control.Monad.IO.Class
( MonadIO, liftIO )
import Foreign ( Ptr )
import Foreign.C
-- dear-imgui
import DearImGui.Raw.Context
( imguiContext )
import DearImGui.Structs
import DearImGui.Raw.Font.GlyphRanges
( GlyphRanges(..) )
-- 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)
C.include "imgui.h"
Cpp.using "namespace ImGui"
-- | Font configuration data handle
--
-- Wraps @ImFontConfig*@.
newtype FontConfig = FontConfig (Ptr ImFontConfig)
-- | Create an instance of config
new :: MonadIO m => m FontConfig
new = liftIO do
FontConfig <$> [C.block|
ImFontConfig* {
return IM_NEW(ImFontConfig);
}
|]
-- | Destroy an instance of config
--
-- Should be used __after__ font atlas building.
destroy :: MonadIO m => FontConfig -> m ()
destroy (FontConfig config) = liftIO do
[C.block|
void {
IM_DELETE($(ImFontConfig* config));
}
|]
-- | TTF/OTF data ownership taken by the container ImFontAtlas (will delete memory itself).
--
-- By default, it is @true@
setFontDataOwnedByAtlas :: MonadIO m => FontConfig -> CBool -> m ()
setFontDataOwnedByAtlas (FontConfig fc) value = liftIO do
[C.block|
void {
$(ImFontConfig* fc)->FontDataOwnedByAtlas = $(bool value);
}
|]
-- | Index of font within TTF/OTF file
--
-- By default, it is @0@
setFontNo :: MonadIO m => FontConfig -> CInt -> m ()
setFontNo (FontConfig fc) value = liftIO do
[C.block|
void {
$(ImFontConfig* fc)->FontNo = $(int value);
}
|]
-- | Size in pixels for rasterizer (more or less maps to the resulting font height).
--
-- Implicitly set by @addFont...@ functions.
setSizePixels :: MonadIO m => FontConfig -> CFloat -> m ()
setSizePixels (FontConfig fc) value = liftIO do
[C.block|
void {
$(ImFontConfig* fc)->SizePixels = $(float value);
}
|]
-- | Rasterize at higher quality for sub-pixel positioning. Note the difference between 2 and 3 is minimal so you can reduce this to 2 to save memory. Read https://github.com/nothings/stb/blob/master/tests/oversample/README.md for details.
--
-- By default, it is @3@
setOversampleH :: MonadIO m => FontConfig -> CInt -> m ()
setOversampleH (FontConfig fc) value = liftIO do
[C.block|
void {
$(ImFontConfig* fc)->OversampleH = $(int value);
}
|]
-- | Rasterize at higher quality for sub-pixel positioning. This is not really useful as we don't use sub-pixel positions on the Y axis.
--
-- By default, it is @1@
setOversampleV :: MonadIO m => FontConfig -> CInt -> m ()
setOversampleV (FontConfig fc) value = liftIO do
[C.block|
void {
$(ImFontConfig* fc)->OversampleV = $(int value);
}
|]
-- | Align every glyph to pixel boundary. Useful e.g. if you are merging a non-pixel aligned font with the default font. If enabled, you can set OversampleH/V to 1.
--
-- By default, it is @false@
setPixelSnapH :: MonadIO m => FontConfig -> CBool -> m ()
setPixelSnapH (FontConfig fc) value = liftIO do
[C.block|
void {
$(ImFontConfig* fc)->PixelSnapH = $(bool value);
}
|]
-- | Extra spacing (in pixels) between glyphs. Only X axis is supported for now.
--
-- By default, it is @0, 0@
setGlyphExtraSpacing :: MonadIO m => FontConfig -> Ptr ImVec2 -> m ()
setGlyphExtraSpacing (FontConfig fc) value = liftIO do
[C.block|
void {
$(ImFontConfig* fc)->GlyphExtraSpacing = *$(ImVec2* value);
}
|]
-- | Offset all glyphs from this font input.
--
-- By default, it is @0, 0@
setGlyphOffset :: MonadIO m => FontConfig -> Ptr ImVec2 -> m ()
setGlyphOffset (FontConfig fc) value = liftIO do
[C.block|
void {
$(ImFontConfig* fc)->GlyphOffset = *$(ImVec2* value);
}
|]
-- | Pointer to a user-provided list of Unicode range (2 value per range, values are inclusive, zero-terminated list). THE ARRAY DATA NEEDS TO PERSIST AS LONG AS THE FONT IS ALIVE.
--
-- By default, it is @NULL@
setGlyphRanges :: MonadIO m => FontConfig -> GlyphRanges -> m ()
setGlyphRanges (FontConfig fc) (GlyphRanges value) = liftIO do
[C.block|
void {
$(ImFontConfig* fc)->GlyphRanges = $(ImWchar* value);
}
|]
-- | Minimum AdvanceX for glyphs, set Min to align font icons, set both Min/Max to enforce mono-space font
--
-- By default, it is @0@
setGlyphMinAdvanceX :: MonadIO m => FontConfig -> CFloat -> m ()
setGlyphMinAdvanceX (FontConfig fc) value = liftIO do
[C.block|
void {
$(ImFontConfig* fc)->GlyphMinAdvanceX = $(float value);
}
|]
-- | Maximum AdvanceX for glyphs
--
-- By default, it is @FLT_MAX@
setGlyphMaxAdvanceX :: MonadIO m => FontConfig -> CFloat -> m ()
setGlyphMaxAdvanceX (FontConfig fc) value = liftIO do
[C.block|
void {
$(ImFontConfig* fc)->GlyphMaxAdvanceX = $(float value);
}
|]
-- | Merge into previous ImFont, so you can combine multiple inputs font into one ImFont (e.g. ASCII font + icons + Japanese glyphs). You may want to use GlyphOffset.y when merge font of different heights.
--
-- By default, it is @false@
setMergeMode :: MonadIO m => FontConfig -> CBool -> m ()
setMergeMode (FontConfig fc) value = liftIO do
[C.block|
void {
$(ImFontConfig* fc)->MergeMode = $(bool value);
}
|]
-- | Settings for custom font builder.
-- THIS IS BUILDER IMPLEMENTATION DEPENDENT.
--
-- By default, it is @0@. Leave it so if unsure.
setFontBuilderFlags :: MonadIO m => FontConfig -> CUInt -> m ()
setFontBuilderFlags (FontConfig fc) value = liftIO do
[C.block|
void {
$(ImFontConfig* fc)->FontBuilderFlags = $(unsigned int value);
}
|]
-- | Brighten (>1.0f) or darken (<1.0f) font output.
-- Brightening small fonts may be a good workaround to make them more readable.
--
-- By default, it is @1.0f@
setRasterizerMultiply :: MonadIO m => FontConfig -> CFloat -> m ()
setRasterizerMultiply (FontConfig fc) value = liftIO do
[C.block|
void {
$(ImFontConfig* fc)->RasterizerMultiply = $(float value);
}
|]
-- | Explicitly specify unicode codepoint of ellipsis character. When fonts are being merged first specified ellipsis will be used.
--
-- By default, it is @-1@
setEllipsisChar :: MonadIO m => FontConfig -> ImWchar -> m ()
setEllipsisChar (FontConfig fc) value = liftIO do
[C.block|
void {
$(ImFontConfig* fc)->EllipsisChar = $(ImWchar value);
}
|]

View File

@ -0,0 +1,295 @@
{-# LANGUAGE BlockArguments #-}
{-# LANGUAGE DuplicateRecordFields #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE PatternSynonyms #-}
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE TemplateHaskell #-}
{-| Font glyph ranges builder
Helper to build glyph ranges from text/string data.
Feed your application strings/characters to it then call 'buildRanges'.
Low-level example of usage:
@
-- import ImGui.Fonts
-- import ImGui.Raw.GlyphRangesBuilder as GRB
builder <- GRB.new
GRB.addRanges builder getGlyphRangesDefault
liftIO $ withCString "Привет" $ GRB.addText builder
rangesVec <- GRB.buildRanges builder
let ranges = GRB.fromRangesVector rangesVec
addFontFromFileTTF'
"./imgui/misc/fonts/DroidSans.ttf" 12
Nothing
(Just ranges)
-- it is strictly necessary to explicitly build the atlas
buildFontAtlas
-- resource destruction comes only after the building
GRB.destroyRangesVector rangesVec
GRB.destroy builder
@
-}
module DearImGui.Raw.Font.GlyphRanges
( GlyphRanges(..)
-- * Built-in ranges
, Builtin(..)
, getBuiltin
, builtinSetup
-- * Preparing a builder
, GlyphRangesBuilder(..)
, new
, destroy
, addChar
, addText
, addRanges
-- * Extracting data
, GlyphRangesVector(..)
, buildRangesVector
, fromRangesVector
, destroyRangesVector
)
where
-- base
import Control.Monad.IO.Class
( MonadIO, liftIO )
import Foreign ( Ptr )
import Foreign.C
import System.IO.Unsafe (unsafePerformIO)
-- dear-imgui
import DearImGui.Raw.Context
( imguiContext )
import DearImGui.Structs
-- 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)
C.include "imgui.h"
Cpp.using "namespace ImGui"
-- | Glyph ranges handle
--
-- Wraps @ImWchar*@.
newtype GlyphRanges = GlyphRanges (Ptr ImWchar)
-- | Builtin glyph ranges tags.
data Builtin
= Latin
| Korean
| Japanese
| ChineseFull
| ChineseSimplifiedCommon
| Cyrillic
| Thai
| Vietnamese
deriving (Eq, Ord, Show, Enum, Bounded)
-- | Get builtin glyph ranges from a tag.
getBuiltin :: Builtin -> GlyphRanges
getBuiltin = \case
Latin -> getGlyphRangesDefault
Korean -> getGlyphRangesKorean
Japanese -> getGlyphRangesJapanese
ChineseFull -> getGlyphRangesChineseFull
ChineseSimplifiedCommon -> getGlyphRangesChineseSimplifiedCommon
Cyrillic -> getGlyphRangesCyrillic
Thai -> getGlyphRangesThai
Vietnamese -> getGlyphRangesVietnamese
-- | Special case of @getBuiltin@, but for font source setup.
builtinSetup :: Builtin -> Maybe GlyphRanges
builtinSetup = \case
Latin -> Nothing
others -> Just (getBuiltin others)
-- | Basic Latin, Extended Latin
getGlyphRangesDefault :: GlyphRanges
getGlyphRangesDefault = unsafePerformIO do
GlyphRanges <$> [C.block|
const ImWchar* {
return GetIO().Fonts->GetGlyphRangesDefault();
}
|]
-- | Default + Korean characters
getGlyphRangesKorean :: GlyphRanges
getGlyphRangesKorean = unsafePerformIO do
GlyphRanges <$> [C.block|
const ImWchar* {
return GetIO().Fonts->GetGlyphRangesKorean();
}
|]
-- | Default + Hiragana, Katakana, Half-Width, Selection of 2999 Ideographs
getGlyphRangesJapanese :: GlyphRanges
getGlyphRangesJapanese = unsafePerformIO do
GlyphRanges <$> [C.block|
const ImWchar* {
return GetIO().Fonts->GetGlyphRangesJapanese();
}
|]
-- | Default + Half-Width + Japanese Hiragana/Katakana + full set of about 21000 CJK Unified Ideographs
getGlyphRangesChineseFull :: GlyphRanges
getGlyphRangesChineseFull = unsafePerformIO do
GlyphRanges <$> [C.block|
const ImWchar* {
return GetIO().Fonts->GetGlyphRangesChineseFull();
}
|]
-- | Default + Half-Width + Japanese Hiragana/Katakana + set of 2500 CJK Unified Ideographs for common simplified Chinese
getGlyphRangesChineseSimplifiedCommon :: GlyphRanges
getGlyphRangesChineseSimplifiedCommon = unsafePerformIO do
GlyphRanges <$> [C.block|
const ImWchar* {
return GetIO().Fonts->GetGlyphRangesChineseSimplifiedCommon();
}
|]
-- | Default + about 400 Cyrillic characters
getGlyphRangesCyrillic :: GlyphRanges
getGlyphRangesCyrillic = unsafePerformIO do
GlyphRanges <$> [C.block|
const ImWchar* {
return GetIO().Fonts->GetGlyphRangesCyrillic();
}
|]
-- | Default + Thai characters
getGlyphRangesThai :: GlyphRanges
getGlyphRangesThai = unsafePerformIO do
GlyphRanges <$> [C.block|
const ImWchar* {
return GetIO().Fonts->GetGlyphRangesThai();
}
|]
-- | Default + Vietnamese characters
getGlyphRangesVietnamese :: GlyphRanges
getGlyphRangesVietnamese = unsafePerformIO do
GlyphRanges <$> [C.block|
const ImWchar* {
return GetIO().Fonts->GetGlyphRangesVietnamese();
}
|]
-- | Glyph ranges builder handle
--
-- Wraps @ImFontGlyphRangesBuilder*@.
newtype GlyphRangesBuilder = GlyphRangesBuilder (Ptr ImFontGlyphRangesBuilder)
-- | Glyph ranges vector handle to keep builder output
--
-- Wraps @ImVector<ImWchar>*@.
newtype GlyphRangesVector = GlyphRangesVector (Ptr ())
-- | Create an instance of builder
new :: MonadIO m => m GlyphRangesBuilder
new = liftIO do
GlyphRangesBuilder <$> [C.block|
ImFontGlyphRangesBuilder* {
return IM_NEW(ImFontGlyphRangesBuilder);
}
|]
-- | Destroy an instance of builder
--
-- Should be used __after__ font atlas building.
destroy :: MonadIO m => GlyphRangesBuilder -> m ()
destroy (GlyphRangesBuilder builder) = liftIO do
[C.block|
void {
IM_DELETE($(ImFontGlyphRangesBuilder* builder));
}
|]
-- | Add character
addChar :: MonadIO m => GlyphRangesBuilder -> ImWchar -> m ()
addChar (GlyphRangesBuilder builder) wChar = liftIO do
[C.block|
void {
$(ImFontGlyphRangesBuilder* builder)->AddChar($(ImWchar wChar));
}
|]
-- | Add string (each character of the UTF-8 string are added)
addText :: MonadIO m => GlyphRangesBuilder -> CString -> m ()
addText (GlyphRangesBuilder builder) string = liftIO do
[C.block|
void {
$(ImFontGlyphRangesBuilder* builder)->AddText($(char* string));
}
|]
-- FIXME: the function uses 'const char* text_end = NULL' parameter,
-- which is pointer for the line ending. It is low level, though it
-- could be utilized for string length parameter.
-- | Add ranges, e.g. 'addRanges builder getGlyphRangesDefault'
-- to force add all of ASCII/Latin+Ext
addRanges :: MonadIO m => GlyphRangesBuilder -> GlyphRanges -> m()
addRanges (GlyphRangesBuilder builder) (GlyphRanges ranges) = liftIO do
[C.block|
void {
$(ImFontGlyphRangesBuilder* builder)->AddRanges($(ImWchar* ranges));
}
|]
-- | Build new ranges and create ranges vector instance,
-- containing them
buildRangesVector :: MonadIO m => GlyphRangesBuilder -> m (GlyphRangesVector)
buildRangesVector (GlyphRangesBuilder builder) = liftIO do
GlyphRangesVector <$> [C.block|
void* {
ImVector<ImWchar>* ranges = IM_NEW(ImVector<ImWchar>);
$(ImFontGlyphRangesBuilder* builder)->BuildRanges(ranges);
return ranges;
}
|]
-- | Extract glyph ranges from a vector
--
-- Should be used __before__ vector destruction.
fromRangesVector :: GlyphRangesVector -> GlyphRanges
fromRangesVector (GlyphRangesVector vecPtr) = unsafePerformIO do
GlyphRanges <$> [C.block|
ImWchar* {
return ((ImVector<ImWchar>*) $(void* vecPtr))->Data;
}
|]
-- | Destroy a ranges vector instance
--
-- Should be used __after__ font atlas building.
destroyRangesVector :: MonadIO m => GlyphRangesVector -> m ()
destroyRangesVector (GlyphRangesVector vecPtr) = liftIO do
[C.block|
void {
IM_DELETE(((ImVector<ImWchar>*) $(void* vecPtr)));
}
|]

View File

@ -39,7 +39,7 @@ import Foreign.C
)
-- dear-imgui
import DearImGui.Context
import DearImGui.Raw.Context
( imguiContext )
-- import DearImGui.Enums
-- import DearImGui.Structs
@ -120,14 +120,11 @@ setUserData ptr = liftIO do
{- TODO:
bool WantCaptureMouse; // Set when Dear ImGui will use mouse inputs, in this case do not dispatch them to your main game/application (either way, always pass on mouse inputs to imgui). (e.g. unclicked mouse is hovering over an imgui window, widget is active, mouse was clicked over an imgui window, etc.).
bool WantCaptureKeyboard; // Set when Dear ImGui will use keyboard inputs, in this case do not dispatch them to your main game/application (either way, always pass keyboard inputs to imgui). (e.g. InputText active, or an imgui window is focused and navigation is enabled, etc.).
bool WantTextInput; // Mobile/console: when set, you may display an on-screen keyboard. This is set by Dear ImGui when it wants textual keyboard input to happen (e.g. when a InputText widget is active).
bool WantSetMousePos; // MousePos has been altered, backend should reposition mouse on next frame. Rarely used! Set only when ImGuiConfigFlags_NavEnableSetMousePos flag is enabled.
bool WantSaveIniSettings; // When manual .ini load/save is active (io.IniFilename == NULL), this will be set to notify your application that you can call SaveIniSettingsToMemory() and save yourself. Important: clear io.WantSaveIniSettings yourself after saving!
bool NavActive; // Keyboard/Gamepad navigation is currently allowed (will handle ImGuiKey_NavXXX events) = a window is focused and it doesn't use the ImGuiWindowFlags_NoNavInputs flag.
bool NavVisible; // Keyboard/Gamepad navigation is visible and allowed (will handle ImGuiKey_NavXXX events).
float Framerate; // Rough estimate of application framerate, in frame per second. Solely for convenience. Rolling average estimation based on io.DeltaTime over 120 frames.
int MetricsRenderVertices; // Vertices output during last call to Render()
int MetricsRenderIndices; // Indices output during last call to Render() = number of triangles * 3
int MetricsRenderWindows; // Number of visible windows

View File

@ -59,7 +59,7 @@ import Foreign.C
import System.IO.Unsafe (unsafePerformIO)
-- dear-imgui
import DearImGui.Context
import DearImGui.Raw.Context
( imguiContext )
import DearImGui.Structs
( ImGuiListClipper )

View File

@ -21,12 +21,14 @@ module DearImGui.SDL (
, sdl2Shutdown
, pollEventWithImGui
, pollEventsWithImGui
-- *** Raw
, dispatchRawEvent
)
where
-- base
import Control.Monad
( when )
( void, when )
import Foreign.Marshal.Alloc
( alloca )
import Foreign.Ptr
@ -42,6 +44,7 @@ import qualified Language.C.Inline.Cpp as Cpp
import SDL
import SDL.Raw.Enum as Raw
import qualified SDL.Raw.Event as Raw
import qualified SDL.Raw.Types as Raw
-- transformers
import Control.Monad.IO.Class
@ -50,7 +53,7 @@ import Control.Monad.IO.Class
C.context (Cpp.cppCtx <> C.bsCtx)
C.include "imgui.h"
C.include "backends/imgui_impl_sdl.h"
C.include "backends/imgui_impl_sdl2.h"
C.include "SDL.h"
Cpp.using "namespace ImGui"
@ -77,11 +80,24 @@ pollEventWithImGui = liftIO do
nEvents <- Raw.peepEvents evPtr 1 Raw.SDL_PEEKEVENT Raw.SDL_FIRSTEVENT Raw.SDL_LASTEVENT
when (nEvents > 0) do
let evPtr' = castPtr evPtr :: Ptr ()
[C.exp| void { ImGui_ImplSDL2_ProcessEvent((SDL_Event*) $(void* evPtr')) } |]
void $ dispatchRawEvent evPtr
pollEvent
-- | Dispatch a raw 'Raw.Event' value to Dear ImGui.
--
-- You may want this function instead of 'pollEventWithImGui' if you do not use
-- @sdl2@'s higher-level 'Event' type (e.g. your application has its own polling
-- mechanism).
--
-- __It is your application's responsibility to both manage the input__
-- __pointer's memory and to fill the memory location with a raw 'Raw.Event'__
-- __value.__
dispatchRawEvent :: MonadIO m => Ptr Raw.Event -> m Bool
dispatchRawEvent evPtr = liftIO do
let evPtr' = castPtr evPtr :: Ptr ()
(0 /=) <$> [C.exp| bool { ImGui_ImplSDL2_ProcessEvent((const SDL_Event*) $(void* evPtr')) } |]
-- | Like the SDL2 'pollEvents' function, while also dispatching the events to
-- Dear ImGui. See 'pollEventWithImGui'.
pollEventsWithImGui :: MonadIO m => m [Event]

View File

@ -42,7 +42,7 @@ import Control.Monad.IO.Class
C.context (Cpp.cppCtx <> C.bsCtx)
C.include "imgui.h"
C.include "backends/imgui_impl_opengl2.h"
C.include "backends/imgui_impl_sdl.h"
C.include "backends/imgui_impl_sdl2.h"
C.include "SDL.h"
C.include "SDL_opengl.h"
Cpp.using "namespace ImGui"

View File

@ -0,0 +1,74 @@
{-# LANGUAGE BlockArguments #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE PatternSynonyms #-}
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE TemplateHaskell #-}
{-|
Module: DearImGUI.SDL.Renderer
Initialising the SDL2 renderer backend for Dear ImGui.
-}
module DearImGui.SDL.Renderer
( sdl2InitForSDLRenderer
, sdlRendererInit
, sdlRendererShutdown
, sdlRendererNewFrame
, sdlRendererRenderDrawData
)
where
-- inline-c
import qualified Language.C.Inline as C
-- inline-c-cpp
import qualified Language.C.Inline.Cpp as Cpp
-- sdl2
import SDL.Internal.Types
( Renderer(..), Window(..) )
-- transformers
import Control.Monad.IO.Class
( MonadIO, liftIO )
-- DearImGui
import DearImGui
( DrawData(..) )
C.context (Cpp.cppCtx <> C.bsCtx)
C.include "imgui.h"
C.include "backends/imgui_impl_sdlrenderer2.h"
C.include "backends/imgui_impl_sdl2.h"
C.include "SDL.h"
Cpp.using "namespace ImGui"
-- | Wraps @ImGui_ImplSDL2_InitForSDLRenderer@.
sdl2InitForSDLRenderer :: MonadIO m => Window -> Renderer -> m Bool
sdl2InitForSDLRenderer (Window windowPtr) (Renderer renderPtr) = liftIO do
(0 /=) <$> [C.exp| bool { ImGui_ImplSDL2_InitForSDLRenderer((SDL_Window*)$(void* windowPtr), (SDL_Renderer*)$(void* renderPtr)) } |]
-- | Wraps @ImGui_ImplSDLRenderer2_Init@.
sdlRendererInit :: MonadIO m => Renderer -> m Bool
sdlRendererInit (Renderer renderPtr) = liftIO do
(0 /=) <$> [C.exp| bool { ImGui_ImplSDLRenderer2_Init((SDL_Renderer*)$(void* renderPtr)) } |]
-- | Wraps @ImGui_ImplSDLRenderer2_Shutdown@.
sdlRendererShutdown :: MonadIO m => m ()
sdlRendererShutdown = liftIO do
[C.exp| void { ImGui_ImplSDLRenderer2_Shutdown(); } |]
-- | Wraps @ImGui_ImplSDLRenderer2_NewFrame@.
sdlRendererNewFrame :: MonadIO m => m ()
sdlRendererNewFrame = liftIO do
[C.exp| void { ImGui_ImplSDLRenderer2_NewFrame(); } |]
-- | Wraps @ImGui_ImplSDLRenderer2_RenderDrawData@.
sdlRendererRenderDrawData :: MonadIO m => DrawData -> m ()
sdlRendererRenderDrawData (DrawData ptr) = liftIO do
[C.exp| void { ImGui_ImplSDLRenderer2_RenderDrawData((ImDrawData*) $( void* ptr )) } |]

View File

@ -33,7 +33,7 @@ import Control.Monad.IO.Class ( MonadIO, liftIO )
C.context Cpp.cppCtx
C.include "imgui.h"
C.include "backends/imgui_impl_vulkan.h"
C.include "backends/imgui_impl_sdl.h"
C.include "backends/imgui_impl_sdl2.h"
C.include "SDL.h"
C.include "SDL_vulkan.h"
Cpp.using "namespace ImGui"

View File

@ -1,13 +1,25 @@
{-# LANGUAGE DuplicateRecordFields #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE CPP #-}
module DearImGui.Structs where
-- base
import Data.Word
( Word32 )
( Word32
#ifndef IMGUI_USE_WCHAR32
, Word16
#endif
)
import Foreign
( Storable(..), castPtr, plusPtr )
( Storable(..), castPtr, plusPtr, Ptr, Int16, nullPtr )
import Foreign.C
( CInt, CBool )
import DearImGui.Enums
import Data.Bits ((.&.))
--------------------------------------------------------------------------------
data ImVec2 = ImVec2 { x, y :: {-# unpack #-} !Float }
@ -80,11 +92,123 @@ data ImGuiContext
-- | Individual font handle.
data ImFont
-- | Font configuration handle.
data ImFontConfig
-- | Glyph ranges builder handle.
data ImFontGlyphRangesBuilder
-- | Opaque DrawList handle.
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 = ImU32
-- | 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
#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
{ specs :: Ptr ImGuiTableColumnSortSpecs
, specsCount :: CInt
, specsDirty :: CBool
} deriving (Show, Eq)
instance Storable ImGuiTableSortSpecs where
sizeOf _ =
sizeOf (undefined :: Ptr ImGuiTableColumnSortSpecs) +
sizeOf (undefined :: CInt) +
sizeOf (undefined :: CBool)
alignment _ =
alignment nullPtr
poke ptr ImGuiTableSortSpecs{..} = do
let specsPtr = castPtr ptr
poke specsPtr specs
let specsCountPtr = castPtr $ specsPtr `plusPtr` sizeOf specs
poke specsCountPtr specsCount
let specsDirtyPtr = castPtr $ specsCountPtr `plusPtr` sizeOf specsCount
poke specsDirtyPtr specsDirty
peek ptr = do
let specsPtr = castPtr ptr
specs <- peek specsPtr
let specsCountPtr = castPtr $ specsPtr `plusPtr` sizeOf specs
specsCount <- peek specsCountPtr
let specsDirtyPtr = castPtr $ specsCountPtr `plusPtr` sizeOf specsCount
specsDirty <- peek specsDirtyPtr
pure ImGuiTableSortSpecs{..}
-- | Sorting specification for one column of a table
data ImGuiTableColumnSortSpecs = ImGuiTableColumnSortSpecs
{ columnUserID :: ImGuiID -- ^ User id of the column (if specified by a TableSetupColumn() call)
, columnIndex :: ImS16 -- ^ Index of the column
, sortOrder :: ImS16 -- ^ Index within parent ImGuiTableSortSpecs (always stored in order starting from 0, tables sorted on a single criteria will always have a 0 here)
, sortDirection :: ImGuiSortDirection -- ^ 'ImGuiSortDirection_Ascending' or 'ImGuiSortDirection_Descending'
} deriving (Show, Eq)
instance Storable ImGuiTableColumnSortSpecs where
sizeOf _ = 12
alignment _ = 4
poke ptr ImGuiTableColumnSortSpecs{..} = do
let columnUserIDPtr = castPtr ptr
poke columnUserIDPtr columnUserID
let columnIndexPtr = castPtr $ columnUserIDPtr `plusPtr` sizeOf columnUserID
poke columnIndexPtr columnIndex
let sortOrderPtr = castPtr $ columnIndexPtr `plusPtr` sizeOf columnIndex
poke sortOrderPtr sortOrder
let sortDirectionPtr = castPtr $ sortOrderPtr `plusPtr` sizeOf sortOrder
poke sortDirectionPtr sortDirection
peek ptr = do
let columnUserIDPtr = castPtr ptr
columnUserID <- peek columnUserIDPtr
let columnIndexPtr = castPtr $ columnUserIDPtr `plusPtr` sizeOf columnUserID
columnIndex <- peek columnIndexPtr
let sortOrderPtr = castPtr $ columnIndexPtr `plusPtr` sizeOf columnIndex
sortOrder <- peek sortOrderPtr
let sortDirectionPtr = castPtr $ sortOrderPtr `plusPtr` sizeOf sortOrder
sortDirection' <- peek sortDirectionPtr :: IO CInt
-- XXX: Specs struct uses trimmed field: @SortDirection : 8@
let sortDirection = case sortDirection' .&. 0xFF of
0 ->
ImGuiSortDirection_None
1 ->
ImGuiSortDirection_Ascending
2 ->
ImGuiSortDirection_Descending
_ ->
error $ "Unexpected value for ImGuiSortDirection: " <> show sortDirection
pure ImGuiTableColumnSortSpecs{..}

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)
@ -132,6 +134,8 @@ vulkanInit ( InitInfo {..} ) renderPass = do
initInfo.MSAASamples = $(VkSampleCountFlagBits msaaSamples);
initInfo.Allocator = $(VkAllocationCallbacks* callbacksPtr);
initInfo.CheckVkResultFn = $( void (*checkResultFunPtr)(VkResult) );
initInfo.UseDynamicRendering = false;
// TODO: initInfo.ColorAttachmentFormat
return ImGui_ImplVulkan_Init(&initInfo, $(VkRenderPass renderPass) );
}|]
pure ( checkResultFunPtr, initResult /= 0 )
@ -184,3 +188,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