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~
.HTF/
.ghc.environment.*
/imgui.ini

83
Main.hs
View File

@ -6,9 +6,10 @@
module Main (main) where
import Control.Monad
import Data.IORef
import DearImGui
import DearImGui.OpenGL
import DearImGui.OpenGL3
import DearImGui.SDL
import DearImGui.SDL.OpenGL
import Control.Exception
@ -23,22 +24,40 @@ main = do
bracket (glCreateContext w) glDeleteContext \glContext ->
bracket createContext destroyContext \_imguiContext ->
bracket_ (sdl2InitForOpenGL w glContext) sdl2Shutdown $
bracket_ openGL2Init openGL2Shutdown do
bracket_ openGL3Init openGL3Shutdown do
checkVersion
styleColorsLight
checked <- newIORef False
color <- newIORef $ ImVec3 1 0 0
slider <- newIORef 0.42
loop w checked color slider
slider <- newIORef (0.42, 0, 0.314)
r <- newIORef 4
pos <- newIORef $ ImVec2 64 64
size' <- newIORef $ ImVec2 512 512
selected <- newIORef 4
tab1 <- newIORef True
tab2 <- newIORef True
loop w checked color slider r pos size' selected tab1 tab2
openGL2Shutdown
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
openGL2NewFrame
openGL3NewFrame
sdl2NewFrame w
newFrame
@ -47,9 +66,34 @@ loop w checked color slider = do
-- showAboutWindow
-- showUserGuide
setNextWindowPos pos ImGuiCond_Once Nothing
setNextWindowSize size' ImGuiCond_Once
-- Works, but will make the window contents illegible without doing something more involved.
-- setNextWindowContentSize size'
-- setNextWindowSizeConstraints size' size'
setNextWindowCollapsed False ImGuiCond_Once
setNextWindowBgAlpha 0.42
begin Begin{ name = "My Window", isOpen = Nothing }
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 ()
@ -67,7 +111,7 @@ loop w checked color slider = do
True -> putStrLn "Oh hi Mark"
False -> return ()
sameLine >> arrowButton "Arrow" ImGuiDirUp
sameLine >> arrowButton "Arrow" ImGuiDir_Up
sameLine >> checkbox Checkbox{ label = "Check!", checked = toStateVar checked } >>= \case
True -> readIORef checked >>= print
@ -75,19 +119,34 @@ loop w checked color slider = do
separator
sliderFloat "Slider" slider 0.0 1.0
dragFloat3 "Slider" slider 0.1 0.0 1.0
progressBar 0.314 (Just "Pi")
beginChild "Child"
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"
@ -104,11 +163,11 @@ loop w checked color slider = do
render
glClear GL_COLOR_BUFFER_BIT
openGL2RenderDrawData =<< getDrawData
openGL3RenderDrawData =<< getDrawData
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

2
README.md
View File

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

2
cabal.project
View File

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

140
dear-imgui.cabal
View File

@ -2,10 +2,20 @@ cabal-version: 3.0
name: dear-imgui
version: 1.0.0
build-type: Simple
data-files:
imgui/imgui.h
flag opengl
flag opengl2
description:
Enable OpenGL backend.
Enable OpenGL 2 backend.
default:
False
manual:
False
flag opengl3
description:
Enable OpenGL 3 backend.
default:
True
manual:
@ -27,16 +37,33 @@ flag sdl
manual:
False
library
exposed-modules:
DearImGui
DearImGui.Context
hs-source-dirs:
src
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
import: common
hs-source-dirs:
src
exposed-modules:
DearImGui
other-modules:
DearImGui.Context
DearImGui.Enums
DearImGui.Structs
cxx-sources:
imgui/imgui.cpp
imgui/imgui_demo.cpp
@ -50,27 +77,36 @@ library
include-dirs:
imgui
build-depends:
base
dear-imgui-generator
, containers
, managed
, inline-c
, inline-c-cpp
, StateVar
if flag(opengl)
if flag(opengl2)
exposed-modules:
DearImGui.OpenGL
DearImGui.OpenGL2
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
if os(windows)
extra-libraries:
opengl32
buildable:
False
else
if os(darwin)
frameworks:
OpenGL
buildable:
False
else
extra-libraries:
GL
pkgconfig-depends:
glew
if flag(vulkan)
exposed-modules:
@ -108,7 +144,7 @@ library
pkgconfig-depends:
sdl2
if flag(opengl)
if flag(opengl2) || flag(opengl3)
exposed-modules:
DearImGui.SDL.OpenGL
@ -116,30 +152,84 @@ library
exposed-modules:
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
import: common
main-is: Main.hs
default-language: Haskell2010
build-depends: base, sdl2, gl, dear-imgui
ghc-options: -Wall
executable readme
main-is: Readme.hs
hs-source-dirs: examples
executable glfw
main-is: Main.hs
hs-source-dirs: examples/glfw
default-language: Haskell2010
build-depends: base, sdl2, gl, dear-imgui, managed
build-depends: base, GLFW-b, gl, dear-imgui, managed
ghc-options: -Wall
executable readme
import: common
main-is: Readme.hs
hs-source-dirs: examples
build-depends: sdl2, gl, dear-imgui, managed
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

14
default.nix
View File

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

4
examples/Readme.hs
View File

@ -11,7 +11,7 @@ import Control.Exception
import Control.Monad.IO.Class
import Control.Monad.Managed
import DearImGui
import DearImGui.OpenGL
import DearImGui.OpenGL2
import DearImGui.SDL
import DearImGui.SDL.OpenGL
import Graphics.GL
@ -55,7 +55,7 @@ mainLoop w = do
newFrame
-- Build the GUI
bracket_ (begin "Hello, ImGui!") end do
bracket_ (begin Begin{ name = "Hello, ImGui!", isOpen = Nothing }) end do
-- Add a text widget
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 DuplicateRecordFields #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE PatternSynonyms #-}
@ -43,10 +44,35 @@ module DearImGui
, begin
, Begin(..)
, end
, setNextWindowPos
, setNextWindowSize
, setNextWindowContentSize
, setNextWindowSizeConstraints
, setNextWindowCollapsed
, setNextWindowBgAlpha
-- * Child Windows
, beginChild
, endChild
-- * Parameter stacks
, pushStyleColor
, popStyleColor
, pushStyleVar
, popStyleVar
-- * Cursor/Layout
, separator
, sameLine
, newLine
, spacing
, dummy
, indent
, unindent
, beginGroup
, endGroup
, setCursorPos
, alignTextToFramePadding
-- * Widgets
-- ** Text
@ -61,20 +87,38 @@ module DearImGui
, progressBar
, bullet
-- ** Slider
, sliderFloat
-- ** Combo Box
, beginCombo
, endCombo
, combo
-- ** Drag Sliders
, dragFloat
, dragFloat2
, dragFloat3
, dragFloat4
-- ** Slider
, sliderFloat
, sliderFloat2
, sliderFloat3
, sliderFloat4
-- * Color Editor/Picker
, colorPicker3
, colorButton
-- * Trees
, treeNode
, treePush
, treePop
-- ** Selectables
, selectable
-- ** List Boxes
, listBox
-- * Data Plotting
, plotHistogram
@ -87,6 +131,14 @@ module DearImGui
, endMenu
, menuItem
-- ** Tabs, tab bar
, beginTabBar
, endTabBar
, beginTabItem
, endTabItem
, tabItemButton
, setTabItemClosed
-- * Tooltips
, beginTooltip
, endTooltip
@ -102,13 +154,8 @@ module DearImGui
, isItemHovered
-- * Types
, ImGuiDir
, pattern ImGuiDirLeft
, pattern ImGuiDirRight
, pattern ImGuiDirUp
, pattern ImGuiDirDown
, ImVec3(..)
, ImVec4(..)
, module DearImGui.Enums
, module DearImGui.Structs
-- * TODO
, toStateVar
@ -117,11 +164,18 @@ module DearImGui
-- base
import Data.Bool
import Data.Coerce
( coerce )
import Data.Int
( Int32 )
import Foreign
import Foreign.C
-- dear-imgui
import DearImGui.Context
( imguiContext )
import DearImGui.Enums
import DearImGui.Structs
-- inline-c
import qualified Language.C.Inline as C
@ -129,6 +183,9 @@ import qualified Language.C.Inline as C
-- inline-c-cpp
import qualified Language.C.Inline.Cpp as Cpp
-- managed
import qualified Control.Monad.Managed as Managed
-- StateVar
import Data.StateVar
( HasGetter(get), HasSetter, ($=!), mapStateVar, StateVar(..) )
@ -292,6 +349,19 @@ end = liftIO do
[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
-- mode, this becomes a vertical separator.
--
@ -340,9 +410,9 @@ smallButton label = liftIO do
--
-- Wraps @ImGui::ArrowButton()@.
arrowButton :: MonadIO m => String -> ImGuiDir -> m Bool
arrowButton strId (ImGuiDir dir) = liftIO do
arrowButton strId dir = liftIO do
withCString strId \strIdPtr ->
(0 /=) <$> [C.exp| bool { ArrowButton($(char* strIdPtr), $(int dir)) } |]
(0 /=) <$> [C.exp| bool { ArrowButton($(char* strIdPtr), $(ImGuiDir dir)) } |]
-- | Wraps @ImGui::Checkbox()@.
@ -388,7 +458,7 @@ beginCombo label previewValue = liftIO $
(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()@.
endCombo :: MonadIO m => m ()
@ -396,18 +466,102 @@ endCombo = liftIO do
[C.exp| void { EndCombo() } |]
-- | 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) ) } |]
-- | Wraps @ImGui::Combo()@.
combo :: (MonadIO m, HasGetter ref Int, HasSetter ref Int) => String -> ref -> [String] -> m Bool
combo label selectedIndex items = liftIO $ Managed.with m return
where
m = do
i <- get selectedIndex
[x', y', z'] <- peekArray 3 refPtr
ref $=! ImVec3 (realToFrac x') (realToFrac y') (realToFrac z')
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 { 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
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()@
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
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.
--
-- Wraps @ImGui::ColorButton()@.
@ -441,6 +664,25 @@ colorButton desc ref = liftIO do
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()@.
selectable :: MonadIO m => String -> m Bool
@ -448,6 +690,25 @@ selectable label = liftIO do
withCString label \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()@.
plotHistogram :: MonadIO m => String -> [CFloat] -> m ()
@ -508,7 +769,7 @@ endMenu = liftIO do
[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
--
-- Wraps @ImGui::MenuItem()@
@ -517,6 +778,57 @@ menuItem label = liftIO do
withCString label \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
-- kind of items).
@ -584,22 +896,176 @@ isItemHovered = liftIO do
(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 Nothing k = k nullPtr
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 Nothing k = k nullPtr
withMaybeStateVar (Just r) k = withStateVar r k

65
src/DearImGui/Context.hs
View File

@ -1,62 +1,39 @@
{-# language DerivingStrategies #-}
{-# language DuplicateRecordFields #-}
{-# language GeneralizedNewtypeDeriving #-}
{-# language NamedFieldPuns #-}
{-# language OverloadedStrings #-}
{-# language PatternSynonyms #-}
{-# language TemplateHaskell #-}
module DearImGui.Context where
import Language.C.Types
import Language.C.Inline.Context
-- containers
import qualified Data.Map.Strict as Map
import Foreign
-- inline-c
import Language.C.Inline.Context
( Context(..) )
import Language.C.Types
( pattern TypeName )
data ImVec3 = ImVec3 { x, y, z :: {-# unpack #-} !Float }
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 }
-- dear-imgui
import DearImGui.Enums
import DearImGui.Structs
--------------------------------------------------------------------------------
imguiContext :: Context
imguiContext = mempty
{ 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 |] )
]
}

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
OpenGL backend for Dear ImGui.
OpenGL 2 backend for Dear ImGui.
-}
module DearImGui.OpenGL
module DearImGui.OpenGL2
( openGL2Init
, openGL2Shutdown
, openGL2NewFrame

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

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

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 }