racket/gui: add warp-pointer' to window<%>'

Removed the method from `canvas<%>', where it was never implemented
with the `racket/gui' reimplementation.

collects/mred/private/mrcanvas.rkt

@@ -28,7 +28,7 @@
   (interface (subwindow<%>)
     min-client-width min-client-height
     on-char on-event on-paint on-tab-in
-    warp-pointer get-dc
+    get-dc
     set-canvas-background get-canvas-background
     set-resize-corner))
 
@@ -44,9 +44,6 @@
     (define min-client-height (param (lambda () wx) min-client-height))
     (public min-client-width min-client-height)
 
-    (define warp-pointer (entry-point (lambda (x y) (send wx warp-pointer x y))))
-    (public warp-pointer)
-
     (define get-dc (entry-point (lambda () (send wx get-dc))))
     (public get-dc)
     (define/public (make-bitmap w h)

collects/mred/private/mrwindow.rkt

@@ -105,6 +105,7 @@
       get-client-size get-size get-width get-height get-x get-y
       get-cursor set-cursor popup-menu
       show is-shown? on-superwindow-show refresh
+      warp-pointer
       get-handle get-client-handle))
 
   (define subwindow<%> 
@@ -205,6 +206,10 @@
        [get-cursor (lambda () cursor)]
        [set-cursor (entry-point
                     (lambda (x)
+                      (unless (or (not x) (x . is-a? . wx:cursor%))
+                        (raise-argument-error (who->name '(method window<%> set-cursor))
+                                              "(or/c (is-a?/c cursor%) #f)"
+                                              x))
                       (send wx set-cursor x)
                       (set! cursor x)))]
 
@@ -221,7 +226,13 @@
        [on-superwindow-show (lambda (visible?) (void))]
        [on-superwindow-enable (lambda (active?) (void))]
 
-       [refresh (entry-point (lambda () (send wx refresh)))])
+       [refresh (entry-point (lambda () (send wx refresh)))]
+       
+       [warp-pointer (entry-point (lambda (x y) 
+                                    (let ([who '(method window<%> warp-pointer)])
+                                      (check-init-pos-integer who x)
+                                      (check-init-pos-integer who y))
+                                    (send wx warp-pointer x y)))])
       (define wx #f)
       (super-make-object (lambda () (set! wx (mk-wx)) wx) get-wx-panel get-outer-wx-panel mismatches parent)
       (unless enabled (enable #f)))))

collects/mred/private/wx/cocoa/canvas.rkt

@@ -790,8 +790,6 @@
          (when (y . >= . 0) (scroll-pos v-scroller (floor (* y (scroll-range v-scroller)))))
          (refresh-for-autoscroll)))
 
-     (define/public (warp-pointer x y) (void))
-
      (define/override (get-virtual-h-pos)
        (scroll-pos h-scroller))
 

collects/mred/private/wx/cocoa/window.rkt

@@ -451,6 +451,9 @@
 
 (define-cocoa NSFilenamesPboardType _id)
 
+(define _CGError _int32)
+(define-appserv CGWarpMouseCursorPosition (_fun _NSPoint -> _CGError))
+
 (define window%
   (class object%
     (init-field parent 
@@ -887,6 +890,12 @@
     (define/public (get-saved-marked) saved-marked)
     (define/public (get-saved-selected) saved-sel)
 
+    (define/public (warp-pointer x y)
+      (define xb (box x))
+      (define yb (box y))
+      (client-to-screen xb yb)
+      (void (CGWarpMouseCursorPosition (make-NSPoint (unbox xb) (unbox yb)))))
+
     (define/private (create-compose-window)
       (unless compose-cocoa
         (set! compose-cocoa (tell (tell InputMethodPanel alloc)

collects/mred/private/wx/gtk/canvas.rkt

@@ -757,8 +757,6 @@
                         (gtk_adjustment_get_page_size vscroll-adj))))))))
          (refresh-for-autoscroll)))
 
-     (define/public (warp-pointer x y) (void))
-
      (define/override (get-virtual-h-pos)
        (inexact->exact (ceiling (gtk_adjustment_get_value hscroll-adj))))
      (define/override (get-virtual-v-pos)

collects/mred/private/wx/gtk/window.rkt

@@ -70,6 +70,10 @@
 
 (define-gdk gdk_keyval_to_unicode (_fun _uint -> _uint32))
 
+(define-gtk gtk_widget_get_display (_fun _GtkWidget -> _GdkDisplay))
+(define-gtk gtk_widget_get_screen (_fun _GtkWidget -> _GdkScreen))
+(define-gdk gdk_display_warp_pointer (_fun _GdkDisplay _GdkScreen _int _int -> _void))
+
 (define-cstruct _GtkRequisition ([width _int]
                                  [height _int]))
 (define-cstruct _GtkAllocation ([x _int]
@@ -733,6 +737,15 @@
     (define/public (get-client-delta)
       (values 0 0))
 
+    (define/public (warp-pointer x y)
+      (define xb (box x))
+      (define yb (box y))
+      (client-to-screen xb yb)
+      (gdk_display_warp_pointer (gtk_widget_get_display gtk)
+                                (gtk_widget_get_screen gtk)
+                                (unbox xb)
+                                (unbox yb)))
+
     (define/public (gets-focus?) #t)))
 
 (define (queue-window-event win thunk)

collects/mred/private/wx/win32/canvas.rkt

@@ -569,8 +569,6 @@
                            (->long (* y (get-real-scroll-range 'vertical)))))
          (refresh-for-autoscroll)))
 
-     (define/public (warp-pointer x y) (void))
-
      (define/public (set-resize-corner on?)
        (void))
 

collects/mred/private/wx/win32/window.rkt

@@ -70,10 +70,12 @@
 (define-user32 SetCapture (_wfun _HWND -> _HWND))
 (define-user32 ReleaseCapture (_wfun -> _BOOL))
 
-(define-user32 WindowFromPoint (_fun _POINT -> _HWND))
-(define-user32 GetParent (_fun _HWND -> _HWND))
-(define-user32 SetParent (_fun _HWND _HWND -> (r : _HWND)
-                               -> (unless r (failed 'SetParent))))
+(define-user32 WindowFromPoint (_wfun _POINT -> _HWND))
+(define-user32 GetParent (_wfun _HWND -> _HWND))
+(define-user32 SetParent (_wfun _HWND _HWND -> (r : _HWND)
+                                -> (unless r (failed 'SetParent))))
+
+(define-user32 SetCursorPos (_wfun _int _int -> _BOOL))
 
 (define-cstruct _NMHDR
   ([hwndFrom _HWND]
@@ -440,6 +442,12 @@
       (set-box! x (POINT-x p))
       (set-box! y (POINT-y p))))
 
+  (define/public (warp-pointer x y)
+    (define xb (box x))
+    (define yb (box y))
+    (client-to-screen xb yb)
+    (void (SetCursorPos (unbox xb) (unbox yb))))
+
   (define/public (in-content? p)
     (ScreenToClient (get-client-hwnd) p)
     (let ([r (GetClientRect (get-client-hwnd))])

collects/scribblings/gui/canvas-intf.scrbl

@@ -292,12 +292,5 @@ See @racket[canvas<%>] for information on canvas flushing.
 Beware that suspending flushing for a canvas can discourage refreshes
 for other windows in the same frame on some platforms.}
 
-
-@defmethod[(warp-pointer [x (integer-in 0 10000)]
-                         [y (integer-in 0 10000)])
-           void?]{
-Moves the cursor to the given location on the canvas.
-
-}
 }
 

collects/scribblings/gui/window-intf.scrbl

@@ -576,5 +576,12 @@ window is shown.
 
 }
 
+@defmethod[(warp-pointer [x (integer-in -10000 10000)]
+                         [y (integer-in -10000 10000)])
+           void?]{
+Moves the cursor to the given location in the window's local coordinates.
+
+}
+
 }
 

doc/release-notes/racket/HISTORY.txt

@@ -9,6 +9,8 @@ scribble/srcdoc: added begin-for-doc
 syntax-color: added special support for dont-stop values;
  this change is backwards incompatible for code that calls
  lexers and may call unknown lexers
+racket/gui/base: moved warp-pointer from canvas<%> to
+ window<%> and restored its functionality
 
 Version 5.3.3.6
 Added "phase-collapse" module inference and instantiation