From 19b2f58d6f1e75acbd382f9150ea1c0bd8ae48b9 Mon Sep 17 00:00:00 2001
From: Doug Coleman <doug.coleman@gmail.com>
Date: Fri, 29 Mar 2019 19:41:59 -0500
Subject: [PATCH] windows: start of IDragSource.

Line 100 of ui.gadgets.pressentations has the object>> you are dragging
---
 .../presentations/presentations.factor        | 57 +++++++++++++++++--
 .../dragdrop-listener.factor                  | 19 ++++++-
 2 files changed, 71 insertions(+), 5 deletions(-)

diff --git a/basis/ui/gadgets/presentations/presentations.factor b/basis/ui/gadgets/presentations/presentations.factor
index b65ca9d074..8a9f004bc1 100644
--- a/basis/ui/gadgets/presentations/presentations.factor
+++ b/basis/ui/gadgets/presentations/presentations.factor
@@ -1,9 +1,12 @@
 ! Copyright (C) 2005, 2009 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: accessors kernel memoize namespaces ui.commands ui.gadgets
-ui.gadgets.borders ui.gadgets.buttons ui.gadgets.buttons.private
-ui.gadgets.glass ui.gadgets.menus ui.gadgets.status-bar
-ui.gadgets.worlds ui.gestures ui.operations ui.pens.solid ui.theme ;
+USING: accessors io io.encodings.string io.encodings.utf8 kernel
+libc literals memoize multiline namespaces prettyprint sequences
+system ui.commands ui.gadgets ui.gadgets.borders
+ui.gadgets.buttons ui.gadgets.buttons.private ui.gadgets.glass
+ui.gadgets.menus ui.gadgets.status-bar ui.gadgets.worlds
+ui.gestures ui.operations ui.pens.solid ui.theme
+windows.kernel32 ;
 IN: ui.gadgets.presentations
 
 TUPLE: presentation < button object hook ;
@@ -56,6 +59,51 @@ PRIVATE>
 M: presentation-menu hide-glass-hook
     presentation>> button-pen-boundary >>boundary drop ;
 
+SYMBOL: platform-drag-object
+
+HOOK: start-platform-drag os ( obj -- )
+
+M: object start-platform-drag
+    drop ;
+
+! TODO: move to windows
+! TODO: add a null?
+: string>global-alloc ( string -- alien )
+    flags{ GMEM_ZEROINIT GMEM_MOVEABLE } over length GlobalAlloc
+    [
+        [
+            ! TODO: CopyMemory instead? same thing?
+            swap utf8 encode dup length memcpy
+        ] with-global-lock
+    ] keep ;
+
+! check out: https://web.archive.org/web/20080514153357/http://www.catch22.net/tuts/dragdrop5.asp
+! TODO: move to windows
+M: windows start-platform-drag
+    [
+        ![[
+        platform-drag-object get [
+            [ "platform-drag-object already set" print flush ] with-global
+            drop
+        ] [
+            object>>
+            [ DoDragDrop ]
+            [ platform-drag-object set ]
+            [ . flush ] tri
+        ] if
+
+        flags{ DROPEFFECT_COPY DROPEFFECT_MOVE }
+        f
+        DoDragDrop
+
+        ]]
+        object>> unparse string>global-alloc drop
+        ! DoDragDrop
+        ! 
+
+        "start drag " write nano-count . flush
+    ] with-global ;
+
 presentation H{
     { T{ button-down f f 3 } [ show-presentation-menu ] }
     { mouse-leave [ [ hide-status ] [ button-update ] bi ] }
@@ -65,4 +113,5 @@ presentation H{
     ! nested presentation and is still inside the parent, the
     ! parent doesn't receive a mouse-enter
     { motion [ show-mouse-help ] }
+    { T{ drag f 1 } [ start-platform-drag ] }
 } set-gestures
diff --git a/basis/windows/dragdrop-listener/dragdrop-listener.factor b/basis/windows/dragdrop-listener/dragdrop-listener.factor
index 4250c37aab..dc7eba7f4d 100644
--- a/basis/windows/dragdrop-listener/dragdrop-listener.factor
+++ b/basis/windows/dragdrop-listener/dragdrop-listener.factor
@@ -1,7 +1,7 @@
 ! Copyright (C) 2008, 2009 Joe Groff, Slava Pestov.
 ! Copyright (C) 2017-2018 Alexander Ilin.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: accessors alien.accessors classes.struct kernel
+USING: accessors alien.accessors classes.struct io kernel math
 namespaces sequences ui.backend.windows ui.gadgets.worlds
 ui.gestures windows.com windows.com.wrapper windows.dropfiles
 windows.kernel32 windows.ole32 windows.user32 ;
@@ -40,6 +40,23 @@ SYMBOL: +listener-dragdrop-wrapper+
 
 <<
 {
+    { IDropSource {
+        [ ! HRESULT GiveFeedback ( DWORD dwEffect )
+            [ "GiveFeedback" print flush ] with-global
+            2drop DRAGDROP_S_USEDEFAULTCURSORS
+        ] [ ! HRESULT QueryContinueDrag ( BOOL fEscapePressed, DWORD grfKeyState )
+            [ "QueryContinueDrag" print flush ] with-global
+            over [
+                3drop DRAGDROP_S_CANCEL
+            ] [
+                2nip MK_LBUTTON MK_RBUTTON bitor bitand 0 > [
+                    DRAGDROP_S_DROP
+                ] [
+                    S_OK
+                ] if
+            ] if
+        ]
+    } }
     { IDropTarget {
         [ ! HRESULT DragEnter ( IDataObject* pDataObject, DWORD grfKeyState, POINTL pt, DWORD* pdwEffect )
             DROPEFFECT_COPY swap 0 set-alien-unsigned-4 3drop