mirror of
https://github.com/Drezil/dear-imgui.hs.git
synced 2025-07-04 12:08:48 +02:00
Compare commits
54 Commits
Author | SHA1 | Date | |
---|---|---|---|
48c8ae0379 | |||
a2c0c0658e | |||
21ce5cabd8 | |||
8db9ddec2f | |||
4ecf62ac9e | |||
8ee82476dc | |||
b4bc36ca89 | |||
76ce7bb569 | |||
259ffbff48 | |||
97825e49f2 | |||
24345bb8f3 | |||
e3f7fbfd6f | |||
88326420b8 | |||
f3b85899f2 | |||
c7a694bce8 | |||
c219f8eb4f | |||
24519778e6 | |||
4bfc7e7099 | |||
efaaa5723a | |||
be7aa1e9b1 | |||
08b3139477 | |||
cede825dff | |||
84a6b8a8fe | |||
cb687b8f01 | |||
8d07a5a42b | |||
d3a0396623 | |||
f49e81c739 | |||
5699f64e95 | |||
9e5b39850e | |||
d7dc999e8b | |||
bde2030c25 | |||
1706b7e966 | |||
bfe8453891 | |||
532eebd8ed | |||
d42eb672a1 | |||
1d6b7cc97b | |||
c4f3a1e0b9 | |||
ff267143d0 | |||
dcaad12ca8 | |||
f584319577 | |||
6ccee5234b | |||
73eee5fc9e | |||
5cdce50c3a | |||
8723ac2625 | |||
b921a72960 | |||
5634b6f67d | |||
3949882060 | |||
b0337eb084 | |||
ebd5286e1c | |||
2eddbdfa04 | |||
007b3cccb8 | |||
06921defb1 | |||
d4aec47f4e | |||
921aefdd69 |
42
ChangeLog.md
Normal file
42
ChangeLog.md
Normal 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
|
56
Main.hs
56
Main.hs
@ -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,26 +39,24 @@ main = do
|
||||
tab2 <- newIORef True
|
||||
loop w checked color slider r pos size' selected tab1 tab2
|
||||
|
||||
openGL3Shutdown
|
||||
|
||||
|
||||
loop
|
||||
:: Window
|
||||
-> IORef Bool
|
||||
-> IORef ImVec3
|
||||
-> IORef (Float, Float, Float)
|
||||
-> IORef Int
|
||||
-> IORef ImVec2
|
||||
loop
|
||||
:: Window
|
||||
-> IORef Bool
|
||||
-> IORef ImVec3
|
||||
-> IORef (Float, Float, Float)
|
||||
-> IORef Int
|
||||
-> IORef ImVec2
|
||||
-> IORef Int
|
||||
-> IORef ImVec2
|
||||
-> IORef Int
|
||||
-> IORef Bool
|
||||
-> IORef Bool
|
||||
-> IO ()
|
||||
loop w checked color slider r pos size' selected tab1Ref tab2Ref = do
|
||||
quit <- pollEvents
|
||||
loop window checked color slider r pos size' selected tab1Ref tab2Ref = do
|
||||
shouldQuit <- checkEvents
|
||||
|
||||
openGL3NewFrame
|
||||
sdl2NewFrame w
|
||||
sdl2NewFrame
|
||||
newFrame
|
||||
|
||||
-- showDemoWindow
|
||||
@ -68,7 +67,7 @@ loop w checked color slider r pos size' selected tab1Ref tab2Ref = do
|
||||
setNextWindowPos pos ImGuiCond_Once Nothing
|
||||
setNextWindowSize size' ImGuiCond_Once
|
||||
-- Works, but will make the window contents illegible without doing something more involved.
|
||||
-- setNextWindowContentSize size'
|
||||
-- setNextWindowContentSize size'
|
||||
-- setNextWindowSizeConstraints size' size'
|
||||
setNextWindowCollapsed False ImGuiCond_Once
|
||||
|
||||
@ -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 ()
|
||||
|
38
README.md
38
README.md
@ -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
|
||||
|
@ -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
|
||||
|
199
dear-imgui.cabal
199
dear-imgui.cabal
@ -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,16 +166,8 @@ library
|
||||
DearImGui.OpenGL3
|
||||
cxx-sources:
|
||||
imgui/backends/imgui_impl_opengl3.cpp
|
||||
if os(windows)
|
||||
buildable:
|
||||
False
|
||||
else
|
||||
if os(darwin)
|
||||
buildable:
|
||||
False
|
||||
else
|
||||
pkgconfig-depends:
|
||||
glew
|
||||
pkgconfig-depends:
|
||||
glew
|
||||
|
||||
if flag(vulkan)
|
||||
exposed-modules:
|
||||
@ -156,7 +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,58 +266,75 @@ 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
|
||||
build-depends: base, GLFW-b, gl, dear-imgui, managed
|
||||
ghc-options: -Wall
|
||||
if (!flag(examples) || !flag(glfw) || !flag(opengl2))
|
||||
buildable: False
|
||||
else
|
||||
build-depends: base, GLFW-b, gl, dear-imgui, managed
|
||||
|
||||
executable readme
|
||||
import: common
|
||||
import: common, 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
|
||||
build-depends:
|
||||
dear-imgui
|
||||
, bytestring
|
||||
>= 0.10.10.0 && < 0.12
|
||||
, containers
|
||||
^>= 0.6.2.1
|
||||
, logging-effect
|
||||
^>= 1.3.12
|
||||
, resourcet
|
||||
^>= 1.2.4.2
|
||||
, sdl2
|
||||
^>= 2.5.3.0
|
||||
, text-short
|
||||
^>= 0.1.3
|
||||
, transformers
|
||||
^>= 0.5.6.2
|
||||
, unliftio
|
||||
>= 0.2.13 && < 0.2.15
|
||||
, unliftio-core
|
||||
^>= 0.2.0.1
|
||||
, vector
|
||||
^>= 0.12.1.2
|
||||
, vulkan
|
||||
^>= 3.9
|
||||
, vulkan-utils
|
||||
^>= 0.4.1
|
||||
ghc-options: -Wall
|
||||
if (!flag(examples) || !flag(sdl) || !flag(vulkan))
|
||||
buildable: False
|
||||
else
|
||||
build-depends:
|
||||
dear-imgui
|
||||
, bytestring
|
||||
>= 0.10.10.0 && < 0.12
|
||||
, containers
|
||||
^>= 0.6.2.1
|
||||
, logging-effect
|
||||
^>= 1.3.12
|
||||
, resourcet
|
||||
^>= 1.2.4.2
|
||||
, sdl2
|
||||
^>= 2.5.3.0
|
||||
, text-short
|
||||
^>= 0.1.3
|
||||
, transformers
|
||||
^>= 0.5.6.2
|
||||
, unliftio
|
||||
>= 0.2.13 && < 0.2.19
|
||||
, unliftio-core
|
||||
^>= 0.2.0.1
|
||||
, vector
|
||||
^>= 0.12.1.2
|
||||
, vulkan
|
||||
^>= 3.9
|
||||
, vulkan-utils
|
||||
^>= 0.4.1
|
||||
|
@ -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;
|
||||
|
@ -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
195
examples/sdl/Image.hs
Normal 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
|
@ -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
|
||||
|
@ -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 $
|
||||
"Couldn't parse Dear ImGui headers:\n\n" <>
|
||||
( unlines ( map Megaparsec.parseErrorPretty . toList $ Megaparsec.bundleErrors err ) )
|
||||
Left err -> do
|
||||
let
|
||||
errorPos :: Int
|
||||
errorPos = Megaparsec.errorOffset . NonEmpty.head $ Megaparsec.bundleErrors err
|
||||
prev, rest :: [ Tok ]
|
||||
( prev, rest ) = second ( take 15 ) . splitAt 5 . drop ( errorPos - 5 ) $ tokens
|
||||
error $
|
||||
"Couldn't parse Dear ImGui headers:\n\n" <>
|
||||
( unlines ( map Megaparsec.parseErrorPretty . toList $ Megaparsec.bundleErrors err ) ) <> "\n" <>
|
||||
( unlines ( map show prev ) <> "\n\n" <> unlines ( map show rest ) )
|
||||
Right res -> pure res
|
||||
TH.lift $ generateNames basicHeaders
|
||||
)
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
-- Generating TH splices.
|
||||
|
||||
enumerationsTypesTable :: Map InlineC.TypeSpecifier ( TH.Q TH.Type )
|
||||
enumerationsTypesTable = Map.fromList . map mkTypePair $ enums headers
|
||||
where
|
||||
mkTypePair :: Enumeration ( TH.Name, TH.Name ) -> ( InlineC.TypeSpecifier, TH.Q TH.Type )
|
||||
mkTypePair ( Enumeration { enumName, enumTypeName } ) =
|
||||
( InlineC.TypeName $ fromString ( Text.unpack enumName )
|
||||
, TH.conT ( fst $ enumTypeName )
|
||||
)
|
||||
|
||||
declareEnumerations :: TH.Name -> TH.Name -> TH.Q [ TH.Dec ]
|
||||
declareEnumerations finiteEnumName countName = do
|
||||
concat <$> mapM ( declareEnumeration finiteEnumName countName ) ( enums headers )
|
||||
|
||||
declareEnumeration :: TH.Name -> TH.Name -> Enumeration -> TH.Q [ TH.Dec ]
|
||||
declareEnumeration :: TH.Name -> TH.Name -> Enumeration ( TH.Name, TH.Name ) -> TH.Q [ TH.Dec ]
|
||||
declareEnumeration finiteEnumName countName ( Enumeration {..} ) = do
|
||||
let
|
||||
enumNameStr :: String
|
||||
enumNameStr = Text.unpack enumName
|
||||
tyName, conName :: TH.Name
|
||||
( tyName, conName ) = enumTypeName
|
||||
isFlagEnum :: Bool
|
||||
isFlagEnum = "Flags" `Text.isInfixOf` enumName
|
||||
tyName <- TH.newName enumNameStr
|
||||
|
||||
conName <- TH.newName enumNameStr
|
||||
let
|
||||
newtypeCon :: TH.Q TH.Con
|
||||
newtypeCon =
|
||||
TH.normalC conName
|
||||
[ TH.bangType
|
||||
( TH.bang TH.noSourceUnpackedness TH.noSourceStrictness )
|
||||
( TH.conT enumType )
|
||||
( TH.conT underlyingType )
|
||||
]
|
||||
classes :: [ TH.Q TH.Type ]
|
||||
classes
|
||||
| isFlagEnum
|
||||
= map TH.conT [ ''Eq, ''Ord, ''Storable, ''Bits ]
|
||||
= map TH.conT [ ''Eq, ''Ord, ''Show, ''Storable, ''Bits ]
|
||||
| otherwise
|
||||
= map TH.conT [ ''Eq, ''Ord, ''Storable ]
|
||||
= map TH.conT [ ''Eq, ''Ord, ''Show, ''Storable ]
|
||||
derivClause :: TH.Q TH.DerivClause
|
||||
derivClause = TH.derivClause ( Just TH.NewtypeStrategy ) classes
|
||||
|
||||
newtypeDecl <-
|
||||
#if MIN_VERSION_base(4,16,0)
|
||||
#if MIN_VERSION_template_haskell(2,18,0)
|
||||
( if null docs
|
||||
then TH.newtypeD
|
||||
else
|
||||
\ ctx name bndrs kd con derivs ->
|
||||
TH.newtypeD_doc ctx name ( fmap pure bndrs ) ( fmap pure kd ) ( con, "", [] ) derivs
|
||||
( Text.unpack . Text.unlines . coerce $ docs )
|
||||
TH.newtypeD_doc ctx name ( fmap pure bndrs ) ( fmap pure kd ) ( con, Nothing, [] ) derivs
|
||||
( Just . Text.unpack . Text.unlines . coerce $ docs )
|
||||
)
|
||||
#else
|
||||
TH.newtypeD
|
||||
@ -126,24 +154,24 @@ declareEnumeration finiteEnumName countName ( Enumeration {..} ) = do
|
||||
<$> TH.appT ( TH.conT countName ) ( TH.conT tyName )
|
||||
<*> TH.litT ( TH.numTyLit enumSize )
|
||||
)
|
||||
]
|
||||
]
|
||||
pure ( finiteEnumInst : )
|
||||
else pure id
|
||||
|
||||
synonyms <- for patterns \ ( patternName, patternValue, CommentText patDoc ) -> do
|
||||
synonyms <- for patterns \ ( patternName, patternValue, CommentText _patDoc ) -> do
|
||||
let
|
||||
patNameStr :: String
|
||||
patNameStr = Text.unpack patternName
|
||||
patName <- TH.newName patNameStr
|
||||
patSynSig <- TH.patSynSigD patName ( TH.conT tyName )
|
||||
pat <-
|
||||
#if MIN_VERSION_base(4,16,0)
|
||||
( if Text.null patDoc
|
||||
#if MIN_VERSION_template_haskell(2,18,0)
|
||||
( if Text.null _patDoc
|
||||
then TH.patSynD
|
||||
else
|
||||
\ nm args dir pat ->
|
||||
TH.patSynD_doc nm args dir pat
|
||||
( Text.unpack patDoc ) []
|
||||
( Just $ Text.unpack patDoc ) []
|
||||
)
|
||||
#else
|
||||
TH.patSynD
|
||||
|
@ -75,7 +75,7 @@ import Data.HashMap.Strict
|
||||
import qualified Data.HashMap.Strict as HashMap
|
||||
( fromList, insert, lookup )
|
||||
|
||||
-- dear-imgui-generator
|
||||
-- dear-imgui-generator
|
||||
import DearImGui.Generator.Tokeniser
|
||||
( Tok(..) )
|
||||
import DearImGui.Generator.Types
|
||||
@ -111,27 +111,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,22 +191,26 @@ data EnumState = EnumState
|
||||
, hasExplicitCount :: Bool
|
||||
}
|
||||
|
||||
enumeration :: MonadParsec CustomParseError [Tok] m => HashMap Text ( TH.Name, Comment ) -> m Enumeration
|
||||
enumeration :: MonadParsec CustomParseError [Tok] m => HashMap Text ( TH.Name, Comment ) -> m ( Enumeration () )
|
||||
enumeration enumNamesAndTypes = do
|
||||
inlineDocs <- many comment
|
||||
keyword "enum"
|
||||
inlineDocs <- try do
|
||||
inlineDocs <- many comment
|
||||
keyword "enum"
|
||||
pure inlineDocs
|
||||
fullEnumName <- identifier
|
||||
let
|
||||
enumName :: Text
|
||||
enumName = Text.dropWhileEnd ( == '_' ) fullEnumName
|
||||
( enumType, forwardDoc ) <- case HashMap.lookup enumName enumNamesAndTypes of
|
||||
enumTypeName :: ()
|
||||
enumTypeName = ()
|
||||
( underlyingType, forwardDoc ) <- case HashMap.lookup enumName enumNamesAndTypes of
|
||||
Just res -> pure res
|
||||
Nothing -> customFailure ( MissingForwardDeclaration { enumName } )
|
||||
let
|
||||
docs :: [Comment]
|
||||
docs = forwardDoc : CommentText "" : inlineDocs
|
||||
reservedSymbol '{'
|
||||
( patterns, EnumState { enumSize, hasExplicitCount } ) <-
|
||||
( patterns, EnumState { enumSize, hasExplicitCount } ) <-
|
||||
( `runStateT` EnumState { enumValues = mempty, currEnumTag = 0, enumSize = 0, hasExplicitCount = False } ) $
|
||||
catMaybes
|
||||
<$> many
|
||||
@ -222,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
|
||||
|
@ -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
2
imgui
Submodule imgui updated: 58075c4414...e3e1fbcf02
@ -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": {
|
||||
|
132
nix/sources.nix
132
nix/sources.nix
@ -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); }
|
||||
|
1756
src/DearImGui.hs
1756
src/DearImGui.hs
File diff suppressed because it is too large
Load Diff
@ -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 |] )
|
||||
]
|
||||
}
|
||||
|
@ -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(); } |]
|
||||
[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
1654
src/DearImGui/Raw.hs
Normal file
File diff suppressed because it is too large
Load Diff
742
src/DearImGui/Raw/DrawList.hs
Normal file
742
src/DearImGui/Raw/DrawList.hs
Normal 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
137
src/DearImGui/Raw/IO.hs
Normal 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;
|
||||
-}
|
149
src/DearImGui/Raw/ListClipper.hs
Normal file
149
src/DearImGui/Raw/ListClipper.hs
Normal 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();
|
||||
}
|
||||
|]
|
@ -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@.
|
||||
|
@ -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
|
||||
|
@ -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 ()
|
||||
|
Reference in New Issue
Block a user