54 Commits
args ... v1.2.1

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
25 changed files with 4866 additions and 777 deletions

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

38
Main.hs
View File

@ -7,6 +7,7 @@ module Main (main) where
import Control.Monad
import Data.IORef
import qualified Data.Vector as Vector
import DearImGui
import DearImGui.OpenGL3
import DearImGui.SDL
@ -38,8 +39,6 @@ main = do
tab2 <- newIORef True
loop w checked color slider r pos size' selected tab1 tab2
openGL3Shutdown
loop
:: Window
@ -53,11 +52,11 @@ loop
-> IORef Bool
-> IORef Bool
-> IO ()
loop w checked color slider r pos size' selected tab1Ref tab2Ref = do
quit <- pollEvents
loop window checked color slider r pos size' selected tab1Ref tab2Ref = do
shouldQuit <- checkEvents
openGL3NewFrame
sdl2NewFrame w
sdl2NewFrame
newFrame
-- showDemoWindow
@ -122,7 +121,7 @@ loop w checked color slider r pos size' selected tab1Ref tab2Ref = do
progressBar 0.314 (Just "Pi")
beginChild "Child"
beginChild "Child" (ImVec2 0 0) True ImGuiWindowFlags_None
beginCombo "Label" "Preview" >>= whenTrue do
selectable "Testing 1"
@ -133,6 +132,21 @@ loop w checked color slider r pos size' selected tab1Ref tab2Ref = do
endChild
text "ListClipper"
withChildOpen "##fixed" (ImVec2 0 200) True ImGuiWindowFlags_None do
let lotsOfItems = Vector.generate 50 (mappend "Item " . show)
withListClipper Nothing lotsOfItems text
text "ListClipper, Haskell-powered"
withChildOpen "##infinite" (ImVec2 0 200) True ImGuiWindowFlags_None do
let infiniteItems = map (mappend "Item " . show) [0 :: Int ..]
withListClipper Nothing infiniteItems text
text "Ethereal ListClipper"
withChildOpen "##ethereal" (ImVec2 0 200) True ImGuiWindowFlags_None do
withListClipper Nothing (ClipRange (0 :: Int) 1000) $
text . mappend "Item " . show
plotHistogram "A histogram" [ 10, 10, 20, 30, 90 ]
colorPicker3 "Test" color
@ -164,13 +178,15 @@ loop w checked color slider r pos size' selected tab1Ref tab2Ref = do
glClear GL_COLOR_BUFFER_BIT
openGL3RenderDrawData =<< getDrawData
glSwapWindow w
glSwapWindow window
if quit then return () else loop w checked color slider r pos size' selected tab1Ref tab2Ref
if shouldQuit
then return ()
else loop window checked color slider r pos size' selected tab1Ref tab2Ref
where
pollEvents = do
checkEvents = do
ev <- pollEventWithImGui
case ev of
@ -180,9 +196,9 @@ loop w checked color slider r pos size' selected tab1Ref tab2Ref = do
QuitEvent -> True
_ -> False
(isQuit ||) <$> pollEvents
(isQuit ||) <$> checkEvents
whenTrue :: IO () -> Bool -> IO ()
whenTrue io True = io
whenTrue io False = return ()
whenTrue _io False = return ()

View File

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

View File

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

View File

@ -1,9 +1,67 @@
cabal-version: 3.0
name: dear-imgui
version: 1.0.0
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
data-files:
imgui/imgui.h
extra-source-files:
README.md,
ChangeLog.md
extra-source-files:
imgui/*.h,
imgui/backends/*.h,
imgui/backends/*.mm,
imgui/imconfig.h,
imgui/LICENSE.txt
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 debug mode.
default:
False
manual:
True
flag opengl2
description:
@ -11,7 +69,7 @@ flag opengl2
default:
False
manual:
False
True
flag opengl3
description:
@ -19,7 +77,7 @@ flag opengl3
default:
True
manual:
False
True
flag vulkan
description:
@ -35,7 +93,7 @@ flag sdl
default:
True
manual:
False
True
flag glfw
description:
@ -45,14 +103,20 @@ flag glfw
manual:
True
flag examples
description:
Build executable examples.
default:
False
manual:
True
common common
build-depends:
base
>= 4.12 && < 4.17
default-language:
Haskell2010
ghc-options:
-Wall
library
import: common
@ -60,18 +124,21 @@ library
src
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:
@ -83,6 +150,8 @@ library
, inline-c
, inline-c-cpp
, StateVar
, unliftio
, vector
if flag(opengl2)
exposed-modules:
@ -97,14 +166,6 @@ library
DearImGui.OpenGL3
cxx-sources:
imgui/backends/imgui_impl_opengl3.cpp
if os(windows)
buildable:
False
else
if os(darwin)
buildable:
False
else
pkgconfig-depends:
glew
@ -156,7 +217,8 @@ library
exposed-modules:
DearImGui.GLFW
build-depends:
GLFW-b
GLFW-b,
bindings-GLFW
cxx-sources:
imgui/backends/imgui_impl_glfw.cpp
@ -183,16 +245,20 @@ library dear-imgui-generator
build-depends:
template-haskell
>= 2.15 && < 2.19
, containers
^>= 0.6.2.1
, directory
>= 1.3 && < 1.4
, filepath
>= 1.4 && < 1.5
, inline-c
>= 0.9.0.0 && < 0.10
, megaparsec
>= 9.0 && < 9.1
, parser-combinators
>= 1.2.0 && < 1.3
>= 1.2.0 && < 1.4
, scientific
>= 0.3.6.2 && < 0.3.7
>= 0.3.6.2 && < 0.3.8
, text
>= 1.2.4 && < 1.3
, th-lift
@ -200,34 +266,52 @@ library dear-imgui-generator
, transformers
>= 0.5.6 && < 0.6
, unordered-containers
>= 0.2.11 && < 0.2.14
>= 0.2.11 && < 0.2.15
executable test
import: common
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
ghc-options: -Wall
executable readme
import: common
import: common, build-flags
main-is: Readme.hs
hs-source-dirs: examples
build-depends: sdl2, gl, dear-imgui, managed
if (!flag(examples) || !flag(sdl) || !flag(opengl2))
buildable: False
executable image
import: common, build-flags
main-is: Image.hs
hs-source-dirs: examples/sdl
build-depends: sdl2, gl, dear-imgui, managed, vector
if (!flag(examples) || !flag(sdl) || !flag(opengl2))
buildable: False
executable vulkan
import: common
import: common, build-flags
main-is: Main.hs
other-modules: Attachments, Backend, Input, Util
hs-source-dirs: examples/vulkan
default-language: Haskell2010
if (!flag(examples) || !flag(sdl) || !flag(vulkan))
buildable: False
else
build-depends:
dear-imgui
, bytestring
@ -245,7 +329,7 @@ executable vulkan
, transformers
^>= 0.5.6.2
, unliftio
>= 0.2.13 && < 0.2.15
>= 0.2.13 && < 0.2.19
, unliftio-core
^>= 0.2.0.1
, vector
@ -254,4 +338,3 @@ executable vulkan
^>= 3.9
, vulkan-utils
^>= 0.4.1
ghc-options: -Wall

View File

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

View File

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

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

View File

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

View File

@ -111,27 +111,46 @@ instance ShowErrorComponent CustomParseError where
--------------------------------------------------------------------------------
-- Parsing headers.
headers :: MonadParsec CustomParseError [Tok] m => m Headers
headers :: MonadParsec CustomParseError [Tok] m => m ( Headers () )
headers = do
_ <- skipManyTill anySingle ( namedSection "Header mess" )
_ <- skipManyTill anySingle ( namedSection "Forward declarations" )
( _structNames, enumNamesAndTypes ) <- forwardDeclarations
_ <- skipManyTill anySingle ( namedSection "Dear ImGui end-user API functions" )
_ <- skipManyTill anySingle ( namedSection "Flags & Enumerations" )
( _defines, enums ) <- partitionEithers <$>
( _defines, basicEnums ) <- partitionEithers <$>
manyTill
( ( Left <$> try ignoreDefine )
<|> ( Right <$> enumeration enumNamesAndTypes )
)
( namedSection "Helpers: Memory allocations macros, ImVector<>" )
_ <- skipManyTill anySingle ( namedSection "ImGuiStyle" )
_ <- skipManyTill anySingle ( namedSection "ImGuiIO" )
_ <- skipManyTill anySingle ( namedSection "Misc data structures" )
_ <- skipManyTill anySingle ( namedSection "Obsolete functions" )
_ <- skipManyTill anySingle ( namedSection "Helpers" )
_ <- skipManyTill anySingle ( namedSection "Drawing API" )
_ <- skipManyTill anySingle ( namedSection "Font API" )
_ <- skipManyTill anySingle ( namedSection "ImGuiStyle" )
_ <- skipManyTill anySingle ( namedSection "ImGuiIO" )
_ <- skipManyTill anySingle ( namedSection "Misc data structures" )
_ <- skipManyTill anySingle ( namedSection "Helpers (ImGuiOnceUponAFrame, ImGuiTextFilter, ImGuiTextBuffer, ImGuiStorage, ImGuiListClipper, ImColor)" )
_ <- skipManyTill anySingle ( namedSection "Drawing API (ImDrawCmd, ImDrawIdx, ImDrawVert, ImDrawChannel, ImDrawListSplitter, ImDrawListFlags, ImDrawList, ImDrawData)" )
skipManyTill anySingle ( try . lookAhead $ many comment *> keyword "enum" )
drawingEnums <- many ( enumeration enumNamesAndTypes )
_ <- skipManyTill anySingle ( namedSection "Font API (ImFontConfig, ImFontGlyph, ImFontAtlasFlags, ImFontAtlas, ImFontGlyphRangesBuilder, ImFont)" )
skipManyTill anySingle ( try . lookAhead $ many comment *> keyword "enum" )
fontEnums <- many ( enumeration enumNamesAndTypes )
_ <- skipManyTill anySingle ( namedSection "Viewports" )
_ <- skipManyTill anySingle ( namedSection "Obsolete functions and types" )
let
enums :: [ Enumeration () ]
enums = basicEnums <> drawingEnums <> fontEnums
pure ( Headers { enums } )
--------------------------------------------------------------------------------
@ -151,7 +170,7 @@ forwardDeclarations = do
_ <- many comment
enums <- many do
keyword "typedef"
ty <- enumTypeName
ty <- cTypeName
enumName <- identifier
reservedSymbol ';'
doc <- commentText <$> comment
@ -159,8 +178,8 @@ forwardDeclarations = do
-- Stopping after simple structs and enums for now.
pure ( HashMap.fromList structs, HashMap.fromList enums )
enumTypeName :: MonadParsec e [Tok] m => m TH.Name
enumTypeName = keyword "int" $> ''CInt
cTypeName :: MonadParsec e [Tok] m => m TH.Name
cTypeName = keyword "int" $> ''CInt
--------------------------------------------------------------------------------
-- Parsing enumerations.
@ -172,15 +191,19 @@ data EnumState = EnumState
, hasExplicitCount :: Bool
}
enumeration :: MonadParsec CustomParseError [Tok] m => HashMap Text ( TH.Name, Comment ) -> m Enumeration
enumeration :: MonadParsec CustomParseError [Tok] m => HashMap Text ( TH.Name, Comment ) -> m ( Enumeration () )
enumeration enumNamesAndTypes = do
inlineDocs <- try do
inlineDocs <- many comment
keyword "enum"
pure inlineDocs
fullEnumName <- identifier
let
enumName :: Text
enumName = Text.dropWhileEnd ( == '_' ) fullEnumName
( enumType, forwardDoc ) <- case HashMap.lookup enumName enumNamesAndTypes of
enumTypeName :: ()
enumTypeName = ()
( underlyingType, forwardDoc ) <- case HashMap.lookup enumName enumNamesAndTypes of
Just res -> pure res
Nothing -> customFailure ( MissingForwardDeclaration { enumName } )
let
@ -222,11 +245,11 @@ patternNameAndValue
patternNameAndValue enumName =
try do
sz <- count
modify' ( ( \ st -> st { enumSize = sz, hasExplicitCount = True } ) :: EnumState -> EnumState )
modify' ( \ ( EnumState {..} ) -> EnumState { enumSize = sz, hasExplicitCount = True, .. } )
pure Nothing
<|> do
pat@( _, val ) <- value
modify' ( \ st -> st { enumSize = ( enumSize :: EnumState -> Integer ) st + 1, currEnumTag = val + 1} )
modify' ( \ ( EnumState {..} ) -> EnumState { enumSize = enumSize + 1, currEnumTag = val + 1, .. } )
pure ( Just pat )
where
count :: StateT EnumState m Integer

View File

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

2
imgui

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

File diff suppressed because it is too large Load Diff

View File

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

View File

@ -19,9 +19,33 @@ 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
@ -44,8 +68,121 @@ 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

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

View File

@ -4,11 +4,14 @@
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
@ -27,6 +30,7 @@ instance Storable ImVec2 where
data ImVec3 = ImVec3 { x, y, z :: {-# unpack #-} !Float }
deriving (Show)
instance Storable ImVec3 where
@ -47,6 +51,7 @@ instance Storable ImVec3 where
data ImVec4 = ImVec4 { x, y, z, w :: {-# unpack #-} !Float }
deriving (Show)
instance Storable ImVec4 where
@ -66,3 +71,20 @@ instance Storable ImVec4 where
z <- peek (castPtr ptr `plusPtr` (sizeOf x * 2))
w <- peek (castPtr ptr `plusPtr` (sizeOf x * 3))
return ImVec4{ x, y, z, w }
--------------------------------------------------------------------------------
-- | DearImGui context handle.
data ImGuiContext
-- | Individual font handle.
data ImFont
-- | 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,8 +110,7 @@ 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
liftIO do
checkResultFunPtr <- $( C.mkFunPtr [t| Vulkan.Result -> IO () |] ) checkResult
initResult <- withCallbacks \ callbacksPtr ->
[C.block| bool {
@ -123,12 +135,14 @@ withVulkan ( InitInfo {..} ) renderPass action = do
return ImGui_ImplVulkan_Init(&initInfo, $(VkRenderPass renderPass) );
}|]
pure ( checkResultFunPtr, initResult /= 0 )
)
( \ ( checkResultFunPtr, _ ) -> liftIO do
-- | 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
)
( \ ( _, initResult ) -> action initResult )
-- | Wraps @ImGui_ImplVulkan_NewFrame@.
vulkanNewFrame :: MonadIO m => m ()