Fix and extend DragDrop API (#209)

Author: dpwiz

ChangeLog.md

@@ -1,5 +1,13 @@
 # Changelog for dear-imgui
 
+## [2.3.1]
+
+- Extended DragDrop API.
+  * Added `DearImGui.withDragDropSource` and `DearImGui.withDragDropTarget` wrappers.
+  * Fixed `DearImGui.Raw.DragDrop.beginTarget` to return accept flag.
+  * Added `DearImGui.Raw.DragDrop.getData` and `DearImGui.Raw.DragDrop.getDataSize`.
+  * Added remaining `Payload` internals.
+
 ## [2.3.0]
 
 - `imgui` updated to [1.90.9].
@@ -138,6 +146,7 @@ Initial Hackage release based on [1.83].
 [2.2.0]: https://github.com/haskell-game/dear-imgui.hs/tree/v2.2.0
 [2.2.1]: https://github.com/haskell-game/dear-imgui.hs/tree/v2.2.1
 [2.3.0]: https://github.com/haskell-game/dear-imgui.hs/tree/v2.3.0
+[2.3.1]: https://github.com/haskell-game/dear-imgui.hs/tree/v2.3.1
 
 [1.90.9]: https://github.com/ocornut/imgui/releases/tag/v1.90.9
 [1.89.9]: https://github.com/ocornut/imgui/releases/tag/v1.89.9

dear-imgui.cabal

@@ -1,7 +1,7 @@
 cabal-version: 3.0
 
 name: dear-imgui
-version: 2.3.0
+version: 2.3.1
 author: Oliver Charles
 maintainer: [email protected], [email protected]
 license: BSD-3-Clause

src/DearImGui.hs

@@ -421,6 +421,14 @@ module DearImGui
   , Raw.setKeyboardFocusHere
   , Raw.setNextItemAllowOverlap
 
+   -- ** Drag and drop
+  , withDragDropSource
+  , withDragDropTarget
+  , withDragDropSource_
+  , withDragDropTarget_
+  , withDragDropSourceData
+  , withDragDropTargetData
+
     -- ** ListClipper
   , withListClipper
   , ClipItems(..)
@@ -446,7 +454,7 @@ import Control.Monad
   ( when )
 import Data.Bool
 import Data.Foldable
-  ( foldl' )
+  ( foldl', for_, traverse_ )
 import Foreign
 import Foreign.C
 
@@ -456,6 +464,7 @@ import DearImGui.Internal.Text (Text)
 import DearImGui.Structs
 import qualified DearImGui.Internal.Text as Text
 import qualified DearImGui.Raw as Raw
+import qualified DearImGui.Raw.DragDrop as Raw.DragDrop
 import qualified DearImGui.Raw.Font as Raw.Font
 import qualified DearImGui.Raw.ListClipper as Raw.ListClipper
 
@@ -471,7 +480,7 @@ import Control.Monad.IO.Class
   ( MonadIO, liftIO )
 
 -- unliftio
-import UnliftIO (MonadUnliftIO)
+import UnliftIO (MonadUnliftIO (..))
 import UnliftIO.Exception (bracket, bracket_)
 
 -- vector
@@ -2609,6 +2618,86 @@ popStyleVar n = liftIO do
 withFont :: MonadUnliftIO m => Raw.Font.Font -> m a -> m a
 withFont font = bracket_ (Raw.Font.pushFont font) Raw.Font.popFont
 
+-- | Attach drag-n-drop source with a payload to a preceding item.
+--
+-- A valid target should have a matching payload type.
+--
+-- Data is copied and retained by DearImGui.
+-- Action is executed when the payload is accepted.
+withDragDropSource :: (MonadUnliftIO m, Storable a) => ImGuiDragDropFlags -> Text -> a -> (Bool -> m ()) -> m ()
+withDragDropSource flags payloadType payload action =
+  withRunInIO \run ->
+    with payload \payloadPtr ->
+      run $ withDragDropSourceData flags payloadType (castPtr payloadPtr, Foreign.sizeOf payload) action
+
+-- | Attach drag-n-drop target to a preceding item.
+--
+-- A valid source should have a matching payload type.
+--
+-- Data is fetched from DearImGui copy and cleared on delivery.
+-- Action is executed when the payload is accepted and not empty.
+withDragDropTarget :: (MonadUnliftIO m, Storable a) => ImGuiDragDropFlags -> Text -> (a -> m ()) -> m ()
+withDragDropTarget flags payloadType action =
+  withRunInIO \run ->
+    Raw.DragDrop.beginTarget >>= flip when do
+      Text.withCString payloadType \typePtr -> do
+        payload_ <- Raw.DragDrop.acceptPayload typePtr flags
+        for_ payload_ \payload -> do
+          dataPtr <- Raw.DragDrop.getData payload
+          Foreign.maybePeek peek (castPtr dataPtr) >>= traverse_ (run . action)
+      Raw.DragDrop.endTarget
+
+-- | Like 'withDragDropSource', but only set payload type.
+withDragDropSource_ :: (MonadUnliftIO m) => ImGuiDragDropFlags -> Text -> (Bool -> m ()) -> m ()
+withDragDropSource_ flags payloadType action =
+  withRunInIO \run ->
+    Raw.DragDrop.beginSource flags >>= flip when do
+      accepted <-
+        Text.withCString payloadType \typePtr ->
+          Raw.DragDrop.setPayload typePtr nullPtr 0 ImGuiCond_Once
+      run $ action accepted
+      Raw.DragDrop.endSource
+
+-- | Like 'withDragDropTarget', but only set payload type.
+--
+-- Payload data is ignored.
+withDragDropTarget_ :: (MonadUnliftIO m) => ImGuiDragDropFlags -> Text -> m () -> m ()
+withDragDropTarget_ flags payloadType action =
+  withRunInIO \run ->
+    Raw.DragDrop.beginTarget >>= flip when do
+      Text.withCString payloadType \typePtr -> do
+        payload_ <- Raw.DragDrop.acceptPayload typePtr flags
+        for_ payload_ (\_dataPtr -> run action)
+      Raw.DragDrop.endTarget
+
+-- | Like 'withDragDropSource', explicitly setting data ptr and size.
+--
+-- Suitable for data with dynamic lengths via @withCStringLen@-like functions.
+withDragDropSourceData :: (MonadUnliftIO m, Integral len) => ImGuiDragDropFlags -> Text -> (Ptr a, len) -> (Bool -> m ()) -> m ()
+withDragDropSourceData flags payloadType (dataPtr, dataSize) action =
+  withRunInIO \run ->
+    Raw.DragDrop.beginSource flags >>= flip when do
+      accepted <-
+        Text.withCString payloadType \typePtr ->
+          Raw.DragDrop.setPayload typePtr dataPtr (fromIntegral dataSize) ImGuiCond_Once
+      run $ action accepted
+      Raw.DragDrop.endSource
+
+-- | Like 'withDragDropTarget', getting raw data ptr and size.
+--
+-- Check the size, and pointer for NULLs etc.!
+withDragDropTargetData :: (MonadUnliftIO m, Integral len) => ImGuiDragDropFlags -> Text -> ((Ptr a, len) -> m ()) -> m ()
+withDragDropTargetData flags payloadType action =
+  withRunInIO \run ->
+    Raw.DragDrop.beginTarget >>= flip when do
+      Text.withCString payloadType \typePtr -> do
+        payload_ <- Raw.DragDrop.acceptPayload typePtr flags
+        for_ payload_ \payload -> do
+          dataPtr <- Raw.DragDrop.getData payload
+          dataSize <- Raw.DragDrop.getDataSize payload
+          run $ action (castPtr dataPtr, fromIntegral dataSize)
+      Raw.DragDrop.endTarget
+
 -- | Clips a large list of items
 --
 -- The requirements on @a@ are that they are all of the same height.

src/DearImGui/Raw/DragDrop.hs

@@ -10,22 +10,32 @@
 {-# LANGUAGE ViewPatterns #-}
 
 module DearImGui.Raw.DragDrop
-  ( Payload(..)
-  , beginSource
+  ( -- * Source
+    beginSource
   , setPayload
   , endSource
+    -- * Target
   , beginTarget
   , acceptPayload
   , endTarget
+    -- * Payload object
+  , Payload(..)
+  , getData
+  , getDataSize
+    -- ** Direct access
   , getPayload
+  , clear
+  , isDataType
+  , isPreview
+  , isDelivery
   )
   where
 
 -- base
 import Control.Monad.IO.Class
   ( MonadIO, liftIO )
 import Foreign
-  ( Ptr, castPtr )
+  ( Ptr, castPtr, nullPtr )
 import Foreign.C
 
 -- dear-imgui
@@ -44,38 +54,93 @@ C.context (Cpp.cppCtx <> C.bsCtx <> imguiContext)
 C.include "imgui.h"
 Cpp.using "namespace ImGui"
 
--- | Font configuration data handle
+-- | Call after submitting an item which may be dragged.
 --
--- Wraps @ImGuiPayload*@.
-newtype Payload = Payload (Ptr ImGuiPayload)
-
-
+-- When this return True, you can call 'setPayload' + 'endDragDropSource'.
 beginSource :: MonadIO m => ImGuiDragDropFlags -> m Bool
 beginSource flags = liftIO do
   (0 /=) <$> [C.exp| bool { BeginDragDropSource( $(ImGuiDragDropFlags flags) ) } |]
 
+-- | Type is a user defined string of maximum 32 characters.
+--
+-- Strings starting with '_' are reserved for dear imgui internal types.
+-- Data is copied and held by imgui.
+-- Returns True when payload has been accepted.
 setPayload :: MonadIO m => CString -> Ptr a -> CSize -> ImGuiCond -> m Bool
 setPayload typePtr dataPtr sz cond = liftIO do
   (0 /=) <$> [C.exp| bool { SetDragDropPayload( $(char* typePtr), $(void* dataPtr'), $(size_t sz), $(ImGuiCond cond) ) } |]
   where
     dataPtr' = castPtr dataPtr
 
+-- | Only call if 'beginSource' returns True!
 endSource :: MonadIO m => m ()
 endSource = liftIO do
   [C.block| void { EndDragDropSource( ); } |]
 
-beginTarget :: MonadIO m => m ()
+-- | Call after submitting an item that may receive a payload.
+--
+-- If this returns True, you can call 'acceptPayload' + 'endTarget'.
+beginTarget :: MonadIO m => m Bool
 beginTarget = liftIO do
-  [C.block| void { BeginDragDropTarget(); } |]
+  (0 /=) <$> [C.exp| bool { BeginDragDropTarget() } |]
 
-acceptPayload :: MonadIO m => CString -> ImGuiDragDropFlags -> m Payload
+-- | Accept contents of a given type.
+--
+-- If "ImGuiDragDropFlags_AcceptBeforeDelivery" is set you can peek into the payload before the mouse button is released.
+acceptPayload :: MonadIO m => CString -> ImGuiDragDropFlags -> m (Maybe Payload)
 acceptPayload typePtr flags = liftIO do
-  Payload <$> [C.exp| const ImGuiPayload* { AcceptDragDropPayload( $(char* typePtr), $(ImGuiDragDropFlags flags) ) } |]
+  ptr <- [C.exp| const ImGuiPayload* { AcceptDragDropPayload( $(char* typePtr), $(ImGuiDragDropFlags flags) ) } |]
+  if ptr == nullPtr then
+    pure Nothing
+  else
+    pure $ Just (Payload ptr)
 
+-- | Only call if 'beginTarget' returns true!
 endTarget :: MonadIO m => m ()
 endTarget = liftIO do
   [C.block| void { EndDragDropTarget(); } |]
 
-getPayload :: MonadIO m => m Payload
+-- | Peek directly into the current payload from anywhere.
+--
+-- Returns NULL when drag and drop is finished or inactive.
+-- Use 'isDataType' to test for the payload type.
+getPayload :: MonadIO m => m (Maybe Payload)
 getPayload = liftIO do
-  Payload <$> [C.exp| const ImGuiPayload* { GetDragDropPayload() } |]
+  ptr <- [C.exp| const ImGuiPayload* { GetDragDropPayload() } |]
+  if ptr == nullPtr then
+    pure Nothing
+  else
+    pure $ Just (Payload ptr)
+
+-- | DragDrop payload data handle
+--
+-- Wraps @ImGuiPayload*@.
+newtype Payload = Payload (Ptr ImGuiPayload)
+  deriving (Eq, Show)
+
+getData :: MonadIO m => Payload -> m (Ptr ())
+getData (Payload payloadPtr) = liftIO do
+  [C.exp| void* { $(ImGuiPayload* payloadPtr)->Data } |]
+
+getDataSize :: MonadIO m => Payload -> m CInt
+getDataSize (Payload payloadPtr) = liftIO do
+  [C.exp| int { $(ImGuiPayload* payloadPtr)->DataSize } |]
+
+-- | Clear the DearImGui copy of payload data.
+--
+-- Gets called on 'endTarget' right after delivery.
+clear :: MonadIO m => Payload -> m ()
+clear (Payload payloadPtr) = liftIO do
+  [C.block| void { $(ImGuiPayload* payloadPtr)->Clear(); } |]
+
+isDataType :: MonadIO m => Payload -> CString -> m Bool
+isDataType (Payload payloadPtr) typePtr = liftIO do
+  (0 /=) <$> [C.exp| bool { $(ImGuiPayload* payloadPtr)->IsDataType($(char* typePtr)) } |]
+
+isPreview :: MonadIO m => Payload -> m Bool
+isPreview (Payload payloadPtr) = liftIO do
+  (0 /=) <$> [C.exp| bool { $(ImGuiPayload* payloadPtr)->IsPreview() } |]
+
+isDelivery :: MonadIO m => Payload -> m Bool
+isDelivery (Payload payloadPtr) = liftIO do
+  (0 /=) <$> [C.exp| bool { $(ImGuiPayload* payloadPtr)->IsDelivery() } |]