73 Commits
args ... implot

Author SHA1 Message Date
8eeb38279f MVP 2022-03-10 18:05:27 +01:00
f066d03017 added options to selectable (#137) 2022-03-10 15:17:42 +00:00
fc307a4d6e Add remaining popup wrappers (#136)
- BeginPopupContextItem
- BeginPopupContextWindow
- BeginPopupContextVoid

For #132
2022-03-10 11:34:13 +03:00
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
67e169dc35 Prepare 1.4.0 (#129) 2022-02-13 19:31:45 +03:00
ae3fdb8bc3 Add new GLFW callback from 1.87 (#128) 2022-02-13 16:12:15 +00:00
ccdff36774 Add wchar32 and disable-obsolete flags (#127) 2022-02-13 16:05:49 +00:00
af6ba9e989 Add image support for vulkan backend (#126) 2022-02-13 14:24:08 +00:00
dc11fad07f Update to 1.87 (#125) 2022-02-13 00:26:39 +03:00
265d143261 Prepare 1.3.1 (#123) 2022-01-31 10:56:12 +03:00
0877843619 Update upstream to 1.86 (#122) 2022-01-19 23:36:33 +03:00
a95d95bb65 Prepare 1.3.0 (#120) 2021-12-22 17:40:24 +03:00
23efa7cb02 Fill in changelog for 1.2.1 (#119) 2021-12-22 11:56:55 +00:00
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
13e68242a1 Update unordered-containers upper limit (#117) 2021-12-19 18:25:11 +03:00
2469623f2e Fix CI (#118) 2021-12-19 17:32:28 +03:00
3087a99044 Allow megaparsec 9.2 (#112)
Closes #106
2021-10-30 18:57:15 +00:00
f74cd218c5 Bump imgui to 1.85 (#111)
Closes #110
2021-10-30 18:49:39 +00:00
48c8ae0379 Add IO exports (#109) 2021-10-04 18:49:16 +00:00
a2c0c0658e Remove library options preventing hackage upload (#108) 2021-10-04 18:41:07 +00:00
21ce5cabd8 Add ImGuiIO basics (#107) 2021-10-04 17:29:32 +00:00
8db9ddec2f Added compiler flags stanzas. (#105) 2021-09-21 15:14:37 +03:00
4ecf62ac9e Implement ImGuiListClipper (#100)
* Added DearImGui.Raw.ImGuiListClipper
* Added the DearImGui.withListClipper bracket
* Added dependency for `vector`
* Added the test in the Main.hs
2021-09-17 11:09:22 +03:00
8ee82476dc Add raw DrawList bindings (#99) 2021-09-15 08:52:00 +03:00
b4bc36ca89 Update readme example (#103)
Fixes #68
2021-09-14 15:41:38 +03:00
76ce7bb569 Nix upgrades (#102)
Switches the default Nix build to use GHC 8.10.7 and NixOS 21.05
2021-09-14 01:58:39 +00:00
259ffbff48 Fix DearImGui TOC (#101) 2021-09-13 17:05:49 +00:00
97825e49f2 Prepare 1.2.0 (#98) 2021-09-12 19:46:05 +03:00
24345bb8f3 Add font utils (#56)
- clearFontAtlas
- addFontDefault
- addFontFromFileTTF
- addFontFromMemoryTTF (raw only)
- buildFontAtlas

Vulkan example updated to use on f the imgui-distributed ttf files.
2021-09-12 15:41:42 +00:00
e3f7fbfd6f Add imageButton (#97) 2021-09-12 13:20:47 +00:00
88326420b8 Tidy up image example (#96) 2021-09-12 11:56:43 +00:00
f3b85899f2 Added image wrapper (#74)
Raw.image and sdl2/gl example "image"

Wrappers should be backend-specific due to different handling of `userTextureIDPtr`.
2021-09-12 10:35:03 +00:00
c7a694bce8 Add remaining BeginChild arguments as required (#93)
Old behaviour with all default arguments is a special case to run
some action scoped to a different child window.

This now handled by `beginChildContext`/`withChildContext`.
2021-09-12 10:28:48 +00:00
c219f8eb4f Wrap GetCurrentContext and SetCurrentContext (#94) 2021-09-12 10:23:23 +00:00
24519778e6 Add inputTextMultiline, inputTextWithHint (#92)
- Experimental explicit encoding for CStrings.
- Fix potential buffer overruns in inputText.
2021-09-12 11:43:44 +03:00
4bfc7e7099 Add invisibleButton (#91) 2021-09-11 11:01:03 +00:00
efaaa5723a Add Show instances to structs and enums (#90) 2021-09-11 10:40:05 +00:00
be7aa1e9b1 Add functions for getting window position and size (#89)
- getWindowPos
- getWindowSize
- getWindowWidth
- getWindowHeight

Closes #88
2021-09-11 10:09:11 +00:00
08b3139477 Remove seg faults (#87)
* Removed double OpenGl3Shutdown, leading to a segmentation fault in Main.hs.
* Changed nullPtr passing with Maybe to use DearImGui default arguments.
2021-09-11 10:00:08 +00:00
cede825dff Bump haskell.nix (#86) 2021-09-08 16:19:57 +00:00
84a6b8a8fe Allow parser-combinators-1.4 (#85) 2021-09-08 13:10:39 +01:00
cb687b8f01 Prepare 1.1.0 (#83) 2021-09-01 18:05:18 +00:00
8d07a5a42b Add more withXXX wrappers (#82)
- withStyleColor
- withStyleVar
- withIndent
- withItemWidth

Closes #63
2021-09-01 17:23:59 +00:00
d3a0396623 Add GLFW callbacks (#81)
Closes #80
2021-09-01 19:22:55 +03:00
f49e81c739 Fix warnings (#79) 2021-08-30 17:08:23 +00:00
5699f64e95 Bump imgui to 1.84.2 (#78) 2021-08-30 19:57:00 +03:00
9e5b39850e Prepare 1.0.2 (#77) 2021-08-30 19:20:26 +03:00
d7dc999e8b Add withID (#75)
Raw versions are specialized to match overloaded C++ functions.
2021-08-28 15:52:04 +00:00
bde2030c25 Upgrade Haskell.nix and niv (#73) 2021-07-01 12:58:55 +00:00
1706b7e966 Fix changelog header and links (#72) 2021-06-30 22:44:31 +00:00
bfe8453891 Fix missing headers in source dist (#71)
Fixes #50 again
2021-06-30 22:33:00 +00:00
532eebd8ed Prepare Hackage release (#70) 2021-07-01 00:47:23 +03:00
d42eb672a1 Bump imgui to 1.83 (#66)
Fixes reported vulkan error among others.
2021-06-20 19:43:49 +00:00
1d6b7cc97b Relax MonadUnliftIO constraint on vulkanInit (#65) 2021-06-20 19:17:58 +00:00
c4f3a1e0b9 Update all flags to allow setting them manually (#64) 2021-06-20 20:24:22 +03:00
ff267143d0 Bump deps (#62) 2021-06-15 21:52:39 +00:00
dcaad12ca8 Add more drags and sliders (#60)
- DragFloatRange2
- DragInt..4
- DragIntRange2
- DragScalar
- DragScalarN

- SliderAngle
- SliderInt..4
- SliderScalar
- SliderScalarN
- vSliderFloat
- vSliderInt
- vSliderScalar

Scalar sliders expose format and flags arguments.
2021-06-06 19:10:34 +03:00
f584319577 Add more text widgets (#59)
- Text replaced with TextUnformatted
- TextColored
- TextDisabled
- TextWrapped
- LabelText
- BulletText
2021-06-05 09:01:48 +00:00
6ccee5234b Add withFullscreen and related machinery (#55)
- `fullscreenFlags` available for those who want an alternative
  to `withFullscreen` without reinventing too much.
- Raw.begin got `open` and `flags` arguments.
- Added Raw.setNextWindowFullscreen combo block.
2021-06-04 23:18:16 +03:00
73eee5fc9e Upgrade to dear-imgui v1.82 (#57) 2021-05-08 11:58:25 +00:00
5cdce50c3a Add wantCaptureMouse, wantCaptureKeyboard (#54) 2021-05-03 12:57:23 +03:00
8723ac2625 Add withXxx and withXxxOpen wrappers for begin/end pairs (#49)
Adds dependency on unliftio for monad-preserving brackets.

Fixes #32
2021-04-18 13:10:20 +03:00
b921a72960 Update generator for GHC 9.2 (#48) 2021-04-09 17:18:00 +03:00
5634b6f67d Extract raw C bindings (#44)
The original DearImGui interface hasn't changed.
2021-04-05 20:16:09 +03:00
3949882060 Disable build-depends when not building executables (#43)
This change follows up on https://github.com/haskell-game/dear-imgui.hs/pull/41
where it seems like cabal still need the examples dependency even when they are
not buildable, e.g.: `next goal: vulkan-utils (dependency of dear-imgui)` with
cabal-install version 3.2.0.0.
2021-03-12 15:39:24 +00:00
b0337eb084 Update StateVars only when its widget reports a change (#42) 2021-03-12 11:03:54 +00:00
ebd5286e1c Build executables conditionally on features (#41)
* Build executables conditionally on features

* Put away examples under a flag
2021-03-11 22:59:57 +00:00
2eddbdfa04 Recover init and shutdown from withVulkan (#40) 2021-03-11 09:00:30 +00:00
007b3cccb8 Bindings for item widths functions, and text input widget. (#38) 2021-02-21 11:39:17 +00:00
06921defb1 Generator: use mkName instead of newName (#37) 2021-02-09 11:23:23 +00:00
d4aec47f4e Handle remaining enums (#36)
This handles the remaining enum types in the headers that aren't in the enums section.

It also automatically handles adding all the enumerations to the inline-c context types table, and a small improvement to the display of parse error messages.
2021-02-07 23:07:14 +00:00
921aefdd69 Allow building of OpenGL3 component on Windows/Darwin (#35) 2021-02-06 21:19:56 +00:00
39 changed files with 6970 additions and 1080 deletions

View File

@ -9,13 +9,14 @@ jobs:
persist-credentials: false
submodules: true
- uses: cachix/install-nix-action@v12
- uses: cachix/install-nix-action@v16
with:
nix_path: nixpkgs=channel:nixos-unstable
- uses: cachix/cachix-action@v8
- uses: cachix/cachix-action@v10
with:
name: hs-dear-imgui
authToken: '${{ secrets.CACHIX_AUTH_TOKEN }}'
- run: nix-build --version
- run: nix-build -A hsPkgs.dear-imgui.components.exes

3
.gitmodules vendored
View File

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

76
ChangeLog.md Normal file
View File

@ -0,0 +1,76 @@
# Changelog for dear-imgui
## [1.4.0]
- `imgui` updated to [1.87].
- Added `DearImGui.Vulkan.vulkanAddTexture`.
- Added `DearImGui.GLFW.glfwCursorPosCallback`.
* Apps that don't install backend callbacks, *must* call it themselves.
- Added flags `use-wchar32` (default on) and `disable-obsolete` (default off).
## [1.3.1]
- `imgui` updated to [1.86].
## [1.3.0]
- Added `DearImGui.FontAtlas` and related `DearImGui.Raw.Font.*` bits.
- 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]
- Fixed `nullPtr` in place of default arguments.
- Added functions for getting window position and size.
- Added `invisibleButton`.
- Added `inputTextMultiline` and `inputTextWithHint`.
- Changed `beginChild` and related `withChild*` to use full arguments.
- Added `withChildContext` to run actions inside other child window.
- Added `getCurrentContext`, `setCurrentContext`.
- Added `image` and `imageButton`.
- Added font atlas utilities.
## [1.1.0]
- `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.
## [1.0.2]
- Added `withID` and `ToID(..)` to make composable components possible.
## [1.0.1]
- Fixed missing headers in source dist.
## [1.0.0]
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.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

61
Main.hs
View File

@ -1,5 +1,4 @@
{-# LANGUAGE BlockArguments #-}
{-# LANGUAGE DuplicateRecordFields #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE OverloadedStrings #-}
@ -8,6 +7,7 @@ module Main (main) where
import Control.Monad
import Data.IORef
import qualified Data.Vector as Vector
import DearImGui
import DearImGui.OpenGL3
import DearImGui.SDL
@ -39,26 +39,24 @@ main = do
tab2 <- newIORef True
loop w checked color slider r pos size' selected tab1 tab2
openGL3Shutdown
loop
:: Window
-> IORef Bool
-> IORef ImVec3
-> IORef (Float, Float, Float)
-> IORef Int
-> IORef ImVec2
loop
:: Window
-> IORef Bool
-> IORef ImVec3
-> IORef (Float, Float, Float)
-> IORef Int
-> IORef ImVec2
-> IORef Int
-> IORef ImVec2
-> IORef Int
-> IORef Bool
-> IORef Bool
-> IO ()
loop w checked color slider r pos size' selected tab1Ref tab2Ref = do
quit <- pollEvents
loop window checked color slider r pos size' selected tab1Ref tab2Ref = do
shouldQuit <- checkEvents
openGL3NewFrame
sdl2NewFrame w
sdl2NewFrame
newFrame
-- showDemoWindow
@ -69,13 +67,13 @@ loop w checked color slider r pos size' selected tab1Ref tab2Ref = do
setNextWindowPos pos ImGuiCond_Once Nothing
setNextWindowSize size' ImGuiCond_Once
-- Works, but will make the window contents illegible without doing something more involved.
-- setNextWindowContentSize size'
-- setNextWindowContentSize size'
-- setNextWindowSizeConstraints size' size'
setNextWindowCollapsed False ImGuiCond_Once
setNextWindowBgAlpha 0.42
begin Begin{ name = "My Window", isOpen = Nothing }
begin "My Window"
text "Hello!"
@ -113,7 +111,7 @@ loop w checked color slider r pos size' selected tab1Ref tab2Ref = do
sameLine >> arrowButton "Arrow" ImGuiDir_Up
sameLine >> checkbox Checkbox{ label = "Check!", checked = toStateVar checked } >>= \case
sameLine >> checkbox "Check!" checked >>= \case
True -> readIORef checked >>= print
False -> return ()
@ -123,7 +121,7 @@ loop w checked color slider r pos size' selected tab1Ref tab2Ref = do
progressBar 0.314 (Just "Pi")
beginChild "Child"
beginChild "Child" (ImVec2 0 0) True ImGuiWindowFlags_None
beginCombo "Label" "Preview" >>= whenTrue do
selectable "Testing 1"
@ -134,6 +132,21 @@ loop w checked color slider r pos size' selected tab1Ref tab2Ref = do
endChild
text "ListClipper"
withChildOpen "##fixed" (ImVec2 0 200) True ImGuiWindowFlags_None do
let lotsOfItems = Vector.generate 50 (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 ..]
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
plotHistogram "A histogram" [ 10, 10, 20, 30, 90 ]
colorPicker3 "Test" color
@ -165,13 +178,15 @@ loop w checked color slider r pos size' selected tab1Ref tab2Ref = do
glClear GL_COLOR_BUFFER_BIT
openGL3RenderDrawData =<< getDrawData
glSwapWindow w
glSwapWindow window
if quit then return () else loop w checked color slider r pos size' selected tab1Ref tab2Ref
if shouldQuit
then return ()
else loop window checked color slider r pos size' selected tab1Ref tab2Ref
where
pollEvents = do
checkEvents = do
ev <- pollEventWithImGui
case ev of
@ -181,9 +196,9 @@ loop w checked color slider r pos size' selected tab1Ref tab2Ref = do
QuitEvent -> True
_ -> False
(isQuit ||) <$> pollEvents
(isQuit ||) <$> checkEvents
whenTrue :: IO () -> Bool -> IO ()
whenTrue io True = io
whenTrue io False = return ()
whenTrue _io False = return ()

View File

@ -25,7 +25,7 @@ OpenGL:
```
package dear-imgui
flags: +sdl +opengl
flags: +sdl +opengl3
```
With this done, the following module is the "Hello, World!" of ImGui:
@ -54,38 +54,35 @@ main = do
runManaged do
-- Create a window using SDL. As we're using OpenGL, we need to enable OpenGL too.
w <- do
window <- do
let title = "Hello, Dear ImGui!"
let config = defaultWindow { windowGraphicsContext = OpenGLContext defaultOpenGL }
managed $ bracket (createWindow title config) destroyWindow
-- Create an OpenGL context
glContext <- managed $ bracket (glCreateContext w) glDeleteContext
glContext <- managed $ bracket (glCreateContext window) glDeleteContext
-- Create an ImGui context
_ <- managed $ bracket createContext destroyContext
-- Initialize ImGui's SDL2 backend
_ <- managed_ $ bracket_ (sdl2InitForOpenGL w glContext) sdl2Shutdown
_ <- managed_ $ bracket_ (sdl2InitForOpenGL window glContext) sdl2Shutdown
-- Initialize ImGui's OpenGL backend
_ <- managed_ $ bracket_ openGL2Init openGL2Shutdown
liftIO $ mainLoop w
liftIO $ mainLoop window
mainLoop :: Window -> IO ()
mainLoop w = do
-- Process the event loop
untilNothingM pollEventWithImGui
mainLoop window = unlessQuit do
-- Tell ImGui we're starting a new frame
openGL2NewFrame
sdl2NewFrame w
sdl2NewFrame
newFrame
-- Build the GUI
bracket_ (begin "Hello, ImGui!") end do
withWindowOpen "Hello, ImGui!" do
-- Add a text widget
text "Hello, ImGui!"
@ -103,12 +100,25 @@ mainLoop w = do
render
openGL2RenderDrawData =<< getDrawData
glSwapWindow w
glSwapWindow window
mainLoop w
mainLoop window
where
untilNothingM m = m >>= maybe (return ()) (\_ -> untilNothingM m)
-- 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
```
# Hacking

View File

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

View File

@ -1,9 +1,68 @@
cabal-version: 3.0
name: dear-imgui
version: 1.0.0
version: 1.4.0
author: Oliver Charles
maintainer: ollie@ocharles.org.uk, aenor.realm@gmail.com
license: BSD-3-Clause
category: Graphics
synopsis: Haskell bindings for Dear ImGui.
description:
The package supports multiple rendering backends.
Set package flags according to your needs.
build-type: Simple
data-files:
imgui/imgui.h
extra-source-files:
README.md,
ChangeLog.md
extra-source-files:
imgui/*.h,
imgui/backends/*.h,
imgui/backends/*.mm,
imgui/imconfig.h,
imgui/LICENSE.txt,
implot/*.h,
implot/LICENSE
common exe-flags
if flag(debug)
if os(linux)
ghc-options: -Wall -g -rtsopts -dcore-lint -debug
cc-options: -g -O0 -fsanitize=address -fno-omit-frame-pointer
cxx-options: -g -O0 -fsanitize=address -fno-omit-frame-pointer -std=c++11
if os(darwin)
ghc-options: -Wall -g -rtsopts -dcore-lint -debug
cc-options: -g -O0 -fsanitize=address -fno-omit-frame-pointer
cxx-options: -g -O0 -fsanitize=address -fno-omit-frame-pointer -std=c++11
if os(windows)
ghc-options: -Wall -g -rtsopts -dcore-lint -debug
cc-options: -g -O0
cxx-options: -g -O0 -std=c++11
else
if os(linux)
ghc-options: -Wall -O2
cc-options: -O2
cxx-options: -std=c++11 -O2
if os(darwin)
ghc-options: -Wall -O2
cc-options: -O2
if os(windows)
ghc-options: -Wall -O2
cc-options: -O2
source-repository head
type: git
location: https://github.com/haskell-game/dear-imgui.hs
flag debug
description:
Enable debug mode.
default:
False
manual:
True
flag opengl2
description:
@ -11,7 +70,7 @@ flag opengl2
default:
False
manual:
False
True
flag opengl3
description:
@ -19,7 +78,7 @@ flag opengl3
default:
True
manual:
False
True
flag vulkan
description:
@ -35,7 +94,7 @@ flag sdl
default:
True
manual:
False
True
flag glfw
description:
@ -45,14 +104,36 @@ flag glfw
manual:
True
flag examples
description:
Build executable examples.
default:
False
manual:
True
flag disable-obsolete
description:
Don't define obsolete functions/enums/behaviors. Consider enabling from time to time after updating to avoid using soon-to-be obsolete function/names.
default:
False
manual:
True
flag use-wchar32
description:
Use 32-bit for ImWchar (default is 16-bit) to support unicode planes 1-16. (e.g. point beyond 0xFFFF like emoticons, dingbats, symbols, shapes, ancient languages, etc...)
default:
True
manual:
True
common common
build-depends:
base
>= 4.12 && < 4.17
default-language:
Haskell2010
ghc-options:
-Wall
library
import: common
@ -60,22 +141,35 @@ library
src
exposed-modules:
DearImGui
DearImGui.FontAtlas
DearImGui.Plot
DearImGui.Raw
DearImGui.Raw.DrawList
DearImGui.Raw.Font
DearImGui.Raw.Font.Config
DearImGui.Raw.Font.GlyphRanges
DearImGui.Raw.ListClipper
DearImGui.Raw.IO
DearImGui.Raw.Plot
other-modules:
DearImGui.Context
DearImGui.Enums
DearImGui.Structs
cxx-options: -std=c++11
cxx-sources:
imgui/imgui.cpp
imgui/imgui_demo.cpp
imgui/imgui_draw.cpp
imgui/imgui_tables.cpp
imgui/imgui_widgets.cpp
cxx-options:
-std=c++11
implot/implot.cpp
implot/implot_demo.cpp
implot/implot_items.cpp
extra-libraries:
stdc++
include-dirs:
imgui
implot
build-depends:
dear-imgui-generator
, containers
@ -83,6 +177,15 @@ library
, inline-c
, inline-c-cpp
, StateVar
, unliftio
, vector
if flag(disable-obsolete)
cxx-options: -DIMGUI_DISABLE_OBSOLETE_FUNCTIONS
if flag(use-wchar32)
cxx-options: -DIMGUI_USE_WCHAR32
cpp-options: -DIMGUI_USE_WCHAR32
if flag(opengl2)
exposed-modules:
@ -97,16 +200,8 @@ library
DearImGui.OpenGL3
cxx-sources:
imgui/backends/imgui_impl_opengl3.cpp
if os(windows)
buildable:
False
else
if os(darwin)
buildable:
False
else
pkgconfig-depends:
glew
pkgconfig-depends:
glew
if flag(vulkan)
exposed-modules:
@ -156,7 +251,8 @@ library
exposed-modules:
DearImGui.GLFW
build-depends:
GLFW-b
GLFW-b,
bindings-GLFW
cxx-sources:
imgui/backends/imgui_impl_glfw.cpp
@ -183,16 +279,20 @@ library dear-imgui-generator
build-depends:
template-haskell
>= 2.15 && < 2.19
, containers
^>= 0.6.2.1
, directory
>= 1.3 && < 1.4
, filepath
>= 1.4 && < 1.5
, inline-c
>= 0.9.0.0 && < 0.10
, megaparsec
>= 9.0 && < 9.1
>= 9.0 && < 9.3
, parser-combinators
>= 1.2.0 && < 1.3
>= 1.2.0 && < 1.4
, scientific
>= 0.3.6.2 && < 0.3.7
>= 0.3.6.2 && < 0.3.8
, text
>= 1.2.4 && < 1.3
, th-lift
@ -200,58 +300,85 @@ library dear-imgui-generator
, transformers
>= 0.5.6 && < 0.6
, unordered-containers
>= 0.2.11 && < 0.2.14
>= 0.2.11 && < 0.3
executable test
import: common
import: common, exe-flags
main-is: Main.hs
default-language: Haskell2010
build-depends: base, sdl2, gl, dear-imgui
ghc-options: -Wall
if (!flag(examples) || !flag(sdl) || !flag(opengl2))
buildable: False
else
build-depends: base, sdl2, gl, dear-imgui, vector
executable glfw
import: common, exe-flags
main-is: Main.hs
hs-source-dirs: examples/glfw
default-language: Haskell2010
build-depends: base, GLFW-b, gl, dear-imgui, managed
ghc-options: -Wall
if (!flag(examples) || !flag(glfw) || !flag(opengl2))
buildable: False
else
build-depends: base, GLFW-b, gl, dear-imgui, managed
executable readme
import: common
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 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(opengl2))
buildable: False
executable vulkan
import: common
import: common, exe-flags
main-is: Main.hs
other-modules: Attachments, Backend, Input, Util
hs-source-dirs: examples/vulkan
default-language: Haskell2010
build-depends:
dear-imgui
, bytestring
>= 0.10.10.0 && < 0.12
, containers
^>= 0.6.2.1
, logging-effect
^>= 1.3.12
, resourcet
^>= 1.2.4.2
, sdl2
^>= 2.5.3.0
, text-short
^>= 0.1.3
, transformers
^>= 0.5.6.2
, unliftio
>= 0.2.13 && < 0.2.15
, unliftio-core
^>= 0.2.0.1
, vector
^>= 0.12.1.2
, vulkan
^>= 3.9
, vulkan-utils
^>= 0.4.1
ghc-options: -Wall
if (!flag(examples) || !flag(sdl) || !flag(vulkan))
buildable: False
else
build-depends:
dear-imgui
, bytestring
>= 0.10.10.0 && < 0.12
, containers
^>= 0.6.2.1
, logging-effect
^>= 1.3.12
, resourcet
^>= 1.2.4.2
, sdl2
^>= 2.5.3.0
, text-short
^>= 0.1.3
, transformers
^>= 0.5.6.2
, unliftio
>= 0.2.13 && < 0.2.19
, unliftio-core
^>= 0.2.0.1
, vector
^>= 0.12.1.2
, vulkan
^>= 3.9
, vulkan-utils
^>= 0.4.1
, VulkanMemoryAllocator
, JuicyPixels

View File

@ -4,12 +4,12 @@ haskellNix ? (import (import ./nix/sources.nix)."haskell.nix" { })
# haskell.nix provides access to the nixpkgs pins which are used by our CI,
# hence you will be more likely to get cache hits when using these.
# But you can also just use your own, e.g. '<nixpkgs>'.
, nixpkgsSrc ? haskellNix.sources.nixpkgs-2009
, nixpkgsSrc ? haskellNix.sources.nixpkgs-2105
# haskell.nix provides some arguments to be passed to nixpkgs, including some
# patches and also the haskell.nix functionality itself as an overlay.
, nixpkgsArgs ? haskellNix.nixpkgsArgs
, compiler-nix-name ? "ghc884"
, compiler-nix-name ? "ghc8107"
}:
let
pkgs = import nixpkgsSrc nixpkgsArgs;

View File

@ -24,38 +24,35 @@ main = do
runManaged do
-- Create a window using SDL. As we're using OpenGL, we need to enable OpenGL too.
w <- do
window <- do
let title = "Hello, Dear ImGui!"
let config = defaultWindow { windowGraphicsContext = OpenGLContext defaultOpenGL }
managed $ bracket (createWindow title config) destroyWindow
-- Create an OpenGL context
glContext <- managed $ bracket (glCreateContext w) glDeleteContext
glContext <- managed $ bracket (glCreateContext window) glDeleteContext
-- Create an ImGui context
_ <- managed $ bracket createContext destroyContext
-- Initialize ImGui's SDL2 backend
_ <- managed_ $ bracket_ (sdl2InitForOpenGL w glContext) sdl2Shutdown
_ <- managed_ $ bracket_ (sdl2InitForOpenGL window glContext) sdl2Shutdown
-- Initialize ImGui's OpenGL backend
_ <- managed_ $ bracket_ openGL2Init openGL2Shutdown
liftIO $ mainLoop w
liftIO $ mainLoop window
mainLoop :: Window -> IO ()
mainLoop w = do
-- Process the event loop
untilNothingM pollEventWithImGui
mainLoop window = unlessQuit do
-- Tell ImGui we're starting a new frame
openGL2NewFrame
sdl2NewFrame w
sdl2NewFrame
newFrame
-- Build the GUI
bracket_ (begin Begin{ name = "Hello, ImGui!", isOpen = Nothing }) end do
withWindowOpen "Hello, ImGui!" do
-- Add a text widget
text "Hello, ImGui!"
@ -73,9 +70,22 @@ mainLoop w = do
render
openGL2RenderDrawData =<< getDrawData
glSwapWindow w
glSwapWindow window
mainLoop w
mainLoop window
where
untilNothingM m = m >>= maybe (return ()) (\_ -> untilNothingM m)
-- 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

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

@ -59,14 +59,19 @@ mainLoop win = do
newFrame
-- Build the GUI
bracket_ (begin Begin{ name = "Hello, ImGui!", isOpen = Nothing }) end do
bracket_ (begin "Hello, ImGui!") end 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!"
clicking <- button "Clickety Click"
when clicking $
putStrLn "Ow!"
itemContextPopup do
text "pop!"
button "ok" >>= \clicked ->
when clicked $
closeCurrentPopup
-- Show the ImGui demo window
showDemoWindow

195
examples/sdl/Image.hs Normal file
View File

@ -0,0 +1,195 @@
{-# language BlockArguments #-}
{-# language LambdaCase #-}
{-# language OverloadedStrings #-}
{- | Drawing an DearImGui image using OpenGL textures.
https://github.com/ocornut/imgui/wiki/Image-Loading-and-Displaying-Examples
-}
module Main ( main ) where
import Control.Exception
import Control.Monad.IO.Class (MonadIO(..))
import Control.Monad.Managed (managed, managed_, runManaged)
import DearImGui
import qualified DearImGui.Raw as Raw
import qualified DearImGui.Raw.DrawList as DrawList
import DearImGui.OpenGL3
import DearImGui.SDL
import DearImGui.SDL.OpenGL
import Graphics.GL
import qualified SDL as SDL
-- For the texture creation
import Foreign
import qualified Data.Vector.Storable as VS
data Texture = Texture
{ textureID :: GLuint
, textureWidth :: GLsizei
, textureHeight :: GLsizei
}
deriving (Show)
textureSize :: Texture -> ImVec2
textureSize texture =
ImVec2
(fromIntegral $ textureWidth texture)
(fromIntegral $ textureHeight texture)
-- | Create a texture pointer in GL memory.
create2DTexture :: Int -> Int -> IO Texture
create2DTexture width height =
alloca \ptr -> do
glGenTextures 1 ptr
tID <- peek ptr
return Texture
{ textureID = tID
, textureWidth = fromIntegral width
, textureHeight = fromIntegral height
}
bindTexture :: Texture -> Ptr GLubyte -> IO ()
bindTexture texture dataPtr = do
glEnable GL_TEXTURE_2D
glBindTexture GL_TEXTURE_2D (textureID texture)
glTexParameteri GL_TEXTURE_2D GL_TEXTURE_MIN_FILTER GL_LINEAR
glTexParameteri GL_TEXTURE_2D GL_TEXTURE_MAG_FILTER GL_LINEAR
glTexParameteri GL_TEXTURE_2D GL_TEXTURE_WRAP_S GL_REPEAT
glTexParameteri GL_TEXTURE_2D GL_TEXTURE_WRAP_T GL_REPEAT
glTexImage2D
GL_TEXTURE_2D
0
GL_RGB
(textureWidth texture)
(textureHeight texture)
0
GL_RGB
GL_UNSIGNED_BYTE
(castPtr dataPtr)
fill :: Texture -> (GLubyte, GLubyte, GLubyte) -> VS.Vector GLubyte
fill texture (r, g, b) =
VS.generate
(3 * width * height)
(\i ->
case i `mod` 3 of
0 -> r
1 -> g
2 -> b
_ -> error "assert: 3-byte pitch"
)
where
width = fromIntegral (textureWidth texture)
height = fromIntegral (textureHeight texture)
main :: IO ()
main = do
-- Initialize SDL
SDL.initializeAll
runManaged do
-- Create a window using SDL. As we're using OpenGL, we need to enable OpenGL too.
window <- do
let title = "Hello, Dear ImGui!"
let config = SDL.defaultWindow { SDL.windowGraphicsContext = SDL.OpenGLContext SDL.defaultOpenGL, SDL.windowResizable = True }
managed $ bracket (SDL.createWindow title config) SDL.destroyWindow
-- Create an OpenGL context
glContext <- managed $ bracket (SDL.glCreateContext window) SDL.glDeleteContext
-- Create an ImGui context
_dearContext <- managed $ bracket createContext destroyContext
-- Initialize ImGui's SDL2 backend
managed_ $ bracket_ (sdl2InitForOpenGL window glContext) sdl2Shutdown
-- Initialize ImGui's OpenGL backend
managed_ $ bracket_ openGL3Init do
putStrLn "ImguiOpenGL shut down"
openGL3Shutdown
liftIO do
blueish <- create2DTexture 320 240
VS.unsafeWith (fill blueish (0x00, 0x7F, 0xFF)) $
bindTexture blueish
pinkish <- create2DTexture 240 320
VS.unsafeWith (fill pinkish (0xFF, 0x00, 0x7F)) $
bindTexture pinkish
err <- glGetError
putStrLn $ "Error-code: " ++ show err
print (blueish, pinkish)
mainLoop window (blueish, pinkish) False
mainLoop :: SDL.Window -> (Texture, Texture) -> Bool -> IO ()
mainLoop window textures flag = unlessQuit do
-- Tell ImGui we're starting a new frame
openGL3NewFrame
sdl2NewFrame
newFrame
let texture = if flag then fst textures else snd textures
-- Drawing images require some backend-specific code.
-- Meanwhile, we have to deal with raw bindings.
let openGLtextureID = intPtrToPtr $ fromIntegral $ textureID texture
-- Build the GUI
clicked <- withWindow "Image example" \open ->
if open then do
text "That's an image, click it"
newLine
-- Using imageButton
Foreign.with (textureSize texture) \sizePtr ->
Foreign.with (ImVec2 0 0) \uv0Ptr ->
Foreign.with (ImVec2 1 1) \uv1Ptr ->
Foreign.with (ImVec4 1 1 1 1) \tintColPtr ->
Foreign.with (ImVec4 1 1 1 1) \bgColPtr ->
Raw.imageButton openGLtextureID sizePtr uv0Ptr uv1Ptr (-1) bgColPtr tintColPtr
else
pure False
-- Using DrawList
bg <- getBackgroundDrawList
Foreign.with (ImVec2 100 100) \pMin ->
Foreign.with (ImVec2 200 200) \pMax ->
Foreign.with (ImVec2 0.25 0.25) \uvMin ->
Foreign.with (ImVec2 0.75 0.75) \uvMax ->
DrawList.addImageRounded
bg
openGLtextureID
pMin pMax uvMin uvMax
(Raw.imCol32 0 255 0 0xFF) -- Extract green channel
32 ImDrawFlags_RoundCornersBottom
-- Render
glClear GL_COLOR_BUFFER_BIT
DearImGui.render
DearImGui.getDrawData >>= openGL3RenderDrawData
SDL.glSwapWindow window
mainLoop window textures (flag /= clicked)
where
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

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,6 +94,39 @@ type Handler = LogMessage -> ResourceT IO ()
deriving via ( ReaderT Handler (ResourceT IO) )
instance MonadResource ( LoggingT LogMessage (ResourceT IO) )
gui :: MonadUnliftIO m => (ImGui.Raw.ImVec2, Ptr ()) -> m ImGui.DrawData
gui texture = do
-- Prepare frame
ImGui.Vulkan.vulkanNewFrame
ImGui.SDL.sdl2NewFrame
ImGui.newFrame
-- 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
ImGui.getDrawData
main :: IO ()
main = runResourceT . ( `runLoggingT` logHandler ) $ app @( LoggingT LogMessage ( ResourceT IO ) )
@ -261,6 +305,80 @@ app = do
logDebug "Allocating command buffers"
commandBuffers <- snd <$> allocatePrimaryCommandBuffers device commandPool imageCount
logDebug "Allocating VMA"
(_key, vma) <- VMA.withAllocator
Vulkan.zero
{ VMA.instance' = Vulkan.instanceHandle instance'
, VMA.device = Vulkan.deviceHandle device
, VMA.physicalDevice = Vulkan.physicalDeviceHandle physicalDevice
, VMA.vulkanFunctions = Just $ vmaVulkanFunctions device instance'
}
ResourceT.allocate
logDebug "Loading image data"
picture <- liftIO (Picture.readImage "Example.png") >>= either error (pure . Picture.convertRGBA8)
logDebug "Allocating image"
let textureWidth = Picture.imageWidth picture
let textureHeight = Picture.imageHeight picture
(_key, (image, _imageAllocation, _imageAllocationInfo)) <- VMA.withImage
vma
( Vulkan.zero
{ Vulkan.imageType = Vulkan.IMAGE_TYPE_2D
, Vulkan.mipLevels = 1
, Vulkan.arrayLayers = 1
, Vulkan.format = Vulkan.FORMAT_R8G8B8A8_SRGB
, Vulkan.extent = Vulkan.Extent3D (fromIntegral textureWidth) (fromIntegral textureHeight) 1
, Vulkan.tiling = Vulkan.IMAGE_TILING_OPTIMAL
, Vulkan.initialLayout = Vulkan.IMAGE_LAYOUT_UNDEFINED
, Vulkan.usage = Vulkan.IMAGE_USAGE_SAMPLED_BIT .|. Vulkan.IMAGE_USAGE_TRANSFER_DST_BIT
, Vulkan.sharingMode = Vulkan.SHARING_MODE_EXCLUSIVE
, Vulkan.samples = Vulkan.SAMPLE_COUNT_1_BIT
}
)
( Vulkan.zero
{ VMA.flags = Vulkan.zero
, VMA.usage = VMA.MEMORY_USAGE_GPU_ONLY
, VMA.requiredFlags = Vulkan.MEMORY_PROPERTY_DEVICE_LOCAL_BIT
}
)
ResourceT.allocate
let (pictureF, pictureSize) = Storable.Vector.unsafeToForeignPtr0 (Picture.imageData picture)
let stageBufferCI = Vulkan.zero
{ Vulkan.size = fromIntegral pictureSize
, Vulkan.usage = Vulkan.BUFFER_USAGE_TRANSFER_SRC_BIT
, Vulkan.sharingMode = Vulkan.SHARING_MODE_EXCLUSIVE
}
let stageAllocationCI = Vulkan.zero
{ VMA.flags = VMA.ALLOCATION_CREATE_MAPPED_BIT
, VMA.usage = VMA.MEMORY_USAGE_CPU_TO_GPU
, VMA.requiredFlags = Vulkan.MEMORY_PROPERTY_HOST_VISIBLE_BIT
}
(stageKey, (stage, stageAllocation, stageAllocationInfo)) <- VMA.withBuffer
vma
stageBufferCI
stageAllocationCI
ResourceT.allocate
liftIO $ withForeignPtr pictureF \srcPtr ->
copyBytes (VMA.mappedData stageAllocationInfo) (castPtr srcPtr) pictureSize
VMA.flushAllocation vma stageAllocation 0 Vulkan.WHOLE_SIZE
logDebug "Allocating sampler"
(_key, sampler) <- Vulkan.withSampler device Vulkan.zero Nothing ResourceT.allocate
logDebug "Allocating image view"
(_key, imageView) <- createImageView
device
image
Vulkan.IMAGE_VIEW_TYPE_2D
Vulkan.FORMAT_R8G8B8A8_SRGB
Vulkan.IMAGE_ASPECT_COLOR_BIT
-------------------------------------------
-- Initialise Dear ImGui.
@ -294,23 +412,96 @@ app = do
logDebug "Creating fence"
( fenceKey, fence ) <- createFence device
logDebug "Allocating one-shot command buffer"
( fontUploadCommandBufferKey, fontUploadCommandBuffer ) <-
( oneshotCommandBufferKey, oneshotCommandBuffer ) <-
second Boxed.Vector.head <$>
allocatePrimaryCommandBuffers device commandPool 1
logDebug "Recording one-shot commands"
beginCommandBuffer fontUploadCommandBuffer
_ <- ImGui.Vulkan.vulkanCreateFontsTexture fontUploadCommandBuffer
endCommandBuffer fontUploadCommandBuffer
beginCommandBuffer oneshotCommandBuffer
_ <- ImGui.Vulkan.vulkanCreateFontsTexture oneshotCommandBuffer
logDebug "Uploading texture"
let textureSubresource = Vulkan.ImageSubresourceRange
{ Vulkan.aspectMask = Vulkan.IMAGE_ASPECT_COLOR_BIT
, Vulkan.baseMipLevel = 0
, Vulkan.levelCount = 1
, Vulkan.baseArrayLayer = 0
, Vulkan.layerCount = 1
}
let uploadBarrier = Vulkan.zero
{ Vulkan.srcAccessMask = Vulkan.zero
, Vulkan.dstAccessMask = Vulkan.ACCESS_TRANSFER_WRITE_BIT
, Vulkan.oldLayout = Vulkan.IMAGE_LAYOUT_UNDEFINED
, Vulkan.newLayout = Vulkan.IMAGE_LAYOUT_TRANSFER_DST_OPTIMAL
, Vulkan.srcQueueFamilyIndex = Vulkan.QUEUE_FAMILY_IGNORED
, Vulkan.dstQueueFamilyIndex = Vulkan.QUEUE_FAMILY_IGNORED
, Vulkan.image = image
, Vulkan.subresourceRange = textureSubresource
} :: Vulkan.ImageMemoryBarrier '[]
Vulkan.cmdPipelineBarrier
oneshotCommandBuffer
Vulkan.PIPELINE_STAGE_TOP_OF_PIPE_BIT
Vulkan.PIPELINE_STAGE_TRANSFER_BIT
Vulkan.zero
mempty
mempty
(Boxed.Vector.singleton $ Vulkan.SomeStruct uploadBarrier)
Vulkan.cmdCopyBufferToImage oneshotCommandBuffer stage image Vulkan.IMAGE_LAYOUT_TRANSFER_DST_OPTIMAL $
Boxed.Vector.singleton Vulkan.BufferImageCopy
{ Vulkan.bufferOffset = 0
, Vulkan.bufferRowLength = Vulkan.zero
, Vulkan.bufferImageHeight = Vulkan.zero
, Vulkan.imageSubresource = Vulkan.ImageSubresourceLayers
{ aspectMask = Vulkan.IMAGE_ASPECT_COLOR_BIT
, mipLevel = 0
, baseArrayLayer = 0
, layerCount = 1
}
, Vulkan.imageOffset = Vulkan.zero
, Vulkan.imageExtent = Vulkan.Extent3D
{ width = fromIntegral textureWidth
, height = fromIntegral textureHeight
, depth = 1
}
}
logDebug "Transitioning texture"
let transitionBarrier = Vulkan.zero
{ Vulkan.srcAccessMask = Vulkan.ACCESS_TRANSFER_WRITE_BIT
, Vulkan.dstAccessMask = Vulkan.ACCESS_SHADER_READ_BIT
, Vulkan.oldLayout = Vulkan.IMAGE_LAYOUT_TRANSFER_DST_OPTIMAL
, Vulkan.newLayout = Vulkan.IMAGE_LAYOUT_SHADER_READ_ONLY_OPTIMAL
, Vulkan.srcQueueFamilyIndex = Vulkan.QUEUE_FAMILY_IGNORED
, Vulkan.dstQueueFamilyIndex = Vulkan.QUEUE_FAMILY_IGNORED
, Vulkan.image = image
, Vulkan.subresourceRange = textureSubresource
} :: Vulkan.ImageMemoryBarrier '[]
Vulkan.cmdPipelineBarrier
oneshotCommandBuffer
Vulkan.PIPELINE_STAGE_TRANSFER_BIT
Vulkan.PIPELINE_STAGE_FRAGMENT_SHADER_BIT
Vulkan.zero
mempty
mempty
(Boxed.Vector.singleton $ Vulkan.SomeStruct transitionBarrier)
endCommandBuffer oneshotCommandBuffer
logDebug "Submitting one-shot commands"
submitCommandBuffer queue fontUploadCommandBuffer [] [] ( Just fence )
submitCommandBuffer queue oneshotCommandBuffer [] [] ( Just fence )
waitForFences device ( WaitAll [ fence ] )
logDebug "Finished uploading font objects"
logDebug "Cleaning up one-shot commands"
ImGui.Vulkan.vulkanDestroyFontUploadObjects
traverse_ ResourceT.release [ fenceKey, fontUploadCommandBufferKey ]
traverse_ ResourceT.release [ fenceKey, oneshotCommandBufferKey, stageKey ]
logDebug "Adding imgui texture"
Vulkan.DescriptorSet ds <- ImGui.Vulkan.vulkanAddTexture sampler imageView Vulkan.IMAGE_LAYOUT_SHADER_READ_ONLY_OPTIMAL
let textureSize = ImGui.Raw.ImVec2 (fromIntegral textureWidth) (fromIntegral textureHeight)
let texture = (textureSize, wordPtrToPtr $ fromIntegral ds)
let
mainLoop :: AppState m -> m ()
@ -341,12 +532,6 @@ app = do
pure ( True, False )
else
handleJust vulkanException ( pure . reloadQuit ) do
ImGui.Vulkan.vulkanNewFrame
ImGui.SDL.sdl2NewFrame window
ImGui.newFrame
ImGui.showDemoWindow
ImGui.render
drawData <- ImGui.getDrawData
let
commandBuffer :: Vulkan.CommandBuffer
commandBuffer = commandBuffers Boxed.Vector.! fromIntegral nextImageIndex
@ -355,7 +540,10 @@ app = do
Vulkan.resetCommandBuffer commandBuffer Vulkan.zero
beginCommandBuffer commandBuffer
cmdBeginRenderPass commandBuffer imGuiRenderPass framebuffer clearValues swapchainExtent
drawData <- gui texture
ImGui.Vulkan.vulkanRenderDrawData drawData commandBuffer Nothing
cmdEndRenderPass commandBuffer
endCommandBuffer commandBuffer
submitCommandBuffer
@ -370,7 +558,7 @@ app = do
freeOldResources
let
freeOldResources :: m ()
freeOldResources = pure ()
freeOldResources = pure ()
unless quit $ mainLoop ( AppState {..} )
let

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

@ -6,21 +6,31 @@
{-# LANGUAGE TemplateHaskell #-}
module DearImGui.Generator
( declareEnumerations )
( declareEnumerations, enumerationsTypesTable )
where
-- base
import Data.Coerce
( coerce )
import Control.Arrow
( second )
import Data.Bits
( Bits )
import Data.Foldable
( toList )
import qualified Data.List.NonEmpty as NonEmpty
( head )
import Data.String
( fromString )
import Data.Traversable
( for )
import Foreign.Storable
( Storable )
-- containers
import Data.Map.Strict
( Map )
import qualified Data.Map.Strict as Map
( fromList )
-- directory
import System.Directory
( canonicalizePath )
@ -29,9 +39,12 @@ import System.Directory
import System.FilePath
( takeDirectory )
-- inline-c
import qualified Language.C.Types as InlineC
( TypeSpecifier(TypeName) )
-- megaparsec
import qualified Text.Megaparsec as Megaparsec
( ParseErrorBundle(bundleErrors), parse, parseErrorPretty )
-- template-haskell
import qualified Language.Haskell.TH as TH
@ -39,7 +52,6 @@ import qualified Language.Haskell.TH.Syntax as TH
-- text
import qualified Data.Text as Text
( isInfixOf, null, unpack, unlines )
import qualified Data.Text.IO as Text
( readFile )
@ -47,70 +59,92 @@ import qualified Data.Text.IO as Text
import qualified DearImGui.Generator.Parser as Parser
( headers )
import DearImGui.Generator.Tokeniser
( tokenise )
( Tok, tokenise )
import DearImGui.Generator.Types
( Comment(..), Enumeration(..), Headers(..) )
( Comment(..), Enumeration(..), Headers(..)
, generateNames
)
--------------------------------------------------------------------------------
-- Obtaining parsed header data.
headers :: Headers
headers :: Headers ( TH.Name, TH.Name )
headers = $( do
currentPath <- TH.loc_filename <$> TH.location
TH.lift =<< TH.runIO do
basicHeaders <- TH.runIO do
headersPath <- canonicalizePath ( takeDirectory currentPath <> "/../../imgui/imgui.h" )
headersSource <- Text.readFile headersPath
tokens <- case tokenise headersSource of
tokensImGui <- case tokenise headersSource of
Left err -> error ( "Couldn't tokenise Dear ImGui headers:\n\n" <> show err )
Right toks -> pure toks
headersPath <- canonicalizePath ( takeDirectory currentPath <> "/../../implot/implot.h" )
headersSource <- Text.readFile headersPath
tokensImPlot <- case tokenise headersSource of
Left err -> error ( "Couldn't tokenise Dear ImPlot headers:\n\n" <> show err )
Right toks -> pure toks
let tokens = tokensImGui<>tokensImPlot
case Megaparsec.parse Parser.headers "" tokens of
Left err -> error $
"Couldn't parse Dear ImGui headers:\n\n" <>
( unlines ( map Megaparsec.parseErrorPretty . toList $ Megaparsec.bundleErrors err ) )
Left err -> do
let
errorPos :: Int
errorPos = Megaparsec.errorOffset . NonEmpty.head $ Megaparsec.bundleErrors err
prev, rest :: [ Tok ]
( prev, rest ) = second ( take 15 ) . splitAt 5 . drop ( errorPos - 5 ) $ tokens
error $
"Couldn't parse Dear ImGui headers:\n\n" <>
( unlines ( map Megaparsec.parseErrorPretty . toList $ Megaparsec.bundleErrors err ) ) <> "\n" <>
( unlines ( map show prev ) <> "\n\n" <> unlines ( map show rest ) )
Right res -> pure res
TH.lift $ generateNames basicHeaders
)
--------------------------------------------------------------------------------
-- Generating TH splices.
enumerationsTypesTable :: Map InlineC.TypeSpecifier ( TH.Q TH.Type )
enumerationsTypesTable = Map.fromList . map mkTypePair $ enums headers
where
mkTypePair :: Enumeration ( TH.Name, TH.Name ) -> ( InlineC.TypeSpecifier, TH.Q TH.Type )
mkTypePair ( Enumeration { enumName, enumTypeName } ) =
( InlineC.TypeName $ fromString ( Text.unpack enumName )
, TH.conT ( fst $ enumTypeName )
)
declareEnumerations :: TH.Name -> TH.Name -> TH.Q [ TH.Dec ]
declareEnumerations finiteEnumName countName = do
concat <$> mapM ( declareEnumeration finiteEnumName countName ) ( enums headers )
declareEnumeration :: TH.Name -> TH.Name -> Enumeration -> TH.Q [ TH.Dec ]
declareEnumeration :: TH.Name -> TH.Name -> Enumeration ( TH.Name, TH.Name ) -> TH.Q [ TH.Dec ]
declareEnumeration finiteEnumName countName ( Enumeration {..} ) = do
let
enumNameStr :: String
enumNameStr = Text.unpack enumName
tyName, conName :: TH.Name
( tyName, conName ) = enumTypeName
isFlagEnum :: Bool
isFlagEnum = "Flags" `Text.isInfixOf` enumName
tyName <- TH.newName enumNameStr
conName <- TH.newName enumNameStr
let
newtypeCon :: TH.Q TH.Con
newtypeCon =
TH.normalC conName
[ TH.bangType
( TH.bang TH.noSourceUnpackedness TH.noSourceStrictness )
( TH.conT enumType )
( TH.conT underlyingType )
]
classes :: [ TH.Q TH.Type ]
classes
| isFlagEnum
= map TH.conT [ ''Eq, ''Ord, ''Storable, ''Bits ]
= map TH.conT [ ''Eq, ''Ord, ''Show, ''Storable, ''Bits ]
| otherwise
= map TH.conT [ ''Eq, ''Ord, ''Storable ]
= map TH.conT [ ''Eq, ''Ord, ''Show, ''Storable ]
derivClause :: TH.Q TH.DerivClause
derivClause = TH.derivClause ( Just TH.NewtypeStrategy ) classes
newtypeDecl <-
#if MIN_VERSION_base(4,16,0)
#if MIN_VERSION_template_haskell(2,18,0)
( if null docs
then TH.newtypeD
else
\ ctx name bndrs kd con derivs ->
TH.newtypeD_doc ctx name ( fmap pure bndrs ) ( fmap pure kd ) ( con, "", [] ) derivs
( Text.unpack . Text.unlines . coerce $ docs )
TH.newtypeD_doc ctx name ( fmap pure bndrs ) ( fmap pure kd ) ( con, Nothing, [] ) derivs
( Just . Text.unpack . Text.unlines . coerce $ docs )
)
#else
TH.newtypeD
@ -126,24 +160,24 @@ declareEnumeration finiteEnumName countName ( Enumeration {..} ) = do
<$> TH.appT ( TH.conT countName ) ( TH.conT tyName )
<*> TH.litT ( TH.numTyLit enumSize )
)
]
]
pure ( finiteEnumInst : )
else pure id
synonyms <- for patterns \ ( patternName, patternValue, CommentText patDoc ) -> do
synonyms <- for patterns \ ( patternName, patternValue, CommentText _patDoc ) -> do
let
patNameStr :: String
patNameStr = Text.unpack patternName
patName <- TH.newName patNameStr
patSynSig <- TH.patSynSigD patName ( TH.conT tyName )
pat <-
#if MIN_VERSION_base(4,16,0)
( if Text.null patDoc
#if MIN_VERSION_template_haskell(2,18,0)
( if Text.null _patDoc
then TH.patSynD
else
\ nm args dir pat ->
TH.patSynD_doc nm args dir pat
( Text.unpack patDoc ) []
( Just $ Text.unpack patDoc ) []
)
#else
TH.patSynD

View File

@ -75,7 +75,7 @@ import Data.HashMap.Strict
import qualified Data.HashMap.Strict as HashMap
( fromList, insert, lookup )
-- dear-imgui-generator
-- dear-imgui-generator
import DearImGui.Generator.Tokeniser
( Tok(..) )
import DearImGui.Generator.Types
@ -111,27 +111,48 @@ instance ShowErrorComponent CustomParseError where
--------------------------------------------------------------------------------
-- Parsing headers.
headers :: MonadParsec CustomParseError [Tok] m => m Headers
headers :: MonadParsec CustomParseError [Tok] m => m ( Headers () )
headers = do
_ <- skipManyTill anySingle ( namedSection "Header mess" )
_ <- skipManyTill anySingle ( namedSection "Forward declarations" )
( _structNames, enumNamesAndTypes ) <- forwardDeclarations
_ <- skipManyTill anySingle ( namedSection "Dear ImGui end-user API functions" )
_ <- skipManyTill anySingle ( namedSection "Flags & Enumerations" )
( _defines, enums ) <- partitionEithers <$>
( _defines, basicEnums ) <- partitionEithers <$>
manyTill
( ( Left <$> try ignoreDefine )
<|> ( Right <$> enumeration enumNamesAndTypes )
)
( namedSection "Helpers: Memory allocations macros, ImVector<>" )
_ <- skipManyTill anySingle ( namedSection "ImGuiStyle" )
_ <- skipManyTill anySingle ( namedSection "ImGuiIO" )
_ <- skipManyTill anySingle ( namedSection "Misc data structures" )
_ <- skipManyTill anySingle ( namedSection "Obsolete functions" )
_ <- skipManyTill anySingle ( namedSection "Helpers" )
_ <- skipManyTill anySingle ( namedSection "Drawing API" )
_ <- skipManyTill anySingle ( namedSection "Font API" )
_ <- skipManyTill anySingle ( namedSection "ImGuiStyle" )
_ <- skipManyTill anySingle ( namedSection "ImGuiIO" )
_ <- skipManyTill anySingle ( namedSection "Misc data structures" )
_ <- skipManyTill anySingle ( namedSection "Helpers (ImGuiOnceUponAFrame, ImGuiTextFilter, ImGuiTextBuffer, ImGuiStorage, ImGuiListClipper, ImColor)" )
_ <- skipManyTill anySingle ( namedSection "Drawing API (ImDrawCmd, ImDrawIdx, ImDrawVert, ImDrawChannel, ImDrawListSplitter, ImDrawListFlags, ImDrawList, ImDrawData)" )
skipManyTill anySingle ( try . lookAhead $ many comment *> keyword "enum" )
drawingEnums <- many ( enumeration enumNamesAndTypes )
_ <- skipManyTill anySingle ( namedSection "Font API (ImFontConfig, ImFontGlyph, ImFontAtlasFlags, ImFontAtlas, ImFontGlyphRangesBuilder, ImFont)" )
skipManyTill anySingle ( try . lookAhead $ many comment *> keyword "enum" )
fontEnums <- many ( enumeration enumNamesAndTypes )
_ <- skipManyTill anySingle ( namedSection "Viewports" )
_ <- skipManyTill anySingle ( namedSection "Platform Dependent Interfaces" ) -- XXX: since 1.87
_ <- skipManyTill anySingle ( namedSection "Obsolete functions and types" )
let
enums :: [ Enumeration () ]
enums = basicEnums <> drawingEnums <> fontEnums
pure ( Headers { enums } )
--------------------------------------------------------------------------------
@ -151,7 +172,7 @@ forwardDeclarations = do
_ <- many comment
enums <- many do
keyword "typedef"
ty <- enumTypeName
ty <- cTypeName
enumName <- identifier
reservedSymbol ';'
doc <- commentText <$> comment
@ -159,8 +180,8 @@ forwardDeclarations = do
-- Stopping after simple structs and enums for now.
pure ( HashMap.fromList structs, HashMap.fromList enums )
enumTypeName :: MonadParsec e [Tok] m => m TH.Name
enumTypeName = keyword "int" $> ''CInt
cTypeName :: MonadParsec e [Tok] m => m TH.Name
cTypeName = keyword "int" $> ''CInt
--------------------------------------------------------------------------------
-- Parsing enumerations.
@ -172,22 +193,26 @@ data EnumState = EnumState
, hasExplicitCount :: Bool
}
enumeration :: MonadParsec CustomParseError [Tok] m => HashMap Text ( TH.Name, Comment ) -> m Enumeration
enumeration :: MonadParsec CustomParseError [Tok] m => HashMap Text ( TH.Name, Comment ) -> m ( Enumeration () )
enumeration enumNamesAndTypes = do
inlineDocs <- many comment
keyword "enum"
inlineDocs <- try do
inlineDocs <- many comment
keyword "enum"
pure inlineDocs
fullEnumName <- identifier
let
enumName :: Text
enumName = Text.dropWhileEnd ( == '_' ) fullEnumName
( enumType, forwardDoc ) <- case HashMap.lookup enumName enumNamesAndTypes of
enumTypeName :: ()
enumTypeName = ()
( underlyingType, forwardDoc ) <- case HashMap.lookup enumName enumNamesAndTypes of
Just res -> pure res
Nothing -> customFailure ( MissingForwardDeclaration { enumName } )
let
docs :: [Comment]
docs = forwardDoc : CommentText "" : inlineDocs
reservedSymbol '{'
( patterns, EnumState { enumSize, hasExplicitCount } ) <-
( patterns, EnumState { enumSize, hasExplicitCount } ) <-
( `runStateT` EnumState { enumValues = mempty, currEnumTag = 0, enumSize = 0, hasExplicitCount = False } ) $
catMaybes
<$> many
@ -222,22 +247,30 @@ patternNameAndValue
patternNameAndValue enumName =
try do
sz <- count
modify' ( ( \ st -> st { enumSize = sz, hasExplicitCount = True } ) :: EnumState -> EnumState )
modify' ( \ ( EnumState {..} ) -> EnumState { enumSize = sz, hasExplicitCount = True, .. } )
pure Nothing
<|> do
pat@( _, val ) <- value
modify' ( \ st -> st { enumSize = ( enumSize :: EnumState -> Integer ) st + 1, currEnumTag = val + 1} )
modify' ( \ ( EnumState {..} ) -> EnumState { enumSize = enumSize + 1, currEnumTag = val + 1, .. } )
pure ( Just pat )
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
@ -248,13 +281,16 @@ patternNameAndValue enumName =
patternRHS =
( do
reservedSymbol '='
try integerExpression <|> try disjunction
EnumState{enumValues} <- get
try disjunction <|> try (integerExpression enumValues)
)
<|> ( currEnumTag <$> get )
disjunction :: StateT EnumState m Integer
disjunction = do
( summands :: [Text] ) <- identifier `sepBy1` symbol "|"
initial <- identifier <* symbol "|"
( rest :: [Text] ) <- identifier `sepBy1` symbol "|"
let summands = initial : rest
valsMap <- enumValues <$> get
let
res :: Either [ Text ] Integer
@ -304,34 +340,53 @@ symbol :: MonadParsec e [ Tok ] m => Text -> m ()
symbol s = token ( \ case { Symbolic s' | s == s' -> Just (); _ -> Nothing } ) mempty
<?> ( Text.unpack s <> " (symbol)" )
integerExpression :: MonadParsec e [ Tok ] m => m Integer
integerExpression = try integerPower <|> integer
integerPower :: MonadParsec e [ Tok ] m => m Integer
integerPower = do
a <- integer
_ <- symbol "<<"
i <- integer
pure ( a `shiftL` fromIntegral i )
integer :: forall e m. MonadParsec e [ Tok ] m => m Integer
integer =
option id mkSign <*>
token
( \ case {
Number i suff
| Just _ <- toBoundedInteger @Int64 i
, Right i' <- floatingOrInteger @Float @Integer i
, not ( Text.any ( (== 'f' ) . toLower ) suff )
-> Just i';
_ -> Nothing
}
)
mempty
<?> "integer"
integerExpression :: MonadParsec e [ Tok ] m => HashMap Text Integer -> m Integer
integerExpression enums = try integerPower <|> try integerAdd <|> try integerSub <|> integer
where
mkSign :: m ( Integer -> Integer )
mkSign = ( symbol "+" $> id ) <|> ( symbol "-" $> negate )
integerPower :: MonadParsec e [ Tok ] m => m Integer
integerPower = do
a <- integer
_ <- symbol "<<"
i <- integer
pure ( a `shiftL` fromIntegral i )
integerAdd :: MonadParsec e [ Tok ] m => m Integer
integerAdd = do
a <- integer
_ <- symbol "+"
i <- integer
pure ( a + i )
integerSub :: MonadParsec e [ Tok ] m => m Integer
integerSub = do
a <- integer
_ <- symbol "-"
i <- integer
pure ( a - i )
integer :: forall e m. MonadParsec e [ Tok ] m => m Integer
integer =
option id mkSign <*>
token
( \case
Number i suff
| Just _ <- toBoundedInteger @Int64 i
, Right i' <- floatingOrInteger @Float @Integer i
, not ( Text.any ( (== 'f' ) . toLower ) suff )
->
Just i'
Identifier name ->
HashMap.lookup name enums
_ ->
Nothing
)
mempty
<?> "integer"
where
mkSign :: m ( Integer -> Integer )
mkSign = ( symbol "+" $> id ) <|> ( symbol "-" $> negate )
section :: MonadParsec e [ Tok ] m => m [Text]
section =

View File

@ -1,19 +1,27 @@
{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE BlockArguments #-}
{-# LANGUAGE DeriveLift #-}
{-# LANGUAGE DerivingStrategies #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE TemplateHaskellQuotes #-}
module DearImGui.Generator.Types where
-- base
import Data.Functor
( (<&>) )
-- template-haskell
import qualified Language.Haskell.TH as TH
import qualified Language.Haskell.TH.Syntax as TH
( Lift(..), Name(..) )
-- text
import Data.Text
( Text )
import qualified Data.Text as Text
( unpack )
-- th-lift
import Language.Haskell.TH.Lift
@ -25,18 +33,33 @@ newtype Comment = CommentText { commentText :: Text }
deriving stock ( Show, TH.Lift )
deriving newtype ( Eq, Ord )
data Enumeration
data Enumeration typeName
= Enumeration
{ docs :: ![Comment]
, enumName :: !Text
, enumTypeName :: !typeName
, enumSize :: !Integer
, enumType :: !TH.Name
, underlyingType :: !TH.Name
, hasExplicitCount :: !Bool
, patterns :: [ ( Text, Integer, Comment ) ]
}
deriving stock ( Show, TH.Lift )
data Headers
data Headers typeName
= Headers
{ enums :: [ Enumeration ] }
{ enums :: [ Enumeration typeName ] }
deriving stock ( Show, TH.Lift )
generateNames :: Headers () -> Headers ( TH.Name, TH.Name )
generateNames ( Headers { enums = basicEnums } ) = Headers { enums = namedEnums }
where
namedEnums :: [ Enumeration ( TH.Name, TH.Name ) ]
namedEnums = basicEnums <&> \ enum@( Enumeration { enumName } ) ->
let
enumNameStr :: String
enumNameStr = Text.unpack enumName
tyName, conName :: TH.Name
tyName = TH.mkName enumNameStr
conName = TH.mkName enumNameStr
in
enum { enumTypeName = ( tyName, conName ) }

2
imgui

Submodule imgui updated: 58075c4414...c71a50deb5

1
implot Submodule

Submodule implot added at b47c8bacdb

View File

@ -5,10 +5,10 @@
"homepage": "https://input-output-hk.github.io/haskell.nix",
"owner": "input-output-hk",
"repo": "haskell.nix",
"rev": "ef4aef4ce2060dc1a41b2690df1f54f986e0f9ab",
"sha256": "0537fbjh4mcnywa33h4hl135kw7i8c0j8qndyzv5i82j7mc8wjvs",
"rev": "970c84ad19e84d4ae42075cfe283022394f6effa",
"sha256": "01afbcas324n7j2bpfib7b4fazg5y6k7b74803c0i9ayrs6sgav6",
"type": "tarball",
"url": "https://github.com/input-output-hk/haskell.nix/archive/ef4aef4ce2060dc1a41b2690df1f54f986e0f9ab.tar.gz",
"url": "https://github.com/input-output-hk/haskell.nix/archive/970c84ad19e84d4ae42075cfe283022394f6effa.tar.gz",
"url_template": "https://github.com/<owner>/<repo>/archive/<rev>.tar.gz"
},
"niv": {
@ -17,10 +17,10 @@
"homepage": "https://github.com/nmattia/niv",
"owner": "nmattia",
"repo": "niv",
"rev": "3cd7914b2c4cff48927e11c216dadfab7d903fe5",
"sha256": "1agq4nvbhrylf2s77kb4xhh9k7xcwdwggq764k4jgsbs70py8cw3",
"rev": "e0ca65c81a2d7a4d82a189f1e23a48d59ad42070",
"sha256": "1pq9nh1d8nn3xvbdny8fafzw87mj7gsmp6pxkdl65w2g18rmcmzx",
"type": "tarball",
"url": "https://github.com/nmattia/niv/archive/3cd7914b2c4cff48927e11c216dadfab7d903fe5.tar.gz",
"url": "https://github.com/nmattia/niv/archive/e0ca65c81a2d7a4d82a189f1e23a48d59ad42070.tar.gz",
"url_template": "https://github.com/<owner>/<repo>/archive/<rev>.tar.gz"
},
"nixpkgs": {

View File

@ -6,52 +6,63 @@ let
# The fetchers. fetch_<type> fetches specs of type <type>.
#
fetch_file = pkgs: spec:
if spec.builtin or true then
builtins_fetchurl { inherit (spec) url sha256; }
else
pkgs.fetchurl { inherit (spec) url sha256; };
fetch_file = pkgs: name: spec:
let
name' = sanitizeName name + "-src";
in
if spec.builtin or true then
builtins_fetchurl { inherit (spec) url sha256; name = name'; }
else
pkgs.fetchurl { inherit (spec) url sha256; name = name'; };
fetch_tarball = pkgs: spec:
if spec.builtin or true then
builtins_fetchTarball { inherit (spec) url sha256; }
else
pkgs.fetchzip { inherit (spec) url sha256; };
fetch_tarball = pkgs: name: spec:
let
name' = sanitizeName name + "-src";
in
if spec.builtin or true then
builtins_fetchTarball { name = name'; inherit (spec) url sha256; }
else
pkgs.fetchzip { name = name'; inherit (spec) url sha256; };
fetch_git = spec:
builtins.fetchGit { url = spec.repo; inherit (spec) rev ref; };
fetch_git = name: spec:
let
ref =
if spec ? ref then spec.ref else
if spec ? branch then "refs/heads/${spec.branch}" else
if spec ? tag then "refs/tags/${spec.tag}" else
abort "In git source '${name}': Please specify `ref`, `tag` or `branch`!";
in
builtins.fetchGit { url = spec.repo; inherit (spec) rev; inherit ref; };
fetch_builtin-tarball = spec:
builtins.trace
''
WARNING:
The niv type "builtin-tarball" will soon be deprecated. You should
instead use `builtin = true`.
fetch_local = spec: spec.path;
$ niv modify <package> -a type=tarball -a builtin=true
''
builtins_fetchTarball { inherit (spec) url sha256; };
fetch_builtin-tarball = name: throw
''[${name}] The niv type "builtin-tarball" is deprecated. You should instead use `builtin = true`.
$ niv modify ${name} -a type=tarball -a builtin=true'';
fetch_builtin-url = spec:
builtins.trace
''
WARNING:
The niv type "builtin-url" will soon be deprecated. You should
instead use `builtin = true`.
$ niv modify <package> -a type=file -a builtin=true
''
(builtins_fetchurl { inherit (spec) url sha256; });
fetch_builtin-url = name: throw
''[${name}] The niv type "builtin-url" will soon be deprecated. You should instead use `builtin = true`.
$ niv modify ${name} -a type=file -a builtin=true'';
#
# Various helpers
#
# https://github.com/NixOS/nixpkgs/pull/83241/files#diff-c6f540a4f3bfa4b0e8b6bafd4cd54e8bR695
sanitizeName = name:
(
concatMapStrings (s: if builtins.isList s then "-" else s)
(
builtins.split "[^[:alnum:]+._?=-]+"
((x: builtins.elemAt (builtins.match "\\.*(.*)" x) 0) name)
)
);
# The set of packages used when specs are fetched using non-builtins.
mkPkgs = sources:
mkPkgs = sources: system:
let
sourcesNixpkgs =
import (builtins_fetchTarball { inherit (sources.nixpkgs) url sha256; }) {};
import (builtins_fetchTarball { inherit (sources.nixpkgs) url sha256; }) { inherit system; };
hasNixpkgsPath = builtins.any (x: x.prefix == "nixpkgs") builtins.nixPath;
hasThisAsNixpkgsPath = <nixpkgs> == ./.;
in
@ -71,14 +82,27 @@ let
if ! builtins.hasAttr "type" spec then
abort "ERROR: niv spec ${name} does not have a 'type' attribute"
else if spec.type == "file" then fetch_file pkgs spec
else if spec.type == "tarball" then fetch_tarball pkgs spec
else if spec.type == "git" then fetch_git spec
else if spec.type == "builtin-tarball" then fetch_builtin-tarball spec
else if spec.type == "builtin-url" then fetch_builtin-url spec
else if spec.type == "file" then fetch_file pkgs name spec
else if spec.type == "tarball" then fetch_tarball pkgs name spec
else if spec.type == "git" then fetch_git name spec
else if spec.type == "local" then fetch_local spec
else if spec.type == "builtin-tarball" then fetch_builtin-tarball name
else if spec.type == "builtin-url" then fetch_builtin-url name
else
abort "ERROR: niv spec ${name} has unknown type ${builtins.toJSON spec.type}";
# If the environment variable NIV_OVERRIDE_${name} is set, then use
# the path directly as opposed to the fetched source.
replace = name: drv:
let
saneName = stringAsChars (c: if isNull (builtins.match "[a-zA-Z0-9]" c) then "_" else c) name;
ersatz = builtins.getEnv "NIV_OVERRIDE_${saneName}";
in
if ersatz == "" then drv else
# this turns the string into an actual Nix path (for both absolute and
# relative paths)
if builtins.substring 0 1 ersatz == "/" then /. + ersatz else /. + builtins.getEnv "PWD" + "/${ersatz}";
# Ports of functions for older nix versions
# a Nix version of mapAttrs if the built-in doesn't exist
@ -87,23 +111,37 @@ let
listToAttrs (map (attr: { name = attr; value = f attr set.${attr}; }) (attrNames set))
);
# https://github.com/NixOS/nixpkgs/blob/0258808f5744ca980b9a1f24fe0b1e6f0fecee9c/lib/lists.nix#L295
range = first: last: if first > last then [] else builtins.genList (n: first + n) (last - first + 1);
# https://github.com/NixOS/nixpkgs/blob/0258808f5744ca980b9a1f24fe0b1e6f0fecee9c/lib/strings.nix#L257
stringToCharacters = s: map (p: builtins.substring p 1 s) (range 0 (builtins.stringLength s - 1));
# https://github.com/NixOS/nixpkgs/blob/0258808f5744ca980b9a1f24fe0b1e6f0fecee9c/lib/strings.nix#L269
stringAsChars = f: s: concatStrings (map f (stringToCharacters s));
concatMapStrings = f: list: concatStrings (map f list);
concatStrings = builtins.concatStringsSep "";
# https://github.com/NixOS/nixpkgs/blob/8a9f58a375c401b96da862d969f66429def1d118/lib/attrsets.nix#L331
optionalAttrs = cond: as: if cond then as else {};
# fetchTarball version that is compatible between all the versions of Nix
builtins_fetchTarball = { url, sha256 }@attrs:
builtins_fetchTarball = { url, name ? null, sha256 }@attrs:
let
inherit (builtins) lessThan nixVersion fetchTarball;
in
if lessThan nixVersion "1.12" then
fetchTarball { inherit url; }
fetchTarball ({ inherit url; } // (optionalAttrs (!isNull name) { inherit name; }))
else
fetchTarball attrs;
# fetchurl version that is compatible between all the versions of Nix
builtins_fetchurl = { url, sha256 }@attrs:
builtins_fetchurl = { url, name ? null, sha256 }@attrs:
let
inherit (builtins) lessThan nixVersion fetchurl;
in
if lessThan nixVersion "1.12" then
fetchurl { inherit url; }
fetchurl ({ inherit url; } // (optionalAttrs (!isNull name) { inherit name; }))
else
fetchurl attrs;
@ -115,14 +153,15 @@ let
then abort
"The values in sources.json should not have an 'outPath' attribute"
else
spec // { outPath = fetch config.pkgs name spec; }
spec // { outPath = replace name (fetch config.pkgs name spec); }
) config.sources;
# The "config" used by the fetchers
mkConfig =
{ sourcesFile ? ./sources.json
, sources ? builtins.fromJSON (builtins.readFile sourcesFile)
, pkgs ? mkPkgs sources
{ sourcesFile ? if builtins.pathExists ./sources.json then ./sources.json else null
, sources ? if isNull sourcesFile then {} else builtins.fromJSON (builtins.readFile sourcesFile)
, system ? builtins.currentSystem
, pkgs ? mkPkgs sources system
}: rec {
# The sources, i.e. the attribute set of spec name to spec
inherit sources;
@ -130,5 +169,6 @@ let
# The "pkgs" (evaluated nixpkgs) to use for e.g. non-builtin fetchers
inherit pkgs;
};
in
mkSources (mkConfig {}) // { __functor = _: settings: mkSources (mkConfig settings); }

File diff suppressed because it is too large Load Diff

View File

@ -18,22 +18,36 @@ import Language.C.Types
( pattern TypeName )
-- dear-imgui
import DearImGui.Enums
import DearImGui.Structs
-- dear-imgui-generator
import DearImGui.Generator
( enumerationsTypesTable )
--------------------------------------------------------------------------------
imguiContext :: Context
imguiContext = mempty
{ ctxTypesTable = Map.fromList
[ ( TypeName "ImGuiCol" , [t| ImGuiCol |] )
, ( TypeName "ImGuiCond", [t| ImGuiCond |] )
, ( TypeName "ImGuiDir" , [t| ImGuiDir |] )
, ( TypeName "ImGuiStyleVar" , [t| ImGuiStyleVar |] )
, ( TypeName "ImGuiTabBarFlags" , [t| ImGuiTabBarFlags |] )
, ( TypeName "ImGuiTabItemFlags", [t| ImGuiTabItemFlags |] )
, ( TypeName "ImVec2", [t| ImVec2 |] )
{ ctxTypesTable = enumerationsTypesTable <>
Map.fromList
[ ( TypeName "ImVec2", [t| ImVec2 |] )
, ( TypeName "ImVec3", [t| ImVec3 |] )
, ( TypeName "ImVec4", [t| ImVec4 |] )
, ( TypeName "ImU32", [t| ImU32 |] )
, ( 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 |] )
]
}
implotContext :: Context
implotContext = mempty
{ ctxTypesTable =
Map.fromList
[ ( TypeName "ImPlotContext", [t| ImPlotContext |] )
]
}

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

@ -0,0 +1,501 @@
{-# 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.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 :: String -> RangesBuilderSetup
addText str =
RangesBuilderSetup \builder ->
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

@ -19,9 +19,34 @@ module DearImGui.GLFW (
-- ** GLFW
glfwNewFrame
, glfwShutdown
-- $callbacks
, glfwWindowFocusCallback
, glfwCursorEnterCallback
, glfwCursorPosCallback
, glfwMouseButtonCallback
, glfwScrollCallback
, glfwKeyCallback
, glfwCharCallback
, glfwMonitorCallback
)
where
-- base
import Foreign
( Ptr, castPtr )
import Foreign.C.Types
( CInt, CDouble, CUInt )
import Unsafe.Coerce (unsafeCoerce)
-- bindings-GLFW
import Bindings.GLFW
( C'GLFWmonitor, C'GLFWwindow )
-- GLFW-b
import Graphics.UI.GLFW
( Monitor, Window )
-- inline-c
import qualified Language.C.Inline as C
@ -44,8 +69,135 @@ glfwNewFrame :: MonadIO m => m ()
glfwNewFrame = liftIO do
[C.exp| void { ImGui_ImplGlfw_NewFrame(); } |]
-- $callbacks
-- == GLFW callbacks
-- * When calling Init with @install_callbacks=true@:
-- GLFW callbacks will be installed for you.
-- They will call user's previously installed callbacks, if any.
-- * When calling Init with @install_callbacks=false@:
-- GLFW callbacks won't be installed.
-- You will need to call those function yourself from your own GLFW callbacks.
-- | Wraps @ImGui_ImplGlfw_Shutdown@.
glfwShutdown :: MonadIO m => m ()
glfwShutdown = liftIO do
[C.exp| void { ImGui_ImplGlfw_Shutdown(); } |]
[C.exp| void { ImGui_ImplGlfw_Shutdown(); } |]
glfwWindowFocusCallback :: MonadIO m => Window -> CInt -> m ()
glfwWindowFocusCallback window focused = liftIO do
[C.exp| void {
ImGui_ImplGlfw_WindowFocusCallback(
static_cast<GLFWwindow *>(
$(void * windowPtr)
),
$(int focused)
);
} |]
where
windowPtr = castPtr $ unWindow window
glfwCursorEnterCallback :: MonadIO m => Window -> CInt -> m ()
glfwCursorEnterCallback window entered = liftIO do
[C.exp| void {
ImGui_ImplGlfw_CursorEnterCallback(
static_cast<GLFWwindow *>(
$(void * windowPtr)
),
$(int entered)
);
} |]
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 {
ImGui_ImplGlfw_MouseButtonCallback(
static_cast<GLFWwindow *>(
$(void * windowPtr)
),
$(int button),
$(int action),
$(int mods)
);
} |]
where
windowPtr = castPtr $ unWindow window
glfwScrollCallback :: MonadIO m => Window -> CDouble -> CDouble -> m ()
glfwScrollCallback window xoffset yoffset = liftIO do
[C.exp| void {
ImGui_ImplGlfw_ScrollCallback(
static_cast<GLFWwindow *>(
$(void * windowPtr)
),
$(double xoffset),
$(double yoffset)
);
} |]
where
windowPtr = castPtr $ unWindow window
glfwKeyCallback :: MonadIO m => Window -> CInt -> CInt -> CInt -> CInt -> m ()
glfwKeyCallback window key scancode action mods = liftIO do
[C.exp| void {
ImGui_ImplGlfw_KeyCallback(
static_cast<GLFWwindow *>(
$(void * windowPtr)
),
$(int key),
$(int scancode),
$(int action),
$(int mods)
);
} |]
where
windowPtr = castPtr $ unWindow window
glfwCharCallback :: MonadIO m => Window -> CUInt -> m ()
glfwCharCallback window c = liftIO do
[C.exp| void {
ImGui_ImplGlfw_CharCallback(
static_cast<GLFWwindow *>(
$(void * windowPtr)
),
$(unsigned int c)
);
} |]
where
windowPtr = castPtr $ unWindow window
glfwMonitorCallback :: MonadIO m => Monitor -> CInt -> m ()
glfwMonitorCallback monitor event = liftIO do
[C.exp| void {
ImGui_ImplGlfw_MonitorCallback(
static_cast<GLFWmonitor *>(
$(void * monitorPtr)
),
$(int event)
);
} |]
where
monitorPtr = castPtr $ unMonitor monitor
-- | Strip the unpublished newtype wrapper.
unWindow :: Window -> Ptr C'GLFWwindow
unWindow = unsafeCoerce
-- | Strip the unpublished newtype wrapper.
unMonitor :: Monitor -> Ptr C'GLFWmonitor
unMonitor = unsafeCoerce

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

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

1646
src/DearImGui/Raw.hs Normal file

File diff suppressed because it is too large Load Diff

View File

@ -0,0 +1,742 @@
{-# LANGUAGE BlockArguments #-}
{-# LANGUAGE DuplicateRecordFields #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE PatternSynonyms #-}
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE ViewPatterns #-}
{-| Draw command list
This is the low-level list of polygons that ImGui functions are filling.
At the end of the frame, all command lists are passed to your @ImGuiIO::RenderDrawListFn@ function for rendering.
Each dear imgui window contains its own ImDrawList.
You can use 'getWindowDrawList' to access the current window draw list and draw custom primitives.
You can interleave normal ImGui calls and adding primitives to the current draw list.
In single viewport mode, top-left is == @GetMainViewport()->Pos@ (generally @0,0@),
bottom-right is == @GetMainViewport()->Pos+Size@ (generally io.DisplaySize).
You are totally free to apply whatever transformation matrix to want to the data
(depending on the use of the transformation you may want to apply it to ClipRect as well!).
__Important__: Primitives are always added to the list and not culled (culling is done at higher-level by ImGui functions),
if you use this API a lot consider coarse culling your drawn objects.
-}
module DearImGui.Raw.DrawList
( DrawList(..)
, new
, destroy
-- * Primitives
-- $primitives
, addLine
, addRect
, addRectFilled
, addRectFilledMultiColor
, addQuad
, addQuadFilled
, addTriangle
, addTriangleFilled
, addCircle
, addCircleFilled
, addNgon
, addNgonFilled
, addText_
, addText
, addPolyLine
, addConvexPolyFilled
, addBezierCubic
, addBezierQuadratic
-- ** Image primitives
-- $image
, addImage
, addImageQuad
, addImageRounded
-- * Stateful path API
-- $stateful
, pathClear
, pathLineTo
, pathLineToMergeDuplicate
, pathFillConvex
, pathStroke
, pathArcTo
, pathArcToFast
, pathBezierCubicCurveTo
, pathBezierQuadraticCurveTo
, pathRect
-- * Advanced
-- , addCallback
, addDrawCmd
, cloneOutput
-- * Internal state
, pushClipRect
, pushClipRectFullScreen
, popClipRect
, getClipRectMin
, getClipRectMax
, pushTextureID
, popTextureID
)
where
import Control.Monad.IO.Class
( MonadIO, liftIO )
import Foreign hiding (new)
import Foreign.C
-- dear-imgui
import DearImGui.Context
( imguiContext )
import DearImGui.Enums
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"
-- | A single draw command list.
-- Generally one per window, conceptually you may see this as a dynamic "mesh" builder.
newtype DrawList = DrawList (Ptr ImDrawList)
new :: MonadIO m => m DrawList
new = liftIO do
DrawList <$> [C.block|
ImDrawList* {
return IM_NEW(ImDrawList(GetDrawListSharedData()));
}
|]
destroy :: MonadIO m => DrawList -> m ()
destroy (DrawList drawList) = liftIO do
[C.block|
void {
IM_DELETE($(ImDrawList* drawList));
}
|]
pushClipRect :: MonadIO m => DrawList -> Ptr ImVec2 -> Ptr ImVec2 -> CBool -> m ()
pushClipRect (DrawList drawList) clip_rect_min clip_rect_max intersect_with_current_clip_rect = liftIO do
[C.block|
void {
$(ImDrawList* drawList)->PushClipRect(
*$(ImVec2* clip_rect_min),
*$(ImVec2* clip_rect_max),
$(bool intersect_with_current_clip_rect)
);
}
|]
pushClipRectFullScreen :: MonadIO m => DrawList -> m ()
pushClipRectFullScreen (DrawList drawList) = liftIO do
[C.block|
void {
$(ImDrawList* drawList)->PushClipRectFullScreen();
}
|]
popClipRect :: MonadIO m => DrawList -> m ()
popClipRect (DrawList drawList) = liftIO do
[C.block|
void {
$(ImDrawList* drawList)->PopClipRect();
}
|]
getClipRectMin :: MonadIO m => DrawList -> m ImVec2
getClipRectMin (DrawList drawList) = liftIO do
C.withPtr_ \ptr ->
[C.block|
void {
*$(ImVec2 * ptr) = $(ImDrawList* drawList)->GetClipRectMin();
}
|]
getClipRectMax :: MonadIO m => DrawList -> m ImVec2
getClipRectMax (DrawList drawList) = liftIO do
C.withPtr_ \ptr ->
[C.block|
void {
*$(ImVec2 * ptr) = $(ImDrawList* drawList)->GetClipRectMax();
}
|]
pushTextureID :: MonadIO m => DrawList -> Ptr () -> m ()
pushTextureID (DrawList drawList) userTextureIDPtr = liftIO do
[C.block|
void {
$(ImDrawList* drawList)->PushTextureID(
$(void* userTextureIDPtr)
);
}
|]
popTextureID :: MonadIO m => DrawList -> m ()
popTextureID (DrawList drawList) = liftIO do
[C.block|
void {
$(ImDrawList* drawList)->PopTextureID();
}
|]
{- $primitives
- For rectangular primitives, @p_min@ and @p_max@ represent the upper-left and lower-right corners.
- For circle primitives, use @num_segments == 0@ to automatically calculate tessellation (preferred).
In older versions (until Dear ImGui 1.77) the 'addCircle' functions defaulted to num_segments == 12.
In future versions we will use textures to provide cheaper and higher-quality circles.
Use 'addNgon' and 'addNgonFilled' functions if you need to guaranteed a specific number of sides.
-}
addLine :: MonadIO m => DrawList -> Ptr ImVec2 -> Ptr ImVec2 -> ImU32 -> CFloat -> m ()
addLine (DrawList drawList) p1 p2 col thickness = liftIO do
[C.block|
void {
$(ImDrawList* drawList)->AddLine(
*$(ImVec2* p1),
*$(ImVec2* p2),
$(ImU32 col),
$(float thickness)
);
}
|]
addRect :: MonadIO m => DrawList -> Ptr ImVec2 -> Ptr ImVec2 -> ImU32 -> CFloat -> ImDrawFlags -> CFloat -> m ()
addRect (DrawList drawList) p_min p_max col rounding flags thickness = liftIO do
[C.block|
void {
$(ImDrawList* drawList)->AddRect(
*$(ImVec2* p_min),
*$(ImVec2* p_max),
$(ImU32 col),
$(float rounding),
$(ImDrawFlags flags),
$(float thickness)
);
}
|]
addRectFilled :: MonadIO m => DrawList -> Ptr ImVec2 -> Ptr ImVec2 -> ImU32 -> CFloat -> ImDrawFlags -> m ()
addRectFilled (DrawList drawList) p_min p_max col rounding flags = liftIO do
[C.block|
void {
$(ImDrawList* drawList)->AddRectFilled(
*$(ImVec2* p_min),
*$(ImVec2* p_max),
$(ImU32 col),
$(float rounding),
$(ImDrawFlags flags)
);
}
|]
addRectFilledMultiColor :: MonadIO m => DrawList -> Ptr ImVec2 -> Ptr ImVec2 -> ImU32 -> ImU32 -> ImU32 -> ImU32 -> m ()
addRectFilledMultiColor (DrawList drawList) p_min p_max col_upr_left col_upr_right col_bot_right col_bot_left = liftIO do
[C.block|
void {
$(ImDrawList* drawList)->AddRectFilledMultiColor(
*$(ImVec2* p_min),
*$(ImVec2* p_max),
$(ImU32 col_upr_left),
$(ImU32 col_upr_right),
$(ImU32 col_bot_right),
$(ImU32 col_bot_left)
);
}
|]
addQuad :: MonadIO m => DrawList -> Ptr ImVec2 -> Ptr ImVec2 -> Ptr ImVec2 -> Ptr ImVec2 -> ImU32 -> CFloat -> m ()
addQuad (DrawList drawList) p1 p2 p3 p4 col thickness = liftIO do
[C.block|
void {
$(ImDrawList* drawList)->AddQuad(
*$(ImVec2* p1),
*$(ImVec2* p2),
*$(ImVec2* p3),
*$(ImVec2* p4),
$(ImU32 col),
$(float thickness)
);
}
|]
addQuadFilled :: MonadIO m => DrawList -> Ptr ImVec2 -> Ptr ImVec2 -> Ptr ImVec2 -> Ptr ImVec2 -> ImU32 -> m ()
addQuadFilled (DrawList drawList) p1 p2 p3 p4 col = liftIO do
[C.block|
void {
$(ImDrawList* drawList)->AddQuadFilled(
*$(ImVec2* p1),
*$(ImVec2* p2),
*$(ImVec2* p3),
*$(ImVec2* p4),
$(ImU32 col)
);
}
|]
addTriangle :: MonadIO m => DrawList -> Ptr ImVec2 -> Ptr ImVec2 -> Ptr ImVec2 -> ImU32 -> CFloat -> m ()
addTriangle (DrawList drawList) p1 p2 p3 col thickness = liftIO do
[C.block|
void {
$(ImDrawList* drawList)->AddTriangle(
*$(ImVec2* p1),
*$(ImVec2* p2),
*$(ImVec2* p3),
$(ImU32 col),
$(float thickness)
);
}
|]
addTriangleFilled :: MonadIO m => DrawList -> Ptr ImVec2 -> Ptr ImVec2 -> Ptr ImVec2 -> ImU32 -> m ()
addTriangleFilled (DrawList drawList) p1 p2 p3 col = liftIO do
[C.block|
void {
$(ImDrawList* drawList)->AddTriangleFilled(
*$(ImVec2* p1),
*$(ImVec2* p2),
*$(ImVec2* p3),
$(ImU32 col)
);
}
|]
addCircle :: MonadIO m => DrawList -> Ptr ImVec2 -> CFloat -> ImU32 -> CInt -> CFloat -> m ()
addCircle (DrawList drawList) center radius col num_segments thickness = liftIO do
[C.block|
void {
$(ImDrawList* drawList)->AddCircle(
*$(ImVec2* center),
$(float radius),
$(ImU32 col),
$(int num_segments),
$(float thickness)
);
}
|]
addCircleFilled :: MonadIO m => DrawList -> Ptr ImVec2 -> CFloat -> ImU32 -> CInt -> m ()
addCircleFilled (DrawList drawList) center radius col num_segments = liftIO do
[C.block|
void {
$(ImDrawList* drawList)->AddCircleFilled(
*$(ImVec2* center),
$(float radius),
$(ImU32 col),
$(int num_segments)
);
}
|]
addNgon :: MonadIO m => DrawList -> Ptr ImVec2 -> CFloat -> ImU32 -> CInt -> CFloat -> m ()
addNgon (DrawList drawList) center radius col num_segments thickness = liftIO do
[C.block|
void {
$(ImDrawList* drawList)->AddNgon(
*$(ImVec2* center),
$(float radius),
$(ImU32 col),
$(int num_segments),
$(float thickness)
);
}
|]
addNgonFilled :: MonadIO m => DrawList -> Ptr ImVec2 -> CFloat -> ImU32 -> CInt -> m ()
addNgonFilled (DrawList drawList) center radius col num_segments = liftIO do
[C.block|
void {
$(ImDrawList* drawList)->AddNgonFilled(
*$(ImVec2* center),
$(float radius),
$(ImU32 col),
$(int num_segments)
);
}
|]
addText_ :: MonadIO m => DrawList -> Ptr ImVec2 -> ImU32 -> CString -> CString -> m ()
addText_ (DrawList drawList) pos col text_begin text_end = liftIO do
[C.block|
void {
$(ImDrawList* drawList)->AddText(
*$(ImVec2* pos),
$(ImU32 col),
$(char* text_begin),
$(char* text_end)
);
}
|]
addText :: MonadIO m => DrawList -> Ptr ImFont -> CFloat -> Ptr ImVec2 -> ImU32 -> CString -> CString -> CFloat -> Ptr ImVec4 -> m ()
addText (DrawList drawList) fontPtr font_size pos col text_begin text_end wrap_width cpu_fine_clip_rect = liftIO do
[C.block|
void {
$(ImDrawList* drawList)->AddText(
$(ImFont* fontPtr),
$(float font_size),
*$(ImVec2* pos),
$(ImU32 col),
$(char* text_begin),
$(char* text_end),
$(float wrap_width),
$(ImVec4* cpu_fine_clip_rect)
);
}
|]
addPolyLine :: MonadIO m => DrawList -> Ptr ImVec2 -> CInt -> ImU32 -> ImDrawFlags -> CFloat -> m ()
addPolyLine (DrawList drawList) points num_points col flags thickness = liftIO do
[C.block|
void {
$(ImDrawList* drawList)->AddPolyline(
$(ImVec2* points),
$(int num_points),
$(ImU32 col),
$(ImDrawFlags flags),
$(float thickness)
);
}
|]
addConvexPolyFilled :: MonadIO m => DrawList -> Ptr ImVec2 -> CInt -> ImU32 -> m ()
addConvexPolyFilled (DrawList drawList) points num_points col = liftIO do
[C.block|
void {
$(ImDrawList* drawList)->AddConvexPolyFilled(
$(ImVec2* points),
$(int num_points),
$(ImU32 col)
);
}
|]
addBezierCubic
:: MonadIO m
=> DrawList
-> Ptr ImVec2 -> Ptr ImVec2 -> Ptr ImVec2 -> Ptr ImVec2 -- Positions (control points)
-> ImU32
-> CFloat
-> CInt
-> m ()
addBezierCubic (DrawList drawList) p1 p2 p3 p4 col thickness numSegments = liftIO do
[C.block|
void {
$(ImDrawList* drawList)->AddBezierCubic(
*$(ImVec2* p1),
*$(ImVec2* p2),
*$(ImVec2* p3),
*$(ImVec2* p4),
$(ImU32 col),
$(float thickness),
$(int numSegments)
);
}
|]
addBezierQuadratic
:: MonadIO m
=> DrawList
-> Ptr ImVec2 -> Ptr ImVec2 -> Ptr ImVec2 -- Positions (control points)
-> ImU32
-> CFloat
-> CInt
-> m ()
addBezierQuadratic (DrawList drawList) p1 p2 p3 col thickness numSegments = liftIO do
[C.block|
void {
$(ImDrawList* drawList)->AddBezierQuadratic(
*$(ImVec2* p1),
*$(ImVec2* p2),
*$(ImVec2* p3),
$(ImU32 col),
$(float thickness),
$(int numSegments)
);
}
|]
{- $image
* Read FAQ to understand what @ImTextureID@ is.
* @p_min@ and @p_max@ represent the upper-left and lower-right corners of the rectangle.
* @uv_min@ and @uv_max@ represent the normalized texture coordinates to use for those corners.
Using @(0,0)->(1,1)@ texture coordinates will generally display the entire texture.
-}
addImage
:: MonadIO m
=> DrawList
-> Ptr ()
-> Ptr ImVec2 -> Ptr ImVec2 -- Positions
-> Ptr ImVec2 -> Ptr ImVec2 -- UVs
-> ImU32
-> m ()
addImage (DrawList drawList) userTextureIDPtr p_min p_max uv_min uv_max col = liftIO do
[C.block|
void {
$(ImDrawList* drawList)->AddImage(
$(void* userTextureIDPtr),
*$(ImVec2* p_min),
*$(ImVec2* p_max),
*$(ImVec2* uv_min),
*$(ImVec2* uv_max),
$(ImU32 col)
);
}
|]
addImageQuad
:: MonadIO m
=> DrawList
-> Ptr ()
-> Ptr ImVec2 -> Ptr ImVec2 -> Ptr ImVec2 -> Ptr ImVec2 -- Positions
-> Ptr ImVec2 -> Ptr ImVec2 -> Ptr ImVec2 -> Ptr ImVec2 -- UVs
-> ImU32
-> m ()
addImageQuad (DrawList drawList) userTextureIDPtr p1 p2 p3 p4 uv1 uv2 uv3 uv4 col = liftIO do
[C.block|
void {
$(ImDrawList* drawList)->AddImageQuad(
$(void* userTextureIDPtr),
*$(ImVec2* p1),
*$(ImVec2* p2),
*$(ImVec2* p3),
*$(ImVec2* p4),
*$(ImVec2* uv1),
*$(ImVec2* uv2),
*$(ImVec2* uv3),
*$(ImVec2* uv4),
$(ImU32 col)
);
}
|]
addImageRounded
:: MonadIO m
=> DrawList
-> Ptr ()
-> Ptr ImVec2 -> Ptr ImVec2 -- Positions
-> Ptr ImVec2 -> Ptr ImVec2 -- UVs
-> ImU32
-> CFloat
-> ImDrawFlags
-> m ()
addImageRounded (DrawList drawList) userTextureIDPtr p_min p_max uv_min uv_max col rounding flags = liftIO do
[C.block|
void {
$(ImDrawList* drawList)->AddImageRounded(
$(void* userTextureIDPtr),
*$(ImVec2* p_min),
*$(ImVec2* p_max),
*$(ImVec2* uv_min),
*$(ImVec2* uv_max),
$(ImU32 col),
$(float rounding),
$(ImDrawFlags flags)
);
}
|]
{- $stateful
Add points then finish with 'pathFillConvex' or 'pathStroke'.
-}
pathClear :: MonadIO m => DrawList -> m ()
pathClear (DrawList drawList) = liftIO do
[C.block|
void {
$(ImDrawList* drawList)->PathClear();
}
|]
pathLineTo :: MonadIO m => DrawList -> Ptr ImVec2 -> m ()
pathLineTo (DrawList drawList) pos = liftIO do
[C.block|
void {
$(ImDrawList* drawList)->PathLineTo(
*$(ImVec2* pos)
);
}
|]
pathLineToMergeDuplicate :: MonadIO m => DrawList -> Ptr ImVec2 -> m ()
pathLineToMergeDuplicate (DrawList drawList) pos = liftIO do
[C.block|
void {
$(ImDrawList* drawList)->PathLineToMergeDuplicate(
*$(ImVec2* pos)
);
}
|]
-- | Note: Anti-aliased filling requires points to be in clockwise order.
pathFillConvex :: MonadIO m => DrawList -> ImU32 -> m ()
pathFillConvex (DrawList drawList) col = liftIO do
[C.block|
void {
$(ImDrawList* drawList)->PathFillConvex(
$(ImU32 col)
);
}
|]
pathStroke :: MonadIO m => DrawList -> ImU32 -> ImDrawFlags -> CFloat -> m ()
pathStroke (DrawList drawList) col flags thickness = liftIO do
[C.block|
void {
$(ImDrawList* drawList)->PathStroke(
$(ImU32 col),
$(ImDrawFlags flags),
$(float thickness)
);
}
|]
pathArcTo :: MonadIO m => DrawList -> Ptr ImVec2 -> CFloat -> CFloat -> CFloat -> CInt -> m ()
pathArcTo (DrawList drawList) center radius a_min a_max num_segments = liftIO do
[C.block|
void {
$(ImDrawList* drawList)->PathArcTo(
*$(ImVec2* center),
$(float radius),
$(float a_min),
$(float a_max),
$(int num_segments)
);
}
|]
-- | Use precomputed angles for a 12 steps circle.
pathArcToFast :: MonadIO m => DrawList -> Ptr ImVec2 -> CFloat -> CInt -> CInt -> m ()
pathArcToFast (DrawList drawList) center radius a_min_of_12 a_max_of_12 = liftIO do
[C.block|
void {
$(ImDrawList* drawList)->PathArcToFast(
*$(ImVec2* center),
$(float radius),
$(int a_min_of_12),
$(int a_max_of_12)
);
}
|]
pathBezierCubicCurveTo
:: MonadIO m
=> DrawList
-> Ptr ImVec2
-> Ptr ImVec2
-> Ptr ImVec2
-> CInt
-> m ()
pathBezierCubicCurveTo (DrawList drawList) p1 p2 p3 num_segments = liftIO do
[C.block|
void {
$(ImDrawList* drawList)->PathBezierCubicCurveTo(
*$(ImVec2* p1),
*$(ImVec2* p2),
*$(ImVec2* p3),
$(int num_segments)
);
}
|]
pathBezierQuadraticCurveTo
:: MonadIO m
=> DrawList
-> Ptr ImVec2
-> Ptr ImVec2
-> CInt
-> m ()
pathBezierQuadraticCurveTo (DrawList drawList) p1 p2 num_segments = liftIO do
[C.block|
void {
$(ImDrawList* drawList)->PathBezierQuadraticCurveTo(
*$(ImVec2* p1),
*$(ImVec2* p2),
$(int num_segments)
);
}
|]
pathRect :: MonadIO m => DrawList -> Ptr ImVec2 -> Ptr ImVec2 -> CFloat -> ImDrawFlags -> m ()
pathRect (DrawList drawList) rect_min rect_max rounding flags = liftIO do
[C.block|
void {
$(ImDrawList* drawList)->PathRect(
*$(ImVec2* rect_min),
*$(ImVec2* rect_max),
$(float rounding),
$(ImDrawFlags flags)
);
}
|]
-- | This is useful if you need to forcefully create a new draw call (to allow for dependent rendering / blending).
-- Otherwise primitives are merged into the same draw-call as much as possible.
addDrawCmd :: MonadIO m => DrawList -> m ()
addDrawCmd (DrawList drawList) = liftIO do
[C.block|
void {
$(ImDrawList* drawList)->AddDrawCmd();
}
|]
-- | Create a clone of the CmdBuffer/IdxBuffer/VtxBuffer.
cloneOutput :: MonadIO m => DrawList -> m DrawList
cloneOutput (DrawList drawList) = liftIO do
DrawList <$> [C.block|
ImDrawList* {
return $(ImDrawList* drawList)->CloneOutput();
}
|]

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.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.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.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)));
}
|]

137
src/DearImGui/Raw/IO.hs Normal file
View File

@ -0,0 +1,137 @@
{-# LANGUAGE BlockArguments #-}
{-# LANGUAGE DuplicateRecordFields #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE PatternSynonyms #-}
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE ViewPatterns #-}
{-| Main configuration and I/O between your application and ImGui
-}
module DearImGui.Raw.IO
( setIniFilename
, setLogFilename
, setMouseDoubleClickMaxDist
, setMouseDoubleClickTime
, setMouseDragThreshold
, setKeyRepeatDelay
, setKeyRepeatRate
, setUserData
) where
-- TODO: add exports
import Control.Monad.IO.Class
( MonadIO, liftIO )
import Foreign
( Ptr )
import Foreign.C
( CFloat(..)
, CString
)
-- dear-imgui
import DearImGui.Context
( imguiContext )
-- import DearImGui.Enums
-- 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"
setIniFilename :: MonadIO m => CString -> m ()
setIniFilename ptr = liftIO do
[C.block|
void {
GetIO().IniFilename = $(char * ptr);
}
|]
setLogFilename :: MonadIO m => CString -> m ()
setLogFilename ptr = liftIO do
[C.block|
void {
GetIO().LogFilename = $(char * ptr);
}
|]
setMouseDoubleClickTime :: MonadIO m => CFloat -> m ()
setMouseDoubleClickTime seconds = liftIO do
[C.block|
void {
GetIO().MouseDoubleClickTime = $(float seconds);
}
|]
setMouseDoubleClickMaxDist :: MonadIO m => CFloat -> m ()
setMouseDoubleClickMaxDist pixels = liftIO do
[C.block|
void {
GetIO().MouseDoubleClickMaxDist = $(float pixels);
}
|]
setMouseDragThreshold :: MonadIO m => CFloat -> m ()
setMouseDragThreshold pixels = liftIO do
[C.block|
void {
GetIO().MouseDragThreshold = $(float pixels);
}
|]
setKeyRepeatDelay :: MonadIO m => CFloat -> m ()
setKeyRepeatDelay seconds = liftIO do
[C.block|
void {
GetIO().KeyRepeatDelay = $(float seconds);
}
|]
setKeyRepeatRate :: MonadIO m => CFloat -> m ()
setKeyRepeatRate pixels = liftIO do
[C.block|
void {
GetIO().KeyRepeatRate = $(float pixels);
}
|]
setUserData :: MonadIO m => Ptr () -> m ()
setUserData ptr = liftIO do
[C.block|
void {
GetIO().UserData = $(void* ptr);
}
|]
{- 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
int MetricsActiveWindows; // Number of active windows
int MetricsActiveAllocations; // Number of active allocations, updated by MemAlloc/MemFree based on current context. May be off if you have multiple imgui contexts.
ImVec2 MouseDelta;
-}

View File

@ -0,0 +1,149 @@
{-# LANGUAGE BlockArguments #-}
{-# LANGUAGE DuplicateRecordFields #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE PatternSynonyms #-}
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE ViewPatterns #-}
{-| Helper: Manually clip large list of items.
If you are submitting lots of evenly spaced items and you have a random access to the list,
you can perform coarse clipping based on visibility to save yourself from processing those items at all.
The clipper calculates the range of visible items and advance the cursor to compensate for the non-visible items we have skipped.
Dear ImGui already clips items based on their bounds but it needs to measure text size to do so,
whereas manual coarse clipping before submission makes this cost and your own data fetching/submission cost almost null.
Usage:
@
clipper <- ListClipper.new
ListClipper.begin clipper 1000 -- We have 1000 elements, evenly spaced.
whileTrue (ListClipper.step clipper) $
start <- ListClipper.displayStart clipper
end <- ListClipper.displayEnd clipper
for_ [start .. end] \ix ->
ImGui.text $ "line number " <> show ix
@
Generally what happens is:
* Clipper lets you process the first element (DisplayStart = 0, DisplayEnd = 1) regardless of it being visible or not.
* User code submit one element.
* Clipper can measure the height of the first element
* Clipper calculate the actual range of elements to display based on the current clipping rectangle,
position the cursor before the first visible element.
* User code submit visible elements.
-}
module DearImGui.Raw.ListClipper
( ListClipper
, new
, delete
, begin
, displayStart
, displayEnd
, step
)
where
import Control.Monad.IO.Class
( MonadIO, liftIO )
import Foreign hiding (new)
import Foreign.C
import System.IO.Unsafe (unsafePerformIO)
-- dear-imgui
import DearImGui.Context
( imguiContext )
import DearImGui.Structs
( ImGuiListClipper )
-- 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"
-- | @ImGuiListClipper@ object handle.
type ListClipper = Ptr ImGuiListClipper
-- | Create a new 'ListClipper' instance.
new :: (MonadIO m) => m ListClipper
new = liftIO do
[C.block|
ImGuiListClipper* {
return IM_NEW(ImGuiListClipper);
}
|]
-- | Destroy 'ListClipper' instance.
delete :: (MonadIO m) => ListClipper -> m ()
delete clipper = liftIO do
[C.block|
void {
IM_DELETE($(ImGuiListClipper* clipper));
}
|]
-- | ListClipper setup
--
-- @items_count@: Use 'maxBound' if you don't know how many items you have
-- (in which case the cursor won't be advanced in the final step).
--
-- @items_height@: Use -1.0f to be calculated automatically on first step.
-- Otherwise pass in the distance between your items, typically
-- 'getTextLineHeightWithSpacing' or 'getFrameHeightWithSpacing'.
--
-- Wraps @ListClipper::Begin()@.
begin :: (MonadIO m) => ListClipper -> CInt -> CFloat -> m ()
begin clipper items_count items_height = liftIO do
[C.block|
void {
$(ImGuiListClipper* clipper)->Begin($(int items_count), $(float items_height));
}
|]
-- | An accessor for @ListClipper::Begin@
displayStart :: ListClipper -> CInt
displayStart clipper = unsafePerformIO do
[C.exp|
int {
$(ImGuiListClipper* clipper)->DisplayStart
}
|]
-- | An accessor for @ListClipper::DisplayStart@
displayEnd :: ListClipper -> CInt
displayEnd clipper = unsafePerformIO
[C.exp|
int {
$(ImGuiListClipper* clipper)->DisplayEnd
}
|]
-- | Call until it returns 'False'.
--
-- The 'displayStart'/'displayEnd' fields will be set and you can process/draw those items.
--
-- Wraps @ListClipper::Step()@.
step :: (MonadIO m) => ListClipper -> m Bool
step clipper = liftIO do
(0 /=) <$> [C.block|
bool {
return $(ImGuiListClipper* clipper)->Step();
}
|]

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

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

View File

@ -40,7 +40,6 @@ import qualified Language.C.Inline.Cpp as Cpp
-- sdl2
import SDL
import SDL.Internal.Types
import SDL.Raw.Enum as Raw
import qualified SDL.Raw.Event as Raw
@ -57,9 +56,9 @@ Cpp.using "namespace ImGui"
-- | Wraps @ImGui_ImplSDL2_NewFrame@.
sdl2NewFrame :: MonadIO m => Window -> m ()
sdl2NewFrame (Window windowPtr) = liftIO do
[C.exp| void { ImGui_ImplSDL2_NewFrame((SDL_Window*)($(void* windowPtr))); } |]
sdl2NewFrame :: MonadIO m => m ()
sdl2NewFrame = liftIO do
[C.exp| void { ImGui_ImplSDL2_NewFrame(); } |]
-- | Wraps @ImGui_ImplSDL2_Shutdown@.

View File

@ -1,14 +1,23 @@
{-# LANGUAGE DuplicateRecordFields #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE CPP #-}
module DearImGui.Structs where
-- base
import Data.Word
( Word32
#ifndef IMGUI_USE_WCHAR32
, Word16
#endif
)
import Foreign
( Storable(..), castPtr, plusPtr )
--------------------------------------------------------------------------------
data ImVec2 = ImVec2 { x, y :: {-# unpack #-} !Float }
deriving (Show)
instance Storable ImVec2 where
@ -27,6 +36,7 @@ instance Storable ImVec2 where
data ImVec3 = ImVec3 { x, y, z :: {-# unpack #-} !Float }
deriving (Show)
instance Storable ImVec3 where
@ -47,6 +57,7 @@ instance Storable ImVec3 where
data ImVec4 = ImVec4 { x, y, z, w :: {-# unpack #-} !Float }
deriving (Show)
instance Storable ImVec4 where
@ -66,3 +77,53 @@ instance Storable ImVec4 where
z <- peek (castPtr ptr `plusPtr` (sizeOf x * 2))
w <- peek (castPtr ptr `plusPtr` (sizeOf x * 3))
return ImVec4{ x, y, z, w }
--------------------------------------------------------------------------------
-- | DearImGui context handle.
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
-- | 32-bit unsigned integer (often used to store packed colors).
type ImU32 = Word32
-- | Single wide character (used mostly in glyph management)
#ifdef IMGUI_USE_WCHAR32
type ImWchar = Word32
#else
type ImWchar = Word16
#endif
--------------------------------------------------------------------------------
-- | DearImPlot context handle
data ImPlotContext
-- | Double precision version of ImVec2 used by ImPlot. Extensible by end users
data ImPlotPoint
-- | Range defined by a min/max value.
data ImPlotRange
-- | Combination of two range limits for X and Y axes. Also an AABB defined by Min()/Max().
data ImPlotRect
-- | Plot style structure
data ImPlotStyle
-- | Input mapping structure. Default values listed. See also MapInputDefault, MapInputReverse.
data ImPlotInputMap

View File

@ -12,11 +12,15 @@ Vulkan backend for Dear ImGui.
module DearImGui.Vulkan
( InitInfo(..)
, withVulkan
, vulkanInit
, vulkanShutdown
, vulkanNewFrame
, vulkanRenderDrawData
, vulkanCreateFontsTexture
, vulkanDestroyFontUploadObjects
, vulkanSetMinImageCount
, vulkanAddTexture
)
where
@ -28,9 +32,9 @@ import Data.Word
import Foreign.Marshal.Alloc
( alloca )
import Foreign.Ptr
( Ptr, freeHaskellFunPtr, nullPtr )
( FunPtr, Ptr, freeHaskellFunPtr, nullPtr )
import Foreign.Storable
( Storable(poke) )
( poke )
-- inline-c
import qualified Language.C.Inline as C
@ -83,7 +87,18 @@ data InitInfo =
-- | Wraps @ImGui_ImplVulkan_Init@ and @ImGui_ImplVulkan_Shutdown@.
withVulkan :: MonadUnliftIO m => InitInfo -> Vulkan.RenderPass -> ( Bool -> m a ) -> m a
withVulkan ( InitInfo {..} ) renderPass action = do
withVulkan initInfo renderPass action =
bracket
( vulkanInit initInfo renderPass )
vulkanShutdown
( \ ( _, 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)
vulkanInit ( InitInfo {..} ) renderPass = do
let
instancePtr :: Ptr Vulkan.Instance_T
instancePtr = Vulkan.instanceHandle instance'
@ -97,38 +112,39 @@ withVulkan ( InitInfo {..} ) renderPass action = do
withCallbacks f = case mbAllocator of
Nothing -> f nullPtr
Just callbacks -> alloca ( \ ptr -> poke ptr callbacks *> f ptr )
bracket
( liftIO do
checkResultFunPtr <- $( C.mkFunPtr [t| Vulkan.Result -> IO () |] ) checkResult
initResult <- withCallbacks \ callbacksPtr ->
[C.block| bool {
ImGui_ImplVulkan_InitInfo initInfo;
VkInstance instance = { $( VkInstance_T* instancePtr ) };
initInfo.Instance = instance;
VkPhysicalDevice physicalDevice = { $( VkPhysicalDevice_T* physicalDevicePtr ) };
initInfo.PhysicalDevice = physicalDevice;
VkDevice device = { $( VkDevice_T* devicePtr ) };
initInfo.Device = device;
initInfo.QueueFamily = $(uint32_t queueFamily);
VkQueue queue = { $( VkQueue_T* queuePtr ) };
initInfo.Queue = queue;
initInfo.PipelineCache = $(VkPipelineCache pipelineCache);
initInfo.DescriptorPool = $(VkDescriptorPool descriptorPool);
initInfo.Subpass = $(uint32_t subpass);
initInfo.MinImageCount = $(uint32_t minImageCount);
initInfo.ImageCount = $(uint32_t imageCount);
initInfo.MSAASamples = $(VkSampleCountFlagBits msaaSamples);
initInfo.Allocator = $(VkAllocationCallbacks* callbacksPtr);
initInfo.CheckVkResultFn = $( void (*checkResultFunPtr)(VkResult) );
return ImGui_ImplVulkan_Init(&initInfo, $(VkRenderPass renderPass) );
}|]
pure ( checkResultFunPtr, initResult /= 0 )
)
( \ ( checkResultFunPtr, _ ) -> liftIO do
[C.exp| void { ImGui_ImplVulkan_Shutdown(); } |]
freeHaskellFunPtr checkResultFunPtr
)
( \ ( _, initResult ) -> action initResult )
liftIO do
checkResultFunPtr <- $( C.mkFunPtr [t| Vulkan.Result -> IO () |] ) checkResult
initResult <- withCallbacks \ callbacksPtr ->
[C.block| bool {
ImGui_ImplVulkan_InitInfo initInfo;
VkInstance instance = { $( VkInstance_T* instancePtr ) };
initInfo.Instance = instance;
VkPhysicalDevice physicalDevice = { $( VkPhysicalDevice_T* physicalDevicePtr ) };
initInfo.PhysicalDevice = physicalDevice;
VkDevice device = { $( VkDevice_T* devicePtr ) };
initInfo.Device = device;
initInfo.QueueFamily = $(uint32_t queueFamily);
VkQueue queue = { $( VkQueue_T* queuePtr ) };
initInfo.Queue = queue;
initInfo.PipelineCache = $(VkPipelineCache pipelineCache);
initInfo.DescriptorPool = $(VkDescriptorPool descriptorPool);
initInfo.Subpass = $(uint32_t subpass);
initInfo.MinImageCount = $(uint32_t minImageCount);
initInfo.ImageCount = $(uint32_t imageCount);
initInfo.MSAASamples = $(VkSampleCountFlagBits msaaSamples);
initInfo.Allocator = $(VkAllocationCallbacks* callbacksPtr);
initInfo.CheckVkResultFn = $( void (*checkResultFunPtr)(VkResult) );
return ImGui_ImplVulkan_Init(&initInfo, $(VkRenderPass renderPass) );
}|]
pure ( checkResultFunPtr, initResult /= 0 )
-- | Wraps @ImGui_ImplVulkan_Shutdown@.
--
-- Counterpart to 'vulkanInit', for clean-up.
vulkanShutdown :: MonadIO m => (FunPtr a, b) -> m ()
vulkanShutdown ( checkResultFunPtr, _ ) = liftIO do
[C.exp| void { ImGui_ImplVulkan_Shutdown(); } |]
freeHaskellFunPtr checkResultFunPtr
-- | Wraps @ImGui_ImplVulkan_NewFrame@.
vulkanNewFrame :: MonadIO m => m ()
@ -170,3 +186,16 @@ vulkanDestroyFontUploadObjects = liftIO do
vulkanSetMinImageCount :: MonadIO m => Word32 -> m ()
vulkanSetMinImageCount minImageCount = liftIO do
[C.exp| void { ImGui_ImplVulkan_SetMinImageCount($(uint32_t minImageCount)); } |]
-- | Wraps @ImGui_ImplVulkan_AddTexture@.
vulkanAddTexture :: MonadIO m => Vulkan.Sampler -> Vulkan.ImageView -> Vulkan.ImageLayout -> m Vulkan.DescriptorSet
vulkanAddTexture sampler imageView imageLayout = liftIO do
[C.block|
VkDescriptorSet {
return ImGui_ImplVulkan_AddTexture(
$(VkSampler sampler),
$(VkImageView imageView),
$(VkImageLayout imageLayout)
);
}
|]

View File

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