diff --git a/ChangeLog.md b/ChangeLog.md --- a/ChangeLog.md +++ b/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 @@ [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 diff --git a/dear-imgui.cabal b/dear-imgui.cabal --- a/dear-imgui.cabal +++ b/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: ollie@ocharles.org.uk, aenor.realm@gmail.com license: BSD-3-Clause diff --git a/src/DearImGui.hs b/src/DearImGui.hs --- a/src/DearImGui.hs +++ b/src/DearImGui.hs @@ -421,6 +421,14 @@ , Raw.setKeyboardFocusHere , Raw.setNextItemAllowOverlap + -- ** Drag and drop + , withDragDropSource + , withDragDropTarget + , withDragDropSource_ + , withDragDropTarget_ + , withDragDropSourceData + , withDragDropTargetData + -- ** ListClipper , withListClipper , ClipItems(..) @@ -446,7 +454,7 @@ ( when ) import Data.Bool import Data.Foldable - ( foldl' ) + ( foldl', for_, traverse_ ) import Foreign import Foreign.C @@ -456,6 +464,7 @@ 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 @@ ( MonadIO, liftIO ) -- unliftio -import UnliftIO (MonadUnliftIO) +import UnliftIO (MonadUnliftIO (..)) import UnliftIO.Exception (bracket, bracket_) -- vector @@ -2608,6 +2617,86 @@ -- | Render widgets inside the block using provided font. 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 -- diff --git a/src/DearImGui/Raw/DragDrop.hs b/src/DearImGui/Raw/DragDrop.hs --- a/src/DearImGui/Raw/DragDrop.hs +++ b/src/DearImGui/Raw/DragDrop.hs @@ -10,14 +10,24 @@ {-# 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 @@ -25,7 +35,7 @@ import Control.Monad.IO.Class ( MonadIO, liftIO ) import Foreign - ( Ptr, castPtr ) + ( Ptr, castPtr, nullPtr ) import Foreign.C -- dear-imgui @@ -44,38 +54,93 @@ 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() } |]