69 Commits

Author SHA1 Message Date
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
9e5dbd755f Add haskell-language-server to the dev shell (#34) 2021-02-06 15:43:26 +00:00
f9412effde Wrap the OpenGL 3 backend (#20) 2021-02-06 14:44:58 +00:00
ac74572121 Add tab bar functions (#30) 2021-02-06 13:26:28 +00:00
860720e7c2 Define types for use in ImGui Context (#31)
Just doing a little cleanup:

* some functions were not exported,
* some functions were missing the initial | for their documentation,
* add types to the ImGui Context instead of coercing to int. This is more robust, in case upstream changes any of the larger enums to be 64 bits instead of 32 for instance
2021-02-06 10:17:37 +00:00
de0e87612c Add setNextWindow functions, pushColor, pushStyle, indent-related functions (#27) 2021-02-05 23:46:48 +00:00
d7686f84e4 Add support for GLFW (#26)
Co-authored-by: Oliver Charles <ollie@ocharles.org.uk>
2021-02-05 21:44:52 +00:00
643d2ea5b7 Add combo to wrap ImGUI::Combo() (#28)
Co-authored-by: Oliver Charles <ollie@ocharles.org.uk>
2021-02-05 21:20:32 +00:00
895f5c1926 Parse enums from headers & generate code (#19) 2021-02-05 20:57:17 +00:00
81582ba6eb Ignore imgui.ini (#29)
This file gets generated by routine testing but we'll never want to commit it.
2021-02-05 20:22:26 +00:00
af49a7b3fb Wrap ImGui::ListBox() (#25) 2021-01-28 23:38:59 +00:00
bb82e87553 Wrap ImGui::TreeNode, TreePush, TreePop (#24) 2021-01-28 23:28:45 +00:00
24903ce76f Implement ImGui::DragFloat{,2,3,4} (#23) 2021-01-28 23:10:58 +00:00
f24a4b78ab Implement ImGui::SliderFloat2,3,4 (#22) 2021-01-28 23:02:04 +00:00
63bb63a32e Wrap ImGui::BeginChild and EndChild (#21) 2021-01-28 22:38:25 +00:00
397cea7bd9 Add Cachix (#14) 2021-01-27 09:08:33 +00:00
35 changed files with 6504 additions and 588 deletions

View File

@ -13,4 +13,9 @@ jobs:
with:
nix_path: nixpkgs=channel:nixos-unstable
- run: nix-build -A hsPkgs.dear-imgui.components.exes --option trusted-public-keys "hydra.iohk.io:f/Ea+s+dFdN+3Y/G+FDgSq+a5NEWhJGzdjvKNGv0/EQ= iohk.cachix.org-1:DpRUyj7h7V830dp/i6Nti+NEO2/nhblbov/8MW7Rqoo= cache.nixos.org-1:6NCHdD59X431o0gWypbMrAURkbJ16ZPMQFGspcDShjY=" --option substituters "https://hydra.iohk.io https://iohk.cachix.org https://cache.nixos.org/"
- uses: cachix/cachix-action@v8
with:
name: hs-dear-imgui
authToken: '${{ secrets.CACHIX_AUTH_TOKEN }}'
- run: nix-build -A hsPkgs.dear-imgui.components.exes

1
.gitignore vendored
View File

@ -21,3 +21,4 @@ cabal.project.local
cabal.project.local~
.HTF/
.ghc.environment.*
/imgui.ini

42
ChangeLog.md Normal file
View File

@ -0,0 +1,42 @@
# Changelog for dear-imgui
## [1.2.1]
- Added `DearImGui.Raw.IO` with attribute setters.
## [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

111
Main.hs
View File

@ -5,9 +5,11 @@
module Main (main) where
import Control.Monad
import Data.IORef
import qualified Data.Vector as Vector
import DearImGui
import DearImGui.OpenGL
import DearImGui.OpenGL3
import DearImGui.SDL
import DearImGui.SDL.OpenGL
import Control.Exception
@ -22,23 +24,39 @@ main = do
bracket (glCreateContext w) glDeleteContext \glContext ->
bracket createContext destroyContext \_imguiContext ->
bracket_ (sdl2InitForOpenGL w glContext) sdl2Shutdown $
bracket_ openGL2Init openGL2Shutdown do
bracket_ openGL3Init openGL3Shutdown do
checkVersion
styleColorsLight
checked <- newIORef False
color <- newIORef $ ImVec3 1 0 0
slider <- newIORef 0.42
loop w checked color slider
slider <- newIORef (0.42, 0, 0.314)
r <- newIORef 4
pos <- newIORef $ ImVec2 64 64
size' <- newIORef $ ImVec2 512 512
selected <- newIORef 4
tab1 <- newIORef True
tab2 <- newIORef True
loop w checked color slider r pos size' selected tab1 tab2
openGL2Shutdown
loop :: Window -> IORef Bool -> IORef ImVec3 -> IORef Float -> IO ()
loop w checked color slider = do
quit <- pollEvents
loop
:: Window
-> IORef Bool
-> IORef ImVec3
-> IORef (Float, Float, Float)
-> IORef Int
-> IORef ImVec2
-> IORef ImVec2
-> IORef Int
-> IORef Bool
-> IORef Bool
-> IO ()
loop window checked color slider r pos size' selected tab1Ref tab2Ref = do
shouldQuit <- checkEvents
openGL2NewFrame
sdl2NewFrame w
openGL3NewFrame
sdl2NewFrame
newFrame
-- showDemoWindow
@ -46,9 +64,34 @@ loop w checked color slider = do
-- showAboutWindow
-- showUserGuide
setNextWindowPos pos ImGuiCond_Once Nothing
setNextWindowSize size' ImGuiCond_Once
-- Works, but will make the window contents illegible without doing something more involved.
-- setNextWindowContentSize size'
-- setNextWindowSizeConstraints size' size'
setNextWindowCollapsed False ImGuiCond_Once
setNextWindowBgAlpha 0.42
begin "My Window"
text "Hello!"
beginTabBar "My tab bar" ImGuiTabBarFlags_Reorderable >>= whenTrue do
beginTabItem "Tab 1" tab1Ref ImGuiTabBarFlags_None >>= whenTrue do
text "Tab 1 is currently selected."
endTabItem
beginTabItem "Tab 2" tab2Ref ImGuiTabBarFlags_None >>= whenTrue do
text "Tab 2 is selected now."
endTabItem
reOpen <- tabItemButton "ReopenTabs" ImGuiTabItemFlags_Trailing
when reOpen do
writeIORef tab1Ref True
writeIORef tab2Ref True
endTabBar
listBox "Items" r [ "A", "B", "C" ]
button "Click me" >>= \case
True -> openPopup "Button Popup"
False -> return ()
@ -66,7 +109,7 @@ loop w checked color slider = do
True -> putStrLn "Oh hi Mark"
False -> return ()
sameLine >> arrowButton "Arrow" ImGuiDirUp
sameLine >> arrowButton "Arrow" ImGuiDir_Up
sameLine >> checkbox "Check!" checked >>= \case
True -> readIORef checked >>= print
@ -74,19 +117,49 @@ loop w checked color slider = do
separator
sliderFloat "Slider" slider 0.0 1.0
dragFloat3 "Slider" slider 0.1 0.0 1.0
progressBar 0.314 (Just "Pi")
beginChild "Child" (ImVec2 0 0) True ImGuiWindowFlags_None
beginCombo "Label" "Preview" >>= whenTrue do
selectable "Testing 1"
selectable "Testing 2"
endCombo
combo "Simple" selected [ "1", "2", "3" ]
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
treeNode "Tree Node 1" >>= whenTrue do
treeNode "Tree Node 2" >>= whenTrue do
treePop
treeNode "Tree Node 3" >>= whenTrue do
treePop
treePop
beginMainMenuBar >>= whenTrue do
beginMenu "Hello" >>= whenTrue do
menuItem "Hello"
@ -103,15 +176,17 @@ loop w checked color slider = do
render
glClear GL_COLOR_BUFFER_BIT
openGL2RenderDrawData =<< getDrawData
openGL3RenderDrawData =<< getDrawData
glSwapWindow w
glSwapWindow window
if quit then return () else loop w checked color slider
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
@ -121,9 +196,9 @@ loop w checked color slider = 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:
@ -41,7 +41,7 @@ import Control.Exception
import Control.Monad.IO.Class
import Control.Monad.Managed
import DearImGui
import DearImGui.OpenGL
import DearImGui.OpenGL2
import DearImGui.SDL
import DearImGui.SDL.OpenGL
import Graphics.GL
@ -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 +opengl +vulkan
flags: +sdl2 +glfw +opengl2 +opengl3 +vulkan +examples
ghc-options: -Wall -Wcompat -fno-warn-unused-do-bind

View File

@ -1,15 +1,83 @@
cabal-version: 3.0
name: dear-imgui
version: 1.0.0
build-type: Simple
flag opengl
name: dear-imgui
version: 1.2.1
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
extra-source-files:
README.md,
ChangeLog.md
extra-source-files:
imgui/*.h,
imgui/backends/*.h,
imgui/backends/*.mm,
imgui/imconfig.h,
imgui/LICENSE.txt
common build-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 OpenGL backend.
Enable debug mode.
default:
False
manual:
True
flag opengl2
description:
Enable OpenGL 2 backend.
default:
False
manual:
True
flag opengl3
description:
Enable OpenGL 3 backend.
default:
True
manual:
False
True
flag vulkan
description:
@ -25,52 +93,81 @@ flag sdl
default:
True
manual:
True
flag glfw
description:
Enable GLFW backend.
default:
False
manual:
True
flag examples
description:
Build executable examples.
default:
False
manual:
True
common common
build-depends:
base
>= 4.12 && < 4.17
default-language:
Haskell2010
library
exposed-modules:
DearImGui
DearImGui.Context
import: common
hs-source-dirs:
src
default-language:
Haskell2010
ghc-options:
-Wall
exposed-modules:
DearImGui
DearImGui.Raw
DearImGui.Raw.DrawList
DearImGui.Raw.ListClipper
DearImGui.Raw.IO
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
extra-libraries:
stdc++
include-dirs:
imgui
build-depends:
base
dear-imgui-generator
, containers
, managed
, inline-c
, inline-c-cpp
, StateVar
, unliftio
, vector
if flag(opengl)
if flag(opengl2)
exposed-modules:
DearImGui.OpenGL
DearImGui.OpenGL2
cxx-sources:
imgui/backends/imgui_impl_opengl2.cpp
if os(windows)
extra-libraries:
opengl32
else
if os(darwin)
frameworks:
OpenGL
else
extra-libraries:
GL
build-depends:
gl
if flag(opengl3)
exposed-modules:
DearImGui.OpenGL3
cxx-sources:
imgui/backends/imgui_impl_opengl3.cpp
pkgconfig-depends:
glew
if flag(vulkan)
exposed-modules:
@ -108,7 +205,7 @@ library
pkgconfig-depends:
sdl2
if flag(opengl)
if flag(opengl2) || flag(opengl3)
exposed-modules:
DearImGui.SDL.OpenGL
@ -116,52 +213,128 @@ library
exposed-modules:
DearImGui.SDL.Vulkan
if flag(glfw)
exposed-modules:
DearImGui.GLFW
build-depends:
GLFW-b,
bindings-GLFW
cxx-sources:
imgui/backends/imgui_impl_glfw.cpp
if os(linux) || os(darwin)
pkgconfig-depends:
glfw3
if flag(opengl2) || flag(opengl3)
exposed-modules:
DearImGui.GLFW.OpenGL
if flag(vulkan)
exposed-modules:
DearImGui.GLFW.Vulkan
library dear-imgui-generator
import: common
hs-source-dirs: generator
exposed-modules:
DearImGui.Generator
, DearImGui.Generator.Parser
, DearImGui.Generator.Tokeniser
, DearImGui.Generator.Types
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
, parser-combinators
>= 1.2.0 && < 1.4
, scientific
>= 0.3.6.2 && < 0.3.8
, text
>= 1.2.4 && < 1.3
, th-lift
>= 0.7 && < 0.9
, transformers
>= 0.5.6 && < 0.6
, unordered-containers
>= 0.2.11 && < 0.2.15
executable test
import: common, build-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, build-flags
main-is: Main.hs
hs-source-dirs: examples/glfw
default-language: Haskell2010
if (!flag(examples) || !flag(glfw) || !flag(opengl2))
buildable: False
else
build-depends: base, GLFW-b, gl, dear-imgui, managed
executable readme
import: common, build-flags
main-is: Readme.hs
hs-source-dirs: examples
default-language: Haskell2010
build-depends: base, sdl2, gl, dear-imgui, managed
ghc-options: -Wall
build-depends: sdl2, gl, dear-imgui, managed
if (!flag(examples) || !flag(sdl) || !flag(opengl2))
buildable: False
executable image
import: common, build-flags
main-is: Image.hs
hs-source-dirs: examples/sdl
build-depends: sdl2, gl, dear-imgui, managed, vector
if (!flag(examples) || !flag(sdl) || !flag(opengl2))
buildable: False
executable vulkan
import: common, build-flags
main-is: Main.hs
other-modules: Attachments, Backend, Input, Util
hs-source-dirs: examples/vulkan
default-language: Haskell2010
build-depends:
dear-imgui
, base
>= 4.13 && < 4.16
, 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

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;
@ -20,4 +20,18 @@ in pkgs.haskell-nix.project {
name = "dear-imgui";
src = ./.;
};
modules = [ {
# This library needs libXext to build, but doesn't explicitly state it in
# its .cabal file.
packages.bindings-GLFW.components.library.libs =
pkgs.lib.mkForce (
pkgs.lib.optionals pkgs.stdenv.isDarwin (with pkgs.darwin.apple_sdk.frameworks; [ AGL Cocoa OpenGL IOKit Kernel CoreVideo pkgs.darwin.CF ]) ++
pkgs.lib.optionals (!pkgs.stdenv.isDarwin) (with pkgs.xorg; [ libXext libXi libXrandr libXxf86vm libXcursor libXinerama pkgs.libGL ])
);
# Depends on libX11 but doesn't state it in the .cabal file.
packages.GLFW-b.components.library.libs =
with pkgs.xorg;
pkgs.lib.mkForce [ libX11 ];
} ];
}

View File

@ -11,7 +11,7 @@ import Control.Exception
import Control.Monad.IO.Class
import Control.Monad.Managed
import DearImGui
import DearImGui.OpenGL
import DearImGui.OpenGL2
import DearImGui.SDL
import DearImGui.SDL.OpenGL
import Graphics.GL
@ -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 "Hello, ImGui!") 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

82
examples/glfw/Main.hs Normal file
View File

@ -0,0 +1,82 @@
{-# language BlockArguments #-}
{-# language LambdaCase #-}
{-# language OverloadedStrings #-}
module Main ( main ) where
import Control.Exception
import Control.Monad
import Control.Monad.IO.Class
import Control.Monad.Managed
import DearImGui
import DearImGui.OpenGL2
import DearImGui.GLFW
import DearImGui.GLFW.OpenGL
import Graphics.GL
import Graphics.UI.GLFW (Window)
import qualified Graphics.UI.GLFW as GLFW
main :: IO ()
main = do
initialised <- GLFW.init
unless initialised $ error "GLFW init failed"
runManaged $ do
mwin <- managed $ bracket
(GLFW.createWindow 800 600 "Hello, Dear ImGui!" Nothing Nothing)
(maybe (return ()) GLFW.destroyWindow)
case mwin of
Just win -> do
liftIO $ do
GLFW.makeContextCurrent (Just win)
GLFW.swapInterval 1
-- Create an ImGui context
_ <- managed $ bracket createContext destroyContext
-- Initialize ImGui's GLFW backend
_ <- managed_ $ bracket_ (glfwInitForOpenGL win True) glfwShutdown
-- Initialize ImGui's OpenGL backend
_ <- managed_ $ bracket_ openGL2Init openGL2Shutdown
liftIO $ mainLoop win
Nothing -> do
error "GLFW createWindow failed"
GLFW.terminate
mainLoop :: Window -> IO ()
mainLoop win = do
-- Process the event loop
GLFW.pollEvents
close <- GLFW.windowShouldClose win
unless close do
-- Tell ImGui we're starting a new frame
openGL2NewFrame
glfwNewFrame
newFrame
-- Build the GUI
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!"
-- Show the ImGui demo window
showDemoWindow
-- Render
glClear GL_COLOR_BUFFER_BIT
render
openGL2RenderDrawData =<< getDrawData
GLFW.swapBuffers win
mainLoop win

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

@ -83,6 +83,20 @@ type Handler = LogMessage -> ResourceT IO ()
deriving via ( ReaderT Handler (ResourceT IO) )
instance MonadResource ( LoggingT LogMessage (ResourceT IO) )
gui :: MonadIO m => m ImGui.DrawData
gui = do
-- Prepare frame
ImGui.Vulkan.vulkanNewFrame
ImGui.SDL.sdl2NewFrame
ImGui.newFrame
-- Run your windows
ImGui.showDemoWindow
-- Process ImGui state into draw commands
ImGui.render
ImGui.getDrawData
main :: IO ()
main = runResourceT . ( `runLoggingT` logHandler ) $ app @( LoggingT LogMessage ( ResourceT IO ) )
@ -120,6 +134,12 @@ app = do
ImGui.createContext
ImGui.destroyContext
logDebug "Adding fonts"
ImGui.clearFontAtlas
_default <- ImGui.addFontDefault
_custom <- ImGui.addFontFromFileTTF "imgui/misc/fonts/ProggyTiny.ttf" 10
ImGui.buildFontAtlas
let
preferredFormat :: Vulkan.SurfaceFormatKHR
preferredFormat =
@ -341,12 +361,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 +369,10 @@ app = do
Vulkan.resetCommandBuffer commandBuffer Vulkan.zero
beginCommandBuffer commandBuffer
cmdBeginRenderPass commandBuffer imGuiRenderPass framebuffer clearValues swapchainExtent
drawData <- gui
ImGui.Vulkan.vulkanRenderDrawData drawData commandBuffer Nothing
cmdEndRenderPass commandBuffer
endCommandBuffer commandBuffer
submitCommandBuffer
@ -370,7 +387,7 @@ app = do
freeOldResources
let
freeOldResources :: m ()
freeOldResources = pure ()
freeOldResources = pure ()
unless quit $ mainLoop ( AppState {..} )
let

View File

@ -0,0 +1,187 @@
{-# LANGUAGE BlockArguments #-}
{-# LANGUAGE CPP #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE TemplateHaskell #-}
module DearImGui.Generator
( declareEnumerations, enumerationsTypesTable )
where
-- base
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 )
-- filepath
import System.FilePath
( takeDirectory )
-- inline-c
import qualified Language.C.Types as InlineC
( TypeSpecifier(TypeName) )
-- megaparsec
import qualified Text.Megaparsec as Megaparsec
-- template-haskell
import qualified Language.Haskell.TH as TH
import qualified Language.Haskell.TH.Syntax as TH
-- text
import qualified Data.Text as Text
import qualified Data.Text.IO as Text
( readFile )
-- dear-imgui-generator
import qualified DearImGui.Generator.Parser as Parser
( headers )
import DearImGui.Generator.Tokeniser
( Tok, tokenise )
import DearImGui.Generator.Types
( Comment(..), Enumeration(..), Headers(..)
, generateNames
)
--------------------------------------------------------------------------------
-- Obtaining parsed header data.
headers :: Headers ( TH.Name, TH.Name )
headers = $( do
currentPath <- TH.loc_filename <$> TH.location
basicHeaders <- TH.runIO do
headersPath <- canonicalizePath ( takeDirectory currentPath <> "/../../imgui/imgui.h" )
headersSource <- Text.readFile headersPath
tokens <- case tokenise headersSource of
Left err -> error ( "Couldn't tokenise Dear ImGui headers:\n\n" <> show err )
Right toks -> pure toks
case Megaparsec.parse Parser.headers "" tokens of
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.Name, TH.Name ) -> TH.Q [ TH.Dec ]
declareEnumeration finiteEnumName countName ( Enumeration {..} ) = do
let
tyName, conName :: TH.Name
( tyName, conName ) = enumTypeName
isFlagEnum :: Bool
isFlagEnum = "Flags" `Text.isInfixOf` enumName
newtypeCon :: TH.Q TH.Con
newtypeCon =
TH.normalC conName
[ TH.bangType
( TH.bang TH.noSourceUnpackedness TH.noSourceStrictness )
( TH.conT underlyingType )
]
classes :: [ TH.Q TH.Type ]
classes
| isFlagEnum
= map TH.conT [ ''Eq, ''Ord, ''Show, ''Storable, ''Bits ]
| otherwise
= map TH.conT [ ''Eq, ''Ord, ''Show, ''Storable ]
derivClause :: TH.Q TH.DerivClause
derivClause = TH.derivClause ( Just TH.NewtypeStrategy ) classes
newtypeDecl <-
#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, Nothing, [] ) derivs
( Just . Text.unpack . Text.unlines . coerce $ docs )
)
#else
TH.newtypeD
#endif
( pure [] ) tyName [] Nothing newtypeCon [ derivClause ]
mbAddFiniteEnumInst <-
if hasExplicitCount
then do
finiteEnumInst <-
TH.instanceD ( pure [] ) ( TH.appT ( TH.conT finiteEnumName ) ( TH.conT tyName ) )
[ TH.tySynInstD ( TH.TySynEqn Nothing
<$> 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
let
patNameStr :: String
patNameStr = Text.unpack patternName
patName <- TH.newName patNameStr
patSynSig <- TH.patSynSigD patName ( TH.conT tyName )
pat <-
#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
( Just $ Text.unpack patDoc ) []
)
#else
TH.patSynD
#endif
patName ( TH.prefixPatSyn [] ) TH.implBidir
( TH.conP conName [ TH.litP $ TH.integerL patternValue ] )
pure ( patSynSig, pat )
pure ( newtypeDecl : mbAddFiniteEnumInst ( unpairs synonyms ) )
unpairs :: [ ( a, a ) ] -> [ a ]
unpairs [] = []
unpairs ( ( x, y ) : as ) = x : y : unpairs as

View File

@ -0,0 +1,415 @@
{-# LANGUAGE BlockArguments #-}
{-# LANGUAGE DerivingStrategies #-}
{-# LANGUAGE DuplicateRecordFields #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TemplateHaskellQuotes #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE ViewPatterns #-}
module DearImGui.Generator.Parser
( CustomParseError(..)
, headers
)
where
-- base
import Control.Applicative
( (<|>), many, optional, some )
import Control.Monad
( void )
import Data.Bits
( Bits(shiftL) )
import Data.Char
( isSpace, toLower )
import Data.Either
( partitionEithers )
import Data.Functor
( ($>) )
import Data.Int
( Int64 )
import Data.Maybe
( catMaybes, fromMaybe )
import Foreign.C.Types
( CInt )
-- template-haskell
import qualified Language.Haskell.TH as TH
( Name )
-- megaparsec
import Text.Megaparsec
( MonadParsec(..), ShowErrorComponent(..)
, (<?>), anySingle, customFailure, single
)
-- parser-combinators
import Control.Applicative.Combinators
( manyTill, option, sepBy1, skipManyTill )
-- scientific
import Data.Scientific
( floatingOrInteger, toBoundedInteger )
-- text
import Data.Text
( Text )
import qualified Data.Text as Text
( all, any, breakOn, drop, dropWhile, dropWhileEnd
, length, stripPrefix, unlines, unpack
)
-- transformers
import Control.Monad.Trans.State.Strict
( StateT(..)
, get, modify'
)
-- unordered-containers
import Data.HashMap.Strict
( HashMap )
import qualified Data.HashMap.Strict as HashMap
( fromList, insert, lookup )
-- dear-imgui-generator
import DearImGui.Generator.Tokeniser
( Tok(..) )
import DearImGui.Generator.Types
( Comment(..), Enumeration(..), Headers(..) )
--------------------------------------------------------------------------------
-- Parse error type.
data CustomParseError
= Couldn'tLookupEnumValues
{ enumName :: !Text
, problems :: ![Text]
}
| MissingForwardDeclaration
{ enumName :: !Text }
| UnexpectedSection
{ sectionName :: !Text
, problem :: ![Text]
}
deriving stock ( Show, Eq, Ord )
instance ShowErrorComponent CustomParseError where
showErrorComponent ( Couldn'tLookupEnumValues { enumName, problems } ) = Text.unpack $
"Couldn't lookup the following values in enum " <> enumName <> ":\n"
<> Text.unlines ( map ( " - " <> ) problems )
showErrorComponent ( MissingForwardDeclaration { enumName } ) = Text.unpack $
"Missing forward declaration for enum named " <> enumName
showErrorComponent ( UnexpectedSection { sectionName, problem } ) = Text.unpack $
"Unexpected section name.\n\
\Expected: " <> sectionName <> "\n\
\ Actual: " <> Text.unlines ( map ( " " <> ) problem )
--------------------------------------------------------------------------------
-- Parsing 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, 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 "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 "Obsolete functions and types" )
let
enums :: [ Enumeration () ]
enums = basicEnums <> drawingEnums <> fontEnums
pure ( Headers { enums } )
--------------------------------------------------------------------------------
-- Parsing forward declarations.
forwardDeclarations
:: MonadParsec CustomParseError [Tok] m
=> m ( HashMap Text Comment, HashMap Text ( TH.Name, Comment ) )
forwardDeclarations = do
_ <- many comment
structs <- many do
keyword "struct"
structName <- identifier
reservedSymbol ';'
doc <- comment
pure ( structName, doc )
_ <- many comment
enums <- many do
keyword "typedef"
ty <- cTypeName
enumName <- identifier
reservedSymbol ';'
doc <- commentText <$> comment
pure ( enumName, ( ty, CommentText <$> Text.drop 2 . snd $ Text.breakOn "//" doc ) )
-- Stopping after simple structs and enums for now.
pure ( HashMap.fromList structs, HashMap.fromList enums )
cTypeName :: MonadParsec e [Tok] m => m TH.Name
cTypeName = keyword "int" $> ''CInt
--------------------------------------------------------------------------------
-- Parsing enumerations.
data EnumState = EnumState
{ enumValues :: HashMap Text Integer
, currEnumTag :: Integer
, enumSize :: Integer
, hasExplicitCount :: Bool
}
enumeration :: MonadParsec CustomParseError [Tok] m => HashMap Text ( TH.Name, Comment ) -> m ( Enumeration () )
enumeration enumNamesAndTypes = do
inlineDocs <- try do
inlineDocs <- many comment
keyword "enum"
pure inlineDocs
fullEnumName <- identifier
let
enumName :: Text
enumName = Text.dropWhileEnd ( == '_' ) fullEnumName
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 } ) <-
( `runStateT` EnumState { enumValues = mempty, currEnumTag = 0, enumSize = 0, hasExplicitCount = False } ) $
catMaybes
<$> many
( some ignoredPatternContent $> Nothing
<|> enumerationPattern fullEnumName
)
reservedSymbol '}'
reservedSymbol ';'
pure ( Enumeration { .. } )
ignoredPatternContent :: MonadParsec e [Tok] m => m ()
ignoredPatternContent = void ( try comment ) <|> cppConditional
enumerationPattern
:: MonadParsec CustomParseError [ Tok ] m
=> Text
-> StateT EnumState m ( Maybe ( Text, Integer, Comment ) )
enumerationPattern enumName = do
mbPatNameVal <- patternNameAndValue enumName
_ <- optional $ reservedSymbol ','
comm <- fromMaybe ( CommentText "" ) <$> optional comment
pure $
case mbPatNameVal of
Nothing -> Nothing
Just ( patName, patValue ) -> Just ( patName, patValue, comm )
patternNameAndValue
:: forall m
. MonadParsec CustomParseError [ Tok ] m
=> Text
-> StateT EnumState m ( Maybe ( Text, Integer ) )
patternNameAndValue enumName =
try do
sz <- count
modify' ( \ ( EnumState {..} ) -> EnumState { enumSize = sz, hasExplicitCount = True, .. } )
pure Nothing
<|> do
pat@( _, val ) <- value
modify' ( \ ( EnumState {..} ) -> EnumState { enumSize = enumSize + 1, currEnumTag = val + 1, .. } )
pure ( Just pat )
where
count :: StateT EnumState m Integer
count = do
_ <- single ( Identifier $ enumName <> "COUNT" )
mbVal <- optional do
_ <- reservedSymbol '='
integerExpression
case mbVal of
Nothing -> currEnumTag <$> get
Just ct -> pure ct
value :: StateT EnumState m ( Text, Integer )
value = do
name <- identifier
val <- patternRHS
modify' ( \ st -> st { enumValues = HashMap.insert name val ( enumValues st ) } )
pure ( name, val )
patternRHS :: StateT EnumState m Integer
patternRHS =
( do
reservedSymbol '='
try integerExpression <|> try disjunction
)
<|> ( currEnumTag <$> get )
disjunction :: StateT EnumState m Integer
disjunction = do
( summands :: [Text] ) <- identifier `sepBy1` symbol "|"
valsMap <- enumValues <$> get
let
res :: Either [ Text ] Integer
res = foldr
( \ summand errsOrVal -> case HashMap.lookup summand valsMap of
Nothing -> case errsOrVal of { Right _ -> Left [ summand ]; Left errs -> Left ( summand : errs ) }
Just v -> case errsOrVal of { Right v' -> Right ( v + v' ); Left errs -> Left errs }
)
( Right 0 )
summands
case res of
Left problems -> customFailure ( Couldn'tLookupEnumValues { enumName, problems } )
Right v -> pure v
--------------------------------------------------------------------------------
-- Simple token parsers.
comment :: MonadParsec e [ Tok ] m => m Comment
comment = CommentText <$>
token ( \ case { Comment comm -> Just comm; _ -> Nothing } ) mempty
<?> "comment"
keyword :: MonadParsec e [ Tok ] m => Text -> m ()
keyword kw = token ( \ case { Keyword kw' | kw == kw' -> Just (); _ -> Nothing } ) mempty
<?> ( Text.unpack kw <> " (keyword)" )
identifier :: MonadParsec e [ Tok ] m => m Text
identifier = token ( \ case { Identifier i -> Just i; _ -> Nothing } ) mempty
<?> "identifier"
{-
prefixedIdentifier :: MonadParsec e [ Tok ] m => Text -> m Text
prefixedIdentifier prefix =
token
( \ case
{ Identifier i -> Text.dropWhile ( == '_' ) <$> Text.stripPrefix prefix i
; _ -> Nothing
}
) mempty
-}
reservedSymbol :: MonadParsec e [ Tok ] m => Char -> m ()
reservedSymbol s = token ( \ case { ReservedSymbol s' | s == s' -> Just (); _ -> Nothing } ) mempty
<?> ( [s] <> " (reserved symbol)" )
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"
where
mkSign :: m ( Integer -> Integer )
mkSign = ( symbol "+" $> id ) <|> ( symbol "-" $> negate )
section :: MonadParsec e [ Tok ] m => m [Text]
section =
do
sectionText <- try do
separator
token
( \ case
{ Comment txt -> fmap ( Text.dropWhile isSpace )
. Text.stripPrefix "[SECTION]"
. Text.dropWhile isSpace
$ txt
; _ -> Nothing
}
) mempty
rest <- endOfSectionHeader
pure ( sectionText : filter ( not . Text.all ( \ c -> c == '-' || isSpace c ) ) rest )
<?> "section"
separator :: MonadParsec e [ Tok ] m => m ()
separator = token
( \ case
{ Comment hyphens | Text.length hyphens > 10 && Text.all ( == '-') hyphens -> Just ()
; _ -> Nothing
}
) mempty
<?> "separator"
endOfSectionHeader :: MonadParsec e [ Tok ] m => m [Text]
endOfSectionHeader = try ( (:) <$> ( commentText <$> comment ) <*> endOfSectionHeader )
<|> ( separator $> [] )
namedSection :: MonadParsec CustomParseError [ Tok ] m => Text -> m ()
namedSection sectionName =
do
sectionTexts <- section
case sectionTexts of
sectionText : _
| Just _ <- Text.stripPrefix sectionName sectionText
-> pure ()
_ -> customFailure ( UnexpectedSection { sectionName, problem = sectionTexts } )
<?> ( "section named " <> Text.unpack sectionName )
cppDirective :: MonadParsec e [Tok] m => ( Text -> Maybe a ) -> m a
cppDirective f = token ( \case { BeginCPP a -> f a; _ -> Nothing } ) mempty
cppConditional :: MonadParsec e [Tok] m => m ()
cppConditional = do
void $ cppDirective ( \case { "ifdef" -> Just True; "ifndef" -> Just False; _ -> Nothing } )
-- assumes no nesting
void $ skipManyTill anySingle ( cppDirective ( \case { "endif" -> Just (); _ -> Nothing } ) )
void $ skipManyTill anySingle ( single EndCPPLine )
ignoreDefine :: MonadParsec e [Tok] m => m ()
ignoreDefine = do
void $ many comment
void $ cppDirective ( \case { "define" -> Just (); _ -> Nothing } )
void $ skipManyTill anySingle ( single EndCPPLine )

View File

@ -0,0 +1,197 @@
{-# LANGUAGE DerivingStrategies #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE ViewPatterns #-}
module DearImGui.Generator.Tokeniser where
-- base
import Control.Arrow
( first, second )
import Control.Applicative
( (<|>), some )
import Data.Char
( isAlpha, isAlphaNum, isDigit, isPunctuation, isSpace, isSymbol, toLower )
import Data.Function
( (&) )
import Data.Functor
( ($>) )
import Data.Monoid
( Sum(..) )
-- megaparsec
import Text.Megaparsec
( MonadParsec, VisualStream(..)
, chunk, parseMaybe, satisfy, try
)
import Text.Megaparsec.Char.Lexer
( hexadecimal, scientific )
-- parser-combinators
import Control.Monad.Combinators
( optional )
-- scientific
import Data.Scientific
( Scientific )
-- text
import Data.Text
( Text )
import qualified Data.Text as Text
( break, breakOn, cons, drop, dropWhile
, head, last, length
, pack, snoc, span, strip, tail, take
, uncons, unpack
)
-- unordered-containers
import Data.HashSet
( HashSet )
import qualified Data.HashSet as HashSet
( fromList, member )
--------------------------------------------------------------------------------
data TokeniserError
= Couldn'tParseNumber { problem :: !Text }
| UnhandledCase { unhandled :: !( Char, Text ) }
deriving stock ( Eq, Ord, Show )
data Tok
= Keyword !Text
| ReservedSymbol !Char
| Symbolic !Text
| Identifier !Text
| Comment !Text
| Char !Char
| String !Text
| Number !Scientific !Text
| BeginCPP !Text
| EndCPPLine
deriving stock ( Show, Eq, Ord )
showToken :: Tok -> String
showToken = \case
Keyword t -> Text.unpack t
ReservedSymbol c -> [c]
Symbolic t -> Text.unpack t
Identifier t -> Text.unpack t
Comment t -> Text.unpack t
Char c -> [c]
String t -> Text.unpack t
Number s t -> show s <> Text.unpack t
BeginCPP t -> "#" <> Text.unpack t
EndCPPLine -> "EndCppLine"
tokenLength :: Tok -> Int
tokenLength = \case
Keyword t -> Text.length t
ReservedSymbol _ -> 1
Symbolic t -> Text.length t
Identifier t -> Text.length t
Comment t -> Text.length t
Char _ -> 1
String t -> Text.length t
Number s t -> length ( show s ) + Text.length t
BeginCPP t -> 1 + Text.length t
EndCPPLine -> length ( "EndCPPLine" :: String )
instance VisualStream [Tok] where
showTokens _ = foldMap showToken
tokensLength _ = getSum . foldMap ( Sum . tokenLength )
keywords :: HashSet Text
keywords = HashSet.fromList
[ "auto", "break", "case", "char", "const", "continue", "default", "do", "double"
, "else", "enum", "extern", "float", "for", "goto", "if", "inline", "int", "long"
, "register", "restrict", "return", "short", "signed", "sizeof", "static", "struct"
, "switch", "typedef", "union", "unsigned", "void", "volatile", "while"
]
reservedSymbols :: HashSet Char
reservedSymbols = HashSet.fromList [ '(', ')', '{', '}', ',', ';', '=', '#' ]
tokenise :: Text -> Either TokeniserError [ Tok ]
tokenise ( Text.uncons -> Just ( c, cs ) )
| isSpace c
= tokenise ( Text.dropWhile isSpace cs )
| isAlpha c || c == '_'
, let
this, rest :: Text
( this, rest ) = first ( c `Text.cons` ) $ Text.span ( \ x -> isAlphaNum x || x == '_' ) cs
= if this `HashSet.member` keywords
then ( Keyword this : ) <$> tokenise rest
else ( Identifier this : ) <$> tokenise rest
| isDigit c
, let
this, rest :: Text
( this, rest ) = continuePastExponent $ first ( c `Text.cons` ) $ Text.span ( \ x -> isAlphaNum x || x == '.' ) cs
= case parseMaybe @() parseNumber this of
Just numTok -> ( numTok : ) <$> tokenise rest
Nothing -> Left ( Couldn'tParseNumber { problem = this } )
| c == '\''
, Just ( '\'', rest ) <- Text.uncons ( Text.drop 1 cs )
= ( Char ( Text.head cs ) : ) <$> tokenise rest
| c == '\"'
, let
this, rest :: Text
( this, rest ) = second Text.tail $ Text.break ( == '"') cs
= ( String this : ) <$> tokenise rest
| c == '#'
, let
directive, line, rest :: Text
( directive, ( line, rest ) )
= cs
& Text.break ( isSpace )
& second ( Text.break ( `elem` [ '\n', '\r' ] ) )
= do
lineTokens <- tokenise line
restTokens <- tokenise rest
pure ( ( BeginCPP directive : lineTokens ) <> ( EndCPPLine : restTokens ) )
| c `HashSet.member` reservedSymbols
= ( ReservedSymbol c : ) <$> tokenise cs
| c == '/'
= case Text.take 1 cs of
"/" ->
let
comm, rest :: Text
( comm, rest ) = first Text.strip $ Text.break ( `elem` [ '\n', '\r' ] ) ( Text.drop 1 cs )
in ( Comment comm : ) <$> tokenise rest
"*" ->
let
comm, rest :: Text
( comm, rest ) = Text.breakOn "*/" ( Text.drop 1 cs )
in ( Comment comm : ) <$> tokenise rest
_ ->
let
this, rest :: Text
( this, rest ) = first ( c `Text.cons` ) $ Text.span ( \ x -> x /= '_' && ( isSymbol x || isPunctuation x ) ) cs
in ( Symbolic this : ) <$> tokenise rest
| isSymbol c || isPunctuation c
, let
this, rest :: Text
( this, rest ) = first ( c `Text.cons` ) $ Text.span ( \ x -> x /= '_' && ( isSymbol x || isPunctuation x ) ) cs
= ( Symbolic this : ) <$> tokenise rest
| otherwise
= Left $ UnhandledCase { unhandled = ( c, cs ) }
tokenise _ = Right []
continuePastExponent :: ( Text, Text ) -> ( Text, Text )
continuePastExponent ( this, rest )
| toLower ( Text.last this ) `elem` [ 'e', 'p' ]
, Just ( r, rs ) <- Text.uncons rest
, r `elem` [ '+', '-' ]
, ( this', rest' ) <- Text.span isAlphaNum rs
= ( this `Text.snoc` r <> this', rest' )
| otherwise
= ( this, rest )
parseNumber :: MonadParsec e Text m => m Tok
parseNumber = try ( chunk "0.f" $> Number 0 "f" ) <|> do
value <- try ( chunk "0x" *> hexadecimal ) <|> scientific
mbSuffix <- fmap ( maybe "" Text.pack ) . optional . some $ satisfy ( \ s -> toLower s `elem` ( "uflz" :: String ) )
pure ( Number value mbSuffix )

View File

@ -0,0 +1,65 @@
{-# 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
-- text
import Data.Text
( Text )
import qualified Data.Text as Text
( unpack )
-- th-lift
import Language.Haskell.TH.Lift
() -- 'Lift' instance for Name
--------------------------------------------------------------------------------
newtype Comment = CommentText { commentText :: Text }
deriving stock ( Show, TH.Lift )
deriving newtype ( Eq, Ord )
data Enumeration typeName
= Enumeration
{ docs :: ![Comment]
, enumName :: !Text
, enumTypeName :: !typeName
, enumSize :: !Integer
, underlyingType :: !TH.Name
, hasExplicitCount :: !Bool
, patterns :: [ ( Text, Integer, Comment ) ]
}
deriving stock ( Show, TH.Lift )
data Headers typeName
= Headers
{ 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...e3e1fbcf02

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

View File

@ -9,7 +9,7 @@ in
# You might want some extra tools in the shell (optional).
# Some common tools can be added with the `tools` argument
tools = { cabal = "3.2.0.0"; };
tools = { cabal = "3.2.0.0"; haskell-language-server = "latest"; };
# Prevents cabal from choosing alternate plans, so that
# *all* dependencies are provided by Nix.

File diff suppressed because it is too large Load Diff

View File

@ -1,62 +1,42 @@
{-# language DerivingStrategies #-}
{-# language DuplicateRecordFields #-}
{-# language GeneralizedNewtypeDeriving #-}
{-# language NamedFieldPuns #-}
{-# language OverloadedStrings #-}
{-# language PatternSynonyms #-}
{-# language TemplateHaskell #-}
module DearImGui.Context where
import Language.C.Types
import Language.C.Inline.Context
-- containers
import qualified Data.Map.Strict as Map
import Foreign
-- inline-c
import Language.C.Inline.Context
( Context(..) )
import Language.C.Types
( pattern TypeName )
data ImVec3 = ImVec3 { x, y, z :: {-# unpack #-} !Float }
-- dear-imgui
import DearImGui.Structs
-- dear-imgui-generator
import DearImGui.Generator
( enumerationsTypesTable )
instance Storable ImVec3 where
sizeOf ~ImVec3{x, y, z} = sizeOf x + sizeOf y + sizeOf z
alignment _ = 0
poke ptr ImVec3{ x, y, z } = do
poke (castPtr ptr `plusPtr` (sizeOf x * 0)) x
poke (castPtr ptr `plusPtr` (sizeOf x * 1)) y
poke (castPtr ptr `plusPtr` (sizeOf x * 2)) z
peek ptr = do
x <- peek (castPtr ptr )
y <- peek (castPtr ptr `plusPtr` (sizeOf x * 1))
z <- peek (castPtr ptr `plusPtr` (sizeOf x * 2))
return ImVec3{ x, y, z }
data ImVec4 = ImVec4 { x, y, z, w :: {-# unpack #-} !Float }
instance Storable ImVec4 where
sizeOf ~ImVec4{x, y, z, w} = sizeOf x + sizeOf y + sizeOf z + sizeOf w
alignment _ = 0
poke ptr ImVec4{ x, y, z, w } = do
poke (castPtr ptr `plusPtr` (sizeOf x * 0)) x
poke (castPtr ptr `plusPtr` (sizeOf x * 1)) y
poke (castPtr ptr `plusPtr` (sizeOf x * 2)) z
poke (castPtr ptr `plusPtr` (sizeOf x * 3)) w
peek ptr = do
x <- peek (castPtr ptr )
y <- peek (castPtr ptr `plusPtr` (sizeOf x * 1))
z <- peek (castPtr ptr `plusPtr` (sizeOf x * 2))
w <- peek (castPtr ptr `plusPtr` (sizeOf x * 3))
return ImVec4{ x, y, z, w }
--------------------------------------------------------------------------------
imguiContext :: Context
imguiContext = mempty
{ ctxTypesTable = Map.fromList
[ ( TypeName "ImVec3", [t| ImVec3 |] )
{ ctxTypesTable = enumerationsTypesTable <>
Map.fromList
[ ( TypeName "ImVec2", [t| ImVec2 |] )
, ( TypeName "ImVec3", [t| ImVec3 |] )
, ( TypeName "ImVec4", [t| ImVec4 |] )
, ( TypeName "ImU32", [t| ImU32 |] )
, ( TypeName "ImDrawList", [t| ImDrawList |] )
, ( TypeName "ImGuiContext", [t| ImGuiContext |] )
, ( TypeName "ImFont", [t| ImFont |] )
, ( TypeName "ImGuiListClipper", [t| ImGuiListClipper |] )
]
}

34
src/DearImGui/Enums.hs Normal file
View File

@ -0,0 +1,34 @@
{-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DerivingStrategies #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE MagicHash #-}
{-# LANGUAGE PatternSynonyms #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeFamilies #-}
module DearImGui.Enums where
-- base
import GHC.Exts
( proxy# )
import GHC.TypeNats
( Nat, KnownNat, natVal' )
import Numeric.Natural
( Natural )
-- dear-imgui-generator
import DearImGui.Generator
( declareEnumerations )
--------------------------------------------------------------------------------
class KnownNat ( Count a ) => FiniteEnum a where
type Count a :: Nat
count :: Natural
count = natVal' @( Count a ) proxy#
declareEnumerations ''FiniteEnum ''Count

188
src/DearImGui/GLFW.hs Normal file
View File

@ -0,0 +1,188 @@
{-# LANGUAGE BlockArguments #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE PatternSynonyms #-}
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE TemplateHaskell #-}
{-|
Module: DearImGui.GLFW
GLFW specific functions backend for Dear ImGui.
Modules for initialising a backend with GLFW can be found under the corresponding backend,
e.g. "DearImGui.GLFW.OpenGL".
-}
module DearImGui.GLFW (
-- ** GLFW
glfwNewFrame
, glfwShutdown
-- $callbacks
, glfwWindowFocusCallback
, glfwCursorEnterCallback
, 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
-- inline-c-cpp
import qualified Language.C.Inline.Cpp as Cpp
-- transformers
import Control.Monad.IO.Class
( MonadIO, liftIO )
C.context (Cpp.cppCtx <> C.bsCtx)
C.include "imgui.h"
C.include "backends/imgui_impl_glfw.h"
Cpp.using "namespace ImGui"
-- | Wraps @ImGui_ImplGlfw_NewFrame@.
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(); } |]
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
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

View File

@ -0,0 +1,61 @@
{-# LANGUAGE BlockArguments #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE PatternSynonyms #-}
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE TemplateHaskell #-}
{-|
Module: DearImGUI.GLFW.OpenGL
Initialising the OpenGL backend for Dear ImGui using GLFW3.
-}
module DearImGui.GLFW.OpenGL
( glfwInitForOpenGL )
where
-- base
import Data.Bool
( bool )
import Foreign.C.Types
( CBool )
import Foreign.Ptr
( Ptr )
import Unsafe.Coerce
( unsafeCoerce )
-- inline-c
import qualified Language.C.Inline as C
-- inline-c-cpp
import qualified Language.C.Inline.Cpp as Cpp
-- GLFW
import Graphics.UI.GLFW
( Window )
-- transformers
import Control.Monad.IO.Class
( MonadIO, liftIO )
C.context (Cpp.cppCtx <> C.bsCtx)
C.include "imgui.h"
C.include "backends/imgui_impl_opengl2.h"
C.include "backends/imgui_impl_glfw.h"
C.include "GLFW/glfw3.h"
Cpp.using "namespace ImGui"
-- | Wraps @ImGui_ImplGlfw_InitForOpenGL@.
glfwInitForOpenGL :: MonadIO m => Window -> Bool -> m Bool
glfwInitForOpenGL window installCallbacks = liftIO do
( 0 /= ) <$> [C.exp| bool { ImGui_ImplGlfw_InitForOpenGL((GLFWwindow*)$(void* windowPtr), $(bool cInstallCallbacks)) } |]
where
windowPtr :: Ptr ()
windowPtr = unsafeCoerce window
cInstallCallbacks :: CBool
cInstallCallbacks = bool 0 1 installCallbacks

View File

@ -0,0 +1,60 @@
{-# LANGUAGE BlockArguments #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE PatternSynonyms #-}
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE TemplateHaskell #-}
{-|
Module: DearImGui.GLFW.Vulkan
Initialising the Vulkan backend for Dear ImGui using GLFW3.
-}
module DearImGui.GLFW.Vulkan
( glfwInitForVulkan )
where
-- base
import Data.Bool
( bool )
import Foreign.C.Types
( CBool )
import Foreign.Ptr
( Ptr )
import Unsafe.Coerce
( unsafeCoerce )
-- inline-c
import qualified Language.C.Inline as C
-- inline-c-cpp
import qualified Language.C.Inline.Cpp as Cpp
-- GLFW
import Graphics.UI.GLFW
( Window )
-- transformers
import Control.Monad.IO.Class ( MonadIO, liftIO )
C.context Cpp.cppCtx
C.include "imgui.h"
C.include "backends/imgui_impl_vulkan.h"
C.include "backends/imgui_impl_glfw.h"
C.include "GLFW/glfw3.h"
Cpp.using "namespace ImGui"
-- | Wraps @ImGui_ImplGlfw_InitForVulkan@.
glfwInitForVulkan :: MonadIO m => Window -> Bool -> m Bool
glfwInitForVulkan window installCallbacks = liftIO do
( 0 /= ) <$> [C.exp| bool { ImGui_ImplGlfw_InitForVulkan((GLFWwindow*)$(void* windowPtr), $(bool cInstallCallbacks)) } |]
where
windowPtr :: Ptr ()
windowPtr = unsafeCoerce window
cInstallCallbacks :: CBool
cInstallCallbacks = bool 0 1 installCallbacks

View File

@ -9,10 +9,10 @@
{-|
Module: DearImGui.OpenGL
OpenGL backend for Dear ImGui.
OpenGL 2 backend for Dear ImGui.
-}
module DearImGui.OpenGL
module DearImGui.OpenGL2
( openGL2Init
, openGL2Shutdown
, openGL2NewFrame

69
src/DearImGui/OpenGL3.hs Normal file
View File

@ -0,0 +1,69 @@
{-# LANGUAGE BlockArguments #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE PatternSynonyms #-}
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE TemplateHaskell #-}
{-|
Module: DearImGui.OpenGL
OpenGL 3 backend for Dear ImGui.
-}
module DearImGui.OpenGL3
( openGL3Init
, openGL3Shutdown
, openGL3NewFrame
, openGL3RenderDrawData
)
where
-- inline-c
import qualified Language.C.Inline as C
-- inline-c-cpp
import qualified Language.C.Inline.Cpp as Cpp
-- transformers
import Control.Monad.IO.Class
( MonadIO, liftIO )
-- DearImGui
import DearImGui
( DrawData(..) )
C.context (Cpp.cppCtx <> C.bsCtx)
C.include "imgui.h"
C.include "GL/glew.h"
C.include "backends/imgui_impl_opengl3.h"
Cpp.using "namespace ImGui"
-- | Wraps @ImGui_ImplOpenGL3_Init@.
openGL3Init :: MonadIO m => m Bool
openGL3Init = liftIO $
( 0 /= ) <$> [C.block| bool {
glewInit();
return ImGui_ImplOpenGL3_Init();
} |]
-- | Wraps @ImGui_ImplOpenGL3_Shutdown@.
openGL3Shutdown :: MonadIO m => m ()
openGL3Shutdown = liftIO do
[C.exp| void { ImGui_ImplOpenGL3_Shutdown(); } |]
-- | Wraps @ImGui_ImplOpenGL3_NewFrame@.
openGL3NewFrame :: MonadIO m => m ()
openGL3NewFrame = liftIO do
[C.exp| void { ImGui_ImplOpenGL3_NewFrame(); } |]
-- | Wraps @ImGui_ImplOpenGL3_RenderDrawData@.
openGL3RenderDrawData :: MonadIO m => DrawData -> m ()
openGL3RenderDrawData (DrawData ptr) = liftIO do
[C.exp| void { ImGui_ImplOpenGL3_RenderDrawData((ImDrawData*) $( void* ptr )) } |]

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

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

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@.

90
src/DearImGui/Structs.hs Normal file
View File

@ -0,0 +1,90 @@
{-# LANGUAGE DuplicateRecordFields #-}
{-# LANGUAGE NamedFieldPuns #-}
module DearImGui.Structs where
-- base
import Data.Word
( Word32 )
import Foreign
( Storable(..), castPtr, plusPtr )
--------------------------------------------------------------------------------
data ImVec2 = ImVec2 { x, y :: {-# unpack #-} !Float }
deriving (Show)
instance Storable ImVec2 where
sizeOf ~ImVec2{x, y} = sizeOf x + sizeOf y
alignment _ = 0
poke ptr ImVec2{ x, y } = do
poke (castPtr ptr `plusPtr` (sizeOf x * 0)) x
poke (castPtr ptr `plusPtr` (sizeOf x * 1)) y
peek ptr = do
x <- peek (castPtr ptr )
y <- peek (castPtr ptr `plusPtr` (sizeOf x * 1))
return ImVec2{ x, y }
data ImVec3 = ImVec3 { x, y, z :: {-# unpack #-} !Float }
deriving (Show)
instance Storable ImVec3 where
sizeOf ~ImVec3{x, y, z} = sizeOf x + sizeOf y + sizeOf z
alignment _ = 0
poke ptr ImVec3{ x, y, z } = do
poke (castPtr ptr `plusPtr` (sizeOf x * 0)) x
poke (castPtr ptr `plusPtr` (sizeOf x * 1)) y
poke (castPtr ptr `plusPtr` (sizeOf x * 2)) z
peek ptr = do
x <- peek (castPtr ptr )
y <- peek (castPtr ptr `plusPtr` (sizeOf x * 1))
z <- peek (castPtr ptr `plusPtr` (sizeOf x * 2))
return ImVec3{ x, y, z }
data ImVec4 = ImVec4 { x, y, z, w :: {-# unpack #-} !Float }
deriving (Show)
instance Storable ImVec4 where
sizeOf ~ImVec4{x, y, z, w} = sizeOf x + sizeOf y + sizeOf z + sizeOf w
alignment _ = 0
poke ptr ImVec4{ x, y, z, w } = do
poke (castPtr ptr `plusPtr` (sizeOf x * 0)) x
poke (castPtr ptr `plusPtr` (sizeOf x * 1)) y
poke (castPtr ptr `plusPtr` (sizeOf x * 2)) z
poke (castPtr ptr `plusPtr` (sizeOf x * 3)) w
peek ptr = do
x <- peek (castPtr ptr )
y <- peek (castPtr ptr `plusPtr` (sizeOf x * 1))
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
-- | 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

View File

@ -12,6 +12,8 @@ Vulkan backend for Dear ImGui.
module DearImGui.Vulkan
( InitInfo(..)
, withVulkan
, vulkanInit
, vulkanShutdown
, vulkanNewFrame
, vulkanRenderDrawData
, vulkanCreateFontsTexture
@ -28,7 +30,7 @@ import Data.Word
import Foreign.Marshal.Alloc
( alloca )
import Foreign.Ptr
( Ptr, freeHaskellFunPtr, nullPtr )
( FunPtr, Ptr, freeHaskellFunPtr, nullPtr )
import Foreign.Storable
( Storable(poke) )
@ -83,7 +85,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 +110,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 ()