fix various cocoa problems

2010-09-07 15:26:21 -06:00 · 2010-09-07 15:26:21 -06:00 · 8ed2fba67d
commit 8ed2fba67d
parent 2a4ea2ef98
13 changed files with 124 additions and 56 deletions
--- 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)
--- 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?)
--- 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?)))
--- 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)))
--- 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?)))
--- 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%
--- a/collects/mred/private/wx/cocoa/panel.rkt
+++ b/collects/mred/private/wx/cocoa/panel.rkt
@ -30,10 +30,18 @@
    (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)
      (fix-dc))
--- 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?)))
--- 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?)))

--- 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?)))
+
--- a/collects/mred/private/wx/cocoa/window.rkt
+++ b/collects/mred/private/wx/cocoa/window.rkt
@ -288,8 +288,20 @@
    (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)
--- a/collects/mred/private/wx/common/backing-dc.rkt
+++ b/collects/mred/private/wx/common/backing-dc.rkt
@ -63,6 +63,9 @@
        (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])
        (when cr
--- 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))