From 59242cf93bdb8eaa805f5c2b0241e9a1cba9a70f Mon Sep 17 00:00:00 2001
From: Joey Hess <joeyh@joeyh.name>
Date: Sun, 28 May 2017 19:04:03 -0400
Subject: [PATCH] expose drag-and-drop clientX and clientY

Available in all drag and drop events except for dragEnd.

Closes https://github.com/HeinrichApfelmus/threepenny-gui/issues/189
---
 js/lib.js                               |  4 +--
 samples/DragNDropExample.hs             |  2 +-
 src/Graphics/UI/Threepenny/DragNDrop.hs | 36 ++++++++++++++-----------
 3 files changed, 23 insertions(+), 19 deletions(-)

diff --git a/js/lib.js b/js/lib.js
index 563b592c..48635dd8 100644
--- a/js/lib.js
+++ b/js/lib.js
@@ -31,8 +31,8 @@ Haskell.bind = function (el, eventType, fun) {
   } else if (eventType.match('dragstart|dragenter|dragover|dragleave|drag|drop|dragend')) {
     $(el).bind(eventType, function(e) {
       fun( e.originalEvent.dataTransfer
-            ? [e.originalEvent.dataTransfer.getData("dragData")]
-            : [] );
+            ? [e.clientX.toString(), e.clientY.toString(), e.originalEvent.dataTransfer.getData("dragData")]
+            : [e.clientX.toString(), e.clientY.toString()] );
     });
   } else if(eventType.match('contextmenu|mousemove|mousedown|mouseup')) {
     $(el).bind(eventType, function(e) {
diff --git a/samples/DragNDropExample.hs b/samples/DragNDropExample.hs
index d917c824..8c60dfdf 100644
--- a/samples/DragNDropExample.hs
+++ b/samples/DragNDropExample.hs
@@ -52,7 +52,7 @@ mkDragPair color position = do
                 # set text ""
                 # set UI.droppable False
 
-    on UI.drop elDrop $ \color' -> when (color == color') $ void $ do
+    on UI.drop elDrop $ \(color', (_x, _y)) -> when (color == color') $ void $ do
         liftIO $ writeIORef dropSuccess True
         delete elDrag
         element elDrop
diff --git a/src/Graphics/UI/Threepenny/DragNDrop.hs b/src/Graphics/UI/Threepenny/DragNDrop.hs
index 7b3c1a68..6d4605be 100644
--- a/src/Graphics/UI/Threepenny/DragNDrop.hs
+++ b/src/Graphics/UI/Threepenny/DragNDrop.hs
@@ -70,41 +70,45 @@ droppable = mkWriteAttr enable
 -- Change this to 'Maybe String' instead.
 type DragData = String
 
-withDragData = fmap (extract . unsafeFromJSON)
+-- | Coordinate within the application's client area at which an event
+-- occurred.
+type ClientXY = (Int, Int)
+
+withDragDataClientXY = fmap (extract . unsafeFromJSON)
     where
-    extract [s] = s
-    extract _   = ""
+    extract [x, y, s] = (s,  (read x, read y))
+    extract [x, y]    = ("", (read x, read y))
 
 -- | Occurs periodically while the element is being dragged around.
-drag :: Element -> Event DragData
-drag = withDragData . domEvent "drag"
+drag :: Element -> Event (DragData, ClientXY)
+drag = withDragDataClientXY . domEvent "drag"
 
 -- | Dragging the element starts.
-dragStart :: Element -> Event DragData
-dragStart = withDragData . domEvent "dragstart"
+dragStart :: Element -> Event (DragData, ClientXY)
+dragStart = withDragDataClientXY . domEvent "dragstart"
 
 -- | Dragging the element ends.
 --
 -- WARNING: This event can occur both before and after a corresponding 'drop' event.
 dragEnd :: Element -> Event DragData
-dragEnd = withDragData . domEvent "dragend"
+dragEnd = fmap fst . withDragDataClientXY . domEvent "dragend"
 
 -- | The element is now the current target element for a 'drop'.
 -- 
 -- WARNING: This element is buggy when moving the mouse over child elements.
-dragEnter :: Element -> Event DragData
-dragEnter = withDragData . domEvent "dragenter"
+dragEnter :: Element -> Event (DragData, ClientXY)
+dragEnter = withDragDataClientXY . domEvent "dragenter"
 
 -- | Occurs periodically while the element is the current target element.
-dragOver :: Element -> Event DragData
-dragOver = withDragData . domEvent "dragover"
+dragOver :: Element -> Event (DragData, ClientXY)
+dragOver = withDragDataClientXY . domEvent "dragover"
 
 -- | The element is no longer the current target element for a 'drop'.
 --
 -- WARNING: This event is also fired when the mouse is moved over a child element.
-dragLeave :: Element -> Event DragData
-dragLeave = withDragData . domEvent "dragleave"
+dragLeave :: Element -> Event (DragData, ClientXY)
+dragLeave = withDragDataClientXY . domEvent "dragleave"
 
 -- | The drag and drop operation is being completed on this element.
-drop :: Element -> Event DragData
-drop = withDragData . domEvent "drop"
+drop :: Element -> Event (DragData, ClientXY)
+drop = withDragDataClientXY . domEvent "drop"