From 8ed2fba67d2503b31b8caadf30e191e729d46a62 Mon Sep 17 00:00:00 2001
From: Matthew Flatt <mflatt@racket-lang.org>
Date: Tue, 7 Sep 2010 15:26:21 -0600
Subject: [PATCH] fix various cocoa problems

---
 collects/mred/private/wx/cocoa/button.rkt     |  6 +-
 collects/mred/private/wx/cocoa/canvas.rkt     | 56 ++++++++++++-------
 collects/mred/private/wx/cocoa/choice.rkt     |  7 ++-
 collects/mred/private/wx/cocoa/frame.rkt      | 32 +++++++----
 collects/mred/private/wx/cocoa/list-box.rkt   |  8 ++-
 collects/mred/private/wx/cocoa/message.rkt    |  4 +-
 collects/mred/private/wx/cocoa/panel.rkt      | 10 +++-
 collects/mred/private/wx/cocoa/radio-box.rkt  |  7 ++-
 collects/mred/private/wx/cocoa/slider.rkt     |  7 ++-
 collects/mred/private/wx/cocoa/tab-panel.rkt  |  8 ++-
 collects/mred/private/wx/cocoa/window.rkt     | 29 +++++++---
 .../mred/private/wx/common/backing-dc.rkt     |  3 +
 collects/sirmail/readr.rkt                    |  3 -
 13 files changed, 124 insertions(+), 56 deletions(-)

diff --git a/collects/mred/private/wx/cocoa/button.rkt b/collects/mred/private/wx/cocoa/button.rkt
index 93e87017f7..936af6100f 100644
--- a/collects/mred/private/wx/cocoa/button.rkt
+++ b/collects/mred/private/wx/cocoa/button.rkt
@@ -33,7 +33,8 @@
   (init parent cb label x y w h style font
         [button-type #f])
   (init-field [event-type 'button])
-  (inherit get-cocoa get-cocoa-window init-font)
+  (inherit get-cocoa get-cocoa-window init-font
+           register-as-child)
 
   (define button-cocoa
     (let ([cocoa 
@@ -119,6 +120,9 @@
 
   (define/override (get-cocoa-control) button-cocoa)
 
+  (define/override (maybe-register-as-child parent on?)
+    (register-as-child parent on?))
+    
   (define/override (set-label label)
     (cond
      [(string? label)
diff --git a/collects/mred/private/wx/cocoa/canvas.rkt b/collects/mred/private/wx/cocoa/canvas.rkt
index 19d2d4d2f1..ba785fce2b 100644
--- a/collects/mred/private/wx/cocoa/canvas.rkt
+++ b/collects/mred/private/wx/cocoa/canvas.rkt
@@ -202,27 +202,37 @@
         (tellv cocoa setNeedsDisplay: #:type _BOOL #t))
       (super focus-is-on on?))
 
-    ;; Avoid multiple queued paints:
-    (define paint-queued? #f)
+    ;; Avoid multiple queued paints, and also allow cancel
+    ;; of queued paint:
+    (define paint-queued #f) ; #f or (box #t)
 
     (define/public (queue-paint)
       ;; can be called from any thread, including the event-pump thread
-      (unless paint-queued?
-        (set! paint-queued? #t)
-        (let ([req (request-flush-delay (get-cocoa-window))])
-          (queue-window-event this (lambda () 
-                                     (set! paint-queued? #f)
-                                     (when (is-shown-to-root?)
-                                       (send dc reset-backing-retained) ; start with a clean slate
-                                       (let ([bg (get-canvas-background)])
-                                         (when bg 
-                                           (let ([old-bg (send dc get-background)])
-                                             (send dc set-background bg)
-                                             (send dc clear)
-                                             (send dc set-background old-bg))))
-                                       (on-paint)
-                                       (queue-backing-flush)
-                                       (cancel-flush-delay req)))))))
+      (unless paint-queued
+        (let ([b (box #t)])
+          (set! paint-queued b)
+          (let ([req (request-flush-delay (get-cocoa-window))])
+            (queue-window-event this (lambda () 
+                                       (do-on-paint req b)))))))
+
+    (define/private (do-on-paint req b)
+      ;; only called in the handler thread
+      (when (or (not b) (unbox b))
+        (let ([pq paint-queued])
+          (when pq (set-box! pq #f)))
+        (set! paint-queued #f)
+        (when (or (not b) (is-shown-to-root?))
+          (send dc reset-backing-retained) ; start with a clean slate
+          (let ([bg (get-canvas-background)])
+            (when bg 
+              (let ([old-bg (send dc get-background)])
+                (send dc set-background bg)
+                (send dc clear)
+                (send dc set-background old-bg))))
+          (on-paint)
+          (queue-backing-flush)))
+      (when req
+        (cancel-flush-delay req)))
 
     (define/public (paint-or-queue-paint)
       (or (do-backing-flush this dc (tell NSGraphicsContext currentContext)
@@ -231,6 +241,11 @@
             (queue-paint)
             #f)))
 
+    (define/override (paint-children)
+      (when (or paint-queued
+                (not (send dc can-backing-flush?)))
+        (do-on-paint #f #f)))
+
     (define/override (refresh)
       ;; can be called from any thread, including the event-pump thread
       (queue-paint))
@@ -283,7 +298,7 @@
     
     (define/public (get-dc) dc)
 
-    (define/public (fix-dc [refresh? #t])
+    (define/override (fix-dc [refresh? #t])
       (when (dc . is-a? . dc%)
         (send dc reset-backing-retained)
         (send dc set-auto-scroll
@@ -608,8 +623,7 @@
     
     (define/override (definitely-wants-event? e) 
       ;; Called in Cocoa event-handling mode
-      (when (and is-combo?
-                 (e . is-a? . mouse-event%)
+      (when (and (e . is-a? . mouse-event%)
                  (send e button-down? 'left))
         (set-focus))
       (or (not is-combo?)
diff --git a/collects/mred/private/wx/cocoa/choice.rkt b/collects/mred/private/wx/cocoa/choice.rkt
index d9caac07a8..b80f27d6d5 100644
--- a/collects/mred/private/wx/cocoa/choice.rkt
+++ b/collects/mred/private/wx/cocoa/choice.rkt
@@ -28,7 +28,7 @@
   (init parent cb label
         x y w h
         choices style font)
-  (inherit get-cocoa init-font)
+  (inherit get-cocoa init-font register-as-child)
 
   (super-new [parent parent]
              [cocoa 
@@ -68,4 +68,7 @@
   (define/public (append lbl)
     (tellv (get-cocoa)
            insertItemWithTitle: #:type _NSString lbl 
-           atIndex: #:type _NSInteger (number))))
+           atIndex: #:type _NSInteger (number)))
+
+  (define/override (maybe-register-as-child parent on?)
+    (register-as-child parent on?)))
diff --git a/collects/mred/private/wx/cocoa/frame.rkt b/collects/mred/private/wx/cocoa/frame.rkt
index 21141deda5..98a89cace3 100644
--- a/collects/mred/private/wx/cocoa/frame.rkt
+++ b/collects/mred/private/wx/cocoa/frame.rkt
@@ -254,11 +254,21 @@
              (set-wait-cursor-mode (not (zero? b))))))))
     
     (define/override (show on?)
-      (when on?
-        (when (eventspace-shutdown? (get-eventspace))
-          (error (string->symbol
-                  (format "show method in ~a" (if is-a-dialog? 'dialog% 'frame%)))
-                 "the eventspace hash been shutdown")))
+      (let ([es (get-eventspace)])
+        (when on?
+          (when (eventspace-shutdown? es)
+            (error (string->symbol
+                    (format "show method in ~a" (if is-a-dialog? 'dialog% 'frame%)))
+                   "the eventspace hash been shutdown"))
+          (when saved-child
+            (if (eq? (current-thread) (eventspace-handler-thread es))
+                (send saved-child paint-children)
+                (let ([s (make-semaphore)])
+                  (queue-callback (lambda ()
+                                    (when saved-child
+                                      (send saved-child paint-children))
+                                    (semaphore-post s)))
+                  (sync/timeout 0.2 s))))))
       (direct-show on?))
 
     (define/public (destroy)
@@ -305,11 +315,13 @@
                               (lambda () (send wx on-kill-focus)))))
 
     (define/override (is-responder wx on?)
-      (if on?
-          (set! first-responder wx)
-          (set! first-responder #f))
-      (when is-main?
-        (do-notify-responder wx on?)))
+      (unless (and (not on?)
+                   (not (eq? first-responder wx)))
+        (if on?
+            (set! first-responder wx)
+            (set! first-responder #f))
+        (when is-main?
+          (do-notify-responder wx on?))))
 
     (define/public (install-wait-cursor)
       (when (positive? (eventspace-wait-cursor-count (get-eventspace)))
diff --git a/collects/mred/private/wx/cocoa/list-box.rkt b/collects/mred/private/wx/cocoa/list-box.rkt
index ea9ee5623d..e25fb0f130 100644
--- a/collects/mred/private/wx/cocoa/list-box.rkt
+++ b/collects/mred/private/wx/cocoa/list-box.rkt
@@ -59,7 +59,8 @@
         label kind x y w h
         choices style
         font label-font)
-  (inherit set-size init-font)
+  (inherit set-size init-font
+           register-as-child)
 
   (define source (as-objc-allocation
                   (tell (tell MyDataSource alloc) init)))
@@ -194,4 +195,7 @@
 
   (define/public (reset)
     (tellv content-cocoa noteNumberOfRowsChanged)
-    (tellv content-cocoa reloadData)))
+    (tellv content-cocoa reloadData))
+
+  (define/override (maybe-register-as-child parent on?)
+    (register-as-child parent on?)))
diff --git a/collects/mred/private/wx/cocoa/message.rkt b/collects/mred/private/wx/cocoa/message.rkt
index 1f2510da77..458b3fc305 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 CursorDisplayer)
+  #:mixins (KeyMouseResponder CursorDisplayer)
   [wxb])
 
 (define-objc-class MyImageView NSImageView
-  #:mixins (FocusResponder KeyMouseResponder CursorDisplayer)
+  #:mixins (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 1ef4c77eae..3837042fe3 100644
--- a/collects/mred/private/wx/cocoa/panel.rkt
+++ b/collects/mred/private/wx/cocoa/panel.rkt
@@ -30,9 +30,17 @@
     (define/public (get-label-position) lbl-pos)
     (define/public (set-label-position pos) (set! lbl-pos pos))
 
-    (define/public (fix-dc)
+    (define/override (fix-dc)
       (for ([child (in-list children)])
         (send child fix-dc)))
+
+    (define/override (hide-children)
+      (for ([child (in-list children)])
+        (send child hide-children)))
+    
+    (define/override (paint-children)
+      (for ([child (in-list children)])
+        (send child paint-children)))
     
     (define/override (set-size x y w h)
       (super set-size x y w h)
diff --git a/collects/mred/private/wx/cocoa/radio-box.rkt b/collects/mred/private/wx/cocoa/radio-box.rkt
index 364e116943..3a0e9b57ac 100644
--- a/collects/mred/private/wx/cocoa/radio-box.rkt
+++ b/collects/mred/private/wx/cocoa/radio-box.rkt
@@ -64,7 +64,7 @@
         val
         style
         font)
-  (inherit get-cocoa set-focus init-font)
+  (inherit get-cocoa set-focus init-font register-as-child)
 
   (define horiz? (and (memq 'horizontal style) #t))
 
@@ -136,4 +136,7 @@
     (if horiz?
         (tell #:type _NSInteger (get-cocoa) selectedColumn)
         (tell #:type _NSInteger (get-cocoa) selectedRow)))
-  (define/public (number) count))
+  (define/public (number) count)
+
+  (define/override (maybe-register-as-child parent on?)
+    (register-as-child parent on?)))
diff --git a/collects/mred/private/wx/cocoa/slider.rkt b/collects/mred/private/wx/cocoa/slider.rkt
index 7af719fb12..246d402df3 100644
--- a/collects/mred/private/wx/cocoa/slider.rkt
+++ b/collects/mred/private/wx/cocoa/slider.rkt
@@ -40,7 +40,7 @@
         x y w
         style
         font)
-  (inherit get-cocoa)
+  (inherit get-cocoa register-as-child)
 
   (super-new [parent parent]
              [cocoa (let ([cocoa (as-objc-allocation
@@ -76,5 +76,8 @@
   (define/public (set-value v)
     (tellv cocoa setDoubleValue: #:type _double* v))
   (define/public (get-value)
-    (inexact->exact (floor (tell #:type _double cocoa doubleValue)))))
+    (inexact->exact (floor (tell #:type _double cocoa doubleValue))))
+
+  (define/override (maybe-register-as-child parent on?)
+    (register-as-child parent on?)))
 
diff --git a/collects/mred/private/wx/cocoa/tab-panel.rkt b/collects/mred/private/wx/cocoa/tab-panel.rkt
index 4662c0d45b..68e29eab04 100644
--- a/collects/mred/private/wx/cocoa/tab-panel.rkt
+++ b/collects/mred/private/wx/cocoa/tab-panel.rkt
@@ -40,7 +40,7 @@
         x y w h
         style
         labels)
-  (inherit get-cocoa)
+  (inherit get-cocoa register-as-child)
 
   (define tabv-cocoa (as-objc-allocation
                       (tell (tell MyTabView alloc) init)))
@@ -147,4 +147,8 @@
              [no-show? (memq 'deleted style)])
   
   (when control-cocoa
-    (set-ivar! control-cocoa wxb (->wxb this))))
+    (set-ivar! control-cocoa wxb (->wxb this)))
+
+  (define/override (maybe-register-as-child parent on?)
+    (register-as-child parent on?)))
+
diff --git a/collects/mred/private/wx/cocoa/window.rkt b/collects/mred/private/wx/cocoa/window.rkt
index e68998104d..a7db02cd49 100644
--- a/collects/mred/private/wx/cocoa/window.rkt
+++ b/collects/mred/private/wx/cocoa/window.rkt
@@ -287,9 +287,21 @@
 
     (define/public (focus-is-on on?)
       (void))
+    
+    (define is-responder? #f)
 
     (define/public (is-responder wx on?)
-      (send parent is-responder wx on?))
+      (unless (eq? on? is-responder?)
+        (set! is-responder? (and on? #t))
+        (send parent is-responder wx on?)))
+
+    (define/public (hide-children)
+      (is-responder this #f)
+      (focus-is-on #f))
+    (define/public (fix-dc) 
+      (void))
+    (define/public (paint-children)
+      (void))
 
     (define/public (get-cocoa) cocoa)
     (define/public (get-cocoa-content) cocoa)
@@ -321,9 +333,11 @@
          (set! is-on? (and on? #t))))
       (maybe-register-as-child parent on?)
       (unless on?
-        (focus-is-on #f)
+        (hide-children)
         (is-responder this #f)))
     (define/public (maybe-register-as-child parent on?)
+      ;; override this to call register-as-child if the window
+      ;; can have the focus or otherwise needs show-state notifications.
       (void))
     (define/public (register-as-child parent on?)
       (send parent register-child this on?))
@@ -538,12 +552,9 @@
     (when wx
       (queue-event (send wx get-eventspace) (lambda () (proc wx))))))
 
-(define depth 0)
-
 (define (request-flush-delay cocoa-win)
   (atomically
    (let ([req (box cocoa-win)])
-     (set! depth (add1 depth))
      (tellv cocoa-win disableFlushWindow)
      (add-event-boundary-sometimes-callback! 
       req
@@ -551,9 +562,8 @@
         ;; in atomic mode
         (when (unbox req) 
           (set-box! req #f)
-          (set! depth (sub1 depth))
           (tellv cocoa-win enableFlushWindow)
-          (tellv cocoa-win flushWindow))))
+          (tellv cocoa-win flushWindowIfNeeded))))
      req)))
 
 (define (cancel-flush-delay req)
@@ -561,8 +571,11 @@
    (let ([cocoa-win (unbox req)])
      (when cocoa-win
        (set-box! req #f)
-       (set! depth (sub1 depth))
        (tellv cocoa-win enableFlushWindow)
+       (add-event-boundary-sometimes-callback! 
+        cocoa-win
+        (lambda (v)
+          (tellv cocoa-win flushWindowIfNeeded)))
        (remove-event-boundary-callback! req)))))
 
 (define (make-init-point x y)
diff --git a/collects/mred/private/wx/common/backing-dc.rkt b/collects/mred/private/wx/common/backing-dc.rkt
index 922894e024..7e7a5dace1 100644
--- a/collects/mred/private/wx/common/backing-dc.rkt
+++ b/collects/mred/private/wx/common/backing-dc.rkt
@@ -62,6 +62,9 @@
        [else 
         (reset-backing-retained proc)
         #t]))
+    
+    (define/public (can-backing-flush?)
+      (and retained-cr #t))
 
     (define/public (reset-backing-retained [proc void])
       (let ([cr retained-cr])
diff --git a/collects/sirmail/readr.rkt b/collects/sirmail/readr.rkt
index ecabc7f9ec..2d84b4ce68 100644
--- a/collects/sirmail/readr.rkt
+++ b/collects/sirmail/readr.rkt
@@ -1840,9 +1840,6 @@
               (send dc set-font font)
               (let-values ([(w h) (get-client-size)]
                            [(tw th ta td) (send dc get-text-extent message)])
-                (send dc set-pen (send the-pen-list find-or-create-pen (get-panel-background) 1 'transparent))
-                (send dc set-brush (send the-brush-list find-or-create-brush (get-panel-background) 'panel))
-                (send dc draw-rectangle 0 0 w h)
                 (send dc draw-text message
                       (- (/ w 2) (/ tw 2))
                       (- (/ h 2) (/ th 2))