1 Commits

Author SHA1 Message Date
36a38f774a Wrap GetCurrentContext and SetCurrentContext 2021-01-27 09:12:38 +00:00
32 changed files with 584 additions and 5171 deletions

View File

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

1
.gitignore vendored
View File

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

View File

@ -1,38 +0,0 @@
# Changelog for dear-imgui
## [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

95
Main.hs
View File

@ -5,10 +5,9 @@
module Main (main) where
import Control.Monad
import Data.IORef
import DearImGui
import DearImGui.OpenGL3
import DearImGui.OpenGL
import DearImGui.SDL
import DearImGui.SDL.OpenGL
import Control.Exception
@ -23,39 +22,23 @@ main = do
bracket (glCreateContext w) glDeleteContext \glContext ->
bracket createContext destroyContext \_imguiContext ->
bracket_ (sdl2InitForOpenGL w glContext) sdl2Shutdown $
bracket_ openGL3Init openGL3Shutdown do
bracket_ openGL2Init openGL2Shutdown do
checkVersion
styleColorsLight
checked <- newIORef False
color <- newIORef $ ImVec3 1 0 0
slider <- newIORef (0.42, 0, 0.314)
r <- newIORef 4
pos <- newIORef $ ImVec2 64 64
size' <- newIORef $ ImVec2 512 512
selected <- newIORef 4
tab1 <- newIORef True
tab2 <- newIORef True
loop w checked color slider r pos size' selected tab1 tab2
slider <- newIORef 0.42
loop w checked color slider
openGL2Shutdown
loop
:: Window
-> IORef Bool
-> IORef ImVec3
-> IORef (Float, Float, Float)
-> IORef Int
-> IORef ImVec2
-> IORef ImVec2
-> IORef Int
-> IORef Bool
-> IORef Bool
-> IO ()
loop window checked color slider r pos size' selected tab1Ref tab2Ref = do
shouldQuit <- checkEvents
loop :: Window -> IORef Bool -> IORef ImVec3 -> IORef Float -> IO ()
loop w checked color slider = do
quit <- pollEvents
openGL3NewFrame
sdl2NewFrame
openGL2NewFrame
sdl2NewFrame w
newFrame
-- showDemoWindow
@ -63,34 +46,9 @@ loop window checked color slider r pos size' selected tab1Ref tab2Ref = do
-- showAboutWindow
-- showUserGuide
setNextWindowPos pos ImGuiCond_Once Nothing
setNextWindowSize size' ImGuiCond_Once
-- Works, but will make the window contents illegible without doing something more involved.
-- setNextWindowContentSize size'
-- setNextWindowSizeConstraints size' size'
setNextWindowCollapsed False ImGuiCond_Once
setNextWindowBgAlpha 0.42
begin "My Window"
text "Hello!"
beginTabBar "My tab bar" ImGuiTabBarFlags_Reorderable >>= whenTrue do
beginTabItem "Tab 1" tab1Ref ImGuiTabBarFlags_None >>= whenTrue do
text "Tab 1 is currently selected."
endTabItem
beginTabItem "Tab 2" tab2Ref ImGuiTabBarFlags_None >>= whenTrue do
text "Tab 2 is selected now."
endTabItem
reOpen <- tabItemButton "ReopenTabs" ImGuiTabItemFlags_Trailing
when reOpen do
writeIORef tab1Ref True
writeIORef tab2Ref True
endTabBar
listBox "Items" r [ "A", "B", "C" ]
button "Click me" >>= \case
True -> openPopup "Button Popup"
False -> return ()
@ -108,7 +66,7 @@ loop window checked color slider r pos size' selected tab1Ref tab2Ref = do
True -> putStrLn "Oh hi Mark"
False -> return ()
sameLine >> arrowButton "Arrow" ImGuiDir_Up
sameLine >> arrowButton "Arrow" ImGuiDirUp
sameLine >> checkbox "Check!" checked >>= \case
True -> readIORef checked >>= print
@ -116,34 +74,19 @@ loop window checked color slider r pos size' selected tab1Ref tab2Ref = do
separator
dragFloat3 "Slider" slider 0.1 0.0 1.0
sliderFloat "Slider" slider 0.0 1.0
progressBar 0.314 (Just "Pi")
beginChild "Child" (ImVec2 0 0) True ImGuiWindowFlags_None
beginCombo "Label" "Preview" >>= whenTrue do
selectable "Testing 1"
selectable "Testing 2"
endCombo
combo "Simple" selected [ "1", "2", "3" ]
endChild
plotHistogram "A histogram" [ 10, 10, 20, 30, 90 ]
colorPicker3 "Test" color
treeNode "Tree Node 1" >>= whenTrue do
treeNode "Tree Node 2" >>= whenTrue do
treePop
treeNode "Tree Node 3" >>= whenTrue do
treePop
treePop
beginMainMenuBar >>= whenTrue do
beginMenu "Hello" >>= whenTrue do
menuItem "Hello"
@ -160,17 +103,15 @@ loop window checked color slider r pos size' selected tab1Ref tab2Ref = do
render
glClear GL_COLOR_BUFFER_BIT
openGL3RenderDrawData =<< getDrawData
openGL2RenderDrawData =<< getDrawData
glSwapWindow window
glSwapWindow w
if shouldQuit
then return ()
else loop window checked color slider r pos size' selected tab1Ref tab2Ref
if quit then return () else loop w checked color slider
where
checkEvents = do
pollEvents = do
ev <- pollEventWithImGui
case ev of
@ -180,9 +121,9 @@ loop window checked color slider r pos size' selected tab1Ref tab2Ref = do
QuitEvent -> True
_ -> False
(isQuit ||) <$> checkEvents
(isQuit ||) <$> pollEvents
whenTrue :: IO () -> Bool -> IO ()
whenTrue io True = io
whenTrue _io False = return ()
whenTrue io False = return ()

View File

@ -25,7 +25,7 @@ OpenGL:
```
package dear-imgui
flags: +sdl +opengl3
flags: +sdl +opengl
```
With this done, the following module is the "Hello, World!" of ImGui:
@ -41,7 +41,7 @@ import Control.Exception
import Control.Monad.IO.Class
import Control.Monad.Managed
import DearImGui
import DearImGui.OpenGL2
import DearImGui.OpenGL
import DearImGui.SDL
import DearImGui.SDL.OpenGL
import Graphics.GL
@ -81,7 +81,7 @@ mainLoop w = do
-- Tell ImGui we're starting a new frame
openGL2NewFrame
sdl2NewFrame
sdl2NewFrame w
newFrame
-- Build the GUI

View File

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

View File

@ -1,48 +1,15 @@
cabal-version: 3.0
name: dear-imgui
version: 1.2.0
author: Oliver Charles
maintainer: ollie@ocharles.org.uk, aenor.realm@gmail.com
license: BSD-3-Clause
category: Graphics
synopsis: Haskell bindings for Dear ImGui.
description:
The package supports multiple rendering backends.
Set package flags according to your needs.
version: 1.0.0
build-type: Simple
extra-source-files:
README.md,
ChangeLog.md
extra-source-files:
imgui/*.h,
imgui/backends/*.h,
imgui/backends/*.mm,
imgui/imconfig.h,
imgui/LICENSE.txt
source-repository head
type: git
location: https://github.com/haskell-game/dear-imgui.hs
flag opengl2
flag opengl
description:
Enable OpenGL 2 backend.
Enable OpenGL backend.
default:
True
manual:
False
manual:
True
flag opengl3
description:
Enable OpenGL 3 backend.
default:
True
manual:
True
flag vulkan
description:
@ -58,44 +25,18 @@ flag sdl
default:
True
manual:
True
flag glfw
description:
Enable GLFW backend.
default:
False
manual:
True
flag examples
description:
Build executable examples.
default:
False
manual:
True
common common
build-depends:
base
>= 4.12 && < 4.17
default-language:
Haskell2010
ghc-options:
-Wall
library
import: common
hs-source-dirs:
src
exposed-modules:
DearImGui
DearImGui.Raw
other-modules:
DearImGui.Context
DearImGui.Enums
DearImGui.Structs
hs-source-dirs:
src
default-language:
Haskell2010
ghc-options:
-Wall
cxx-sources:
imgui/imgui.cpp
imgui/imgui_demo.cpp
@ -109,29 +50,27 @@ library
include-dirs:
imgui
build-depends:
dear-imgui-generator
base
, containers
, managed
, inline-c
, inline-c-cpp
, StateVar
, unliftio
if flag(opengl2)
if flag(opengl)
exposed-modules:
DearImGui.OpenGL2
DearImGui.OpenGL
cxx-sources:
imgui/backends/imgui_impl_opengl2.cpp
build-depends:
gl
if flag(opengl3)
exposed-modules:
DearImGui.OpenGL3
cxx-sources:
imgui/backends/imgui_impl_opengl3.cpp
pkgconfig-depends:
glew
if os(windows)
extra-libraries:
opengl32
else
if os(darwin)
frameworks:
OpenGL
else
extra-libraries:
GL
if flag(vulkan)
exposed-modules:
@ -169,7 +108,7 @@ library
pkgconfig-depends:
sdl2
if flag(opengl2) || flag(opengl3)
if flag(opengl)
exposed-modules:
DearImGui.SDL.OpenGL
@ -177,130 +116,52 @@ library
exposed-modules:
DearImGui.SDL.Vulkan
if flag(glfw)
exposed-modules:
DearImGui.GLFW
build-depends:
GLFW-b,
bindings-GLFW
cxx-sources:
imgui/backends/imgui_impl_glfw.cpp
if os(linux) || os(darwin)
pkgconfig-depends:
glfw3
if flag(opengl2) || flag(opengl3)
exposed-modules:
DearImGui.GLFW.OpenGL
if flag(vulkan)
exposed-modules:
DearImGui.GLFW.Vulkan
library dear-imgui-generator
import: common
hs-source-dirs: generator
exposed-modules:
DearImGui.Generator
, DearImGui.Generator.Parser
, DearImGui.Generator.Tokeniser
, DearImGui.Generator.Types
build-depends:
template-haskell
>= 2.15 && < 2.19
, containers
^>= 0.6.2.1
, directory
>= 1.3 && < 1.4
, filepath
>= 1.4 && < 1.5
, inline-c
>= 0.9.0.0 && < 0.10
, megaparsec
>= 9.0 && < 9.1
, parser-combinators
>= 1.2.0 && < 1.4
, scientific
>= 0.3.6.2 && < 0.3.8
, text
>= 1.2.4 && < 1.3
, th-lift
>= 0.7 && < 0.9
, transformers
>= 0.5.6 && < 0.6
, unordered-containers
>= 0.2.11 && < 0.2.15
executable test
import: common
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
executable glfw
main-is: Main.hs
hs-source-dirs: examples/glfw
default-language: Haskell2010
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
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
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
default-language: Haskell2010
build-depends: base, sdl2, gl, dear-imgui, managed
ghc-options: -Wall
executable vulkan
import: common
main-is: Main.hs
other-modules: Attachments, Backend, Input, Util
hs-source-dirs: examples/vulkan
default-language: Haskell2010
build-depends:
dear-imgui
, base
>= 4.13 && < 4.16
, bytestring
>= 0.10.10.0 && < 0.12
, containers
^>= 0.6.2.1
, logging-effect
^>= 1.3.12
, resourcet
^>= 1.2.4.2
, sdl2
^>= 2.5.3.0
, text-short
^>= 0.1.3
, transformers
^>= 0.5.6.2
, unliftio
>= 0.2.13 && < 0.2.15
, unliftio-core
^>= 0.2.0.1
, vector
^>= 0.12.1.2
, vulkan
^>= 3.9
, vulkan-utils
^>= 0.4.1
ghc-options: -Wall
if (!flag(examples) || !flag(sdl) || !flag(vulkan))
buildable: False
else
build-depends:
dear-imgui
, bytestring
>= 0.10.10.0 && < 0.12
, containers
^>= 0.6.2.1
, logging-effect
^>= 1.3.12
, resourcet
^>= 1.2.4.2
, sdl2
^>= 2.5.3.0
, text-short
^>= 0.1.3
, transformers
^>= 0.5.6.2
, unliftio
>= 0.2.13 && < 0.2.19
, unliftio-core
^>= 0.2.0.1
, vector
^>= 0.12.1.2
, vulkan
^>= 3.9
, vulkan-utils
^>= 0.4.1

View File

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

View File

@ -11,7 +11,7 @@ import Control.Exception
import Control.Monad.IO.Class
import Control.Monad.Managed
import DearImGui
import DearImGui.OpenGL2
import DearImGui.OpenGL
import DearImGui.SDL
import DearImGui.SDL.OpenGL
import Graphics.GL
@ -24,38 +24,38 @@ main = do
runManaged do
-- Create a window using SDL. As we're using OpenGL, we need to enable OpenGL too.
window <- do
w <- 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 window) glDeleteContext
glContext <- managed $ bracket (glCreateContext w) glDeleteContext
-- Create an ImGui context
_ <- managed $ bracket createContext destroyContext
-- Initialize ImGui's SDL2 backend
_ <- managed_ $ bracket_ (sdl2InitForOpenGL window glContext) sdl2Shutdown
_ <- managed_ $ bracket_ (sdl2InitForOpenGL w glContext) sdl2Shutdown
-- Initialize ImGui's OpenGL backend
_ <- managed_ $ bracket_ openGL2Init openGL2Shutdown
liftIO $ mainLoop window
liftIO $ mainLoop w
mainLoop :: Window -> IO ()
mainLoop window = do
mainLoop w = do
-- Process the event loop
untilNothingM pollEventWithImGui
-- Tell ImGui we're starting a new frame
openGL2NewFrame
sdl2NewFrame
sdl2NewFrame w
newFrame
-- Build the GUI
withWindowOpen "Hello, ImGui!" do
bracket_ (begin "Hello, ImGui!") end do
-- Add a text widget
text "Hello, ImGui!"
@ -73,9 +73,9 @@ mainLoop window = do
render
openGL2RenderDrawData =<< getDrawData
glSwapWindow window
glSwapWindow w
mainLoop window
mainLoop w
where
untilNothingM m = m >>= maybe (return ()) (\_ -> untilNothingM m)

View File

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

View File

@ -1,181 +0,0 @@
{-# 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 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
-- Build the GUI
clicked <- withWindow "Image example" \open ->
if open then do
text "That's an image, click it"
newLine
let texture = if flag then fst textures else snd textures
-- Drawing images require some backend-specific code.
-- Meanwhile, we have to deal with raw binding.
let openGLtextureID = intPtrToPtr $ fromIntegral $ textureID texture
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
-- Render
glClear GL_COLOR_BUFFER_BIT
DearImGui.render
DearImGui.getDrawData >>= openGL3RenderDrawData
SDL.glSwapWindow window
mainLoop window textures (flag /= clicked)
where
unlessQuit action = do
shouldQuit <- checkEvents
if shouldQuit then pure () else action
checkEvents = do
pollEventWithImGui >>= \case
Nothing ->
return False
Just event ->
(isQuit event ||) <$> checkEvents
isQuit event =
SDL.eventPayload event == SDL.QuitEvent

View File

@ -83,20 +83,6 @@ 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 ) )
@ -134,12 +120,6 @@ app = do
ImGui.createContext
ImGui.destroyContext
logDebug "Adding fonts"
ImGui.clearFontAtlas
_default <- ImGui.addFontDefault
_custom <- ImGui.addFontFromFileTTF "imgui/misc/fonts/ProggyTiny.ttf" 10
ImGui.buildFontAtlas
let
preferredFormat :: Vulkan.SurfaceFormatKHR
preferredFormat =
@ -361,6 +341,12 @@ 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
@ -369,10 +355,7 @@ 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
@ -387,7 +370,7 @@ app = do
freeOldResources
let
freeOldResources :: m ()
freeOldResources = pure ()
freeOldResources = pure ()
unless quit $ mainLoop ( AppState {..} )
let

View File

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

View File

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

View File

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

View File

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

2
imgui

Submodule imgui updated: e3e1fbcf02...58075c4414

View File

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

View File

@ -6,63 +6,52 @@ let
# The fetchers. fetch_<type> fetches specs of type <type>.
#
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_file = pkgs: spec:
if spec.builtin or true then
builtins_fetchurl { inherit (spec) url sha256; }
else
pkgs.fetchurl { 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_tarball = pkgs: spec:
if spec.builtin or true then
builtins_fetchTarball { inherit (spec) url sha256; }
else
pkgs.fetchzip { inherit (spec) url sha256; };
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_git = spec:
builtins.fetchGit { url = spec.repo; inherit (spec) rev ref; };
fetch_local = spec: spec.path;
fetch_builtin-tarball = spec:
builtins.trace
''
WARNING:
The niv type "builtin-tarball" will soon be deprecated. You should
instead use `builtin = true`.
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'';
$ niv modify <package> -a type=tarball -a builtin=true
''
builtins_fetchTarball { 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'';
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; });
#
# 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: system:
mkPkgs = sources:
let
sourcesNixpkgs =
import (builtins_fetchTarball { inherit (sources.nixpkgs) url sha256; }) { inherit system; };
import (builtins_fetchTarball { inherit (sources.nixpkgs) url sha256; }) {};
hasNixpkgsPath = builtins.any (x: x.prefix == "nixpkgs") builtins.nixPath;
hasThisAsNixpkgsPath = <nixpkgs> == ./.;
in
@ -82,27 +71,14 @@ 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 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 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
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
@ -111,37 +87,23 @@ 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, name ? null, sha256 }@attrs:
builtins_fetchTarball = { url, sha256 }@attrs:
let
inherit (builtins) lessThan nixVersion fetchTarball;
in
if lessThan nixVersion "1.12" then
fetchTarball ({ inherit url; } // (optionalAttrs (!isNull name) { inherit name; }))
fetchTarball { inherit url; }
else
fetchTarball attrs;
# fetchurl version that is compatible between all the versions of Nix
builtins_fetchurl = { url, name ? null, sha256 }@attrs:
builtins_fetchurl = { url, sha256 }@attrs:
let
inherit (builtins) lessThan nixVersion fetchurl;
in
if lessThan nixVersion "1.12" then
fetchurl ({ inherit url; } // (optionalAttrs (!isNull name) { inherit name; }))
fetchurl { inherit url; }
else
fetchurl attrs;
@ -153,15 +115,14 @@ let
then abort
"The values in sources.json should not have an 'outPath' attribute"
else
spec // { outPath = replace name (fetch config.pkgs name spec); }
spec // { outPath = fetch config.pkgs name spec; }
) config.sources;
# The "config" used by the fetchers
mkConfig =
{ 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
{ sourcesFile ? ./sources.json
, sources ? builtins.fromJSON (builtins.readFile sourcesFile)
, pkgs ? mkPkgs sources
}: rec {
# The sources, i.e. the attribute set of spec name to spec
inherit sources;
@ -169,6 +130,5 @@ let
# The "pkgs" (evaluated nixpkgs) to use for e.g. non-builtin fetchers
inherit pkgs;
};
in
mkSources (mkConfig {}) // { __functor = _: settings: mkSources (mkConfig settings); }

View File

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

File diff suppressed because it is too large Load Diff

View File

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

View File

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

View File

@ -1,188 +0,0 @@
{-# LANGUAGE BlockArguments #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE PatternSynonyms #-}
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE TemplateHaskell #-}
{-|
Module: DearImGui.GLFW
GLFW specific functions backend for Dear ImGui.
Modules for initialising a backend with GLFW can be found under the corresponding backend,
e.g. "DearImGui.GLFW.OpenGL".
-}
module DearImGui.GLFW (
-- ** GLFW
glfwNewFrame
, glfwShutdown
-- $callbacks
, glfwWindowFocusCallback
, glfwCursorEnterCallback
, glfwMouseButtonCallback
, glfwScrollCallback
, glfwKeyCallback
, glfwCharCallback
, glfwMonitorCallback
)
where
-- base
import Foreign
( Ptr, castPtr )
import Foreign.C.Types
( CInt, CDouble, CUInt )
import Unsafe.Coerce (unsafeCoerce)
-- bindings-GLFW
import Bindings.GLFW
( C'GLFWmonitor, C'GLFWwindow )
-- GLFW-b
import Graphics.UI.GLFW
( Monitor, Window )
-- inline-c
import qualified Language.C.Inline as C
-- inline-c-cpp
import qualified Language.C.Inline.Cpp as Cpp
-- transformers
import Control.Monad.IO.Class
( MonadIO, liftIO )
C.context (Cpp.cppCtx <> C.bsCtx)
C.include "imgui.h"
C.include "backends/imgui_impl_glfw.h"
Cpp.using "namespace ImGui"
-- | Wraps @ImGui_ImplGlfw_NewFrame@.
glfwNewFrame :: MonadIO m => m ()
glfwNewFrame = liftIO do
[C.exp| void { ImGui_ImplGlfw_NewFrame(); } |]
-- $callbacks
-- == GLFW callbacks
-- * When calling Init with @install_callbacks=true@:
-- GLFW callbacks will be installed for you.
-- They will call user's previously installed callbacks, if any.
-- * When calling Init with @install_callbacks=false@:
-- GLFW callbacks won't be installed.
-- You will need to call those function yourself from your own GLFW callbacks.
-- | Wraps @ImGui_ImplGlfw_Shutdown@.
glfwShutdown :: MonadIO m => m ()
glfwShutdown = liftIO do
[C.exp| void { ImGui_ImplGlfw_Shutdown(); } |]
glfwWindowFocusCallback :: MonadIO m => Window -> CInt -> m ()
glfwWindowFocusCallback window focused = liftIO do
[C.exp| void {
ImGui_ImplGlfw_WindowFocusCallback(
static_cast<GLFWwindow *>(
$(void * windowPtr)
),
$(int focused)
);
} |]
where
windowPtr = castPtr $ unWindow window
glfwCursorEnterCallback :: MonadIO m => Window -> CInt -> m ()
glfwCursorEnterCallback window entered = liftIO do
[C.exp| void {
ImGui_ImplGlfw_CursorEnterCallback(
static_cast<GLFWwindow *>(
$(void * windowPtr)
),
$(int entered)
);
} |]
where
windowPtr = castPtr $ unWindow window
glfwMouseButtonCallback :: MonadIO m => Window -> CInt -> CInt -> CInt -> m ()
glfwMouseButtonCallback window button action mods = liftIO do
[C.exp| void {
ImGui_ImplGlfw_MouseButtonCallback(
static_cast<GLFWwindow *>(
$(void * windowPtr)
),
$(int button),
$(int action),
$(int mods)
);
} |]
where
windowPtr = castPtr $ unWindow window
glfwScrollCallback :: MonadIO m => Window -> CDouble -> CDouble -> m ()
glfwScrollCallback window xoffset yoffset = liftIO do
[C.exp| void {
ImGui_ImplGlfw_ScrollCallback(
static_cast<GLFWwindow *>(
$(void * windowPtr)
),
$(double xoffset),
$(double yoffset)
);
} |]
where
windowPtr = castPtr $ unWindow window
glfwKeyCallback :: MonadIO m => Window -> CInt -> CInt -> CInt -> CInt -> m ()
glfwKeyCallback window key scancode action mods = liftIO do
[C.exp| void {
ImGui_ImplGlfw_KeyCallback(
static_cast<GLFWwindow *>(
$(void * windowPtr)
),
$(int key),
$(int scancode),
$(int action),
$(int mods)
);
} |]
where
windowPtr = castPtr $ unWindow window
glfwCharCallback :: MonadIO m => Window -> CUInt -> m ()
glfwCharCallback window c = liftIO do
[C.exp| void {
ImGui_ImplGlfw_CharCallback(
static_cast<GLFWwindow *>(
$(void * windowPtr)
),
$(unsigned int c)
);
} |]
where
windowPtr = castPtr $ unWindow window
glfwMonitorCallback :: MonadIO m => Monitor -> CInt -> m ()
glfwMonitorCallback monitor event = liftIO do
[C.exp| void {
ImGui_ImplGlfw_MonitorCallback(
static_cast<GLFWmonitor *>(
$(void * monitorPtr)
),
$(int event)
);
} |]
where
monitorPtr = castPtr $ unMonitor monitor
-- | Strip the unpublished newtype wrapper.
unWindow :: Window -> Ptr C'GLFWwindow
unWindow = unsafeCoerce
-- | Strip the unpublished newtype wrapper.
unMonitor :: Monitor -> Ptr C'GLFWmonitor
unMonitor = unsafeCoerce

View File

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

View File

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

View File

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

View File

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

File diff suppressed because it is too large Load Diff

View File

@ -40,6 +40,7 @@ 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
@ -56,9 +57,9 @@ Cpp.using "namespace ImGui"
-- | Wraps @ImGui_ImplSDL2_NewFrame@.
sdl2NewFrame :: MonadIO m => m ()
sdl2NewFrame = liftIO do
[C.exp| void { ImGui_ImplSDL2_NewFrame(); } |]
sdl2NewFrame :: MonadIO m => Window -> m ()
sdl2NewFrame (Window windowPtr) = liftIO do
[C.exp| void { ImGui_ImplSDL2_NewFrame((SDL_Window*)($(void* windowPtr))); } |]
-- | Wraps @ImGui_ImplSDL2_Shutdown@.

View File

@ -1,79 +0,0 @@
{-# LANGUAGE DuplicateRecordFields #-}
{-# LANGUAGE NamedFieldPuns #-}
module DearImGui.Structs where
-- base
import Foreign
( Storable(..), castPtr, plusPtr )
--------------------------------------------------------------------------------
data ImVec2 = ImVec2 { x, y :: {-# unpack #-} !Float }
deriving (Show)
instance Storable ImVec2 where
sizeOf ~ImVec2{x, y} = sizeOf x + sizeOf y
alignment _ = 0
poke ptr ImVec2{ x, y } = do
poke (castPtr ptr `plusPtr` (sizeOf x * 0)) x
poke (castPtr ptr `plusPtr` (sizeOf x * 1)) y
peek ptr = do
x <- peek (castPtr ptr )
y <- peek (castPtr ptr `plusPtr` (sizeOf x * 1))
return ImVec2{ x, y }
data ImVec3 = ImVec3 { x, y, z :: {-# unpack #-} !Float }
deriving (Show)
instance Storable ImVec3 where
sizeOf ~ImVec3{x, y, z} = sizeOf x + sizeOf y + sizeOf z
alignment _ = 0
poke ptr ImVec3{ x, y, z } = do
poke (castPtr ptr `plusPtr` (sizeOf x * 0)) x
poke (castPtr ptr `plusPtr` (sizeOf x * 1)) y
poke (castPtr ptr `plusPtr` (sizeOf x * 2)) z
peek ptr = do
x <- peek (castPtr ptr )
y <- peek (castPtr ptr `plusPtr` (sizeOf x * 1))
z <- peek (castPtr ptr `plusPtr` (sizeOf x * 2))
return ImVec3{ x, y, z }
data ImVec4 = ImVec4 { x, y, z, w :: {-# unpack #-} !Float }
deriving (Show)
instance Storable ImVec4 where
sizeOf ~ImVec4{x, y, z, w} = sizeOf x + sizeOf y + sizeOf z + sizeOf w
alignment _ = 0
poke ptr ImVec4{ x, y, z, w } = do
poke (castPtr ptr `plusPtr` (sizeOf x * 0)) x
poke (castPtr ptr `plusPtr` (sizeOf x * 1)) y
poke (castPtr ptr `plusPtr` (sizeOf x * 2)) z
poke (castPtr ptr `plusPtr` (sizeOf x * 3)) w
peek ptr = do
x <- peek (castPtr ptr )
y <- peek (castPtr ptr `plusPtr` (sizeOf x * 1))
z <- peek (castPtr ptr `plusPtr` (sizeOf x * 2))
w <- peek (castPtr ptr `plusPtr` (sizeOf x * 3))
return ImVec4{ x, y, z, w }
--------------------------------------------------------------------------------
-- | DearImGui context handle.
data ImGuiContext
-- | Individual font handle.
data ImFont

View File

@ -12,8 +12,6 @@ Vulkan backend for Dear ImGui.
module DearImGui.Vulkan
( InitInfo(..)
, withVulkan
, vulkanInit
, vulkanShutdown
, vulkanNewFrame
, vulkanRenderDrawData
, vulkanCreateFontsTexture
@ -30,7 +28,7 @@ import Data.Word
import Foreign.Marshal.Alloc
( alloca )
import Foreign.Ptr
( FunPtr, Ptr, freeHaskellFunPtr, nullPtr )
( Ptr, freeHaskellFunPtr, nullPtr )
import Foreign.Storable
( Storable(poke) )
@ -85,18 +83,7 @@ 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 =
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
withVulkan ( InitInfo {..} ) renderPass action = do
let
instancePtr :: Ptr Vulkan.Instance_T
instancePtr = Vulkan.instanceHandle instance'
@ -110,39 +97,38 @@ vulkanInit ( InitInfo {..} ) renderPass = do
withCallbacks f = case mbAllocator of
Nothing -> f nullPtr
Just callbacks -> alloca ( \ ptr -> poke ptr callbacks *> f ptr )
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
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 )
-- | Wraps @ImGui_ImplVulkan_NewFrame@.
vulkanNewFrame :: MonadIO m => m ()