unify cocoa & gtk canvas-painting implementation

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

@@ -16,6 +16,7 @@
          "gc.rkt"
          "image.rkt"
          "../common/backing-dc.rkt"
+         "../common/canvas-mixin.rkt"
          "../common/event.rkt"
          "../common/queue.rkt"
          "../../syntax.rkt"
@@ -164,6 +165,7 @@
 (define scroll-width (tell #:type _CGFloat NSScroller scrollerWidth))
 
 (define canvas%
+  (canvas-mixin
    (class window%
      (init parent
            x y w h
@@ -211,41 +213,15 @@
          (tellv cocoa setNeedsDisplay: #:type _BOOL #t))
        (super focus-is-on on?))
 
-    ;; Avoid multiple queued paints, and also allow cancel
+     ;; The `queue-paint' and `paint-children' methods
-    ;; of queued paint:
+     ;; are defined by `canvas-mixin' from ../common/canvas-mixin
-    (define paint-queued #f) ; #f or (box #t)
+     (define/public (queue-paint) (void))
-
+     (define/public (request-canvas-flush-delay)
-    (define/public (queue-paint)
+       (request-flush-delay (get-cocoa-window)))
-      ;; can be called from any thread, including the event-pump thread
+     (define/public (cancel-canvas-flush-delay req)
-      (unless paint-queued
+       (cancel-flush-delay req))
-        (let ([b (box #t)])
+     (define/public (queue-canvas-refresh-event thunk)
-          (set! paint-queued b)
+       (queue-window-refresh-event this  thunk))
-          (let ([req (request-flush-delay (get-cocoa-window))])
-            (queue-window-refresh-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 suspend-flush)
-          (send dc ensure-ready)
-          (send dc erase) ; 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)
-          (send dc resume-flush)
-          (queue-backing-flush)))
-      (when req
-        (cancel-flush-delay req)))
 
      (define/public (paint-or-queue-paint)
        (or (do-backing-flush this dc (tell NSGraphicsContext currentContext)
@@ -254,11 +230,6 @@
              (queue-paint)
              #f)))
 
-    (define/override (paint-children)
-      (when (or paint-queued
-                (not (send dc can-backing-flush?)))
-        (do-on-paint #f #f)))
-
      (define/public (begin-refresh-sequence)
        (send dc suspend-flush))
      (define/public (end-refresh-sequence)
@@ -810,4 +781,4 @@
      (define/public (unregister-collecting-blits)
        (atomically
         (suspend-all-reg-blits)
-       (set! blits null)))))
+        (set! blits null))))))

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

@@ -35,8 +35,9 @@
 
     (define/override (release-bitmap-storage)
       (atomically
+       (when s
          (cairo_surface_destroy s)
-       (set! s #f)))))
+         (set! s #f))))))
 
 (define dc%
   (class backing-dc%

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

@@ -475,8 +475,10 @@
                    (and on? #t))
         (tellv cocoa zoom: cocoa)))
 
-    (def/public-unimplemented iconized?)
+    (define/public (iconized?)
-    (def/public-unimplemented iconize)
+      (tell #:type _BOOL cocoa isMiniaturized))
+    (define/public (iconize on?)
+      (tellv cocoa miniaturize: cocoa))
 
     (define/public (set-title s)
       (tellv cocoa setTitle: #:type _NSString s))))

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

@@ -663,7 +663,8 @@
   (do-request-flush-delay 
    cocoa-win
    (lambda (cocoa-win)
-     (tellv cocoa-win disableFlushWindow))
+     (tellv cocoa-win disableFlushWindow)
+     #t)
    (lambda (cocoa-win)
      (tellv cocoa-win enableFlushWindow))))
 

collects/mred/private/wx/common/canvas-mixin.rkt

@@ -0,0 +1,58 @@
+#lang racket/base
+(require racket/class
+         "backing-dc.rkt")
+
+(provide canvas-mixin)
+
+(define (canvas-mixin %)
+  (class %
+    (super-new)
+    (inherit request-canvas-flush-delay
+             cancel-canvas-flush-delay
+             queue-canvas-refresh-event
+             is-shown-to-root?
+             on-paint
+             queue-backing-flush
+             get-dc
+             get-canvas-background)
+    
+    ;; Avoid multiple queued paints, and also allow cancel
+    ;; of queued paint:
+    (define paint-queued #f) ; #f or (box #t)
+
+    (define/override (queue-paint)
+      ;; can be called from any thread, including the event-pump thread
+      (unless paint-queued
+        (let ([b (box #t)])
+          (set! paint-queued b)
+          (let ([req (request-canvas-flush-delay)])
+            (queue-canvas-refresh-event
+             (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?))
+          (let ([dc (get-dc)])
+            (send dc suspend-flush)
+            (send dc ensure-ready)
+            (send dc erase) ; 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)
+            (send dc resume-flush)
+            (queue-backing-flush))))
+      (when req
+        (cancel-canvas-flush-delay req)))
+
+    (define/override (paint-children)
+      (when (or paint-queued
+                (not (send (get-dc) can-backing-flush?)))
+        (do-on-paint #f #f)))))

collects/mred/private/wx/common/delay.rkt

@@ -8,7 +8,9 @@
 (define (do-request-flush-delay win disable enable)
   (atomically
    (let ([req (box win)])
+     (and 
       (disable win)
+      (begin
         (add-event-boundary-sometimes-callback! 
          req
          (lambda (v) 
@@ -16,7 +18,7 @@
            (when (unbox req) 
              (set-box! req #f)
              (enable win))))
-     req)))
+        req)))))
 
 (define (do-cancel-flush-delay req enable)
   (atomically

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

@@ -6,6 +6,7 @@
          racket/draw/color
          racket/draw/local
          "../common/backing-dc.rkt"
+         "../common/canvas-mixin.rkt"
          "../../syntax.rkt"
 	 "../../lock.rkt"
          "../common/event.rkt"
@@ -176,6 +177,7 @@
   #t)
 
 (define canvas%
+  (canvas-mixin
    (class (client-size-mixin window%)
      (init parent
            x y w h
@@ -337,39 +339,15 @@
      (define/override (get-client-delta)
        (values margin margin))
 
-    ;; Avoid multiple queued paints:
+     ;; The `queue-paint' and `paint-children' methods
-    (define paint-queued? #f)
+     ;; are defined by `canvas-mixin' from ../common/canvas-mixin
-    ;; To handle paint requests that happen while on-paint
+     (define/public (queue-paint) (void))
-    ;;  is being called already. kProbably doesn't happen,
+     (define/public (request-canvas-flush-delay)
-    ;;  because expose callabcks should be in the right
+       (request-flush-delay client-gtk))
-    ;;  eventspace.
+     (define/public (cancel-canvas-flush-delay req)
-    (define now-drawing? #f)
+       (cancel-flush-delay req))
-    (define refresh-after-drawing? #f)
+     (define/public (queue-canvas-refresh-event thunk)
-
+       (queue-window-refresh-event this thunk))
-    (define/public (queue-paint)
-      ;; can be called from any thread, including the event-pump thread
-      (unless paint-queued?
-        (set! paint-queued? #t)
-        (queue-window-refresh-event
-         this
-         (lambda () 
-           (set! paint-queued? #f)
-           (set! now-drawing? #t)
-           (send dc suspend-flush)
-           (send dc ensure-ready)
-           (send dc erase) ; 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)
-           (send dc resume-flush)
-           (set! now-drawing? #f)
-           (when refresh-after-drawing?
-             (set! refresh-after-drawing? #f)
-             (refresh))))))
 
      (define/public (paint-or-queue-paint)
        (or (do-backing-flush this dc (if is-combo?
@@ -530,10 +508,6 @@
      (define/public (set-canvas-background col) (set! bg-col col))
      (define/public (get-canvas-background-for-clearing) 
        ;; called in event-dispatch mode
-      (if now-drawing?
-          (begin
-            (set! refresh-after-drawing? #t)
-            #f)
        (if clear-bg?
            (let* ([conv (lambda (x) (bitwise-ior x (arithmetic-shift x 8)))]
                   [w (widget-window gtk)]
@@ -543,7 +517,7 @@
                                                         (conv (color-green bg-col))
                                                         (conv (color-blue bg-col))))
              gc)
-              #f)))
+           #f))
 
      (when is-combo?
        (connect-changed client-gtk))
@@ -633,4 +607,4 @@
         (for ([r (in-list reg-blits)])
           (g_object_unref (car r))
           (scheme_remove_gc_callback (cdr r)))
-       (set! reg-blits null)))))
+        (set! reg-blits null))))))

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

@@ -237,14 +237,24 @@
       (gtk_window_resize gtk (max 1 w) (max 1 h)))
 
     (define/override (show on?)
+      (let ([es (get-eventspace)])
         (when (and on?
-                 (eventspace-shutdown? (get-eventspace)))
+                   (eventspace-shutdown? es))
           (error (string->symbol
                   (format "show method in ~a"
                           (if (frame-relative-dialog-status this)
                               'dialog%
                               'frame%)))
-               "eventspace has been shutdown"))
+                 "eventspace has 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 1 s))))))
       (super show on?))
 
     (define saved-child #f)

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

@@ -32,6 +32,11 @@
         (for ([child (in-list children)])
           (send child reset-child-dcs))))
     
+    (define/override (paint-children)
+      (when (pair? 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)
       (reset-child-dcs))

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

@@ -568,6 +568,9 @@
       (when parent
         (send parent register-child this on?)))
 
+    (define/public (paint-children)
+      (void))
+
     (def/public-unimplemented on-drop-file)
     (def/public-unimplemented get-handle)
     (def/public-unimplemented set-phantom-size)
@@ -625,12 +628,16 @@
   (do-request-flush-delay 
    gtk
    (lambda (gtk)
-     (gdk_window_freeze_updates (widget-window gtk)))
+     (let ([win (widget-window gtk)])
+       (and win
+            (gdk_window_freeze_updates win)
+            #t)))
    (lambda (gtk)
      (gdk_window_thaw_updates (widget-window gtk)))))
 
 (define (cancel-flush-delay req)
+  (when req
     (do-cancel-flush-delay 
      req
      (lambda (gtk)
-     (gdk_window_thaw_updates (widget-window gtk)))))
+       (gdk_window_thaw_updates (widget-window gtk))))))