Stubbing out ImGui::ColorButton() and ImVec4

Author: ocharles

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"

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

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

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 |] )
+      ]
+    }