diff --git a/.gitignore b/.gitignore index 4c9e245..db60a58 100644 --- a/.gitignore +++ b/.gitignore @@ -21,3 +21,4 @@ cabal.project.local cabal.project.local~ .HTF/ .ghc.environment.* +/imgui.ini diff --git a/Main.hs b/Main.hs index 5ada7e9..91f6e1a 100644 --- a/Main.hs +++ b/Main.hs @@ -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 diff --git a/README.md b/README.md index c39f231..7ad3ea5 100644 --- a/README.md +++ b/README.md @@ -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 diff --git a/cabal.project b/cabal.project index b19ede2..a5f90d8 100644 --- a/cabal.project +++ b/cabal.project @@ -1,3 +1,3 @@ packages: *.cabal package dear-imgui - flags: +sdl2 +opengl +vulkan + flags: +sdl2 +glfw +opengl2 +opengl3 +vulkan diff --git a/dear-imgui.cabal b/dear-imgui.cabal index 1de71bd..ba67363 100644 --- a/dear-imgui.cabal +++ b/dear-imgui.cabal @@ -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 +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 - exposed-modules: - DearImGui - DearImGui.Context + import: common hs-source-dirs: src - default-language: - Haskell2010 - ghc-options: - -Wall + 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 diff --git a/default.nix b/default.nix index 9699393..91194ad 100644 --- a/default.nix +++ b/default.nix @@ -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 ]; + } ]; } diff --git a/examples/Readme.hs b/examples/Readme.hs index 85b17a6..f9426d7 100644 --- a/examples/Readme.hs +++ b/examples/Readme.hs @@ -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!" diff --git a/examples/glfw/Main.hs b/examples/glfw/Main.hs new file mode 100644 index 0000000..036bded --- /dev/null +++ b/examples/glfw/Main.hs @@ -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 diff --git a/generator/DearImGui/Generator.hs b/generator/DearImGui/Generator.hs new file mode 100644 index 0000000..431dc35 --- /dev/null +++ b/generator/DearImGui/Generator.hs @@ -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 diff --git a/generator/DearImGui/Generator/Parser.hs b/generator/DearImGui/Generator/Parser.hs new file mode 100644 index 0000000..13b5994 --- /dev/null +++ b/generator/DearImGui/Generator/Parser.hs @@ -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 ) diff --git a/generator/DearImGui/Generator/Tokeniser.hs b/generator/DearImGui/Generator/Tokeniser.hs new file mode 100644 index 0000000..12c70f7 --- /dev/null +++ b/generator/DearImGui/Generator/Tokeniser.hs @@ -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 ) diff --git a/generator/DearImGui/Generator/Types.hs b/generator/DearImGui/Generator/Types.hs new file mode 100644 index 0000000..dffd94c --- /dev/null +++ b/generator/DearImGui/Generator/Types.hs @@ -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 ) diff --git a/src/DearImGui.hs b/src/DearImGui.hs index f0d856f..70ef2de 100644 --- a/src/DearImGui.hs +++ b/src/DearImGui.hs @@ -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 diff --git a/src/DearImGui/Context.hs b/src/DearImGui/Context.hs index 3220ae3..9e807f3 100644 --- a/src/DearImGui/Context.hs +++ b/src/DearImGui/Context.hs @@ -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 |] ) ] } diff --git a/src/DearImGui/Enums.hs b/src/DearImGui/Enums.hs new file mode 100644 index 0000000..0ee776b --- /dev/null +++ b/src/DearImGui/Enums.hs @@ -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 diff --git a/src/DearImGui/GLFW.hs b/src/DearImGui/GLFW.hs new file mode 100644 index 0000000..ee43b3b --- /dev/null +++ b/src/DearImGui/GLFW.hs @@ -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(); } |] \ No newline at end of file diff --git a/src/DearImGui/GLFW/OpenGL.hs b/src/DearImGui/GLFW/OpenGL.hs new file mode 100644 index 0000000..8212ddc --- /dev/null +++ b/src/DearImGui/GLFW/OpenGL.hs @@ -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 diff --git a/src/DearImGui/GLFW/Vulkan.hs b/src/DearImGui/GLFW/Vulkan.hs new file mode 100644 index 0000000..0438f70 --- /dev/null +++ b/src/DearImGui/GLFW/Vulkan.hs @@ -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 diff --git a/src/DearImGui/OpenGL.hs b/src/DearImGui/OpenGL2.hs similarity index 96% rename from src/DearImGui/OpenGL.hs rename to src/DearImGui/OpenGL2.hs index bfbaf30..a0417ee 100644 --- a/src/DearImGui/OpenGL.hs +++ b/src/DearImGui/OpenGL2.hs @@ -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 diff --git a/src/DearImGui/OpenGL3.hs b/src/DearImGui/OpenGL3.hs new file mode 100644 index 0000000..b9039ba --- /dev/null +++ b/src/DearImGui/OpenGL3.hs @@ -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 )) } |] diff --git a/src/DearImGui/Structs.hs b/src/DearImGui/Structs.hs new file mode 100644 index 0000000..d5f5c3b --- /dev/null +++ b/src/DearImGui/Structs.hs @@ -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 }