From 63bb63a32e3d455b16a8b02006d54a59a6c5a61c Mon Sep 17 00:00:00 2001 From: Ollie Charles Date: Thu, 28 Jan 2021 22:38:25 +0000 Subject: [PATCH 01/13] Wrap ImGui::BeginChild and EndChild (#21) --- Main.hs | 4 ++++ src/DearImGui.hs | 17 +++++++++++++++++ 2 files changed, 21 insertions(+) diff --git a/Main.hs b/Main.hs index 5485202..f8651af 100644 --- a/Main.hs +++ b/Main.hs @@ -78,11 +78,15 @@ loop w checked color slider = do progressBar 0.314 (Just "Pi") + beginChild "Child" + beginCombo "Label" "Preview" >>= whenTrue do selectable "Testing 1" selectable "Testing 2" endCombo + endChild + plotHistogram "A histogram" [ 10, 10, 20, 30, 90 ] colorPicker3 "Test" color diff --git a/src/DearImGui.hs b/src/DearImGui.hs index a796b22..b3fe43a 100644 --- a/src/DearImGui.hs +++ b/src/DearImGui.hs @@ -43,6 +43,10 @@ module DearImGui , begin , end + -- * Child Windows + , beginChild + , endChild + -- * Cursor/Layout , separator , sameLine @@ -276,6 +280,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. -- From f24a4b78ab684571d1c86fba24875d6cedcb04c5 Mon Sep 17 00:00:00 2001 From: Ollie Charles Date: Thu, 28 Jan 2021 23:02:04 +0000 Subject: [PATCH 02/13] Implement ImGui::SliderFloat2,3,4 (#22) --- Main.hs | 6 ++-- src/DearImGui.hs | 91 +++++++++++++++++++++++++++++++++++++++--------- 2 files changed, 78 insertions(+), 19 deletions(-) diff --git a/Main.hs b/Main.hs index f8651af..6c59c7c 100644 --- a/Main.hs +++ b/Main.hs @@ -28,12 +28,12 @@ main = do checked <- newIORef False color <- newIORef $ ImVec3 1 0 0 - slider <- newIORef 0.42 + slider <- newIORef (0.42, 0, 0.314) loop w checked color slider openGL2Shutdown -loop :: Window -> IORef Bool -> IORef ImVec3 -> IORef Float -> IO () +loop :: Window -> IORef Bool -> IORef ImVec3 -> IORef (Float, Float, Float) -> IO () loop w checked color slider = do quit <- pollEvents @@ -74,7 +74,7 @@ loop w checked color slider = do separator - sliderFloat "Slider" slider 0.0 1.0 + sliderFloat3 "Slider" slider 0.0 1.0 progressBar 0.314 (Just "Pi") diff --git a/src/DearImGui.hs b/src/DearImGui.hs index b3fe43a..b434f70 100644 --- a/src/DearImGui.hs +++ b/src/DearImGui.hs @@ -63,13 +63,16 @@ module DearImGui , progressBar , bullet - -- ** Slider - , sliderFloat - -- ** Combo Box , beginCombo , endCombo + -- ** Slider + , sliderFloat + , sliderFloat2 + , sliderFloat3 + , sliderFloat4 + -- * Color Editor/Picker , colorPicker3 , colorButton @@ -397,19 +400,6 @@ 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) ) } |] - - [x', y', z'] <- peekArray 3 refPtr - ref $=! ImVec3 (realToFrac x') (realToFrac y') (realToFrac z') - - return changed - -- | Wraps @ImGui::SliderFloat()@ sliderFloat :: (MonadIO m, HasSetter ref Float, HasGetter ref Float) => String -> ref -> Float -> Float -> m Bool sliderFloat desc ref minValue maxValue = liftIO do @@ -427,6 +417,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()@. From 24903ce76ff5bf756bc0d5cc2f5b6d23bc2035aa Mon Sep 17 00:00:00 2001 From: Ollie Charles Date: Thu, 28 Jan 2021 23:10:58 +0000 Subject: [PATCH 03/13] Implement ImGui::DragFloat{,2,3,4} (#23) --- Main.hs | 2 +- src/DearImGui.hs | 82 ++++++++++++++++++++++++++++++++++++++++++++++++ 2 files changed, 83 insertions(+), 1 deletion(-) diff --git a/Main.hs b/Main.hs index 6c59c7c..35b6bd1 100644 --- a/Main.hs +++ b/Main.hs @@ -74,7 +74,7 @@ loop w checked color slider = do separator - sliderFloat3 "Slider" slider 0.0 1.0 + dragFloat3 "Slider" slider 0.1 0.0 1.0 progressBar 0.314 (Just "Pi") diff --git a/src/DearImGui.hs b/src/DearImGui.hs index b434f70..4f6bdc5 100644 --- a/src/DearImGui.hs +++ b/src/DearImGui.hs @@ -67,6 +67,12 @@ module DearImGui , beginCombo , endCombo + -- ** Drag Sliders + , dragFloat + , dragFloat2 + , dragFloat3 + , dragFloat4 + -- ** Slider , sliderFloat , sliderFloat2 @@ -400,6 +406,82 @@ endCombo = liftIO do [C.exp| void { EndCombo() } |] +-- | 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 sliderFloat desc ref minValue maxValue = liftIO do From bb82e8755329838feda79d75ff1b852129538ff2 Mon Sep 17 00:00:00 2001 From: Ollie Charles Date: Thu, 28 Jan 2021 23:28:45 +0000 Subject: [PATCH 04/13] Wrap ImGui::TreeNode, TreePush, TreePop (#24) --- Main.hs | 9 +++++++++ src/DearImGui.hs | 24 ++++++++++++++++++++++++ 2 files changed, 33 insertions(+) diff --git a/Main.hs b/Main.hs index 35b6bd1..f28d0e0 100644 --- a/Main.hs +++ b/Main.hs @@ -91,6 +91,15 @@ loop w checked color slider = do 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" diff --git a/src/DearImGui.hs b/src/DearImGui.hs index 4f6bdc5..4c458fa 100644 --- a/src/DearImGui.hs +++ b/src/DearImGui.hs @@ -83,6 +83,11 @@ module DearImGui , colorPicker3 , colorButton + -- * Trees + , treeNode + , treePush + , treePop + -- ** Selectables , selectable @@ -583,6 +588,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 From af49a7b3fbd1833ed36459ec36fed3d58fb3d30f Mon Sep 17 00:00:00 2001 From: Ollie Charles Date: Thu, 28 Jan 2021 23:38:59 +0000 Subject: [PATCH 05/13] Wrap ImGui::ListBox() (#25) --- Main.hs | 12 ++++++++---- dear-imgui.cabal | 1 + src/DearImGui.hs | 27 +++++++++++++++++++++++++++ 3 files changed, 36 insertions(+), 4 deletions(-) diff --git a/Main.hs b/Main.hs index f28d0e0..2f47e00 100644 --- a/Main.hs +++ b/Main.hs @@ -29,12 +29,14 @@ main = do checked <- newIORef False color <- newIORef $ ImVec3 1 0 0 slider <- newIORef (0.42, 0, 0.314) - loop w checked color slider + r <- newIORef 4 + loop w checked color slider r openGL2Shutdown -loop :: Window -> IORef Bool -> IORef ImVec3 -> IORef (Float, Float, Float) -> IO () -loop w checked color slider = do + +loop :: Window -> IORef Bool -> IORef ImVec3 -> IORef (Float, Float, Float) -> IORef Int -> IO () +loop w checked color slider r = do quit <- pollEvents openGL2NewFrame @@ -49,6 +51,8 @@ loop w checked color slider = do begin "My Window" text "Hello!" + listBox "Items" r [ "A", "B", "C" ] + button "Click me" >>= \case True -> openPopup "Button Popup" False -> return () @@ -120,7 +124,7 @@ loop w checked color slider = do glSwapWindow w - if quit then return () else loop w checked color slider + if quit then return () else loop w checked color slider r where diff --git a/dear-imgui.cabal b/dear-imgui.cabal index 1de71bd..7d77c14 100644 --- a/dear-imgui.cabal +++ b/dear-imgui.cabal @@ -52,6 +52,7 @@ library build-depends: base , containers + , managed , inline-c , inline-c-cpp , StateVar diff --git a/src/DearImGui.hs b/src/DearImGui.hs index 4c458fa..4f3f892 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 #-} @@ -91,6 +92,9 @@ module DearImGui -- ** Selectables , selectable + -- ** List Boxes + , listBox + -- * Data Plotting , plotHistogram @@ -142,6 +146,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, ($=!) ) @@ -615,6 +622,26 @@ selectable label = liftIO do (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 () plotHistogram label values = liftIO $ From 81582ba6ebc3d2df0fd976200cd2ff40985d56c2 Mon Sep 17 00:00:00 2001 From: Ollie Charles Date: Fri, 5 Feb 2021 20:22:26 +0000 Subject: [PATCH 06/13] Ignore imgui.ini (#29) This file gets generated by routine testing but we'll never want to commit it. --- .gitignore | 1 + 1 file changed, 1 insertion(+) 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 From 895f5c192680640b24bd1fa79b3cdc0f0c5ccf78 Mon Sep 17 00:00:00 2001 From: sheaf Date: Fri, 5 Feb 2021 21:57:17 +0100 Subject: [PATCH 07/13] Parse enums from headers & generate code (#19) --- Main.hs | 2 +- dear-imgui.cabal | 70 +++- generator/DearImGui/Generator.hs | 159 +++++++++ generator/DearImGui/Generator/Parser.hs | 392 +++++++++++++++++++++ generator/DearImGui/Generator/Tokeniser.hs | 197 +++++++++++ generator/DearImGui/Generator/Types.hs | 42 +++ src/DearImGui.hs | 23 +- src/DearImGui/Context.hs | 56 +-- src/DearImGui/Enums.hs | 34 ++ src/DearImGui/Structs.hs | 51 +++ 10 files changed, 947 insertions(+), 79 deletions(-) create mode 100644 generator/DearImGui/Generator.hs create mode 100644 generator/DearImGui/Generator/Parser.hs create mode 100644 generator/DearImGui/Generator/Tokeniser.hs create mode 100644 generator/DearImGui/Generator/Types.hs create mode 100644 src/DearImGui/Enums.hs create mode 100644 src/DearImGui/Structs.hs diff --git a/Main.hs b/Main.hs index 2f47e00..f5d8b0b 100644 --- a/Main.hs +++ b/Main.hs @@ -70,7 +70,7 @@ loop w checked color slider r = do True -> putStrLn "Oh hi Mark" False -> return () - sameLine >> arrowButton "Arrow" ImGuiDirUp + sameLine >> arrowButton "Arrow" ImGuiDir_Up sameLine >> checkbox "Check!" checked >>= \case True -> readIORef checked >>= print diff --git a/dear-imgui.cabal b/dear-imgui.cabal index 7d77c14..358e896 100644 --- a/dear-imgui.cabal +++ b/dear-imgui.cabal @@ -2,6 +2,8 @@ cabal-version: 3.0 name: dear-imgui version: 1.0.0 build-type: Simple +data-files: + imgui/imgui.h flag opengl description: @@ -27,16 +29,25 @@ flag sdl manual: False +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,7 +61,7 @@ library include-dirs: imgui build-depends: - base + dear-imgui-generator , containers , managed , inline-c @@ -117,30 +128,55 @@ library exposed-modules: DearImGui.SDL.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 - + build-depends: sdl2, gl, dear-imgui executable readme + import: common main-is: Readme.hs hs-source-dirs: examples - default-language: Haskell2010 - build-depends: base, sdl2, gl, dear-imgui, managed - ghc-options: -Wall + 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/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 4f3f892..da135a8 100644 --- a/src/DearImGui.hs +++ b/src/DearImGui.hs @@ -122,13 +122,8 @@ module DearImGui , isItemHovered -- * Types - , ImGuiDir - , pattern ImGuiDirLeft - , pattern ImGuiDirRight - , pattern ImGuiDirUp - , pattern ImGuiDirDown - , ImVec3(..) - , ImVec4(..) + , module DearImGui.Enums + , module DearImGui.Structs ) where @@ -139,6 +134,9 @@ import Foreign.C -- dear-imgui import DearImGui.Context + ( imguiContext ) +import DearImGui.Enums +import DearImGui.Structs -- inline-c import qualified Language.C.Inline as C @@ -777,17 +775,6 @@ 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 diff --git a/src/DearImGui/Context.hs b/src/DearImGui/Context.hs index 3220ae3..cbfd48d 100644 --- a/src/DearImGui/Context.hs +++ b/src/DearImGui/Context.hs @@ -1,57 +1,27 @@ +{-# 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.Structs + ( ImVec3, ImVec4 ) +-------------------------------------------------------------------------------- imguiContext :: Context imguiContext = mempty 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/Structs.hs b/src/DearImGui/Structs.hs new file mode 100644 index 0000000..45af7b0 --- /dev/null +++ b/src/DearImGui/Structs.hs @@ -0,0 +1,51 @@ +{-# LANGUAGE DuplicateRecordFields #-} +{-# LANGUAGE NamedFieldPuns #-} + +module DearImGui.Structs where + +-- base +import Foreign + ( Storable(..), castPtr, plusPtr ) + +-------------------------------------------------------------------------------- + +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 } From 643d2ea5b76490bfbc47742520ddbd53f702b645 Mon Sep 17 00:00:00 2001 From: Shaun Sharples Date: Fri, 5 Feb 2021 23:20:32 +0200 Subject: [PATCH 08/13] Add combo to wrap ImGUI::Combo() (#28) Co-authored-by: Oliver Charles --- Main.hs | 18 ++++++++++++++---- src/DearImGui.hs | 22 ++++++++++++++++++++++ 2 files changed, 36 insertions(+), 4 deletions(-) diff --git a/Main.hs b/Main.hs index f5d8b0b..f69aa7f 100644 --- a/Main.hs +++ b/Main.hs @@ -30,13 +30,21 @@ main = do color <- newIORef $ ImVec3 1 0 0 slider <- newIORef (0.42, 0, 0.314) r <- newIORef 4 - loop w checked color slider r + selected <- newIORef 4 + loop w checked color slider r selected openGL2Shutdown -loop :: Window -> IORef Bool -> IORef ImVec3 -> IORef (Float, Float, Float) -> IORef Int -> IO () -loop w checked color slider r = do +loop + :: Window + -> IORef Bool + -> IORef ImVec3 + -> IORef (Float, Float, Float) + -> IORef Int + -> IORef Int + -> IO () +loop w checked color slider r selected = do quit <- pollEvents openGL2NewFrame @@ -89,6 +97,8 @@ loop w checked color slider r = do selectable "Testing 2" endCombo + combo "Simple" selected [ "1", "2", "3" ] + endChild plotHistogram "A histogram" [ 10, 10, 20, 30, 90 ] @@ -124,7 +134,7 @@ loop w checked color slider r = do glSwapWindow w - if quit then return () else loop w checked color slider r + if quit then return () else loop w checked color slider r selected where diff --git a/src/DearImGui.hs b/src/DearImGui.hs index da135a8..341ec00 100644 --- a/src/DearImGui.hs +++ b/src/DearImGui.hs @@ -67,6 +67,7 @@ module DearImGui -- ** Combo Box , beginCombo , endCombo + , combo -- ** Drag Sliders , dragFloat @@ -416,6 +417,27 @@ endCombo = liftIO do [C.exp| void { EndCombo() } |] +-- 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 + + 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 From d7686f84e4c418a9886dff42a4719c0e049aa4cb Mon Sep 17 00:00:00 2001 From: Shaun Sharples Date: Fri, 5 Feb 2021 23:44:52 +0200 Subject: [PATCH 09/13] Add support for GLFW (#26) Co-authored-by: Oliver Charles --- cabal.project | 2 +- dear-imgui.cabal | 39 ++++++++++++++++- default.nix | 14 ++++++ examples/glfw/Main.hs | 82 ++++++++++++++++++++++++++++++++++++ src/DearImGui/GLFW.hs | 51 ++++++++++++++++++++++ src/DearImGui/GLFW/OpenGL.hs | 61 +++++++++++++++++++++++++++ src/DearImGui/GLFW/Vulkan.hs | 60 ++++++++++++++++++++++++++ 7 files changed, 307 insertions(+), 2 deletions(-) create mode 100644 examples/glfw/Main.hs create mode 100644 src/DearImGui/GLFW.hs create mode 100644 src/DearImGui/GLFW/OpenGL.hs create mode 100644 src/DearImGui/GLFW/Vulkan.hs diff --git a/cabal.project b/cabal.project index b19ede2..74f9cfc 100644 --- a/cabal.project +++ b/cabal.project @@ -1,3 +1,3 @@ packages: *.cabal package dear-imgui - flags: +sdl2 +opengl +vulkan + flags: +sdl2 +glfw +opengl +vulkan diff --git a/dear-imgui.cabal b/dear-imgui.cabal index 358e896..cf1f506 100644 --- a/dear-imgui.cabal +++ b/dear-imgui.cabal @@ -29,6 +29,14 @@ flag sdl manual: False +flag glfw + description: + Enable GLFW backend. + default: + False + manual: + True + common common build-depends: base @@ -128,6 +136,26 @@ 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(opengl) + exposed-modules: + DearImGui.GLFW.OpenGL + + if flag(vulkan) + exposed-modules: + DearImGui.GLFW.Vulkan + library dear-imgui-generator import: common hs-source-dirs: generator @@ -161,7 +189,16 @@ library dear-imgui-generator executable test import: common main-is: Main.hs - build-depends: sdl2, gl, dear-imgui + default-language: Haskell2010 + build-depends: base, sdl2, gl, dear-imgui + ghc-options: -Wall + +executable glfw + main-is: Main.hs + hs-source-dirs: examples/glfw + default-language: Haskell2010 + build-depends: base, GLFW-b, gl, dear-imgui, managed + ghc-options: -Wall executable readme import: common 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/glfw/Main.hs b/examples/glfw/Main.hs new file mode 100644 index 0000000..161488e --- /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.OpenGL +import DearImGui.GLFW +import DearImGui.GLFW.OpenGL +import Graphics.GL +import Graphics.UI.GLFW (Window) +import qualified Graphics.UI.GLFW as GLFW + +main :: IO () +main = do + initialised <- GLFW.init + unless initialised $ error "GLFW init failed" + + runManaged $ do + mwin <- managed $ bracket + (GLFW.createWindow 800 600 "Hello, Dear ImGui!" Nothing Nothing) + (maybe (return ()) GLFW.destroyWindow) + case mwin of + Just win -> do + liftIO $ do + GLFW.makeContextCurrent (Just win) + GLFW.swapInterval 1 + + -- Create an ImGui context + _ <- managed $ bracket createContext destroyContext + + -- Initialize ImGui's GLFW backend + _ <- managed_ $ bracket_ (glfwInitForOpenGL win True) glfwShutdown + + -- Initialize ImGui's OpenGL backend + _ <- managed_ $ bracket_ openGL2Init openGL2Shutdown + + liftIO $ mainLoop win + Nothing -> do + error "GLFW createWindow failed" + + GLFW.terminate + +mainLoop :: Window -> IO () +mainLoop win = do + -- Process the event loop + GLFW.pollEvents + close <- GLFW.windowShouldClose win + unless close do + + -- Tell ImGui we're starting a new frame + openGL2NewFrame + glfwNewFrame + newFrame + + -- Build the GUI + bracket_ (begin "Hello, ImGui!") end do + -- Add a text widget + text "Hello, ImGui!" + + -- Add a button widget, and call 'putStrLn' when it's clicked + button "Clickety Click" >>= \case + False -> return () + True -> putStrLn "Ow!" + + -- Show the ImGui demo window + showDemoWindow + + -- Render + glClear GL_COLOR_BUFFER_BIT + + render + openGL2RenderDrawData =<< getDrawData + + GLFW.swapBuffers win + + mainLoop win \ No newline at end of file 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 From de0e87612c6d43cc1ac931c57595f3f7022f2454 Mon Sep 17 00:00:00 2001 From: Tim Pierson Date: Fri, 5 Feb 2021 23:46:48 +0000 Subject: [PATCH 10/13] Add setNextWindow functions, pushColor, pushStyle, indent-related functions (#27) --- Main.hs | 19 ++++- src/DearImGui.hs | 173 +++++++++++++++++++++++++++++++++++++++ src/DearImGui/Context.hs | 5 +- src/DearImGui/Structs.hs | 17 ++++ 4 files changed, 209 insertions(+), 5 deletions(-) diff --git a/Main.hs b/Main.hs index f69aa7f..1a35d22 100644 --- a/Main.hs +++ b/Main.hs @@ -30,8 +30,10 @@ main = do color <- newIORef $ ImVec3 1 0 0 slider <- newIORef (0.42, 0, 0.314) r <- newIORef 4 + pos <- newIORef $ ImVec2 64 64 + size' <- newIORef $ ImVec2 512 512 selected <- newIORef 4 - loop w checked color slider r selected + loop w checked color slider r pos size' selected openGL2Shutdown @@ -42,9 +44,11 @@ loop -> IORef ImVec3 -> IORef (Float, Float, Float) -> IORef Int + -> IORef ImVec2 + -> IORef ImVec2 -> IORef Int -> IO () -loop w checked color slider r selected = do +loop w checked color slider r pos size' selected = do quit <- pollEvents openGL2NewFrame @@ -56,6 +60,15 @@ loop w checked color slider r selected = do -- showAboutWindow -- showUserGuide + setNextWindowPos pos ImGuiCond_Once Nothing + setNextWindowSize size' ImGuiCond_Once + -- Works, but will make the window contents illegible without doing something more involved. + -- setNextWindowContentSize size' + -- setNextWindowSizeConstraints size' size' + setNextWindowCollapsed False ImGuiCond_Once + + setNextWindowBgAlpha 0.42 + begin "My Window" text "Hello!" @@ -134,7 +147,7 @@ loop w checked color slider r selected = do glSwapWindow w - if quit then return () else loop w checked color slider r selected + if quit then return () else loop w checked color slider r pos size' selected where diff --git a/src/DearImGui.hs b/src/DearImGui.hs index 341ec00..6f885e2 100644 --- a/src/DearImGui.hs +++ b/src/DearImGui.hs @@ -43,6 +43,12 @@ module DearImGui -- * Windows , begin , end + , setNextWindowPos + , setNextWindowSize + , setNextWindowContentSize + , setNextWindowSizeConstraints + , setNextWindowCollapsed + , setNextWindowBgAlpha -- * Child Windows , beginChild @@ -130,6 +136,10 @@ module DearImGui -- base import Data.Bool +import Data.Coerce + ( coerce ) +import Data.Int + ( Int32 ) import Foreign import Foreign.C @@ -800,3 +810,166 @@ isItemHovered = liftIO do 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 (ImGuiCond con) 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), $(int con), *$(ImVec2 *pivotPtr)) } |] + Nothing -> + [C.exp| void { SetNextWindowPos(*$(ImVec2 *posPtr), $(int con)) } |] + +-- | Set next window size. Call before `begin` +-- +-- Wraps @ImGui::SetNextWindowSize()@ +setNextWindowSize :: (MonadIO m, HasGetter ref ImVec2) => ref -> ImGuiCond -> m () +setNextWindowSize sizeRef (ImGuiCond con) = liftIO do + size' <- get sizeRef + with size' $ + \sizePtr ->[C.exp| void { SetNextWindowSize(*$(ImVec2 *sizePtr), $(int con)) } |] + +-- | 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 (ImGuiCond con) = liftIO do + let b' = bool 0 1 b + [C.exp| void { SetNextWindowCollapsed($(bool b'), $(int con)) } |] + +-- | 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 (ImGuiCol idx) colorRef = liftIO do + color <- get colorRef + with color $ \ colorPtr -> [C.exp| void { PushStyleColor($(int idx), *$(ImVec4 *colorPtr)) } |] + +-- | Remove style color modifications from the shared stack +-- +-- Wraps @ImGui::PopStyleColor()@ +popStyleColor :: (MonadIO m) => Int32 -> m () +popStyleColor count = liftIO do + let count' = coerce count + [C.exp| void { PopStyleColor($(int count')) } |] + +-- | 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 (ImGuiStyleVar idx) valRef = liftIO do + val <- get valRef + with val $ \ valPtr -> [C.exp| void { PushStyleVar($(int idx), *$(ImVec2 *valPtr)) } |] + + +-- | Remove style variable modifications from the shared stack +-- +-- Wraps @ImGui::PopStyleVar()@ +popStyleVar :: (MonadIO m) => Int32 -> m () +popStyleVar count = liftIO do + let count' = coerce count + [C.exp| void { PopStyleVar($(int count')) } |] + \ No newline at end of file diff --git a/src/DearImGui/Context.hs b/src/DearImGui/Context.hs index cbfd48d..88892b8 100644 --- a/src/DearImGui/Context.hs +++ b/src/DearImGui/Context.hs @@ -19,14 +19,15 @@ import Language.C.Types -- dear-imgui import DearImGui.Structs - ( ImVec3, ImVec4 ) + ( ImVec2, ImVec3, ImVec4 ) -------------------------------------------------------------------------------- imguiContext :: Context imguiContext = mempty { ctxTypesTable = Map.fromList - [ ( TypeName "ImVec3", [t| ImVec3 |] ) + [ ( TypeName "ImVec2", [t| ImVec2 |] ) + , ( TypeName "ImVec3", [t| ImVec3 |] ) , ( TypeName "ImVec4", [t| ImVec4 |] ) ] } diff --git a/src/DearImGui/Structs.hs b/src/DearImGui/Structs.hs index 45af7b0..d5f5c3b 100644 --- a/src/DearImGui/Structs.hs +++ b/src/DearImGui/Structs.hs @@ -8,6 +8,23 @@ 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 } From 860720e7c204adf7ad442d39485b97e84a3525c6 Mon Sep 17 00:00:00 2001 From: sheaf Date: Sat, 6 Feb 2021 11:17:37 +0100 Subject: [PATCH 11/13] Define types for use in ImGui Context (#31) Just doing a little cleanup: * some functions were not exported, * some functions were missing the initial | for their documentation, * add types to the ImGui Context instead of coercing to int. This is more robust, in case upstream changes any of the larger enums to be 64 bits instead of 32 for instance --- src/DearImGui.hs | 66 +++++++++++++++++++++++++--------------- src/DearImGui/Context.hs | 12 +++++--- 2 files changed, 49 insertions(+), 29 deletions(-) diff --git a/src/DearImGui.hs b/src/DearImGui.hs index 6f885e2..9224695 100644 --- a/src/DearImGui.hs +++ b/src/DearImGui.hs @@ -54,9 +54,24 @@ module DearImGui , beginChild , endChild + -- * Parameter stacks + , pushStyleColor + , popStyleColor + , pushStyleVar + , popStyleVar + -- * Cursor/Layout , separator , sameLine + , newLine + , spacing + , dummy + , indent + , unindent + , beginGroup + , endGroup + , setCursorPos + , alignTextToFramePadding -- * Widgets -- ** Text @@ -371,9 +386,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()@. @@ -419,7 +434,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 () @@ -427,7 +442,7 @@ endCombo = liftIO do [C.exp| void { EndCombo() } |] --- Wraps @ImGui::Combo()@. +-- | 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 @@ -651,7 +666,6 @@ 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 @@ -731,7 +745,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()@ @@ -816,25 +830,25 @@ withCStringOrNull (Just s) k = withCString s k -- -- Wraps @ImGui::SetNextWindowPos()@ setNextWindowPos :: (MonadIO m, HasGetter ref ImVec2) => ref -> ImGuiCond -> Maybe ref -> m () -setNextWindowPos posRef (ImGuiCond con) pivotMaybe = liftIO do +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), $(int con), *$(ImVec2 *pivotPtr)) } |] + [C.exp| void { SetNextWindowPos(*$(ImVec2 *posPtr), $(ImGuiCond cond), *$(ImVec2 *pivotPtr)) } |] Nothing -> - [C.exp| void { SetNextWindowPos(*$(ImVec2 *posPtr), $(int con)) } |] + [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 (ImGuiCond con) = liftIO do +setNextWindowSize sizeRef cond = liftIO do size' <- get sizeRef with size' $ - \sizePtr ->[C.exp| void { SetNextWindowSize(*$(ImVec2 *sizePtr), $(int con)) } |] + \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` -- @@ -861,9 +875,9 @@ setNextWindowSizeConstraints sizeMinRef sizeMaxRef = liftIO do -- -- Wraps @ImGui::SetNextWindowCollapsed()@ setNextWindowCollapsed :: (MonadIO m) => Bool -> ImGuiCond -> m () -setNextWindowCollapsed b (ImGuiCond con) = liftIO do +setNextWindowCollapsed b cond = liftIO do let b' = bool 0 1 b - [C.exp| void { SetNextWindowCollapsed($(bool b'), $(int con)) } |] + [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`. -- @@ -944,32 +958,34 @@ setCursorPos posRef = liftIO do -- -- Wraps @ImGui::PushStyleColor()@ pushStyleColor :: (MonadIO m, HasGetter ref ImVec4) => ImGuiCol -> ref -> m () -pushStyleColor (ImGuiCol idx) colorRef = liftIO do +pushStyleColor col colorRef = liftIO do color <- get colorRef - with color $ \ colorPtr -> [C.exp| void { PushStyleColor($(int idx), *$(ImVec4 *colorPtr)) } |] + 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 count = liftIO do - let count' = coerce count - [C.exp| void { PopStyleColor($(int count')) } |] +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 (ImGuiStyleVar idx) valRef = liftIO do +pushStyleVar style valRef = liftIO do val <- get valRef - with val $ \ valPtr -> [C.exp| void { PushStyleVar($(int idx), *$(ImVec2 *valPtr)) } |] - + 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 count = liftIO do - let count' = coerce count - [C.exp| void { PopStyleVar($(int count')) } |] - \ No newline at end of file +popStyleVar n = liftIO do + let + m :: CInt + m = coerce n + [C.exp| void { PopStyleVar($(int m)) } |] diff --git a/src/DearImGui/Context.hs b/src/DearImGui/Context.hs index 88892b8..8b7a582 100644 --- a/src/DearImGui/Context.hs +++ b/src/DearImGui/Context.hs @@ -18,16 +18,20 @@ import Language.C.Types ( pattern TypeName ) -- dear-imgui +import DearImGui.Enums import DearImGui.Structs - ( ImVec2, ImVec3, ImVec4 ) -------------------------------------------------------------------------------- imguiContext :: Context imguiContext = mempty { ctxTypesTable = Map.fromList - [ ( TypeName "ImVec2", [t| ImVec2 |] ) - , ( TypeName "ImVec3", [t| ImVec3 |] ) - , ( TypeName "ImVec4", [t| ImVec4 |] ) + [ ( TypeName "ImGuiCol" , [t| ImGuiCol |] ) + , ( TypeName "ImGuiCond" , [t| ImGuiCond |] ) + , ( TypeName "ImGuiDir" , [t| ImGuiDir |] ) + , ( TypeName "ImGuiStyleVar", [t| ImGuiStyleVar |] ) + , ( TypeName "ImVec2" , [t| ImVec2 |] ) + , ( TypeName "ImVec3" , [t| ImVec3 |] ) + , ( TypeName "ImVec4" , [t| ImVec4 |] ) ] } From ac7457212143fc816a13abcb31236955259327de Mon Sep 17 00:00:00 2001 From: sheaf Date: Sat, 6 Feb 2021 14:26:28 +0100 Subject: [PATCH 12/13] Add tab bar functions (#30) --- Main.hs | 25 +++++++++++++++-- src/DearImGui.hs | 59 ++++++++++++++++++++++++++++++++++++++++ src/DearImGui/Context.hs | 16 ++++++----- 3 files changed, 90 insertions(+), 10 deletions(-) diff --git a/Main.hs b/Main.hs index 1a35d22..841af6c 100644 --- a/Main.hs +++ b/Main.hs @@ -5,6 +5,7 @@ module Main (main) where +import Control.Monad import Data.IORef import DearImGui import DearImGui.OpenGL @@ -33,7 +34,9 @@ main = do pos <- newIORef $ ImVec2 64 64 size' <- newIORef $ ImVec2 512 512 selected <- newIORef 4 - loop w checked color slider r pos size' selected + tab1 <- newIORef True + tab2 <- newIORef True + loop w checked color slider r pos size' selected tab1 tab2 openGL2Shutdown @@ -47,8 +50,10 @@ loop -> IORef ImVec2 -> IORef ImVec2 -> IORef Int + -> IORef Bool + -> IORef Bool -> IO () -loop w checked color slider r pos size' selected = do +loop w checked color slider r pos size' selected tab1Ref tab2Ref = do quit <- pollEvents openGL2NewFrame @@ -70,8 +75,22 @@ loop w checked color slider r pos size' selected = do setNextWindowBgAlpha 0.42 begin "My Window" + text "Hello!" + beginTabBar "My tab bar" ImGuiTabBarFlags_Reorderable >>= whenTrue do + beginTabItem "Tab 1" tab1Ref ImGuiTabBarFlags_None >>= whenTrue do + text "Tab 1 is currently selected." + endTabItem + beginTabItem "Tab 2" tab2Ref ImGuiTabBarFlags_None >>= whenTrue do + text "Tab 2 is selected now." + endTabItem + reOpen <- tabItemButton "ReopenTabs" ImGuiTabItemFlags_Trailing + when reOpen do + writeIORef tab1Ref True + writeIORef tab2Ref True + endTabBar + listBox "Items" r [ "A", "B", "C" ] button "Click me" >>= \case @@ -147,7 +166,7 @@ loop w checked color slider r pos size' selected = do glSwapWindow w - if quit then return () else loop w checked color slider r pos size' selected + if quit then return () else loop w checked color slider r pos size' selected tab1Ref tab2Ref where diff --git a/src/DearImGui.hs b/src/DearImGui.hs index 9224695..6977597 100644 --- a/src/DearImGui.hs +++ b/src/DearImGui.hs @@ -129,6 +129,14 @@ module DearImGui , endMenu , menuItem + -- ** Tabs, tab bar + , beginTabBar + , endTabBar + , beginTabItem + , endTabItem + , tabItemButton + , setTabItemClosed + -- * Tooltips , beginTooltip , endTooltip @@ -754,6 +762,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). diff --git a/src/DearImGui/Context.hs b/src/DearImGui/Context.hs index 8b7a582..9e807f3 100644 --- a/src/DearImGui/Context.hs +++ b/src/DearImGui/Context.hs @@ -26,12 +26,14 @@ import DearImGui.Structs imguiContext :: Context imguiContext = mempty { ctxTypesTable = Map.fromList - [ ( TypeName "ImGuiCol" , [t| ImGuiCol |] ) - , ( TypeName "ImGuiCond" , [t| ImGuiCond |] ) - , ( TypeName "ImGuiDir" , [t| ImGuiDir |] ) - , ( TypeName "ImGuiStyleVar", [t| ImGuiStyleVar |] ) - , ( TypeName "ImVec2" , [t| ImVec2 |] ) - , ( TypeName "ImVec3" , [t| ImVec3 |] ) - , ( TypeName "ImVec4" , [t| ImVec4 |] ) + [ ( 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 |] ) ] } From f9412effde27fec49b6447ce2e8c54e4be2d4426 Mon Sep 17 00:00:00 2001 From: Ollie Charles Date: Sat, 6 Feb 2021 14:44:58 +0000 Subject: [PATCH 13/13] Wrap the OpenGL 3 backend (#20) --- Main.hs | 10 ++-- README.md | 2 +- cabal.project | 2 +- dear-imgui.cabal | 40 +++++++++----- examples/Readme.hs | 2 +- examples/glfw/Main.hs | 4 +- src/DearImGui/{OpenGL.hs => OpenGL2.hs} | 4 +- src/DearImGui/OpenGL3.hs | 69 +++++++++++++++++++++++++ 8 files changed, 109 insertions(+), 24 deletions(-) rename src/DearImGui/{OpenGL.hs => OpenGL2.hs} (96%) create mode 100644 src/DearImGui/OpenGL3.hs diff --git a/Main.hs b/Main.hs index 841af6c..951ff99 100644 --- a/Main.hs +++ b/Main.hs @@ -8,7 +8,7 @@ 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,7 +23,7 @@ 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 @@ -38,7 +38,7 @@ main = do tab2 <- newIORef True loop w checked color slider r pos size' selected tab1 tab2 - openGL2Shutdown + openGL3Shutdown loop @@ -56,7 +56,7 @@ loop loop w checked color slider r pos size' selected tab1Ref tab2Ref = do quit <- pollEvents - openGL2NewFrame + openGL3NewFrame sdl2NewFrame w newFrame @@ -162,7 +162,7 @@ loop w checked color slider r pos size' selected tab1Ref tab2Ref = do render glClear GL_COLOR_BUFFER_BIT - openGL2RenderDrawData =<< getDrawData + openGL3RenderDrawData =<< getDrawData glSwapWindow w 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 74f9cfc..a5f90d8 100644 --- a/cabal.project +++ b/cabal.project @@ -1,3 +1,3 @@ packages: *.cabal package dear-imgui - flags: +sdl2 +glfw +opengl +vulkan + flags: +sdl2 +glfw +opengl2 +opengl3 +vulkan diff --git a/dear-imgui.cabal b/dear-imgui.cabal index cf1f506..ba67363 100644 --- a/dear-imgui.cabal +++ b/dear-imgui.cabal @@ -5,9 +5,17 @@ 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: @@ -76,21 +84,29 @@ library , 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: @@ -128,7 +144,7 @@ library pkgconfig-depends: sdl2 - if flag(opengl) + if flag(opengl2) || flag(opengl3) exposed-modules: DearImGui.SDL.OpenGL @@ -148,7 +164,7 @@ library pkgconfig-depends: glfw3 - if flag(opengl) + if flag(opengl2) || flag(opengl3) exposed-modules: DearImGui.GLFW.OpenGL diff --git a/examples/Readme.hs b/examples/Readme.hs index 85b17a6..598d908 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 diff --git a/examples/glfw/Main.hs b/examples/glfw/Main.hs index 161488e..f85c891 100644 --- a/examples/glfw/Main.hs +++ b/examples/glfw/Main.hs @@ -9,7 +9,7 @@ import Control.Monad import Control.Monad.IO.Class import Control.Monad.Managed import DearImGui -import DearImGui.OpenGL +import DearImGui.OpenGL2 import DearImGui.GLFW import DearImGui.GLFW.OpenGL import Graphics.GL @@ -79,4 +79,4 @@ mainLoop win = do GLFW.swapBuffers win - mainLoop win \ No newline at end of file + mainLoop win 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 )) } |]