diff --git a/Main.hs b/Main.hs index 554acd4..5495317 100644 --- a/Main.hs +++ b/Main.hs @@ -80,6 +80,9 @@ loop w checked = do plotHistogram "A histogram" [ 10, 10, 20, 30, 90 ] + ref <- newIORef $ ImVec4 1 0 0 1 + colorButton "Test" ref + beginMainMenuBar >>= whenTrue do beginMenu "Hello" >>= whenTrue do menuItem "Hello" diff --git a/hs-dear-imgui.cabal b/hs-dear-imgui.cabal index 682807b..6f8f5c0 100644 --- a/hs-dear-imgui.cabal +++ b/hs-dear-imgui.cabal @@ -22,6 +22,7 @@ flag sdl library exposed-modules: DearImGui + DearImGui.Context hs-source-dirs: src default-language: @@ -42,6 +43,7 @@ library imgui build-depends: base + , containers , inline-c , inline-c-cpp , StateVar diff --git a/src/DearImGui.hs b/src/DearImGui.hs index 2a50e63..b8945c3 100644 --- a/src/DearImGui.hs +++ b/src/DearImGui.hs @@ -62,6 +62,9 @@ module DearImGui , beginCombo , endCombo + -- * Color Editor/Picker + , colorButton + -- ** Selectables , selectable @@ -97,6 +100,7 @@ module DearImGui , pattern ImGuiDirRight , pattern ImGuiDirUp , pattern ImGuiDirDown + , ImVec4(..) ) where @@ -105,6 +109,9 @@ import Data.Bool import Foreign import Foreign.C +-- dear-imgui +import DearImGui.Context + -- inline-c import qualified Language.C.Inline as C @@ -120,7 +127,7 @@ import Control.Monad.IO.Class ( MonadIO, liftIO ) -C.context (Cpp.cppCtx <> C.bsCtx) +C.context (Cpp.cppCtx <> C.bsCtx <> imguiContext) C.include "imgui.h" Cpp.using "namespace ImGui" @@ -367,6 +374,22 @@ endCombo = liftIO do [C.exp| void { EndCombo() } |] +-- | Display a color square/button, hover for details, return true when pressed. +-- +-- | Wraps @ImGui::ColorButton()@. +colorButton :: (MonadIO m, HasSetter ref ImVec4, HasGetter ref ImVec4) => String -> ref -> m Bool +colorButton desc ref = liftIO do + currentValue <- get ref + with currentValue \refPtr -> do + changed <- withCString desc \descPtr -> + (1 == ) <$> [C.exp| bool { ColorButton( $(char* descPtr), *$(ImVec4 *refPtr) ) } |] + + newValue <- peek refPtr + ref $=! newValue + + return changed + + -- | Wraps @ImGui::Selectable()@. selectable :: MonadIO m => String -> m Bool selectable label = liftIO do diff --git a/src/DearImGui/Context.hs b/src/DearImGui/Context.hs new file mode 100644 index 0000000..e39539c --- /dev/null +++ b/src/DearImGui/Context.hs @@ -0,0 +1,40 @@ +{-# language NamedFieldPuns #-} +{-# language OverloadedStrings #-} +{-# language TemplateHaskell #-} + +module DearImGui.Context where + +import Language.C.Types +import Language.C.Inline.Context +import qualified Data.Map.Strict as Map +import Foreign + + +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 `plusPtr` ) + y <- peek (castPtr ptr `plusPtr` (sizeOf x * 1)) + z <- peek (castPtr ptr `plusPtr` (sizeOf x * 2)) + w <- peek (castPtr ptr `plusPtr` (sizeOf x * 3)) + return ImVec4{ x, y, z, w } + + +imguiContext :: Context +imguiContext = mempty + { ctxTypesTable = Map.fromList + [ ( TypeName "ImVec4", [t| ImVec4 |] ) + ] + }