Drezil/dear-imgui.hs
1
0
Fork 0
mirror of https://github.com/Drezil/dear-imgui.hs.git synced 2024-11-25 18:17:00 +00:00
Code Issues Packages Projects Releases Wiki Activity

Merge branch 'main' of github.com:haskell-game/dear-imgui.hs into args

Browse Source
This commit is contained in:
Ollie Charles 2021-02-06 15:28:41 +00:00
commit ab9d2b66fb
21 changed files with 1944 additions and 122 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

1
.gitignore vendored
View File

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

83
Main.hs
View File

@ -6,9 +6,10 @@
module Main (main) where module Main (main) where
import Control.Monad
import Data.IORef import Data.IORef
import DearImGui import DearImGui
import DearImGui.OpenGL import DearImGui.OpenGL3
import DearImGui.SDL import DearImGui.SDL
import DearImGui.SDL.OpenGL import DearImGui.SDL.OpenGL
import Control.Exception import Control.Exception
@ -23,22 +24,40 @@ main = do
bracket (glCreateContext w) glDeleteContext \glContext -> bracket (glCreateContext w) glDeleteContext \glContext ->
bracket createContext destroyContext \_imguiContext -> bracket createContext destroyContext \_imguiContext ->
bracket_ (sdl2InitForOpenGL w glContext) sdl2Shutdown $ bracket_ (sdl2InitForOpenGL w glContext) sdl2Shutdown $
bracket_ openGL2Init openGL2Shutdown do bracket_ openGL3Init openGL3Shutdown do
checkVersion checkVersion
styleColorsLight styleColorsLight
checked <- newIORef False checked <- newIORef False
color <- newIORef $ ImVec3 1 0 0 color <- newIORef $ ImVec3 1 0 0
slider <- newIORef 0.42 slider <- newIORef (0.42, 0, 0.314)
loop w checked color slider r <- newIORef 4
pos <- newIORef $ ImVec2 64 64
size' <- newIORef $ ImVec2 512 512
selected <- newIORef 4
tab1 <- newIORef True
tab2 <- newIORef True
loop w checked color slider r pos size' selected tab1 tab2
openGL2Shutdown openGL3Shutdown
loop :: Window -> IORef Bool -> IORef ImVec3 -> IORef Float -> IO ()
loop w checked color slider = do loop
:: Window
-> IORef Bool
-> IORef ImVec3
-> IORef (Float, Float, Float)
-> IORef Int
-> IORef ImVec2
-> IORef ImVec2
-> IORef Int
-> IORef Bool
-> IORef Bool
-> IO ()
loop w checked color slider r pos size' selected tab1Ref tab2Ref = do
quit <- pollEvents quit <- pollEvents
openGL2NewFrame openGL3NewFrame
sdl2NewFrame w sdl2NewFrame w
newFrame newFrame
@ -47,9 +66,34 @@ loop w checked color slider = do
-- showAboutWindow -- showAboutWindow
-- showUserGuide -- 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 Begin{ name = "My Window", isOpen = Nothing } begin Begin{ name = "My Window", isOpen = Nothing }
text "Hello!" 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 button "Click me" >>= \case
True -> openPopup "Button Popup" True -> openPopup "Button Popup"
False -> return () False -> return ()
@ -67,7 +111,7 @@ loop w checked color slider = do
True -> putStrLn "Oh hi Mark" True -> putStrLn "Oh hi Mark"
False -> return () False -> return ()
sameLine >> arrowButton "Arrow" ImGuiDirUp sameLine >> arrowButton "Arrow" ImGuiDir_Up
sameLine >> checkbox Checkbox{ label = "Check!", checked = toStateVar checked } >>= \case sameLine >> checkbox Checkbox{ label = "Check!", checked = toStateVar checked } >>= \case
True -> readIORef checked >>= print True -> readIORef checked >>= print
@ -75,19 +119,34 @@ loop w checked color slider = do
separator separator
sliderFloat "Slider" slider 0.0 1.0 dragFloat3 "Slider" slider 0.1 0.0 1.0
progressBar 0.314 (Just "Pi") progressBar 0.314 (Just "Pi")
beginChild "Child"
beginCombo "Label" "Preview" >>= whenTrue do beginCombo "Label" "Preview" >>= whenTrue do
selectable "Testing 1" selectable "Testing 1"
selectable "Testing 2" selectable "Testing 2"
endCombo endCombo
combo "Simple" selected [ "1", "2", "3" ]
endChild
plotHistogram "A histogram" [ 10, 10, 20, 30, 90 ] plotHistogram "A histogram" [ 10, 10, 20, 30, 90 ]
colorPicker3 "Test" color 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 beginMainMenuBar >>= whenTrue do
beginMenu "Hello" >>= whenTrue do beginMenu "Hello" >>= whenTrue do
menuItem "Hello" menuItem "Hello"
@ -104,11 +163,11 @@ loop w checked color slider = do
render render
glClear GL_COLOR_BUFFER_BIT glClear GL_COLOR_BUFFER_BIT
openGL2RenderDrawData =<< getDrawData openGL3RenderDrawData =<< getDrawData
glSwapWindow w glSwapWindow w
if quit then return () else loop w checked color slider if quit then return () else loop w checked color slider r pos size' selected tab1Ref tab2Ref
where where

2
README.md
View File

@ -41,7 +41,7 @@ import Control.Exception
import Control.Monad.IO.Class import Control.Monad.IO.Class
import Control.Monad.Managed import Control.Monad.Managed
import DearImGui import DearImGui
import DearImGui.OpenGL import DearImGui.OpenGL2
import DearImGui.SDL import DearImGui.SDL
import DearImGui.SDL.OpenGL import DearImGui.SDL.OpenGL
import Graphics.GL import Graphics.GL

2
cabal.project
View File

@ -1,3 +1,3 @@
packages: *.cabal packages: *.cabal
package dear-imgui package dear-imgui
flags: +sdl2 +opengl +vulkan flags: +sdl2 +glfw +opengl2 +opengl3 +vulkan

142
dear-imgui.cabal
View File

@ -2,10 +2,20 @@ cabal-version: 3.0
name: dear-imgui name: dear-imgui
version: 1.0.0 version: 1.0.0
build-type: Simple build-type: Simple
data-files:
imgui/imgui.h
flag opengl flag opengl2
description: description:
Enable OpenGL backend. Enable OpenGL 2 backend.
default:
False
manual:
False
flag opengl3
description:
Enable OpenGL 3 backend.
default: default:
True True
manual: manual:
@ -27,16 +37,33 @@ flag sdl
manual: manual:
False False
flag glfw
description:
Enable GLFW backend.
default:
False
manual:
True
common common
build-depends:
base
>= 4.12 && < 4.17
default-language:
Haskell2010
ghc-options:
-Wall
library library
exposed-modules: import: common
DearImGui
DearImGui.Context
hs-source-dirs: hs-source-dirs:
src src
default-language: exposed-modules:
Haskell2010 DearImGui
ghc-options: other-modules:
-Wall DearImGui.Context
DearImGui.Enums
DearImGui.Structs
cxx-sources: cxx-sources:
imgui/imgui.cpp imgui/imgui.cpp
imgui/imgui_demo.cpp imgui/imgui_demo.cpp
@ -50,27 +77,36 @@ library
include-dirs: include-dirs:
imgui imgui
build-depends: build-depends:
base dear-imgui-generator
, containers , containers
, managed
, inline-c , inline-c
, inline-c-cpp , inline-c-cpp
, StateVar , StateVar
if flag(opengl) if flag(opengl2)
exposed-modules: exposed-modules:
DearImGui.OpenGL DearImGui.OpenGL2
cxx-sources: cxx-sources:
imgui/backends/imgui_impl_opengl2.cpp imgui/backends/imgui_impl_opengl2.cpp
build-depends:
gl
if flag(opengl3)
exposed-modules:
DearImGui.OpenGL3
cxx-sources:
imgui/backends/imgui_impl_opengl3.cpp
if os(windows) if os(windows)
extra-libraries: buildable:
opengl32 False
else else
if os(darwin) if os(darwin)
frameworks: buildable:
OpenGL False
else else
extra-libraries: pkgconfig-depends:
GL glew
if flag(vulkan) if flag(vulkan)
exposed-modules: exposed-modules:
@ -108,7 +144,7 @@ library
pkgconfig-depends: pkgconfig-depends:
sdl2 sdl2
if flag(opengl) if flag(opengl2) || flag(opengl3)
exposed-modules: exposed-modules:
DearImGui.SDL.OpenGL DearImGui.SDL.OpenGL
@ -116,30 +152,84 @@ library
exposed-modules: exposed-modules:
DearImGui.SDL.Vulkan DearImGui.SDL.Vulkan
if flag(glfw)
exposed-modules:
DearImGui.GLFW
build-depends:
GLFW-b
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
, directory
>= 1.3 && < 1.4
, filepath
>= 1.4 && < 1.5
, megaparsec
>= 9.0 && < 9.1
, parser-combinators
>= 1.2.0 && < 1.3
, scientific
>= 0.3.6.2 && < 0.3.7
, 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.14
executable test executable test
import: common
main-is: Main.hs main-is: Main.hs
default-language: Haskell2010 default-language: Haskell2010
build-depends: base, sdl2, gl, dear-imgui build-depends: base, sdl2, gl, dear-imgui
ghc-options: -Wall ghc-options: -Wall
executable glfw
executable readme main-is: Main.hs
main-is: Readme.hs hs-source-dirs: examples/glfw
hs-source-dirs: examples
default-language: Haskell2010 default-language: Haskell2010
build-depends: base, sdl2, gl, dear-imgui, managed build-depends: base, GLFW-b, gl, dear-imgui, managed
ghc-options: -Wall ghc-options: -Wall
executable readme
import: common
main-is: Readme.hs
hs-source-dirs: examples
build-depends: sdl2, gl, dear-imgui, managed
executable vulkan executable vulkan
import: common
main-is: Main.hs main-is: Main.hs
other-modules: Attachments, Backend, Input, Util other-modules: Attachments, Backend, Input, Util
hs-source-dirs: examples/vulkan hs-source-dirs: examples/vulkan
default-language: Haskell2010 default-language: Haskell2010
build-depends: build-depends:
dear-imgui dear-imgui
, base
>= 4.13 && < 4.16
, bytestring , bytestring
>= 0.10.10.0 && < 0.12 >= 0.10.10.0 && < 0.12
, containers , containers

14
default.nix
View File

@ -20,4 +20,18 @@ in pkgs.haskell-nix.project {
name = "dear-imgui"; name = "dear-imgui";
src = ./.; 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 ];
} ];
} }

4
examples/Readme.hs
View File

@ -11,7 +11,7 @@ import Control.Exception
import Control.Monad.IO.Class import Control.Monad.IO.Class
import Control.Monad.Managed import Control.Monad.Managed
import DearImGui import DearImGui
import DearImGui.OpenGL import DearImGui.OpenGL2
import DearImGui.SDL import DearImGui.SDL
import DearImGui.SDL.OpenGL import DearImGui.SDL.OpenGL
import Graphics.GL import Graphics.GL
@ -55,7 +55,7 @@ mainLoop w = do
newFrame newFrame
-- Build the GUI -- Build the GUI
bracket_ (begin "Hello, ImGui!") end do bracket_ (begin Begin{ name = "Hello, ImGui!", isOpen = Nothing }) end do
-- Add a text widget -- Add a text widget
text "Hello, ImGui!" text "Hello, ImGui!"

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

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

159
generator/DearImGui/Generator.hs Normal file
View File

@ -0,0 +1,159 @@
{-# LANGUAGE BlockArguments #-}
{-# LANGUAGE CPP #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE TemplateHaskell #-}
module DearImGui.Generator
( declareEnumerations )
where
-- base
import Data.Coerce
( coerce )
import Data.Bits
( Bits )
import Data.Foldable
( toList )
import Data.Traversable
( for )
import Foreign.Storable
( Storable )
-- directory
import System.Directory
( canonicalizePath )
-- filepath
import System.FilePath
( takeDirectory )
-- megaparsec
import qualified Text.Megaparsec as Megaparsec
( ParseErrorBundle(bundleErrors), parse, parseErrorPretty )
-- template-haskell
import qualified Language.Haskell.TH as TH
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 )
-- dear-imgui-generator
import qualified DearImGui.Generator.Parser as Parser
( headers )
import DearImGui.Generator.Tokeniser
( tokenise )
import DearImGui.Generator.Types
( Comment(..), Enumeration(..), Headers(..) )
--------------------------------------------------------------------------------
-- Obtaining parsed header data.
headers :: Headers
headers = $( do
currentPath <- TH.loc_filename <$> TH.location
TH.lift =<< 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 ) )
Right res -> pure res
)
--------------------------------------------------------------------------------
-- Generating TH splices.
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 finiteEnumName countName ( Enumeration {..} ) = do
let
enumNameStr :: String
enumNameStr = Text.unpack enumName
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 )
]
classes :: [ TH.Q TH.Type ]
classes
| isFlagEnum
= map TH.conT [ ''Eq, ''Ord, ''Storable, ''Bits ]
| otherwise
= map TH.conT [ ''Eq, ''Ord, ''Storable ]
derivClause :: TH.Q TH.DerivClause
derivClause = TH.derivClause ( Just TH.NewtypeStrategy ) classes
newtypeDecl <-
#if MIN_VERSION_base(4,16,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 )
)
#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_base(4,16,0)
( if Text.null patDoc
then TH.patSynD
else
\ nm args dir pat ->
TH.patSynD_doc nm args dir pat
( 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

392
generator/DearImGui/Generator/Parser.hs Normal file
View File

@ -0,0 +1,392 @@
{-# 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, enums ) <- 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" )
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 <- enumTypeName
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 )
enumTypeName :: MonadParsec e [Tok] m => m TH.Name
enumTypeName = 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 <- many comment
keyword "enum"
fullEnumName <- identifier
let
enumName :: Text
enumName = Text.dropWhileEnd ( == '_' ) fullEnumName
( enumType, 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' ( ( \ st -> st { enumSize = sz, hasExplicitCount = True } ) :: EnumState -> EnumState )
pure Nothing
<|> do
pat@( _, val ) <- value
modify' ( \ st -> st { enumSize = ( enumSize :: EnumState -> Integer ) st + 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 )

197
generator/DearImGui/Generator/Tokeniser.hs Normal file
View File

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

42
generator/DearImGui/Generator/Types.hs Normal file
View File

@ -0,0 +1,42 @@
{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE DeriveLift #-}
{-# LANGUAGE DerivingStrategies #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE TemplateHaskellQuotes #-}
module DearImGui.Generator.Types where
-- template-haskell
import qualified Language.Haskell.TH.Syntax as TH
( Lift(..), Name(..) )
-- text
import Data.Text
( Text )
-- 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
= Enumeration
{ docs :: ![Comment]
, enumName :: !Text
, enumSize :: !Integer
, enumType :: !TH.Name
, hasExplicitCount :: !Bool
, patterns :: [ ( Text, Integer, Comment ) ]
}
deriving stock ( Show, TH.Lift )
data Headers
= Headers
{ enums :: [ Enumeration ] }
deriving stock ( Show, TH.Lift )

534
src/DearImGui.hs
View File

@ -1,6 +1,7 @@
{-# LANGUAGE BlockArguments #-} {-# LANGUAGE BlockArguments #-}
{-# LANGUAGE DuplicateRecordFields #-} {-# LANGUAGE DuplicateRecordFields #-}
{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE PatternSynonyms #-} {-# LANGUAGE PatternSynonyms #-}
@ -43,10 +44,35 @@ module DearImGui
, begin , begin
, Begin(..) , Begin(..)
, end , end
, setNextWindowPos
, setNextWindowSize
, setNextWindowContentSize
, setNextWindowSizeConstraints
, setNextWindowCollapsed
, setNextWindowBgAlpha
-- * Child Windows
, beginChild
, endChild
-- * Parameter stacks
, pushStyleColor
, popStyleColor
, pushStyleVar
, popStyleVar
-- * Cursor/Layout -- * Cursor/Layout
, separator , separator
, sameLine , sameLine
, newLine
, spacing
, dummy
, indent
, unindent
, beginGroup
, endGroup
, setCursorPos
, alignTextToFramePadding
-- * Widgets -- * Widgets
-- ** Text -- ** Text
@ -61,20 +87,38 @@ module DearImGui
, progressBar , progressBar
, bullet , bullet
-- ** Slider
, sliderFloat
-- ** Combo Box -- ** Combo Box
, beginCombo , beginCombo
, endCombo , endCombo
, combo
-- ** Drag Sliders
, dragFloat
, dragFloat2
, dragFloat3
, dragFloat4
-- ** Slider
, sliderFloat
, sliderFloat2
, sliderFloat3
, sliderFloat4
-- * Color Editor/Picker -- * Color Editor/Picker
, colorPicker3 , colorPicker3
, colorButton , colorButton
-- * Trees
, treeNode
, treePush
, treePop
-- ** Selectables -- ** Selectables
, selectable , selectable
-- ** List Boxes
, listBox
-- * Data Plotting -- * Data Plotting
, plotHistogram , plotHistogram
@ -87,6 +131,14 @@ module DearImGui
, endMenu , endMenu
, menuItem , menuItem
-- ** Tabs, tab bar
, beginTabBar
, endTabBar
, beginTabItem
, endTabItem
, tabItemButton
, setTabItemClosed
-- * Tooltips -- * Tooltips
, beginTooltip , beginTooltip
, endTooltip , endTooltip
@ -102,13 +154,8 @@ module DearImGui
, isItemHovered , isItemHovered
-- * Types -- * Types
, ImGuiDir , module DearImGui.Enums
, pattern ImGuiDirLeft , module DearImGui.Structs
, pattern ImGuiDirRight
, pattern ImGuiDirUp
, pattern ImGuiDirDown
, ImVec3(..)
, ImVec4(..)
-- * TODO -- * TODO
, toStateVar , toStateVar
@ -117,11 +164,18 @@ module DearImGui
-- base -- base
import Data.Bool import Data.Bool
import Data.Coerce
( coerce )
import Data.Int
( Int32 )
import Foreign import Foreign
import Foreign.C import Foreign.C
-- dear-imgui -- dear-imgui
import DearImGui.Context import DearImGui.Context
( imguiContext )
import DearImGui.Enums
import DearImGui.Structs
-- inline-c -- inline-c
import qualified Language.C.Inline as C import qualified Language.C.Inline as C
@ -129,6 +183,9 @@ import qualified Language.C.Inline as C
-- inline-c-cpp -- inline-c-cpp
import qualified Language.C.Inline.Cpp as Cpp import qualified Language.C.Inline.Cpp as Cpp
-- managed
import qualified Control.Monad.Managed as Managed
-- StateVar -- StateVar
import Data.StateVar import Data.StateVar
( HasGetter(get), HasSetter, ($=!), mapStateVar, StateVar(..) ) ( HasGetter(get), HasSetter, ($=!), mapStateVar, StateVar(..) )
@ -292,6 +349,19 @@ end = liftIO do
[C.exp| void { ImGui::End(); } |] [C.exp| void { ImGui::End(); } |]
-- | Wraps @ImGui::BeginChild()@.
beginChild :: MonadIO m => String -> m Bool
beginChild name = liftIO do
withCString name \namePtr ->
(0 /=) <$> [C.exp| bool { ImGui::BeginChild($(char* namePtr)) } |]
-- | Wraps @ImGui::EndChild()@.
endChild :: MonadIO m => m ()
endChild = liftIO do
[C.exp| void { ImGui::EndChild(); } |]
-- | Separator, generally horizontal. inside a menu bar or in horizontal layout -- | Separator, generally horizontal. inside a menu bar or in horizontal layout
-- mode, this becomes a vertical separator. -- mode, this becomes a vertical separator.
-- --
@ -340,9 +410,9 @@ smallButton label = liftIO do
-- --
-- Wraps @ImGui::ArrowButton()@. -- Wraps @ImGui::ArrowButton()@.
arrowButton :: MonadIO m => String -> ImGuiDir -> m Bool arrowButton :: MonadIO m => String -> ImGuiDir -> m Bool
arrowButton strId (ImGuiDir dir) = liftIO do arrowButton strId dir = liftIO do
withCString strId \strIdPtr -> withCString strId \strIdPtr ->
(0 /=) <$> [C.exp| bool { ArrowButton($(char* strIdPtr), $(int dir)) } |] (0 /=) <$> [C.exp| bool { ArrowButton($(char* strIdPtr), $(ImGuiDir dir)) } |]
-- | Wraps @ImGui::Checkbox()@. -- | Wraps @ImGui::Checkbox()@.
@ -388,7 +458,7 @@ beginCombo label previewValue = liftIO $
(0 /=) <$> [C.exp| bool { BeginCombo($(char* labelPtr), $(char* previewValuePtr)) } |] (0 /=) <$> [C.exp| bool { BeginCombo($(char* labelPtr), $(char* previewValuePtr)) } |]
-- | Only call 'endCombo' if 'beginCombon' returns 'True'! -- | Only call 'endCombo' if 'beginCombo' returns 'True'!
-- --
-- Wraps @ImGui::EndCombo()@. -- Wraps @ImGui::EndCombo()@.
endCombo :: MonadIO m => m () endCombo :: MonadIO m => m ()
@ -396,18 +466,102 @@ endCombo = liftIO do
[C.exp| void { EndCombo() } |] [C.exp| void { EndCombo() } |]
-- | Wraps @ImGui::ColorPicker3()@. -- | Wraps @ImGui::Combo()@.
colorPicker3 :: (MonadIO m, HasSetter ref ImVec3, HasGetter ref ImVec3) => String -> ref -> m Bool combo :: (MonadIO m, HasGetter ref Int, HasSetter ref Int) => String -> ref -> [String] -> m Bool
colorPicker3 desc ref = liftIO do combo label selectedIndex items = liftIO $ Managed.with m return
ImVec3{x, y, z} <- get ref where
withArray (realToFrac <$> [x, y, z]) \refPtr -> do m = do
changed <- withCString desc \descPtr -> i <- get selectedIndex
(0 /= ) <$> [C.exp| bool { ColorPicker3( $(char* descPtr), $(float *refPtr) ) } |]
[x', y', z'] <- peekArray 3 refPtr cStrings <- traverse (\str -> Managed.managed (withCString str)) items
ref $=! ImVec3 (realToFrac x') (realToFrac y') (realToFrac z') labelPtr <- Managed.managed $ withCString label
iPtr <- Managed.managed $ with (fromIntegral i)
liftIO $ withArrayLen cStrings \len itemsPtr -> do
let len' = fromIntegral len
[C.exp| bool { Combo($(char* labelPtr), $(int* iPtr), $(char** itemsPtr), $(int len')) }|] >>= \case
0 -> return False
_ -> do
i' <- peek iPtr
selectedIndex $=! fromIntegral i'
return True
-- | Wraps @ImGui::DragFloat()@
dragFloat :: (MonadIO m, HasSetter ref Float, HasGetter ref Float) => String -> ref -> Float -> Float -> Float -> m Bool
dragFloat desc ref speed minValue maxValue = liftIO do
currentValue <- get ref
with (realToFrac currentValue) \floatPtr -> do
changed <- withCString desc \descPtr ->
(0 /=) <$> [C.exp| bool { DragFloat( $(char* descPtr), $(float *floatPtr), $(float speed'), $(float min'), $(float max')) } |]
newValue <- peek floatPtr
ref $=! realToFrac newValue
return changed return changed
where
min', max', speed' :: CFloat
min' = realToFrac minValue
max' = realToFrac maxValue
speed' = realToFrac speed
-- | Wraps @ImGui::DragFloat2()@
dragFloat2 :: (MonadIO m, HasSetter ref (Float, Float), HasGetter ref (Float, Float)) => String -> ref -> Float -> Float -> Float -> m Bool
dragFloat2 desc ref speed minValue maxValue = liftIO do
(x, y) <- get ref
withArray [ realToFrac x, realToFrac y ] \floatPtr -> do
changed <- withCString desc \descPtr ->
(0 /=) <$> [C.exp| bool { DragFloat2( $(char* descPtr), $(float *floatPtr), $(float speed'), $(float min'), $(float max')) } |]
[x', y'] <- peekArray 2 floatPtr
ref $=! (realToFrac x', realToFrac y')
return changed
where
min', max', speed' :: CFloat
min' = realToFrac minValue
max' = realToFrac maxValue
speed' = realToFrac speed
-- | Wraps @ImGui::DragFloat3()@
dragFloat3 :: (MonadIO m, HasSetter ref (Float, Float, Float), HasGetter ref (Float, Float, Float)) => String -> ref -> Float -> Float -> Float -> m Bool
dragFloat3 desc ref speed minValue maxValue = liftIO do
(x, y, z) <- get ref
withArray [ realToFrac x, realToFrac y, realToFrac z ] \floatPtr -> do
changed <- withCString desc \descPtr ->
(0 /=) <$> [C.exp| bool { DragFloat3( $(char* descPtr), $(float *floatPtr), $(float speed'), $(float min'), $(float max')) } |]
[x', y', z'] <- peekArray 3 floatPtr
ref $=! (realToFrac x', realToFrac y', realToFrac z')
return changed
where
min', max', speed' :: CFloat
min' = realToFrac minValue
max' = realToFrac maxValue
speed' = realToFrac speed
-- | Wraps @ImGui::DragFloat4()@
dragFloat4 :: (MonadIO m, HasSetter ref (Float, Float, Float, Float), HasGetter ref (Float, Float, Float, Float)) => String -> ref -> Float -> Float -> Float -> m Bool
dragFloat4 desc ref speed minValue maxValue = liftIO do
(x, y, z, u) <- get ref
withArray [ realToFrac x, realToFrac y, realToFrac z, realToFrac u ] \floatPtr -> do
changed <- withCString desc \descPtr ->
(0 /=) <$> [C.exp| bool { DragFloat4( $(char* descPtr), $(float *floatPtr), $(float speed'), $(float min'), $(float max')) } |]
[x', y', z', u'] <- peekArray 4 floatPtr
ref $=! (realToFrac x', realToFrac y', realToFrac z', realToFrac u')
return changed
where
min', max', speed' :: CFloat
min' = realToFrac minValue
max' = realToFrac maxValue
speed' = realToFrac speed
-- | Wraps @ImGui::SliderFloat()@ -- | Wraps @ImGui::SliderFloat()@
sliderFloat :: (MonadIO m, HasSetter ref Float, HasGetter ref Float) => String -> ref -> Float -> Float -> m Bool sliderFloat :: (MonadIO m, HasSetter ref Float, HasGetter ref Float) => String -> ref -> Float -> Float -> m Bool
@ -426,6 +580,75 @@ sliderFloat desc ref minValue maxValue = liftIO do
min' = realToFrac minValue min' = realToFrac minValue
max' = realToFrac maxValue max' = realToFrac maxValue
-- | Wraps @ImGui::SliderFloat2()@
sliderFloat2 :: (MonadIO m, HasSetter ref (Float, Float), HasGetter ref (Float, Float)) => String -> ref -> Float -> Float -> m Bool
sliderFloat2 desc ref minValue maxValue = liftIO do
(x, y) <- get ref
withArray [ realToFrac x, realToFrac y ] \floatPtr -> do
changed <- withCString desc \descPtr ->
(0 /=) <$> [C.exp| bool { SliderFloat2( $(char* descPtr), $(float *floatPtr), $(float min'), $(float max')) } |]
[x', y'] <- peekArray 2 floatPtr
ref $=! (realToFrac x', realToFrac y')
return changed
where
min', max' :: CFloat
min' = realToFrac minValue
max' = realToFrac maxValue
-- | Wraps @ImGui::SliderFloat3()@
sliderFloat3 :: (MonadIO m, HasSetter ref (Float, Float, Float), HasGetter ref (Float, Float, Float)) => String -> ref -> Float -> Float -> m Bool
sliderFloat3 desc ref minValue maxValue = liftIO do
(x, y, z) <- get ref
withArray [ realToFrac x, realToFrac y, realToFrac z ] \floatPtr -> do
changed <- withCString desc \descPtr ->
(0 /=) <$> [C.exp| bool { SliderFloat3( $(char* descPtr), $(float *floatPtr), $(float min'), $(float max')) } |]
[x', y', z'] <- peekArray 3 floatPtr
ref $=! (realToFrac x', realToFrac y', realToFrac z')
return changed
where
min', max' :: CFloat
min' = realToFrac minValue
max' = realToFrac maxValue
-- | Wraps @ImGui::SliderFloat4()@
sliderFloat4 :: (MonadIO m, HasSetter ref (Float, Float, Float, Float), HasGetter ref (Float, Float, Float, Float)) => String -> ref -> Float -> Float -> m Bool
sliderFloat4 desc ref minValue maxValue = liftIO do
(x, y, z, u) <- get ref
withArray [ realToFrac x, realToFrac y, realToFrac z, realToFrac u ] \floatPtr -> do
changed <- withCString desc \descPtr ->
(0 /=) <$> [C.exp| bool { SliderFloat4( $(char* descPtr), $(float *floatPtr), $(float min'), $(float max')) } |]
[x', y', z', u'] <- peekArray 4 floatPtr
ref $=! (realToFrac x', realToFrac y', realToFrac z', realToFrac u')
return changed
where
min', max' :: CFloat
min' = realToFrac minValue
max' = realToFrac maxValue
-- | Wraps @ImGui::ColorPicker3()@.
colorPicker3 :: (MonadIO m, HasSetter ref ImVec3, HasGetter ref ImVec3) => String -> ref -> m Bool
colorPicker3 desc ref = liftIO do
ImVec3{x, y, z} <- get ref
withArray (realToFrac <$> [x, y, z]) \refPtr -> do
changed <- withCString desc \descPtr ->
(0 /= ) <$> [C.exp| bool { ColorPicker3( $(char* descPtr), $(float *refPtr) ) } |]
[x', y', z'] <- peekArray 3 refPtr
ref $=! ImVec3 (realToFrac x') (realToFrac y') (realToFrac z')
return changed
-- | Display a color square/button, hover for details, return true when pressed. -- | Display a color square/button, hover for details, return true when pressed.
-- --
-- Wraps @ImGui::ColorButton()@. -- Wraps @ImGui::ColorButton()@.
@ -441,6 +664,25 @@ colorButton desc ref = liftIO do
return changed return changed
-- | Wraps @ImGui::TreeNode()@.
treeNode :: MonadIO m => String -> m Bool
treeNode label = liftIO do
withCString label \labelPtr ->
(0 /=) <$> [C.exp| bool { TreeNode($(char* labelPtr)) } |]
-- | Wraps @ImGui::TreePush()@.
treePush :: MonadIO m => String -> m ()
treePush label = liftIO do
withCString label \labelPtr ->
[C.exp| void { TreePush($(char* labelPtr)) } |]
-- | Wraps @ImGui::TreePop()@.
treePop :: MonadIO m => m ()
treePop = liftIO do
[C.exp| void { TreePop() } |]
-- | Wraps @ImGui::Selectable()@. -- | Wraps @ImGui::Selectable()@.
selectable :: MonadIO m => String -> m Bool selectable :: MonadIO m => String -> m Bool
@ -448,6 +690,25 @@ selectable label = liftIO do
withCString label \labelPtr -> withCString label \labelPtr ->
(0 /=) <$> [C.exp| bool { Selectable($(char* labelPtr)) } |] (0 /=) <$> [C.exp| bool { Selectable($(char* labelPtr)) } |]
listBox :: (MonadIO m, HasGetter ref Int, HasSetter ref Int) => String -> ref -> [String] -> m Bool
listBox label selectedIndex items = liftIO $ Managed.with m return
where
m = do
i <- get selectedIndex
cStrings <- traverse (\str -> Managed.managed (withCString str)) items
labelPtr <- Managed.managed $ withCString label
iPtr <- Managed.managed $ with (fromIntegral i)
liftIO $ withArrayLen cStrings \len itemsPtr -> do
let len' = fromIntegral len
[C.exp| bool { ListBox($(char* labelPtr), $(int* iPtr), $(char** itemsPtr), $(int len')) }|] >>= \case
0 -> return False
_ -> do
i' <- peek iPtr
selectedIndex $=! fromIntegral i'
return True
-- | Wraps @ImGui::PlotHistogram()@. -- | Wraps @ImGui::PlotHistogram()@.
plotHistogram :: MonadIO m => String -> [CFloat] -> m () plotHistogram :: MonadIO m => String -> [CFloat] -> m ()
@ -508,7 +769,7 @@ endMenu = liftIO do
[C.exp| void { EndMenu(); } |] [C.exp| void { EndMenu(); } |]
-- Return true when activated. Shortcuts are displayed for convenience but not -- | Return true when activated. Shortcuts are displayed for convenience but not
-- processed by ImGui at the moment -- processed by ImGui at the moment
-- --
-- Wraps @ImGui::MenuItem()@ -- Wraps @ImGui::MenuItem()@
@ -517,6 +778,57 @@ menuItem label = liftIO do
withCString label \labelPtr -> withCString label \labelPtr ->
(0 /=) <$> [C.exp| bool { MenuItem($(char* labelPtr)) } |] (0 /=) <$> [C.exp| bool { MenuItem($(char* labelPtr)) } |]
-- | Create a @TabBar@ and start appending to it.
--
-- Wraps @ImGui::BeginTabBar@.
beginTabBar :: MonadIO m => String -> ImGuiTabBarFlags -> m Bool
beginTabBar tabBarID flags = liftIO do
withCString tabBarID \ptr ->
(0 /=) <$> [C.exp| bool { BeginTabBar($(char* ptr), $(ImGuiTabBarFlags flags) ) } |]
-- | Finish appending elements to a tab bar. Only call if 'beginTabBar' returns @True@.
--
-- Wraps @ImGui::EndTabBar@.
endTabBar :: MonadIO m => m ()
endTabBar = liftIO do
[C.exp| void { EndTabBar(); } |]
-- | Create a new tab. Returns @True@ if the tab is selected.
--
-- Wraps @ImGui::BeginTabItem@.
beginTabItem :: ( MonadIO m, HasGetter ref Bool, HasSetter ref Bool ) => String -> ref -> ImGuiTabBarFlags -> m Bool
beginTabItem tabName ref flags = liftIO do
currentValue <- get ref
with ( bool 0 1 currentValue :: CBool ) \ refPtr -> do
open <- withCString tabName \ ptrName ->
(0 /=) <$> [C.exp| bool { BeginTabItem($(char* ptrName), $(bool* refPtr), $(ImGuiTabBarFlags flags) ) } |]
newValue <- (0 /=) <$> peek refPtr
ref $=! newValue
pure open
-- | Finish appending elements to a tab. Only call if 'beginTabItem' returns @True@.
--
-- Wraps @ImGui::EndTabItem@.
endTabItem :: MonadIO m => m ()
endTabItem = liftIO do
[C.exp| void { EndTabItem(); } |]
-- | Create a tab that behaves like a button. Returns @True@ when clicked. Cannot be selected in the tab bar.
--
-- Wraps @ImGui.TabItemButton@.
tabItemButton :: MonadIO m => String -> ImGuiTabItemFlags -> m Bool
tabItemButton tabName flags = liftIO do
withCString tabName \ namePtr ->
(0 /=) <$> [C.exp| bool { TabItemButton($(char* namePtr), $(ImGuiTabItemFlags flags) ) } |]
-- | Notify the tab bar (or the docking system) that a tab/window is about to close.
-- Useful to reduce visual flicker on reorderable tab bars.
--
-- __For tab-bar__: call after 'beginTabBar' and before tab submission. Otherwise, call with a window name.
setTabItemClosed :: MonadIO m => String -> m ()
setTabItemClosed tabName = liftIO do
withCString tabName \ namePtr ->
[C.exp| void { SetTabItemClosed($(char* namePtr)); } |]
-- | Begin/append a tooltip window to create full-featured tooltip (with any -- | Begin/append a tooltip window to create full-featured tooltip (with any
-- kind of items). -- kind of items).
@ -584,22 +896,176 @@ isItemHovered = liftIO do
(0 /=) <$> [C.exp| bool { IsItemHovered() } |] (0 /=) <$> [C.exp| bool { IsItemHovered() } |]
-- | A cardinal direction.
newtype ImGuiDir = ImGuiDir CInt
pattern ImGuiDirLeft, ImGuiDirRight, ImGuiDirUp, ImGuiDirDown :: ImGuiDir
pattern ImGuiDirLeft = ImGuiDir 0
pattern ImGuiDirRight = ImGuiDir 1
pattern ImGuiDirUp = ImGuiDir 2
pattern ImGuiDirDown = ImGuiDir 3
withCStringOrNull :: Maybe String -> (Ptr CChar -> IO a) -> IO a withCStringOrNull :: Maybe String -> (Ptr CChar -> IO a) -> IO a
withCStringOrNull Nothing k = k nullPtr withCStringOrNull Nothing k = k nullPtr
withCStringOrNull (Just s) k = withCString s k withCStringOrNull (Just s) k = withCString s k
-- | Set next window position. Call before `begin` Use pivot=(0.5,0.5) to center on given point, etc.
--
-- Wraps @ImGui::SetNextWindowPos()@
setNextWindowPos :: (MonadIO m, HasGetter ref ImVec2) => ref -> ImGuiCond -> Maybe ref -> m ()
setNextWindowPos posRef cond pivotMaybe = liftIO do
pos <- get posRef
with pos $ \posPtr ->
case pivotMaybe of
Just pivotRef -> do
pivot <- get pivotRef
with pivot $ \pivotPtr ->
[C.exp| void { SetNextWindowPos(*$(ImVec2 *posPtr), $(ImGuiCond cond), *$(ImVec2 *pivotPtr)) } |]
Nothing ->
[C.exp| void { SetNextWindowPos(*$(ImVec2 *posPtr), $(ImGuiCond cond)) } |]
-- | Set next window size. Call before `begin`
--
-- Wraps @ImGui::SetNextWindowSize()@
setNextWindowSize :: (MonadIO m, HasGetter ref ImVec2) => ref -> ImGuiCond -> m ()
setNextWindowSize sizeRef cond = liftIO do
size' <- get sizeRef
with size' $
\sizePtr ->[C.exp| void { SetNextWindowSize(*$(ImVec2 *sizePtr), $(ImGuiCond cond)) } |]
-- | Set next window content size (~ scrollable client area, which enforce the range of scrollbars). Not including window decorations (title bar, menu bar, etc.) nor WindowPadding. call before `begin`
--
-- Wraps @ImGui::SetNextWindowContentSize()@
setNextWindowContentSize :: (MonadIO m, HasGetter ref ImVec2) => ref -> m ()
setNextWindowContentSize sizeRef = liftIO do
size' <- get sizeRef
with size' $
\sizePtr ->[C.exp| void { SetNextWindowContentSize(*$(ImVec2 *sizePtr)) } |]
-- | Set next window size limits. use -1,-1 on either X/Y axis to preserve the current size. Sizes will be rounded down.
--
-- Wraps @ImGui::SetNextWindowContentSize()@
setNextWindowSizeConstraints :: (MonadIO m, HasGetter ref ImVec2) => ref -> ref -> m ()
setNextWindowSizeConstraints sizeMinRef sizeMaxRef = liftIO do
sizeMin <- get sizeMinRef
sizeMax <- get sizeMaxRef
with sizeMin $
\sizeMinPtr ->
with sizeMax $ \sizeMaxPtr ->
[C.exp| void { SetNextWindowSizeConstraints(*$(ImVec2 *sizeMinPtr), *$(ImVec2 *sizeMaxPtr)) } |]
-- | Set next window collapsed state. call before `begin`
--
-- Wraps @ImGui::SetNextWindowCollapsed()@
setNextWindowCollapsed :: (MonadIO m) => Bool -> ImGuiCond -> m ()
setNextWindowCollapsed b cond = liftIO do
let b' = bool 0 1 b
[C.exp| void { SetNextWindowCollapsed($(bool b'), $(ImGuiCond cond)) } |]
-- | Set next window background color alpha. helper to easily override the Alpha component of `ImGuiCol_WindowBg`, `ChildBg`, `PopupBg`. you may also use `ImGuiWindowFlags_NoBackground`.
--
-- Wraps @ImGui::SetNextWindowBgAlpha()@
setNextWindowBgAlpha :: (MonadIO m) => Float -> m ()
setNextWindowBgAlpha f = liftIO do
let f' = coerce f
[C.exp| void { SetNextWindowBgAlpha($(float f')) } |]
-- | undo a sameLine or force a new line when in an horizontal-layout context.
--
-- Wraps @ImGui::NewLine()@
newLine :: (MonadIO m) => m ()
newLine = liftIO do
[C.exp| void { NewLine() } |]
-- | Add vertical spacing.
--
-- Wraps @ImGui::Spacing()@
spacing :: (MonadIO m) => m ()
spacing = liftIO do
[C.exp| void { Spacing() } |]
-- | Add a dummy item of given size. unlike `invisibleButton`, `dummy` won't take the mouse click or be navigable into.
--
-- Wraps @ImGui::Dummy()@
dummy :: (MonadIO m, HasGetter ref ImVec2) => ref -> m ()
dummy sizeRef = liftIO do
size' <- get sizeRef
with size' $ \ sizePtr -> [C.exp| void { Dummy(*$(ImVec2 *sizePtr)) } |]
-- | Move content position toward the right, by indent_w, or style.IndentSpacing if indent_w <= 0
--
-- Wraps @ImGui::Indent()@
indent :: (MonadIO m) => Float -> m ()
indent indent_w = liftIO do
let indent_w' = coerce indent_w
[C.exp| void { Indent($(float indent_w')) } |]
-- | Move content position back to the left, by indent_w, or style.IndentSpacing if indent_w <= 0
--
-- Wraps @ImGui::Unindent()@
unindent :: (MonadIO m) => Float -> m ()
unindent f = liftIO do
let f' = coerce f
[C.exp| void { Unindent($(float f')) } |]
-- | lock horizontal starting position
--
-- Wraps @ImGui::BeginGroup()@
beginGroup :: (MonadIO m) => m ()
beginGroup = liftIO do
[C.exp| void { BeginGroup() } |]
-- | unlock horizontal starting position + capture the whole group bounding box into one "item" (so you can use `isItemHovered` or layout primitives such as `sameLine` on whole group, etc.)
--
-- Wraps @ImGui::EndGroup()@
endGroup :: (MonadIO m) => m ()
endGroup = liftIO do
[C.exp| void { EndGroup() } |]
-- | Vertically align upcoming text baseline to FramePadding.y so that it will align properly to regularly framed items (call if you have text on a line before a framed item)
--
-- Wraps @ImGui::AlignTextToFramePadding()@
alignTextToFramePadding :: (MonadIO m) => m ()
alignTextToFramePadding = liftIO do
[C.exp| void { AlignTextToFramePadding() } |]
-- | Set cursor position in window-local coordinates
--
-- Wraps @ImGui::SetCursorPos()@
setCursorPos :: (MonadIO m, HasGetter ref ImVec2) => ref -> m ()
setCursorPos posRef = liftIO do
pos <- get posRef
with pos $ \ posPtr -> [C.exp| void { SetCursorPos(*$(ImVec2 *posPtr)) } |]
-- | Modify a style color by pushing to the shared stack. always use this if you modify the style after `newFrame`
--
-- Wraps @ImGui::PushStyleColor()@
pushStyleColor :: (MonadIO m, HasGetter ref ImVec4) => ImGuiCol -> ref -> m ()
pushStyleColor col colorRef = liftIO do
color <- get colorRef
with color $ \ colorPtr -> [C.exp| void { PushStyleColor($(ImGuiCol col), *$(ImVec4 *colorPtr)) } |]
-- | Remove style color modifications from the shared stack
--
-- Wraps @ImGui::PopStyleColor()@
popStyleColor :: (MonadIO m) => Int32 -> m ()
popStyleColor n = liftIO do
let
m :: CInt
m = coerce n
[C.exp| void { PopStyleColor($(int m)) } |]
-- | Modify a style variable by pushing to the shared stack. always use this if you modify the style after `newFrame`
--
-- Wraps @ImGui::PushStyleVar()@
pushStyleVar :: (MonadIO m, HasGetter ref ImVec2) => ImGuiStyleVar -> ref -> m ()
pushStyleVar style valRef = liftIO do
val <- get valRef
with val $ \ valPtr -> [C.exp| void { PushStyleVar($(ImGuiStyleVar style), *$(ImVec2 *valPtr)) } |]
-- | Remove style variable modifications from the shared stack
--
-- Wraps @ImGui::PopStyleVar()@
popStyleVar :: (MonadIO m) => Int32 -> m ()
popStyleVar n = liftIO do
let
m :: CInt
m = coerce n
[C.exp| void { PopStyleVar($(int m)) } |]
withMaybeStateVar :: Storable x => Maybe (StateVar x) -> (Ptr x -> IO r) -> IO r withMaybeStateVar :: Storable x => Maybe (StateVar x) -> (Ptr x -> IO r) -> IO r
withMaybeStateVar Nothing k = k nullPtr withMaybeStateVar Nothing k = k nullPtr
withMaybeStateVar (Just r) k = withStateVar r k withMaybeStateVar (Just r) k = withStateVar r k

65
src/DearImGui/Context.hs
View File

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

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

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

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

@ -0,0 +1,51 @@
{-# 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
)
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 )
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(); } |]
-- | Wraps @ImGui_ImplGlfw_Shutdown@.
glfwShutdown :: MonadIO m => m ()
glfwShutdown = liftIO do
[C.exp| void { ImGui_ImplGlfw_Shutdown(); } |]

61
src/DearImGui/GLFW/OpenGL.hs Normal file
View File

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

60
src/DearImGui/GLFW/Vulkan.hs Normal file
View File

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

4
src/DearImGui/OpenGL.hs → src/DearImGui/OpenGL2.hs
View File

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

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

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

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

@ -0,0 +1,68 @@
{-# LANGUAGE DuplicateRecordFields #-}
{-# LANGUAGE NamedFieldPuns #-}
module DearImGui.Structs where
-- base
import Foreign
( Storable(..), castPtr, plusPtr )
--------------------------------------------------------------------------------
data ImVec2 = ImVec2 { x, y :: {-# unpack #-} !Float }
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 }
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 }