From 40c1c2ffef5f5ee4972ac6ef98b050e13cd8ab34 Mon Sep 17 00:00:00 2001
From: Matthew Flatt <mflatt@racket-lang.org>
Date: Tue, 17 Aug 2010 10:49:53 -0600
Subject: [PATCH] cocoa cursors

---
 collects/drracket/private/unit.rkt            |  4 +-
 collects/mred/private/kernel.rkt              |  5 +-
 collects/mred/private/wx/cocoa/button.rkt     |  2 +-
 collects/mred/private/wx/cocoa/canvas.rkt     | 14 ++-
 collects/mred/private/wx/cocoa/choice.rkt     |  2 +-
 collects/mred/private/wx/cocoa/cursor.rkt     | 88 ++++++++++++++++---
 collects/mred/private/wx/cocoa/frame.rkt      | 41 ++++++++-
 collects/mred/private/wx/cocoa/gauge.rkt      |  2 +-
 .../mred/private/wx/cocoa/group-panel.rkt     |  4 +-
 collects/mred/private/wx/cocoa/list-box.rkt   |  2 +-
 collects/mred/private/wx/cocoa/message.rkt    |  4 +-
 collects/mred/private/wx/cocoa/panel.rkt      |  6 +-
 collects/mred/private/wx/cocoa/platform.rkt   |  3 -
 collects/mred/private/wx/cocoa/procs.rkt      |  8 --
 collects/mred/private/wx/cocoa/radio-box.rkt  |  2 +-
 collects/mred/private/wx/cocoa/slider.rkt     |  2 +-
 collects/mred/private/wx/cocoa/tab-panel.rkt  |  3 +-
 collects/mred/private/wx/cocoa/window.rkt     | 39 +++++++-
 collects/mred/private/wx/common/cursor.rkt    |  3 +
 collects/mred/private/wx/common/local.rkt     |  6 +-
 collects/mred/private/wx/common/queue.rkt     | 40 ++++++++-
 collects/mred/private/wx/gtk/frame.rkt        |  3 +
 collects/mred/private/wx/gtk/platform.rkt     |  3 -
 collects/mred/private/wx/gtk/procs.rkt        |  8 --
 collects/mred/private/wx/platform.rkt         |  3 -
 collects/mred/private/wx/win32/platform.rkt   |  3 -
 collects/mred/private/wx/win32/procs.rkt      |  3 -
 collects/mred/private/wxlitem.rkt             | 14 +--
 collects/tests/gracket/item.rkt               |  2 +-
 29 files changed, 242 insertions(+), 77 deletions(-)

diff --git a/collects/drracket/private/unit.rkt b/collects/drracket/private/unit.rkt
index 786601645c..30f7a903d7 100644
--- a/collects/drracket/private/unit.rkt
+++ b/collects/drracket/private/unit.rkt
@@ -4158,8 +4158,8 @@ module browser threading seems wrong.
         (define/override (on-event evt)
           (let-values ([(w h) (get-client-size)])
             (let ([new-inside?
-                   (and (<= 0 (send evt get-x) w)
-                        (<= 0 (send evt get-y) h))]
+                   (and (< 0 (send evt get-x) w)
+                        (< 0 (send evt get-y) h))]
                   [old-inside? inside?])
               (set! inside? new-inside?)
               (cond
diff --git a/collects/mred/private/kernel.rkt b/collects/mred/private/kernel.rkt
index 419c640824..114af2bf0a 100644
--- a/collects/mred/private/kernel.rkt
+++ b/collects/mred/private/kernel.rkt
@@ -34,4 +34,7 @@
          eventspace-handler-thread
          queue-callback
          middle-queue-key
-         get-top-level-windows)
+         get-top-level-windows
+         begin-busy-cursor
+         is-busy?
+         end-busy-cursor)
diff --git a/collects/mred/private/wx/cocoa/button.rkt b/collects/mred/private/wx/cocoa/button.rkt
index 924df485b8..93e87017f7 100644
--- a/collects/mred/private/wx/cocoa/button.rkt
+++ b/collects/mred/private/wx/cocoa/button.rkt
@@ -24,7 +24,7 @@
 (define MIN-BUTTON-WIDTH 72)
 
 (define-objc-class MyButton NSButton
-  #:mixins (FocusResponder KeyMouseResponder)
+  #:mixins (FocusResponder KeyMouseResponder CursorDisplayer)
   [wxb]
   (-a _void (clicked: [_id sender])
       (queue-window*-event wxb (lambda (wx) (send wx clicked)))))
diff --git a/collects/mred/private/wx/cocoa/canvas.rkt b/collects/mred/private/wx/cocoa/canvas.rkt
index 99598d44a1..9e7dff5d0b 100644
--- a/collects/mred/private/wx/cocoa/canvas.rkt
+++ b/collects/mred/private/wx/cocoa/canvas.rkt
@@ -47,7 +47,7 @@
             (tellv ctx restoreGraphicsState)))))))
 
 (define-objc-class MyView NSView 
-  #:mixins (FocusResponder KeyMouseResponder) 
+  #:mixins (FocusResponder KeyMouseResponder CursorDisplayer) 
   [wxb]
   (-a _void (drawRect: [_NSRect r])
       (when wxb
@@ -127,7 +127,7 @@
           (tellv ctx restoreGraphicsState)))))
 
 (define-objc-class MyComboBox NSComboBox
-  #:mixins (FocusResponder KeyMouseResponder) 
+  #:mixins (FocusResponder KeyMouseResponder CursorDisplayer) 
   #:protocols (NSComboBoxDelegate)
   [wxb]
   (-a _void (drawRect: [_NSRect r])
@@ -172,7 +172,8 @@
              move get-x get-y
              on-size
              register-as-child
-             get-size get-position)
+             get-size get-position
+             set-focus)
 
     (define vscroll-ok? (and (memq 'vscroll style) #t))
     (define vscroll? vscroll-ok?)
@@ -607,6 +608,10 @@
     
     (define/override (definitely-wants-event? e) 
       ;; Called in Cocoa event-handling mode
+      (when (and is-combo?
+                 (e . is-a? . mouse-event%)
+                 (send e button-down? 'left))
+        (set-focus))
       (or (not is-combo?)
           (e . is-a? . key-event%)
           (not (send e button-down? 'left))
@@ -670,6 +675,9 @@
       (when is-combo?
         (set-box! xb (- (unbox xb) 22))))
 
+    (define/override (get-cursor-width-delta)
+      (if is-combo? 22 0))
+
     (define/public (is-flipped?)
       (tell #:type _BOOL (get-cocoa-content) isFlipped))
 
diff --git a/collects/mred/private/wx/cocoa/choice.rkt b/collects/mred/private/wx/cocoa/choice.rkt
index b8dab3b95a..d9caac07a8 100644
--- a/collects/mred/private/wx/cocoa/choice.rkt
+++ b/collects/mred/private/wx/cocoa/choice.rkt
@@ -19,7 +19,7 @@
 (import-class NSPopUpButton)
 
 (define-objc-class MyPopUpButton NSPopUpButton 
-  #:mixins (FocusResponder KeyMouseResponder)
+  #:mixins (FocusResponder KeyMouseResponder CursorDisplayer)
   [wxb]
   (-a _void (clicked: [_id sender])
       (queue-window*-event wxb (lambda (wx) (send wx clicked)))))
diff --git a/collects/mred/private/wx/cocoa/cursor.rkt b/collects/mred/private/wx/cocoa/cursor.rkt
index 6854f2804f..c323533342 100644
--- a/collects/mred/private/wx/cocoa/cursor.rkt
+++ b/collects/mred/private/wx/cocoa/cursor.rkt
@@ -1,14 +1,53 @@
-#lang scheme/base
-(require ffi/objc
-         scheme/foreign
-         scheme/class)
-(unsafe!)
-(objc-unsafe!)
+#lang racket/base
+(require ffi/unsafe
+         ffi/unsafe/objc
+         racket/class
+         racket/draw
+         "image.rkt"
+         "types.rkt"
+         "../common/local.rkt")
 
-(provide cursor-driver%)
+(provide cursor-driver%
+         arrow-cursor-handle
+         get-wait-cursor-handle)
 
 (import-class NSCursor)
 
+(define wait #f)
+(define bullseye #f)
+(define blank #f)
+(define size-ne/sw #f)
+(define size-nw/se #f)
+
+(define-syntax-rule (image-cursor id draw-proc)
+  (or id
+      (begin
+        (set! id (make-image-cursor draw-proc))
+        id)))
+
+(define (make-image-cursor draw-proc)
+  (let* ([bm (make-object bitmap% 16 16 #f #t)]
+         [dc (make-object bitmap-dc% bm)])
+    (send dc set-smoothing 'aligned)
+    (draw-proc dc 16 16)
+    (send dc set-bitmap #f)
+    (let ([image (bitmap->image bm)])
+      (tell (tell NSCursor alloc)
+            initWithImage: image
+            hotSpot: #:type _NSPoint (make-NSPoint 8 8)))))
+
+(define arrow-cursor-handle (tell NSCursor arrowCursor))
+(define (get-wait-cursor-handle)
+  (image-cursor wait
+                (lambda (dc w h)
+                  (send dc set-brush "black" 'solid)
+                  (send dc draw-rectangle 5 0 6 4)
+                  (send dc draw-rectangle 5 12 6 4)
+                  (send dc set-brush "white" 'solid)
+                  (send dc draw-ellipse 3 3 10 10)
+                  (send dc draw-line 7 5 7 8)
+                  (send dc draw-line 7 8 9 8))))
+
 (define cursor-driver% 
   (class object%
     (define handle #f)
@@ -16,7 +55,7 @@
     (define/public (set-standard sym)
       (case sym
         [(arrow)
-         (set! handle (tell NSCursor arrowCursor))]
+         (set! handle arrow-cursor-handle)]
         [(cross)
          (set! handle (tell NSCursor crosshairCursor))]
         [(hand)
@@ -26,9 +65,38 @@
         [(size-n/s)
          (set! handle (tell NSCursor resizeUpDownCursor))]
         [(size-e/w)
-         (set! handle (tell NSCursor resizeLeftRightCursor))]))
+         (set! handle (tell NSCursor resizeLeftRightCursor))]
+        [(size-nw/se)
+         (set! handle
+               (image-cursor size-nw/se (lambda (dc w h)
+                                          (send dc draw-line 0 16 16 0)
+                                          (send dc draw-line 0 0 16 16)
+                                          (send dc draw-line 0 3 0 0)
+                                          (send dc draw-line 0 0 3 0)
+                                          (send dc draw-line 12 15 15 15)
+                                          (send dc draw-line 15 15 15 12))))]
+        [(size-ne/sw)
+         (set! handle
+               (image-cursor size-ne/sw (lambda (dc w h)
+                                          (send dc draw-line 0 16 16 0)
+                                          (send dc draw-line 0 0 16 16)
+                                          (send dc draw-line 12 0 15 0)
+                                          (send dc draw-line 15 0 15 3)
+                                          (send dc draw-line 0 12 0 15)
+                                          (send dc draw-line 0 15 3 15))))]
+        [(watch)
+         (set! handle (get-wait-cursor-handle))]
+        [(bullseye)
+         (set! handle
+               (image-cursor bullseye (lambda (dc w h)
+                                        (send dc draw-ellipse 1 1 (- w 2) (- h 2))
+                                        (send dc draw-ellipse 4 4 (- w 8) (- h 8))
+                                        (send dc draw-ellipse 7 7 2 2))))]
+        [(blank)
+         (set! handle (image-cursor blank void))]))
     
     (define/public (ok?) (and handle #t))
 
-    (super-new)))
+    (define/public (get-handle) handle)
 
+    (super-new)))
diff --git a/collects/mred/private/wx/cocoa/frame.rkt b/collects/mred/private/wx/cocoa/frame.rkt
index d4f00a6db3..3c95a7b969 100644
--- a/collects/mred/private/wx/cocoa/frame.rkt
+++ b/collects/mred/private/wx/cocoa/frame.rkt
@@ -9,6 +9,7 @@
          "window.rkt"
          "queue.rkt"
          "menu-bar.rkt"
+         "cursor.rkt"
          "../../syntax.rkt"
          "../common/queue.rkt"
          "../../lock.rkt")
@@ -59,6 +60,7 @@
         (let ([wx (->wx wxb)])
           (when wx
             (set! front wx)
+            (send wx install-wait-cursor)
             (send wx install-mb)
             (send wx notify-responder #t)
             (queue-window-event wx (lambda ()
@@ -67,7 +69,9 @@
       (when wxb
         (let ([wx (->wx wxb)])
           (when wx
-            (when (eq? front wx) (set! front #f))
+            (when (eq? front wx) 
+              (set! front #f)
+              (send wx uninstall-wait-cursor))
             (send empty-mb install)
             (send wx notify-responder #f)
             (queue-window-event wx (lambda ()
@@ -237,8 +241,11 @@
                   [next (tellv next makeKeyWindow)]
                   [root-fake-frame (send root-fake-frame install-mb)]
                   [else (void)]))))
-         (register-frame-shown this on?))))
-
+         (register-frame-shown this on?)
+         (when on?
+           (let ([b (eventspace-wait-cursor-count (get-eventspace))])
+             (set-wait-cursor-mode (not (zero? b))))))))
+    
     (define/override (show on?)
       (when on?
         (when (eventspace-shutdown? (get-eventspace))
@@ -267,6 +274,17 @@
     (define is-main? #f)
     (define first-responder #f)
 
+    (define saved-child #f)
+    (define/override (register-child child on?)
+      (unless on? (error 'register-child-in-frame "did not expect #f"))
+      (unless (or (not saved-child) (eq? child saved-child))
+        (error 'register-child-in-frame "expected only one child"))
+      (set! saved-child child))
+
+    (define/override (set-cursor c)
+      (when saved-child
+        (send saved-child set-cursor c)))
+
     (define/public (notify-responder on?)
       (set! is-main? on?)
       (when first-responder
@@ -286,6 +304,23 @@
       (when is-main?
         (do-notify-responder wx on?)))
 
+    (define/public (install-wait-cursor)
+      (when (positive? (eventspace-wait-cursor-count (get-eventspace)))
+        (tellv (get-wait-cursor-handle) set)))
+
+    (define/public (uninstall-wait-cursor)
+      (when (positive? (eventspace-wait-cursor-count (get-eventspace)))
+        (tellv arrow-cursor-handle set)))
+
+    (define/public (set-wait-cursor-mode on?)
+      (if on?
+          (tell cocoa disableCursorRects)
+          (tell cocoa enableCursorRects))
+      (when (eq? this front)
+        (if on?
+            (install-wait-cursor)
+            (uninstall-wait-cursor))))
+
     (define/public (flip-screen y)
       (let ([f (tell #:type _NSRect (tell cocoa screen) frame)])
         (- (NSSize-height (NSRect-size f)) y)))
diff --git a/collects/mred/private/wx/cocoa/gauge.rkt b/collects/mred/private/wx/cocoa/gauge.rkt
index 04be129449..d4eeb201b0 100644
--- a/collects/mred/private/wx/cocoa/gauge.rkt
+++ b/collects/mred/private/wx/cocoa/gauge.rkt
@@ -19,7 +19,7 @@
 (import-class NSProgressIndicator)
 
 (define-objc-class MyProgressIndicator NSProgressIndicator
-  #:mixins (KeyMouseResponder)
+  #:mixins (KeyMouseResponder CursorDisplayer)
   [wxb])
 
 (defclass gauge% item%
diff --git a/collects/mred/private/wx/cocoa/group-panel.rkt b/collects/mred/private/wx/cocoa/group-panel.rkt
index 0b367e474c..8c70afe1cc 100644
--- a/collects/mred/private/wx/cocoa/group-panel.rkt
+++ b/collects/mred/private/wx/cocoa/group-panel.rkt
@@ -15,7 +15,7 @@
 (import-class NSBox)
 
 (define-objc-class MyBox NSBox
-  #:mixins (FocusResponder KeyMouseResponder)
+  #:mixins (FocusResponder KeyMouseResponder CursorDisplayer)
   [wxb])
 
 (defclass group-panel% (panel-mixin window%)
@@ -37,6 +37,8 @@
 
   (define/override (get-cocoa-content) 
     (tell (get-cocoa) contentView))
+  (define/override (get-cocoa-cursor-content) 
+    (get-cocoa))
 
   (define/public (set-label l)
     (tellv (get-cocoa) setTitle: #:type _NSString l)))
diff --git a/collects/mred/private/wx/cocoa/list-box.rkt b/collects/mred/private/wx/cocoa/list-box.rkt
index 6b86fd009e..ea9ee5623d 100644
--- a/collects/mred/private/wx/cocoa/list-box.rkt
+++ b/collects/mred/private/wx/cocoa/list-box.rkt
@@ -22,7 +22,7 @@
 (import-protocol NSTableViewDataSource)
 
 (define-objc-class MyTableView NSTableView
-  #:mixins (FocusResponder KeyMouseResponder)
+  #:mixins (FocusResponder KeyMouseResponder CursorDisplayer)
   [wxb]
   [-a _id (preparedCellAtColumn: [_NSInteger column] row: [_NSInteger row])
       (let ([wx (->wx wxb)])
diff --git a/collects/mred/private/wx/cocoa/message.rkt b/collects/mred/private/wx/cocoa/message.rkt
index 0fce8fc5eb..1f2510da77 100644
--- a/collects/mred/private/wx/cocoa/message.rkt
+++ b/collects/mred/private/wx/cocoa/message.rkt
@@ -32,11 +32,11 @@
               "NSApplicationPath")))
 
 (define-objc-class MyTextField NSTextField
-  #:mixins (FocusResponder KeyMouseResponder)
+  #:mixins (FocusResponder KeyMouseResponder CursorDisplayer)
   [wxb])
 
 (define-objc-class MyImageView NSImageView
-  #:mixins (FocusResponder KeyMouseResponder)
+  #:mixins (FocusResponder KeyMouseResponder CursorDisplayer)
   [wxb])
 
 (defclass message% item%
diff --git a/collects/mred/private/wx/cocoa/panel.rkt b/collects/mred/private/wx/cocoa/panel.rkt
index 5602219ac5..ec461c46e9 100644
--- a/collects/mred/private/wx/cocoa/panel.rkt
+++ b/collects/mred/private/wx/cocoa/panel.rkt
@@ -14,6 +14,10 @@
 
 (import-class NSView)
 
+(define-objc-class MyPanelView NSView
+  #:mixins (CursorDisplayer)
+  [wxb])
+
 (define (panel-mixin %)
   (class %
     (inherit register-as-child)
@@ -61,7 +65,7 @@
   (super-new [parent parent]
              [cocoa
               (as-objc-allocation
-               (tell (tell NSView alloc)
+               (tell (tell MyPanelView alloc)
                      initWithFrame: #:type _NSRect (make-NSRect (make-init-point x y)
                                                                 (make-NSSize w h))))]
              [no-show? (memq 'deleted style)]))
diff --git a/collects/mred/private/wx/cocoa/platform.rkt b/collects/mred/private/wx/cocoa/platform.rkt
index 77bc402c39..f6e408e8d8 100644
--- a/collects/mred/private/wx/cocoa/platform.rkt
+++ b/collects/mred/private/wx/cocoa/platform.rkt
@@ -61,9 +61,6 @@
    file-selector
    is-color-display?
    get-display-depth
-   begin-busy-cursor
-   is-busy?
-   end-busy-cursor
    has-x-selection?
    hide-cursor
    bell
diff --git a/collects/mred/private/wx/cocoa/procs.rkt b/collects/mred/private/wx/cocoa/procs.rkt
index e9e66c15dd..2b4cc3db7a 100644
--- a/collects/mred/private/wx/cocoa/procs.rkt
+++ b/collects/mred/private/wx/cocoa/procs.rkt
@@ -49,9 +49,6 @@
  display-size
  bell
  hide-cursor
- end-busy-cursor
- is-busy?
- begin-busy-cursor
  get-display-depth
  is-color-display?
  file-selector
@@ -113,11 +110,6 @@
 (define (hide-cursor) 
   (tellv NSCursor setHiddenUntilMouseMoves: #:type _BOOL #t))
 
-(define busy-count 0)
-(define (end-busy-cursor) (atomically (set! busy-count (add1 busy-count))))
-(define (is-busy?) (positive? busy-count))
-(define (begin-busy-cursor) (atomically (set! busy-count (sub1 busy-count))))
-
 (define (get-display-depth) 32)
 (define-unimplemented is-color-display?)
 (define-unimplemented file-selector)
diff --git a/collects/mred/private/wx/cocoa/radio-box.rkt b/collects/mred/private/wx/cocoa/radio-box.rkt
index 95b1ef4667..364e116943 100644
--- a/collects/mred/private/wx/cocoa/radio-box.rkt
+++ b/collects/mred/private/wx/cocoa/radio-box.rkt
@@ -24,7 +24,7 @@
 (define NSListModeMatrix 2)
 
 (define-objc-class MyMatrix NSMatrix
-  #:mixins (FocusResponder KeyMouseResponder)
+  #:mixins (FocusResponder KeyMouseResponder CursorDisplayer)
   [wxb]
   (-a _void (clicked: [_id sender])
       (queue-window*-event wxb (lambda (wx) (send wx clicked)))))
diff --git a/collects/mred/private/wx/cocoa/slider.rkt b/collects/mred/private/wx/cocoa/slider.rkt
index 19f086bb67..7af719fb12 100644
--- a/collects/mred/private/wx/cocoa/slider.rkt
+++ b/collects/mred/private/wx/cocoa/slider.rkt
@@ -22,7 +22,7 @@
 (import-class NSSlider)
 
 (define-objc-class MySlider NSSlider
-  #:mixins (FocusResponder KeyMouseResponder)
+  #:mixins (FocusResponder KeyMouseResponder CursorDisplayer)
   [wxb]
   (-a _void (changed: [_id sender])
       (let ([wx (->wx wxb)])
diff --git a/collects/mred/private/wx/cocoa/tab-panel.rkt b/collects/mred/private/wx/cocoa/tab-panel.rkt
index cad55b788d..58beb5f6a1 100644
--- a/collects/mred/private/wx/cocoa/tab-panel.rkt
+++ b/collects/mred/private/wx/cocoa/tab-panel.rkt
@@ -18,7 +18,7 @@
 (import-protocol NSTabViewDelegate)
 
 (define-objc-class MyTabView NSTabView
-  #:mixins (FocusResponder KeyMouseResponder)
+  #:mixins (FocusResponder KeyMouseResponder CursorDisplayer)
   #:protocols (NSTabViewDelegate)
   [wxb]
   (-a _void (tabView: [_id cocoa] didSelectTabViewItem: [_id item-cocoa])
@@ -51,6 +51,7 @@
   (tell #:type _void cocoa addSubview: content-cocoa)
 
   (define/override (get-cocoa-content) content-cocoa)
+  (define/override (get-cocoa-cursor-content) cocoa)
   (define/override (set-size x y w h)
     (super set-size x y w h)
     (tellv content-cocoa setFrame: #:type _NSRect (tell #:type _NSRect cocoa contentRect)))
diff --git a/collects/mred/private/wx/cocoa/window.rkt b/collects/mred/private/wx/cocoa/window.rkt
index 059e1492c2..70caeb77c1 100644
--- a/collects/mred/private/wx/cocoa/window.rkt
+++ b/collects/mred/private/wx/cocoa/window.rkt
@@ -8,6 +8,8 @@
          "types.rkt"
          "keycode.rkt"
          "pool.rkt"
+         "cursor.rkt"
+         "../common/local.rkt"
          "../../lock.rkt"
          "../common/event.rkt"
          "../common/queue.rkt"
@@ -20,6 +22,7 @@
 
          FocusResponder
          KeyMouseResponder
+         CursorDisplayer
 
          queue-window-event
          queue-window*-event
@@ -107,6 +110,13 @@
           (queue-window-event wx (lambda ()
                                    (send wx key-event-as-string str)))))])
 
+(define-objc-mixin (CursorDisplayer Superclass)
+  [wxb]
+  [-a _void (resetCursorRects)
+      (let ([wx (->wx wxb)])
+        (when wx
+          (send wx reset-cursor-rects)))])
+
 (define (do-key-event wxb event)
   (let ([wx (->wx wxb)])
     (and
@@ -205,6 +215,7 @@
 
     (define/public (get-cocoa) cocoa)
     (define/public (get-cocoa-content) cocoa)
+    (define/public (get-cocoa-cursor-content) (get-cocoa-content))
     (define/public (get-cocoa-window) (send parent get-cocoa-window))
     (define/public (get-wx-window) (send parent get-wx-window))
 
@@ -314,8 +325,8 @@
         (set-box! h (->long (NSSize-height s)))))
 
     (define/public (set-size x y w h)
-      (let ([x (if (= x -11111) 0 x)]
-            [y (if (= y -11111) 0 y)])
+      (let ([x (if (= x -11111) (get-x) x)]
+            [y (if (= y -11111) (get-y) y)])
         (tellv cocoa setFrame: #:type _NSRect (make-NSRect (make-NSPoint x (flip y h))
                                                            (make-NSSize w h)))))
     (define/public (move x y)
@@ -409,8 +420,28 @@
       
     (def/public-unimplemented fit)
 
-    (define/public (set-cursor c) (void))
-
+    (define cursor-handle #f)
+    (define/public (set-cursor c)
+      (let ([h (if c
+                   (send (send c get-driver) get-handle)
+                   #f)])
+        (unless (eq? h cursor-handle)
+          (atomically
+           (set! cursor-handle h)
+           (tellv (get-cocoa-window) invalidateCursorRectsForView: (get-cocoa-cursor-content))))))
+    (define/public (reset-cursor-rects)
+      ;; called in event-pump thread
+      (when cursor-handle
+        (let ([content (get-cocoa-cursor-content)])
+          (let* ([r (tell #:type _NSRect content frame)]
+                 [r (make-NSRect (make-NSPoint 0 0)
+                                 (make-NSSize
+                                  (- (NSSize-width (NSRect-size r))
+                                     (get-cursor-width-delta))
+                                  (NSSize-height (NSRect-size r))))])
+            (tellv content addCursorRect: #:type _NSRect r cursor: cursor-handle)))))
+    (define/public (get-cursor-width-delta) 0)
+    
     (define/public (gets-focus?) #f)
     
     (def/public-unimplemented centre)))
diff --git a/collects/mred/private/wx/common/cursor.rkt b/collects/mred/private/wx/common/cursor.rkt
index f27675866e..fb879edfb3 100644
--- a/collects/mred/private/wx/common/cursor.rkt
+++ b/collects/mred/private/wx/common/cursor.rkt
@@ -1,6 +1,7 @@
 #lang racket/base
 (require racket/class
          racket/draw
+         "local.rkt"
          (only-in "../platform.rkt" cursor-driver%)
           "../../syntax.rkt")
 
@@ -32,5 +33,7 @@
         c)]
      (init-name 'cursor%)))
 
+  (define/public (get-driver) driver)
+
   (def/public (ok?) (send driver ok?))
   (super-new))
diff --git a/collects/mred/private/wx/common/local.rkt b/collects/mred/private/wx/common/local.rkt
index 00b39c087e..6ffb76cb5c 100644
--- a/collects/mred/private/wx/common/local.rkt
+++ b/collects/mred/private/wx/common/local.rkt
@@ -5,4 +5,8 @@
 
 (define-local-member-name
   ;; clipboard-client%:
-  get-client-eventspace)
+  get-client-eventspace
+
+  ;; cursor%
+  get-driver)
+
diff --git a/collects/mred/private/wx/common/queue.rkt b/collects/mred/private/wx/common/queue.rkt
index bf93f75572..2f52f60ac9 100644
--- a/collects/mred/private/wx/common/queue.rkt
+++ b/collects/mred/private/wx/common/queue.rkt
@@ -26,6 +26,7 @@
          eventspace-shutdown?
          main-eventspace?
          eventspace-handler-thread
+         eventspace-wait-cursor-count
 
          queue-callback
          middle-queue-key
@@ -39,7 +40,11 @@
          other-modal?
 
          queue-quit-event
-         queue-prefs-event)
+         queue-prefs-event
+
+         begin-busy-cursor
+         end-busy-cursor
+         is-busy?)
 
 ;; ------------------------------------------------------------
 ;; This module must be instantiated only once:
@@ -116,7 +121,13 @@
 ;; ------------------------------------------------------------
 ;; Eventspaces
 
-(define-struct eventspace (handler-thread queue-proc frames-hash done-evt [shutdown? #:mutable] done-sema)
+(define-struct eventspace (handler-thread 
+                           queue-proc 
+                           frames-hash 
+                           done-evt 
+                           [shutdown? #:mutable] 
+                           done-sema 
+                           [wait-cursor-count #:mutable])
   #:property prop:evt (lambda (v)
                         (wrap-evt (eventspace-done-evt v)
                                   (lambda (_) v))))
@@ -270,7 +281,8 @@
                             frames
                             (semaphore-peek-evt done-sema)
                             #f
-                            done-sema)]
+                            done-sema
+                            0)]
           [cb-box (box #f)])
       (parameterize ([current-cb-box cb-box])
         (scheme_add_managed (current-custodian) 
@@ -390,3 +402,25 @@
 (define (queue-prefs-event)
   ;; called in event-pump thread
   (queue-event main-eventspace (application-pref-handler) 'med))
+
+(define (begin-busy-cursor) 
+  (let ([e (current-eventspace)])
+    (atomically 
+     (set-eventspace-wait-cursor-count!
+      e
+      (add1 (eventspace-wait-cursor-count e)))
+     (when (= (eventspace-wait-cursor-count e) 1)
+       (for ([e (in-list (get-top-level-windows))])
+         (send e set-wait-cursor-mode #t))))))
+
+(define (end-busy-cursor) 
+  (let ([e (current-eventspace)])
+    (atomically 
+     (set-eventspace-wait-cursor-count!
+      e
+      (sub1 (eventspace-wait-cursor-count e)))
+     (when (zero? (eventspace-wait-cursor-count e))
+       (for ([e (in-list (get-top-level-windows))])
+         (send e set-wait-cursor-mode #f))))))
+
+(define (is-busy?) (positive? (eventspace-wait-cursor-count (current-eventspace))))
diff --git a/collects/mred/private/wx/gtk/frame.rkt b/collects/mred/private/wx/gtk/frame.rkt
index d4b6cb68ac..419a303bde 100644
--- a/collects/mred/private/wx/gtk/frame.rkt
+++ b/collects/mred/private/wx/gtk/frame.rkt
@@ -289,6 +289,9 @@
     (define/public (set-status-text s) (void))
     (def/public-unimplemented status-line-exists?)
 
+    (define/public (set-wait-cursor-mode on?)
+      (void))
+
     (define maximized? #f)
     
     (define/public (is-maximized?)
diff --git a/collects/mred/private/wx/gtk/platform.rkt b/collects/mred/private/wx/gtk/platform.rkt
index e5305e47aa..00ccbd0e7e 100644
--- a/collects/mred/private/wx/gtk/platform.rkt
+++ b/collects/mred/private/wx/gtk/platform.rkt
@@ -61,9 +61,6 @@
    file-selector
    is-color-display?
    get-display-depth
-   begin-busy-cursor
-   is-busy?
-   end-busy-cursor
    has-x-selection?
    hide-cursor
    bell
diff --git a/collects/mred/private/wx/gtk/procs.rkt b/collects/mred/private/wx/gtk/procs.rkt
index 7f48f76552..83bda61800 100644
--- a/collects/mred/private/wx/gtk/procs.rkt
+++ b/collects/mred/private/wx/gtk/procs.rkt
@@ -51,9 +51,6 @@
  display-size
  bell
  hide-cursor
- end-busy-cursor
- is-busy?
- begin-busy-cursor
  get-display-depth
  is-color-display?
  file-selector
@@ -119,11 +116,6 @@
 (define-unimplemented bell)
 (define (hide-cursor) (void))
 
-(define busy-count 0)
-(define (end-busy-cursor) (atomically (set! busy-count (add1 busy-count))))
-(define (is-busy?) (positive? busy-count))
-(define (begin-busy-cursor) (atomically (set! busy-count (sub1 busy-count))))
-
 (define-unimplemented is-color-display?)
 
 (define (id-to-menu-item i) i)
diff --git a/collects/mred/private/wx/platform.rkt b/collects/mred/private/wx/platform.rkt
index e76fadfda4..729f23937e 100644
--- a/collects/mred/private/wx/platform.rkt
+++ b/collects/mred/private/wx/platform.rkt
@@ -39,9 +39,6 @@
                 file-selector
                 is-color-display?
                 get-display-depth
-                begin-busy-cursor
-                is-busy?
-                end-busy-cursor
                 has-x-selection?
                 hide-cursor
                 bell
diff --git a/collects/mred/private/wx/win32/platform.rkt b/collects/mred/private/wx/win32/platform.rkt
index ba32858c5f..ba59b5654b 100644
--- a/collects/mred/private/wx/win32/platform.rkt
+++ b/collects/mred/private/wx/win32/platform.rkt
@@ -60,9 +60,6 @@
    file-selector
    is-color-display?
    get-display-depth
-   begin-busy-cursor
-   is-busy?
-   end-busy-cursor
    has-x-selection?
    hide-cursor
    bell
diff --git a/collects/mred/private/wx/win32/procs.rkt b/collects/mred/private/wx/win32/procs.rkt
index 2c953a8ba8..d4d7d4ad91 100644
--- a/collects/mred/private/wx/win32/procs.rkt
+++ b/collects/mred/private/wx/win32/procs.rkt
@@ -42,9 +42,6 @@
  display-size
  bell
  hide-cursor
- end-busy-cursor
- is-busy?
- begin-busy-cursor
  get-display-depth
  is-color-display?
  file-selector
diff --git a/collects/mred/private/wxlitem.rkt b/collects/mred/private/wxlitem.rkt
index 5b507d9eb9..ea947168b1 100644
--- a/collects/mred/private/wxlitem.rkt
+++ b/collects/mred/private/wxlitem.rkt
@@ -56,7 +56,7 @@
   
   (define wx-label-panel%
     (class wx-horizontal-panel% 
-      (init proxy parent label style font valign)
+      (init proxy parent label style font halign valign)
       (inherit area-parent)
       (define c #f)
 
@@ -67,7 +67,7 @@
       (unless (memq 'deleted style)
         (send (area-parent) add-child this))
       (define horiz? (is-horiz? style parent))
-      (define p (make-sub horiz? proxy this (if horiz? 'left 'center) valign))
+      (define p (make-sub horiz? proxy this (if horiz? 'left halign) valign))
 
       (define l (make-label label proxy p font))
       (define/public (set-label s) (when l (send l set-label s)))
@@ -96,7 +96,7 @@
       (init mred proxy parent cb label x y w h choices style font)
       (inherit stretchable-in-y stretchable-in-x get-p set-c)
 
-      (super-init proxy parent label style font 'center)
+      (super-init proxy parent label style font 'left 'center)
 
       (define c (make-object wx-internal-choice% mred proxy (get-p) cb label x y w h choices 
                              (filter-style style) font))
@@ -154,7 +154,7 @@
       (init mred proxy parent cb label kind x y w h choices style font label-font)
       (inherit get-p set-c)
 
-      (super-init proxy parent label style font 'top)
+      (super-init proxy parent label style font 'left 'top)
 
       (define c (make-object wx-internal-list-box% mred proxy (get-p) cb label kind x y w h choices 
                              (filter-style style) font label-font))
@@ -227,7 +227,7 @@
       (init mred proxy parent cb label x y w h choices major style font)
       (inherit stretchable-in-y stretchable-in-x get-p set-c)
 
-      (super-init proxy parent label style font 'center)
+      (super-init proxy parent label style font 'left 'center)
 
       (define c (make-object wx-internal-radio-box% mred proxy (get-p) cb label x y w h choices 
                              major (filter-style style) font))
@@ -302,7 +302,7 @@
       (init mred proxy parent label range style font)
       (inherit stretchable-in-y stretchable-in-x get-p set-c)
       
-      (super-init proxy parent label style font 'center)
+      (super-init proxy parent label style font 'center 'center)
       
       (define c (make-object wx-internal-gauge% mred proxy (get-p) label range
                              (filter-style style) font))
@@ -360,7 +360,7 @@
       (init mred proxy parent func label value min-val max-val style font)
       (inherit stretchable-in-y stretchable-in-x get-p set-c)
 
-      (super-init proxy parent label style font 'center)
+      (super-init proxy parent label style font 'center 'center)
 
       (define c (make-object wx-internal-slider% mred proxy (get-p) func label value min-val max-val
                              (filter-style style) font))
diff --git a/collects/tests/gracket/item.rkt b/collects/tests/gracket/item.rkt
index c54e7c62ff..0027c1cd20 100644
--- a/collects/tests/gracket/item.rkt
+++ b/collects/tests/gracket/item.rkt
@@ -2069,7 +2069,7 @@
 			   f
 			   (lambda (b e)
 			     (send f set-cursor (make-object cursor% s)))))
-	    '(arrow bullseye cross hand ibeam watch arrow-watch blank size-n/s size-e/w size-ne/sw size-nw/se))
+	    '(arrow bullseye cross hand ibeam watch blank size-n/s size-e/w size-ne/sw size-nw/se))
   (send f show #t))