cocoa: fix interaction of combo-field% popup and canvas refresh

and also reduce work on redundant show/hide of canvas
 Closes PR 11557

original commit: 975c2400a1e994f48938b61dd26aa61738dcda37

collects/framework/gui-utils.rkt

@@ -111,36 +111,36 @@
 
 (define (cancel-on-right?) (system-position-ok-before-cancel?))
 
-(define ok/cancel-buttons
+(define (ok/cancel-buttons parent 
-  (lambda (parent 
+                           confirm-callback
-           confirm-callback
+                           cancel-callback 
-           cancel-callback 
+                           [confirm-str (string-constant ok)]
-           [confirm-str (string-constant ok)]
+                           [cancel-str (string-constant cancel)]
-           [cancel-str (string-constant cancel)])
+                           #:confirm-style [confirm-style '(border)]) 
-    (let ([confirm (λ ()
+  (let ([confirm (λ ()
-                     (instantiate button% ()
+                   (instantiate button% ()
-                       (parent parent)
+                     (parent parent)
-                       (callback confirm-callback)
+                     (callback confirm-callback)
-                       (label confirm-str)
+                     (label confirm-str)
-                       (style '(border))))]
+                     (style confirm-style)))]
-          [cancel (λ ()
+        [cancel (λ ()
-                    (instantiate button% ()
+                  (instantiate button% ()
-                      (parent parent)
+                    (parent parent)
-                      (callback cancel-callback)
+                    (callback cancel-callback)
-                      (label cancel-str)))])
+                    (label cancel-str)))])
-      (let-values ([(b1 b2)
+    (let-values ([(b1 b2)
-                    (cond
+                  (cond
-                      [(cancel-on-right?)
+                    [(cancel-on-right?)
-                       (values (confirm) (cancel))]
+                     (values (confirm) (cancel))]
-                      [else
+                    [else
-                       (values (cancel) (confirm))])])
+                     (values (cancel) (confirm))])])
-        (let ([w (max (send b1 get-width)
+      (let ([w (max (send b1 get-width)
-                      (send b2 get-width))])
+                    (send b2 get-width))])
-          (send b1 min-width w)
+        (send b1 min-width w)
-          (send b2 min-width w)
+        (send b2 min-width w)
-          (if (cancel-on-right?)
+        (if (cancel-on-right?)
-              (values b1 b2)
+            (values b1 b2)
-              (values b2 b1)))))))
+            (values b2 b1))))))
 
 
 (define clickback-delta (make-object style-delta% 'change-underline #t))
@@ -346,24 +346,30 @@
         ((is-a?/c button%) (is-a?/c event%) . -> . any)
         ((is-a?/c button%) (is-a?/c event%) . -> . any))
        (string?
-        string?)
+        string?
+        #:confirm-style (listof symbol?))
        (values (is-a?/c button%)
                (is-a?/c button%)))
   ((parent
     confirm-callback
     cancel-callback)
    ((confirm-label (string-constant ok))
-    (cancel-label (string-constant cancel))))
+    (cancel-label (string-constant cancel))
+    (confirm-style '(border))))
   @{Adds an Ok and a cancel button to a panel, changing the order
     to suit the platform. Under Mac OS X and unix, the confirmation action
     is on the right (or bottom) and under Windows, the canceling action is on
     the right (or bottom).
-    The confirmation action button has the @scheme['(border)] style.
     The buttons are also sized to be the same width.
     
     The first result is be the OK button and the second is
     the cancel button.
     
+    By default, the confirmation action button has the @scheme['(border)] style,
+    meaning that hitting return in the dialog will trigger the confirmation action.
+    The @racket[confirm-style] argument can override this behavior, tho.
+    See @racket[button%] for the precise list of allowed styles.
+    
     See also @scheme[gui-utils:cancel-on-right?].})
  
  (proc-doc/names

collects/mred/mred.rkt

@@ -4,20 +4,19 @@
                  namespace-anchor->empty-namespace
                  make-base-empty-namespace)
            scheme/class
-           racket/draw
+           racket/draw racket/snip
            mzlib/etc
 	   (prefix wx: "private/kernel.ss")
 	   (prefix wx: "private/wxme/style.ss")
 	   (prefix wx: "private/wxme/editor.ss")
 	   (prefix wx: "private/wxme/text.ss")
 	   (prefix wx: "private/wxme/pasteboard.ss")
-	   (prefix wx: "private/wxme/snip.ss")
 	   (prefix wx: "private/wxme/keymap.ss")
 	   (prefix wx: "private/wxme/editor-admin.ss")
+           (prefix wx: "private/wxme/editor-data.ss")
 	   (prefix wx: "private/wxme/editor-snip.ss")
 	   (prefix wx: "private/wxme/stream.ss")
 	   (prefix wx: "private/wxme/wordbreak.ss")
-	   (prefix wx: "private/wxme/snip-admin.ss")
 	   "private/wxtop.ss"
 	   "private/app.ss"
 	   "private/misc.ss"
@@ -68,7 +67,7 @@
   ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 
   (define (make-eventspace)
-    (parameterize ([wx:the-snip-class-list (wx:make-the-snip-class-list)]
+    (parameterize ([the-snip-class-list (make-the-snip-class-list)]
                    [wx:the-editor-data-class-list (wx:make-the-editor-data-class-list)])
       (wx:make-eventspace)))
 
@@ -120,8 +119,6 @@
 	     get-highlight-background-color
              get-highlight-text-color
 	     get-the-editor-data-class-list
-	     get-the-snip-class-list
-	     image-snip%
 	     is-busy?
 	     is-color-display?
 	     key-event%
@@ -142,19 +139,13 @@
 	     read-editor-global-header
 	     read-editor-version
 	     scroll-event%
-	     snip%
-	     snip-admin%
-	     snip-class%
-	     snip-class-list<%>
 	     special-control-key
 	     special-option-key
              map-command-as-meta-key
 	     label->plain-label
-	     string-snip%
 	     style<%>
 	     style-delta%
 	     style-list%
-	     tab-snip%
 	     write-editor-global-footer
 	     write-editor-global-header
 	     write-editor-version
@@ -183,7 +174,8 @@
                          [else ".gracketrc"]))]
           [else #f])))
 
-  (provide (all-from racket/draw))
+  (provide (all-from racket/draw)
+           (all-from racket/snip))
 
   (provide button%
 	   canvas%
@@ -274,7 +266,6 @@
 	   view-control-font
 	   menu-control-font
 	   timer%
-	   readable-snip<%>
 	   open-input-text-editor
 	   open-input-graphical-file
 	   open-output-text-editor

collects/mred/private/snipfile.rkt

@@ -3,67 +3,18 @@
            racket/port
 	   syntax/moddep
            (prefix-in wx: "kernel.ss")
-	   (prefix-in wx: "wxme/snip.ss")
+	   (prefix-in wx: racket/snip)
 	   (prefix-in wx: "wxme/cycle.ss")
 	   "check.ss"
 	   "editor.ss")
 		
-  (provide readable-snip<%>
+  (provide open-input-text-editor 
-	   open-input-text-editor 
 	   open-input-graphical-file
 	   text-editor-load-handler
 	   open-output-text-editor )
 
-  ;; snip-class% and editor-data-class% loaders
-
-  (define (ok-string-element? m)
-    (and (string? m)
-         (regexp-match? #rx"^[-a-zA-Z0-9_. ]+$" m)
-         (not (string=? m ".."))
-         (not (string=? m "."))))
-  
-  (define (ok-lib-path? m)
-    (and (pair? m)
-         (eq? 'lib (car m))
-         (pair? (cdr m))
-         (list? m)
-         (andmap ok-string-element? (cdr m))))
-
-  (let ([load-one
-	 (lambda (str id %)
-	   (let ([m (with-handlers ([exn:fail:read? (lambda (x) #f)])
-		      (and (regexp-match #rx"^[(].*[)]$" str)
-                           (let* ([p (open-input-string str)]
-                                  [m (read p)])
-                             (and (eof-object? (read p))
-                                  m))))])
-	     (if (or (ok-lib-path? m)
-                     (and (list? m)
-                          (= (length m) 2)
-                          (ok-lib-path? (car m))
-                          (ok-lib-path? (cadr m))))
-                 (let ([m (if (ok-lib-path? m)
-                              m
-                              (car m))])
-                   (let ([result (dynamic-require m id)])
-                     (if (is-a? result %)
-                         result
-                         (error 'load-class "not a ~a% instance" id))))
-		 #f)))])
-    ;; install the getters:
-    (wx:set-get-snip-class!
-     (lambda (name)
-       (load-one name 'snip-class wx:snip-class%)))
-    (wx:set-get-editor-data-class!
-     (lambda (name)
-       (load-one name 'editor-data-class wx:editor-data-class%))))
-
   ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 
-  (define readable-snip<%>
-    (interface ()
-      read-special))
-
   (define empty-string (make-bytes 0))
   
   ;; open-input-text-editor : (instanceof text%) num num -> input-port
@@ -188,7 +139,7 @@
 					 (next-snip empty-string)
 					 (lambda (file line col ppos)
 					   (if (is-a? the-snip wx:snip%)
-					       (if (is-a? the-snip readable-snip<%>)
+					       (if (is-a? the-snip wx:readable-snip<%>)
 						   (send the-snip read-special file line col ppos)
 						   (send the-snip copy))
 					       the-snip)))]
@@ -212,7 +163,7 @@
 				      v)))
 			      close)])
 		  (when lock-while-reading? 
-                    (send text begin-edit-sequencce)
+                    (send text begin-edit-sequence)
                     (send text lock #t))
                   (if (is-a? snip wx:string-snip%)
 		      ;; Special handling for initial snip string in

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

@@ -245,7 +245,8 @@
               client-to-screen
               is-auto-scroll? get-virtual-width get-virtual-height
               reset-auto-scroll
-              refresh-for-autoscroll)
+              refresh-for-autoscroll
+              flush)
 
      (define vscroll-ok? (and (memq 'vscroll style) #t))
      (define vscroll? vscroll-ok?)
@@ -360,7 +361,7 @@
        (tellv content-cocoa setDelegate: content-cocoa)
        (install-control-font content-cocoa #f))
 
-     (define dc (make-object dc% this))
+     (define dc (make-object dc% this (memq 'transparent canvas-style)))
 
      (send dc start-backing-retained)
 
@@ -382,6 +383,7 @@
      (define/override (get-client-size xb yb)
        (super get-client-size xb yb)
        (when is-combo?
+         (set-box! xb (max 0 (- (unbox xb) 22)))
          (set-box! yb (max 0 (- (unbox yb) 5)))))
 
      (define/override (maybe-register-as-child parent on?)
@@ -396,15 +398,16 @@
 
      (define/override (show on?)
        ;; FIXME: what if we're in the middle of an on-paint?
-       (super show on?)
+       (super show on?))
-       (fix-dc))
 
      (define/override (hide-children)
        (super hide-children)
+       (fix-dc #f)
        (suspend-all-reg-blits))
 
      (define/override (show-children)
        (super show-children)
+       (fix-dc)
        (resume-all-reg-blits))
 
      (define/override (fixup-locations-children)
@@ -627,6 +630,13 @@
        (tellv content-cocoa addItemWithObjectValue: #:type _NSString str)
        #t)
      (define/public (on-combo-select i) (void))
+     (define/public (popup-combo)
+       ;; Pending refresh events intefere with combo popups
+       ;; for some reason, so flush them:
+       (yield-refresh)
+       (flush)
+       ;; Beware that the `popUp:' method is undocumented:
+       (tellv (tell content-cocoa cell) popUp: #f))
 
      (define clear-bg? (and (not (memq 'transparent canvas-style)) 
                             (not (memq 'no-autoclear canvas-style))))
@@ -718,7 +728,7 @@
        (let ([xb (box 0)]
              [yb (box 0)])
          (get-client-size xb yb)
-         ((send e get-x) . > . (- (unbox xb) 22))))
+         ((send e get-x) . > . (unbox xb))))
 
      (define/public (on-popup) (void))
 
@@ -764,12 +774,10 @@
        (void))
 
      (define/public (get-backing-size xb yb)
-       (get-client-size xb yb)
+       (get-client-size xb yb))
-       (when is-combo?
-         (set-box! xb (- (unbox xb) 22))))
 
      (define/override (get-cursor-width-delta)
-       (if is-combo? 22 0))
+       0)
 
      (define/public (is-flipped?)
        (tell #:type _BOOL (get-cocoa-content) isFlipped))

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

@@ -23,11 +23,12 @@
 
 (define dc%
   (class backing-dc%
-    (init [(cnvs canvas)])
+    (init [(cnvs canvas)]
+          transparent?)
     (define canvas cnvs)
 
     (inherit end-delay)
-    (super-new)
+    (super-new [transparent? transparent?])
 
     (define gl #f)
     (define/override (get-gl-context)
@@ -89,13 +90,6 @@
                (let* ([surface (cairo_quartz_surface_create_for_cg_context cg (unbox w) (unbox h))]
                       [cr (cairo_create surface)])
                  (cairo_surface_destroy surface)
-                 (let ([s (cairo_get_source cr)])
+                 (backing-draw-bm bm cr (unbox w) (unbox h))
-                   (cairo_pattern_reference s)
-                   (cairo_set_source_surface cr (send bm get-cairo-surface) 0 0)
-                   (cairo_new_path cr)
-                   (cairo_rectangle cr 0 0 (unbox w) (unbox h))
-                   (cairo_fill cr)
-                   (cairo_set_source cr s)
-                   (cairo_pattern_destroy s))
                  (cairo_destroy cr))))))
    (tellv ctx restoreGraphicsState)))

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

@@ -16,20 +16,14 @@
 
 ;; ----------------------------------------
 
-(import-class NSTextField NSImageView NSWorkspace)
+(import-class NSTextField NSImageView NSWorkspace NSRunningApplication)
 
 (define _OSType _uint32)
 
 (define-cocoa NSFileTypeForHFSTypeCode (_fun _OSType -> _id))
 
 (define (get-app-icon)
-  (tell (tell NSWorkspace sharedWorkspace)
+  (tell (tell NSRunningApplication currentApplication) icon))
-        iconForFile:
-        (tell (tell (tell NSWorkspace sharedWorkspace)
-                    activeApplication)
-              objectForKey:
-              #:type _NSString
-              "NSApplicationPath")))
 
 (define (make-icon label)
   (let ([icon

collects/mred/private/wx/common/backing-dc.rkt

@@ -4,11 +4,14 @@
          racket/draw/private/bitmap-dc
          racket/draw/private/bitmap
          racket/draw/private/local
+         racket/draw/private/record-dc
+         racket/draw/unsafe/cairo
          "../../lock.rkt"
          "queue.rkt")
 
 (provide 
  (protect-out backing-dc%
+              backing-draw-bm
               
               ;; scoped method names:
               get-backing-size
@@ -35,13 +38,19 @@
   end-delay)
 
 (define backing-dc%
-  (class (dc-mixin bitmap-dc-backend%)
+  (class (record-dc-mixin (dc-mixin bitmap-dc-backend%))
+    (init transparent?)
+
     (inherit internal-get-bitmap
              internal-set-bitmap
-             reset-cr)
+             reset-cr
+             set-recording-limit
+             get-recorded-command)
 
     (super-new)
 
+    (set-recording-limit (if transparent? 1024 -1))
+
     (define/override (ok?) #t)
 
     ;; Override this method to get the right size
@@ -67,7 +76,8 @@
        [(not retained-cr) #f]
        [(positive? retained-counter) 
         (unless nada?
-          (proc (internal-get-bitmap)))
+          (proc (or (get-recorded-command)
+                    (internal-get-bitmap))))
         #t]
        [else 
         (reset-backing-retained proc)
@@ -155,3 +165,43 @@
 
 (define (release-backing-bitmap bm)
   (send bm release-bitmap-storage))
+
+(define cairo-dc
+  (make-object (dc-mixin
+                (class default-dc-backend%
+                  (inherit reset-cr)
+
+                  (define cr #f)
+                  (define w 0)
+                  (define h 0)
+
+                  (super-new)
+
+                  (define/public (set-cr new-cr new-w new-h)
+                    (set! cr new-cr)
+                    (set! w new-w)
+                    (set! h new-h)
+                    (when cr
+                      (reset-cr cr)))
+
+                  (define/override (get-cr) cr)
+
+                  (define/override (reset-clip cr)
+                    (super reset-clip cr)
+                    (cairo_rectangle cr 0 0 w h)
+                    (cairo_clip cr))))))
+
+(define (backing-draw-bm bm cr w h)
+  (if (procedure? bm)
+      (begin
+        (send cairo-dc set-cr cr w h)
+        (bm cairo-dc)
+        (send cairo-dc set-cr #f 0 0))
+      (let ([s (cairo_get_source cr)])
+        (cairo_pattern_reference s)
+        (cairo_set_source_surface cr (send bm get-cairo-surface) 0 0)
+        (cairo_new_path cr)
+        (cairo_rectangle cr 0 0 w h)
+        (cairo_fill cr)
+        (cairo_set_source cr s)
+        (cairo_pattern_destroy s))))

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

@@ -143,7 +143,8 @@
         (let ([pq paint-queued])
           (when pq (set-box! pq #f)))
         (set! paint-queued #f)
-        (when (or (not b) (is-shown-to-root?))
+        (cond
+         [(or (not b) (is-shown-to-root?))
           (let ([dc (get-dc)])
             (send dc suspend-flush)
             (send dc ensure-ready)
@@ -156,7 +157,11 @@
                   (send dc set-background old-bg))))
             (on-paint)
             (send dc resume-flush)
-            (queue-backing-flush))))
+            (queue-backing-flush))]
+         [b ; => not shown to root
+          ;; invalidate dc so that it's refresh
+          ;; when it's shown again
+          (send (get-dc) reset-backing-retained)]))
       (when req
         (cancel-canvas-flush-delay req)))
 

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

@@ -41,6 +41,7 @@
 (define-gtk gtk_combo_box_entry_new_text (_fun -> _GtkWidget))
 (define-gtk gtk_combo_box_append_text (_fun _GtkWidget _string -> _void))
 (define-gtk gtk_combo_box_remove_text (_fun _GtkWidget _int -> _void))
+(define-gtk gtk_combo_box_popup (_fun _GtkWidget -> _void))
 
 (define-gtk gtk_widget_queue_draw (_fun _GtkWidget -> _void))
 
@@ -283,7 +284,7 @@
 
      (set-size x y w h)
      
-     (define dc (new dc% [canvas this]))
+     (define dc (new dc% [canvas this] [transparent? (memq 'transparent style)]))
 
      (define for-gl? (memq 'gl style))
      (when for-gl?
@@ -344,10 +345,19 @@
      (define/override (handles-events? gtk) (not (ptr-equal? gtk combo-button-gtk)))
 
      (define/override (internal-pre-on-event gtk e)
-       (when (and (ptr-equal? gtk combo-button-gtk)
+       (if (and (ptr-equal? gtk combo-button-gtk)
-                  (send e button-down?))
+                (send e button-down?))
-         (on-popup))
+           (begin
-       #f)
+             (on-popup)
+             #t)
+           #f))
+     (define/public (popup-combo)
+       ;; Unfortunately, the user has to hold the mouse 
+       ;; button down when popping up the menu this way,
+       ;; whereas the default handler (that we subvert in
+       ;; `internal-pre-on-event') keeps the menu open if
+       ;; the user release the mouse button right away.
+       (gtk_combo_box_popup gtk))
 
      (define/override (get-client-delta)
        (values margin margin))

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

@@ -92,11 +92,12 @@
 
 (define dc%
   (class backing-dc%
-    (init [(cnvs canvas)])
+    (init [(cnvs canvas)]
+          transparent?)
     (inherit end-delay)
     (define canvas cnvs)
 
-    (super-new)
+    (super-new [transparent? transparent?])
 
     (define gl #f)
     (define/override (get-gl-context)
@@ -146,12 +147,5 @@
                 [h (box 0)])
             (send canvas get-client-size w h)
             (let ([cr (gdk_cairo_create win)])
-              (let ([s (cairo_get_source cr)])
+              (backing-draw-bm bm cr (unbox w) (unbox h))
-                (cairo_pattern_reference s)
-                (cairo_set_source_surface cr (send bm get-cairo-surface) 0 0)
-                (cairo_new_path cr)
-                (cairo_rectangle cr 0 0 (unbox w) (unbox h))
-                (cairo_fill cr)
-                (cairo_set_source cr s)
-                (cairo_pattern_destroy s))
               (cairo_destroy cr))))))

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

@@ -47,6 +47,8 @@
 (define HTHSCROLL           6)
 (define HTVSCROLL           7)
 
+(define CB_SHOWDROPDOWN #x014F)
+
 (define-cstruct _SCROLLINFO
   ([cbSize _UINT]
    [fMask _UINT]
@@ -202,7 +204,7 @@
      (define/override (wndproc-for-ctlproc w msg wParam lParam default)
        (default w msg wParam lParam))
      
-     (define dc (new dc% [canvas this]))
+     (define dc (new dc% [canvas this] [transparent? (memq 'transparent style)]))
      (send dc start-backing-retained)
 
      (define/public (get-dc) dc)
@@ -488,6 +490,9 @@
         [(= cmd CBN_DROPDOWN)
          (constrained-reply (get-eventspace) (lambda () (on-popup)) (void))]))
 
+     (define/public (popup-combo)
+       (SendMessageW combo-hwnd CB_SHOWDROPDOWN 1 0))
+
      (define/override (is-hwnd? a-hwnd)
        (or (ptr-equal? panel-hwnd a-hwnd)
            (ptr-equal? canvas-hwnd a-hwnd)

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

@@ -63,11 +63,12 @@
 
 (define dc%
   (class backing-dc%
-    (init [(cnvs canvas)])
+    (init [(cnvs canvas)]
+          transparent?)
     (inherit end-delay)
     (define canvas cnvs)
 
-    (super-new)
+    (super-new [transparent? transparent?])
 
     (define gl #f)
     (define/override (get-gl-context)
@@ -116,14 +117,7 @@
             (let* ([surface (cairo_win32_surface_create hdc)]
                    [cr (cairo_create surface)])
               (cairo_surface_destroy surface)
-              (let ([s (cairo_get_source cr)])
+              (backing-draw-bm bm cr (unbox w) (unbox h))
-                (cairo_pattern_reference s)
-                (cairo_set_source_surface cr (send bm get-cairo-surface) 0 0)
-                (cairo_new_path cr)
-                (cairo_rectangle cr 0 0 (unbox w) (unbox h))
-                (cairo_fill cr)
-                (cairo_set_source cr s)
-                (cairo_pattern_destroy s))
               (cairo_destroy cr))))))
 
 (define (request-flush-delay canvas)

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

@@ -22,16 +22,19 @@
 
     (define children null)
     (define/override (register-child child on?)
-      (let ([now-on? (and (memq child children) #t)])
+      (let ([on? (and on? #t)]
+            [now-on? (and (memq child children) #t)])
         (unless (eq? on? now-on?)
           (unless on?
             (when (eq? child mouse-in-child)
+              (send child send-leaves #f)
               (set! mouse-in-child #f)))
           (set! children 
                 (if on?
                     (cons child children)
                     (remq child children)))
-          (send child parent-enable (is-enabled-to-root?)))))
+          (when on?
+            (send child parent-enable (is-enabled-to-root?))))))
 
     (define/override (internal-enable on?)
       (super internal-enable on?)

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

@@ -601,12 +601,13 @@
 
   (define/public (send-leaves mk)
     (set! mouse-in? #f)
-    (let ([e (mk 'leave)])
+    (when mk
-      (if (eq? (current-thread) 
+      (let ([e (mk 'leave)])
-               (eventspace-handler-thread eventspace))
+        (if (eq? (current-thread) 
-          (handle-mouse-event (get-client-hwnd) 0 0 e)
+                 (eventspace-handler-thread eventspace))
-          (queue-window-event this
+            (handle-mouse-event (get-client-hwnd) 0 0 e)
-                              (lambda () (dispatch-on-event/sync e))))))
+            (queue-window-event this
+                                (lambda () (dispatch-on-event/sync e)))))))
 
   (define/public (send-child-leaves mk)
     #f)

collects/mred/private/wxme/cycle.rkt

@@ -8,7 +8,6 @@
 
 (decl text% set-text%!)
 (decl pasteboard% set-pasteboard%!)
-(decl snip-admin% set-snip-admin%!)
 (decl editor-stream-in% set-editor-stream-in%!)
 (decl editor-stream-out% set-editor-stream-out%!)
 (decl editor-snip% set-editor-snip%!)
@@ -18,7 +17,6 @@
 (decl extended-text% set-extended-text%!)
 (decl extended-pasteboard% set-extended-pasteboard%!)
 
-(decl get-snip-class set-get-snip-class!)
 (decl get-editor-data-class set-get-editor-data-class!)
 
 (decl editor-get-file set-editor-get-file!)

collects/mred/private/wxme/editor-admin.rkt

@@ -1,8 +1,9 @@
 #lang scheme/base
 (require scheme/class
          "../syntax.ss"
-         "snip.ss"
+         racket/snip
          "private.ss"
+         racket/snip/private/private
          (only-in "cycle.ss" popup-menu%))
 
 (provide editor-admin%)

collects/mred/private/wxme/editor-canvas.rkt

@@ -5,6 +5,7 @@
          "editor.ss"
          "editor-admin.ss"
          "private.ss"
+         racket/snip/private/private
          (only-in "cycle.ss" popup-menu%)
          (only-in "../helper.ss" queue-window-callback)
          "wx.ss")

collects/mred/private/wxme/editor-data.rkt

@@ -0,0 +1,170 @@
+#lang racket/base
+
+(require scheme/class
+         scheme/file file/convertible
+         "../syntax.ss"
+         racket/snip/private/snip-flags
+         "private.ss"
+         racket/snip/private/private
+         "style.ss"
+        racket/snip/private/load-one
+	(only-in "cycle.ss"
+                  editor-stream-in% editor-stream-out%
+                  get-editor-data-class set-get-editor-data-class!)
+         "../wx/common/event.rkt"
+         racket/draw)
+
+(provide get-the-editor-data-class-list         
+         editor-data%
+         editor-data-class%
+         location-editor-data%
+         editor-data-class-list<%>
+         the-editor-data-class-list ;; parameter
+         make-the-editor-data-class-list
+         (struct-out editor-data-class-link))
+
+;; ------------------------------------------------------------
+
+(defclass editor-data% object%
+  (properties [[(make-or-false editor-data-class%) dataclass] #f]
+              [[(make-or-false editor-data%) next] #f])
+  (super-new)
+  (def/public (write [editor-stream-out% f])
+    (error 'write "should have overridden"))
+
+  (define/public (get-s-dataclass) dataclass)
+  (define/public (get-s-next) next)
+  (define/public (set-s-next v) (set! next v)))
+
+
+(defclass location-editor-data% editor-data%
+  (inherit set-dataclass)
+  (init-field x y)
+  (super-new)
+  (set-dataclass the-location-editor-data-class)
+
+  (define/public (get-x) x)
+  (define/public (get-y) y)
+
+  (def/override (write [editor-stream-out% f])
+    (send f put x)
+    (send f put y)
+    #t))
+
+;; ------------------------------------------------------------
+
+(defclass editor-data-class% object%
+  (define classname "wxbad")  
+  (def/public (set-classname [string? s])
+    (set! classname (string->immutable-string s)))
+  (def/public (get-classname) classname)
+
+  (properties [[bool? required?] #f])
+  (define/public (get-s-required?) required?)
+
+  (def/public (read [editor-stream-in% f]) (void))
+
+  (super-new))
+
+(defclass location-editor-data-class% editor-data-class%
+  (inherit set-classname
+           set-required?)
+
+  (super-new)
+
+  (set-classname "wxloc")
+  (set-required? #t)
+
+  (def/override (read [editor-stream-in% f])
+    (let ([x (send f get-inexact)]
+          [y (send f get-inexact)])
+      (new location-editor-data% [x x][y y]))))
+
+(define the-location-editor-data-class
+  (new location-editor-data-class%))
+
+;; ------------------------------------------------------------
+
+(define-struct editor-data-class-link ([c #:mutable] [name #:mutable] map-position))
+
+(defclass editor-data-class-list% object%
+  (define ht (make-hash))
+  (define pos-ht (make-hash))
+  (define rev-pos-ht (make-hash))
+
+  (super-new)
+
+  (add the-location-editor-data-class)
+
+  (def/public (find [string? name])
+    (let ([c (hash-ref ht name #f)])
+      (or c
+          (let ([c (get-editor-data-class name)])
+            (when c (add c))
+            c))))
+  
+  (def/public (find-position [editor-data-class% c])
+    (hash-ref pos-ht c 0))
+  
+  (def/public (add [editor-data-class% c])
+    (let ([name (send c get-classname)])
+      (hash-set! ht name c)
+      (let ([n (add1 (hash-count pos-ht))])
+        (hash-set! pos-ht c n)
+        (hash-set! rev-pos-ht n c))))
+
+  (def/public (number) (hash-count ht))
+
+  (def/public (nth [exact-nonnegative-integer? n]) (hash-ref rev-pos-ht n #f))
+
+  (def/public (write [editor-stream-out% f])
+    (let ([n (number)])
+      (send f put n)
+      (for ([i (in-range 1 (add1 n))])
+        (let ([c (nth i)])
+          (send f put (string->bytes/utf-8 (send c get-classname)))
+
+          (send f add-dl (make-editor-data-class-link c
+                                                      #f
+                                                      i)))))
+    #t)
+
+  (def/public (read [editor-stream-in% f])
+    (let-boxes ([count 0])
+        (send f get count)
+      (for/and ([i (in-range count)])
+        (let ([s (send f get-bytes)])
+          (and (send f ok?)
+               (send f add-dl (make-editor-data-class-link
+                               #f
+                               (bytes->string/utf-8 s #\?)
+                               (add1 i)))
+               #t)))))
+
+  (define/public (find-by-map-position f n)
+    (ormap (lambda (s)
+             (and (= n (editor-data-class-link-map-position s))
+                  (begin
+                    (when (editor-data-class-link-name s)
+                      (let ([c (find (editor-data-class-link-name s))])
+                        (when (not c)
+                          ;; unknown class/version
+                          (log-error (format "unknown editor data class: ~e" 
+                                             (editor-data-class-link-name s))))
+                        (set-editor-data-class-link-name! s #f)
+                        (set-editor-data-class-link-c! s c)))
+                    (editor-data-class-link-c s))))
+           (send f get-dl))))
+
+(define editor-data-class-list<%> (class->interface editor-data-class-list%))
+
+(define (make-the-editor-data-class-list)
+  (new editor-data-class-list%))
+
+(define the-editor-data-class-list (make-parameter (make-the-editor-data-class-list)))
+(define (get-the-editor-data-class-list)
+  (the-editor-data-class-list))
+
+(set-get-editor-data-class!
+ (lambda (name)
+   (load-one name 'editor-data-class editor-data-class%)))

collects/mred/private/wxme/editor-snip-class.rkt

@@ -0,0 +1,76 @@
+#lang racket/base
+
+(require racket/class
+         racket/file file/convertible
+         "../syntax.ss"
+         racket/snip/private/snip-flags
+         "private.ss"
+         racket/snip/private/private
+         "style.ss"
+         racket/snip
+         (only-in "cycle.ss"
+                  editor-stream-in% editor-stream-out%
+                  extended-text% extended-pasteboard% extended-editor-snip% 
+                  get-editor-data-class)
+         "../wx/common/event.rkt"
+         racket/draw)
+
+(provide the-editor-snip-class)
+;; ------------------------------------------------------------
+
+(defclass editor-snip-class% snip-class%
+  (inherit set-classname
+           set-version)
+  (inherit-field s-required?)
+
+  (super-new)
+  
+  (set-classname "wxmedia")
+  (set-version 4)
+  (set! s-required? #t)
+
+  (def/override (read [editor-stream-in% f])
+    (let ([vers (send f do-reading-version this)])
+      (let ([ed% (case (send f get-exact)
+                   [(1) extended-text%]
+                   [(2) extended-pasteboard%]
+                   [else #f])]
+            [border? (positive? (send f get-exact))]
+            [lm (max 0 (send f get-exact))]
+            [tm (max 0 (send f get-exact))]
+            [rm (max 0 (send f get-exact))]
+            [bm (max 0 (send f get-exact))]
+            [li (max 0 (send f get-exact))]
+            [ti (max 0 (send f get-exact))]
+            [ri (max 0 (send f get-exact))]
+            [bi (max 0 (send f get-exact))]
+            [min-w (send f get-inexact)]
+            [max-w (send f get-inexact)]
+            [min-h (send f get-inexact)]
+            [max-h (send f get-inexact)]
+            [tf? (and (vers . > . 1)
+                      (positive? (send f get-exact)))]
+            [atl? (and (vers . > . 2)
+                       (positive? (send f get-exact)))]
+            [ubs? (and (vers . > . 3)
+                       (positive? (send f get-exact)))])
+        (let ([e (and ed% (new ed%))])
+          (let ([snip (make-object extended-editor-snip%
+                                   e
+                                   border?
+                                   lm tm rm bm li ti ri bi
+                                   (if (negative? min-w) 'none min-w)
+                                   (if (negative? max-w) 'none max-w)
+                                   (if (negative? min-h) 'none min-h)
+                                   (if (negative? max-h) 'none max-h))])
+            (send snip do-set-graphics tf? atl? ubs?)
+            (if e
+                (begin
+                  (send e get-style-list)
+                  (send e read-from-file f #t))
+                (send snip set-editor #f))
+            snip))))))
+
+(define the-editor-snip-class (new editor-snip-class%))
+
+(send (get-the-snip-class-list) add the-editor-snip-class)

collects/mred/private/wxme/editor-snip.rkt

@@ -2,12 +2,14 @@
 (require scheme/class
          "../syntax.ss"
          "private.ss"
+         racket/snip/private/private
          "const.ss"
-         "snip.ss"
+         racket/snip
-         "snip-flags.ss"
+         racket/snip/private/snip-flags
+         "standard-snip-admin.rkt"
          "editor.ss"
          "editor-admin.ss"
-         "snip-admin.ss"
+         "editor-snip-class.rkt"
          "text.ss"
          "pasteboard.ss"
          "wx.ss"
@@ -15,8 +17,7 @@
                     text%
                     pasteboard%
                     editor-snip%
-                    editor-snip-editor-admin%
+                    editor-snip-editor-admin%))
-                    snip-admin%))
 
 (provide editor-snip%
          editor-snip-editor-admin<%>)
@@ -360,8 +361,8 @@
                   (when with-border?
                     (let ([pen (send dc get-pen)])
                       (when (and (pair? caret)
-                                 selected-text-color)
+                                 (send my-admin get-selected-text-color))
-                        (send dc set-pen selected-text-color 1 'solid))
+                        (send dc set-pen (send my-admin get-selected-text-color) 1 'solid))
                       (let* ([l (+ orig-x left-inset)]
                              [t (+ orig-y top-inset)]
                              [r (+ l w left-margin right-margin 

collects/mred/private/wxme/editor.rkt

@@ -4,13 +4,15 @@
          scheme/file
          "../syntax.ss"
          "private.ss"
+         racket/snip/private/private
          "style.ss"
-         "snip.ss"
+         racket/snip
-         "snip-flags.ss"
+         racket/snip/private/snip-flags
          "editor-admin.ss"
          "stream.ss"
          "undo.ss"
          "keymap.ss"
+         "editor-data.rkt"
          (only-in "cycle.ss" 
                   text%
                   pasteboard%

collects/mred/private/wxme/mline.rkt

@@ -2,9 +2,10 @@
 (require scheme/class
          "../syntax.ss"
          "const.ss"
-         "snip.ss"
+         racket/snip
-         "snip-flags.ss"
+         racket/snip/private/snip-flags
-         "private.ss")
+         "private.ss"
+         racket/snip/private/private)
 
 (provide create-mline
          (struct-out mline)

collects/mred/private/wxme/pasteboard.rkt

@@ -5,12 +5,14 @@
          "../syntax.ss"
          "const.ss"
          "private.ss"
+         racket/snip/private/private
          "editor.ss"
+         "editor-data.rkt"
          "undo.ss"
          "style.ss"
-         "snip.ss"
+         racket/snip
-         "snip-flags.ss"
+         racket/snip/private/snip-flags
-         "snip-admin.ss"
+         "standard-snip-admin.rkt"
          "keymap.ss"
          (only-in "cycle.ss" set-pasteboard%!)
          "wordbreak.ss"

collects/mred/private/wxme/private.rkt

@@ -3,44 +3,11 @@
 
 (provide (all-defined-out))
 
-;; snip% and editor%
-(define-local-member-name
-  s-admin)
-
-;; snip%
-(define-local-member-name
-  s-prev set-s-prev
-  s-next set-s-next
-  s-count
-  s-style set-s-style
-  s-line set-s-line
-  s-snipclass set-s-snipclass
-  s-flags set-s-flags
-  s-dtext get-s-dtext
-  s-buffer get-s-buffer
-  str-w set-str-w
-  s-set-flags
-  do-copy-to)
-
-;; string-snip%
-(define-local-member-name
-  insert-with-offset)
-
-;; snip-class%
-(define-local-member-name
-  get-s-required?
-  s-read)
-
 ;; editor-data%
 (define-local-member-name
   get-s-dataclass
   get-s-next)
 
-;; standard-snip-class-list%, editor-data-class-list%
-(define-local-member-name
-  reset-header-flags
-  find-by-map-position)
-
 ;; editor%
 (define-local-member-name
   s-offscreen
@@ -111,25 +78,6 @@
   do-get-canvas
   do-scroll-to)
 
-;; editor-stream%
-(define-local-member-name
-  get-sl
-  get-dl
-  set-sl
-  set-dl
-  add-sl
-  add-dl
-  set-s-sll
-  get-s-sll
-  get-s-scl
-  get-s-bdl
-  get-s-style-count
-  set-s-style-count
-  do-reading-version
-  do-map-position
-  do-get-header-flag
-  do-set-header-flag)
-
 ;; editor-stream-in%
 (define-local-member-name
   set-s-read-format

collects/mred/private/wxme/standard-snip-admin.rkt

@@ -1,56 +1,15 @@
 #lang scheme/base
 (require scheme/class
          "../syntax.ss"
-         "snip.ss"
+         racket/snip
          (only-in "cycle.ss" 
-                  set-snip-admin%!
                   popup-menu%)
-         "wx.ss")
+         (prefix-in wx: "wx.ss"))
 
-(provide snip-admin%
+(provide standard-snip-admin%)
-         standard-snip-admin%)
 
-(defclass snip-admin% object%
+(define TAB-WIDTH 20)
-  (super-new)
 
-  (def/public (get-editor) #f)
-  (def/public (get-dc) #f)
-  (def/public (get-view-size [maybe-box? w] [maybe-box? h])
-    #f)
-
-  (def/public (get-view [maybe-box? x] [maybe-box? y] [maybe-box? w] [maybe-box? h] 
-                        [(make-or-false snip%) [snip #f]])
-    #f)
-
-  (def/public (scroll-to [snip% s]
-                         [real? x] [real? y]
-                         [nonnegative-real? w] [nonnegative-real? h]
-                         [any? refresh?]
-                         [(symbol-in start end none) [bias 'none]])
-    #f)
-
-  (def/public (set-caret-owner [snip% s] [(symbol-in imeditorte display global) dist])
-    (void))
-
-  (def/public (resized [snip% s] [any? redraw?]) (void))
-
-  (def/public (recounted [snip% s] [any? redraw?]) (void))
-
-  (def/public (needs-update [snip% s] [real? x] [real? y]
-                            [nonnegative-real? w] [nonnegative-real? h])
-    (void))
-
-  (def/public (release-snip [snip% s]) #f)
-
-  (def/public (update-cursor) (void))
-
-  (def/public (popup-menu [popup-menu% p][snip% snip][real? x][real? y])
-    #f)
-
-  (def/public (modified [snip% s] [any? modified?])
-    (void)))
-
-(set-snip-admin%! snip-admin%)
 
 (defclass standard-snip-admin% snip-admin%
   (init-field editor)
@@ -146,4 +105,27 @@
 
   (def/override (modified [snip% s] [any? modified?])
     (when (eq? (send s get-admin) this)
-      (send editor on-snip-modified s modified?))))
+      (send editor on-snip-modified s modified?)))
+  
+  (def/override (get-line-spacing)
+    (if (object-method-arity-includes? editor 'get-line-spacing 0)
+        (send editor get-line-spacing)
+        0))
+  
+  (def/override (get-tabs [maybe-box? [length #f]] [maybe-box? [tab-width #f]] [maybe-box? [in-units #f]])
+    (if (object-method-arity-includes? editor 'get-tabs 3)
+        (send editor get-tabs length tab-width in-units)
+        (begin (when length (set-box! length 0))
+               (when tab-width (set-box! tab-width TAB-WIDTH))
+               (when in-units (set-box! in-units #t))
+               null)))
+  
+  (def/override (get-selected-text-color)
+    (wx:get-highlight-text-color))
+  
+  (def/override (call-with-busy-cursor [procedure? thunk])
+    (dynamic-wind
+     wx:begin-busy-cursor
+     thunk
+     wx:end-busy-cursor))
+  )

collects/mred/private/wxme/stream.rkt

@@ -2,7 +2,9 @@
 (require scheme/class
          "../syntax.ss"
          "private.ss"
-         "snip.ss"
+         racket/snip/private/private
+         racket/snip
+         "editor-data.rkt"
          (only-in "cycle.ss"
                   set-editor-stream-in%!
                   set-editor-stream-out%!))

collects/mred/private/wxme/text.rkt

@@ -7,12 +7,14 @@
          "const.ss"
          "mline.ss"
          "private.ss"
+         racket/snip/private/private
          "editor.ss"
+         "editor-data.rkt"
          "undo.ss"
          "style.ss"
-         "snip.ss"
+         racket/snip
-         "snip-flags.ss"
+         racket/snip/private/snip-flags
-         "snip-admin.ss"
+         "standard-snip-admin.rkt"
          "keymap.ss"
          (only-in "cycle.ss" set-text%!)
          "wordbreak.ss"
@@ -5106,7 +5108,22 @@
                   (lambda ()
                     (call-on-paint #f)
                     (set! write-locked? wl?)
-                    (set! flow-locked? #f))])
+                    (set! flow-locked? #f))]
+
+                 [local-caret-pen
+                  (if bg-color
+                      (let ([r (send bg-color red)]
+                            [g (send bg-color green)]
+                            [b (send bg-color blue)])
+                        (if (and (= r 255) (= g 255) (= b 255))
+                            caret-pen
+                            (make-object pen% (make-object color% 
+                                                           (- 255 r)
+                                                           (- 255 g)
+                                                           (- 255 b))
+                                         (send caret-pen get-width) 
+                                         'solid)))
+                      caret-pen)])
 
             (call-on-paint #t)
             
@@ -5132,7 +5149,7 @@
                                hilite-on?)
                       (let ([y ycounter]
                             [save-pen (send dc get-pen)])
-                        (send dc set-pen caret-pen)
+                        (send dc set-pen local-caret-pen)
                         (send dc draw-line dx (+ y dy) dx (sub1 (+ y extra-line-h dy)))
                         (send dc set-pen save-pen)))
                     (paint-done)]
@@ -5312,7 +5329,7 @@
                                          (when (eq? 'show-caret show-caret)
                                            (when (and (hsxs . <= . rightx) (hsxs . >= . leftx))
                                              (let ([save-pen (send dc get-pen)])
-                                               (send dc set-pen caret-pen)
+                                               (send dc set-pen local-caret-pen)
                                                (send dc draw-line (+ hsxs dx) (+ hsys dy) 
                                                      (+ hsxs dx) 
                                                      (+ hsye (sub1 dy)))

collects/mred/private/wxme/undo.rkt

@@ -1,8 +1,9 @@
 #lang scheme/base
 (require scheme/class
          "private.ss"
-         "snip.ss"
+         racket/snip/private/private
-         "snip-flags.ss")
+         racket/snip
+         racket/snip/private/snip-flags)
 
 (provide change-record%
          proc-record%

collects/mred/private/wxme/wx.rkt

@@ -1,22 +1,14 @@
 #lang scheme/base
-(require "../kernel.ss")
+(require "../kernel.ss" "symbol-predicates.rkt")
 
 (define the-clipboard (get-the-clipboard))
 (define the-x-selection-clipboard (get-the-x-selection))
 
-(define (family-symbol? s)
-  (memq s '(default decorative roman script
-             swiss modern symbol system)))
-(define (style-symbol? s)
-  (memq s '(normal italic slant)))
-(define (weight-symbol? s)
-  (memq s '(normal bold light)))
-(define (smoothing-symbol? s)
-  (memq s '(default smoothed unsmoothed partly-smoothed)))
 (define (size? v) (and (exact-positive-integer? v)
                        (byte? v)))
 
-(provide event%
+(provide (all-from-out "symbol-predicates.rkt")
+         event%
          mouse-event%
          key-event%
          timer%

collects/mred/private/wxtextfield.rkt

@@ -3,7 +3,7 @@
 	   mzlib/class100
 	   (prefix-in wx: "kernel.ss")
            (prefix-in wx: "wxme/text.ss")
-           (prefix-in wx: "wxme/snip.ss")
+           (prefix-in wx: racket/snip)
            (prefix-in wx: "wxme/editor-canvas.ss")
 	   "lock.ss"
 	   "const.ss"
@@ -221,6 +221,7 @@
       (private-field
        [l (and label
 	       (make-object wx-message% #f proxy p label -1 -1 null font))]
+       [combo-callback #f]
        [c (make-object (class wx-text-editor-canvas% 
                          (define/override (on-combo-select i)
                            (let ([len (length callbacks)])
@@ -239,8 +240,31 @@
 				'(hide-hscroll))
 			    '(hide-vscroll hide-hscroll))))]
        [callbacks null])
+      (override 
+        [pre-on-event (lambda (w e)
+                        (or (super pre-on-event w e)
+                            (and combo-callback
+                                 (eq? w c)
+                                 (send e button-down?)
+                                 (let ([w (box 0)]
+                                       [h (box 0)])
+                                   (send c get-client-size w h)
+                                   (not (and (<= 0 (send e get-x) (unbox w))
+                                             (<= 0 (send e get-y) (unbox h)))))
+                                 (begin
+                                   (do-popup-callback)
+                                   #t))))])
+      (private
+        [do-popup-callback (lambda ()
+                             (wx:queue-callback (lambda ()
+                                                  (when (send c is-enabled-to-root?)
+                                                    (combo-callback)
+                                                    (send c popup-combo)))
+                                                wx:middle-queue-key))])
       (public
-        [set-on-popup (lambda (proc) (send c set-on-popup proc))]
+        [set-on-popup (lambda (proc) 
+                        (set! combo-callback proc) 
+                        (send c set-on-popup (lambda () (do-popup-callback))))]
         [clear-combo-items (lambda () (set! callbacks null) (send c clear-combo-items))]
         [append-combo-item (lambda (s cb)
                              (and (send c append-combo-item s)

collects/mrlib/cache-image-snip.rkt

@@ -1,5 +1,6 @@
 (module cache-image-snip mzscheme
-  (require mred
+  (require racket/draw
+           racket/snip
            mzlib/class
            mzlib/string
 	   mzlib/contract

collects/mrlib/image-core.rkt

@@ -28,15 +28,17 @@ has been moved out).
 |#
 
 (require racket/class
-         racket/gui/base
+         racket/draw
+         (for-syntax racket/base)
+         file/convertible         
          racket/math
          racket/contract
          "private/image-core-bitmap.ss" 
          "image-core-wxme.ss"
          "private/image-core-snipclass.rkt"
          "private/regmk.rkt"
-         (prefix-in cis: "cache-image-snip.ss")
+         racket/snip
-         (for-syntax racket/base))
+         (prefix-in cis: "cache-image-snip.ss"))
 
 
 
@@ -197,8 +199,31 @@ has been moved out).
 (define skip-image-equality-fast-path (make-parameter #f))
 (define render-normalized (make-parameter #f))
 
+(define png-convertible<%>
+  (interface* ()
+              ([prop:convertible
+                (lambda (img format default)
+                  (case format
+                    [(png-bytes)
+                     (let ([s (open-output-bytes)])
+                       (send (to-bitmap (to-img img)) save-file s 'png)
+                       (get-output-bytes s))]
+                    [else default]))])))
+
+(define (to-bitmap img)  
+  (let* ([bb (send img get-bb)]
+         [bm (make-bitmap
+              (add1 (inexact->exact (ceiling (bb-right bb)))) 
+              (add1 (inexact->exact (ceiling (bb-bottom bb)))))]
+         [bdc (new bitmap-dc% [bitmap bm])])
+    (send bdc clear)
+    (render-image img bdc 0 0)
+    (begin0
+        (send bdc get-bitmap)
+      (send bdc set-bitmap #f))))
+	     
 (define image%
-  (class* snip% (equal<%> image<%>)
+  (class* snip% (png-convertible<%> equal<%> image<%>)
     (init-field shape bb normalized? pinhole)
     (define/public (equal-to? that eq-recur)
       (or (eq? this that)
@@ -260,10 +285,7 @@ has been moved out).
               (when standard
                 (let ([dc (make-object bitmap-dc% (make-object bitmap% 1 1))])
                   (let-values ([(w h d a) (send dc get-text-extent "X" (send standard get-font))])
-                    (set! scroll-step (+ h
+                    (set! scroll-step (+ h (send admin get-line-spacing)))))))))
-                                         (if (is-a? ed text%)
-                                             (send ed get-line-spacing)
-                                             0)))))))))
         ;; if that didn't happen, set it to 12.
         (unless scroll-step (set! scroll-step 12))))
     
@@ -280,8 +302,7 @@ has been moved out).
 
     (define/override (copy) (make-image shape bb normalized? pinhole))
     (define/override (draw dc x y left top right bottom dx dy draw-caret?)
-      (let ([smoothing (send dc get-smoothing)])
+      (render-image this dc x y))
-        (render-image this dc x y)))
     
     (define/override (get-extent dc x y [w #f] [h #f] [descent #f] [space #f] [lspace #f] [rspace #f])
       (send (get-the-snip-class-list) add snip-class)
@@ -1146,7 +1167,8 @@ the mask bitmap and the original bitmap are all together in a single bytes!
          
          to-img
          bitmap->image
-         image-snip->image)
+         image-snip->image
+         image-snip%)
 
 ;; method names
 (provide get-shape get-bb get-pinhole get-normalized? get-normalized-shape)

collects/mrlib/private/image-core-bitmap.rkt

@@ -1,5 +1,5 @@
 #lang scheme/base
-(require scheme/gui/base
+(require racket/draw
          scheme/class)
 
 

collects/mrlib/switchable-button.rkt

@@ -88,7 +88,8 @@
     (define/override (on-superwindow-show show?)
       (unless show?
         (set! in? #f)
-        (set! down? #f))
+        (set! down? #f)
+        (refresh))
       (super on-superwindow-show show?))
     
     (define/override (on-event evt)

collects/scribblings/gui/canvas-class.scrbl

@@ -55,8 +55,9 @@ The @scheme[style] argument indicates one or more of the following styles:
        canvas before calls to @method[canvas% on-paint]} 
 
  @item{@scheme['transparent] --- the canvas is automatically ``erased''
- before an update using it's parent window's background; the result is
+ before an update using it's parent window's background; see @racket[canvas<%>]
- undefined if this flag is combined with @scheme['no-autoclear]}
+ for information on the interaction of @racket['transparent] and offscreen buffering; 
+ the result is undefined if this flag is combined with @scheme['no-autoclear]}
  
  @item{@scheme['no-focus] --- prevents the canvas from accepting the
  keyboard focus when the canvas is clicked, or when the

collects/scribblings/gui/canvas-intf.scrbl

@@ -6,9 +6,6 @@
 A canvas is a subwindow onto which graphics and text can be drawn. Canvases also
  receive mouse and keyboard events.
 
-To draw onto a canvas, get its device context (see
-@method[canvas<%> get-dc]).
-
 The @scheme[canvas<%>] interface is implemented by two classes:
 @itemize[
 
@@ -20,6 +17,28 @@ The @scheme[canvas<%>] interface is implemented by two classes:
 
 ]
 
+To draw onto a canvas, get its device context (see
+@method[canvas<%> get-dc]).
+
+Drawing to a canvas's drawing context actually renders into an
+offscreen buffer. The buffer is automatically flushed to the screen by
+a background thread, explicitly via the @method[canvas<%> flush]
+method, or explicitly via @racket[flush-display]---unless flushing
+has been disabled for the canvas.  The @method[canvas<%>
+suspend-flush] method suspends flushing for a canvas until a matching
+@method[canvas<%> resume-flush] calls; calls to @method[canvas<%>
+suspend-flush] and @method[canvas<%> resume-flush] can be nested, in
+which case flushing is suspended until the outermost @method[canvas<%>
+suspend-flush] is balanced by a @method[canvas<%> resume-flush].
+
+In the case of a transparent canvas (i.e., one that is created with
+@racket['transparent] style), line and text smoothing can depend on
+the window that serves as the canvas's background. For example,
+smoothing may color pixels differently depending on whether the target
+context is white or gray.  Background-sensitive smoothing is supported
+only if a relatively small number of drawing commands are recorded in
+the canvas's offscreen buffer, however.
+
 
 @defmethod*[([(accept-tab-focus)
               boolean?]
@@ -191,7 +210,7 @@ Does nothing.
 
 @defmethod[(resume-flush) void?]{
 
-See @method[canvas<%> suspend-flush].}
+See @racket[canvas<%>] for information on canvas flushing.}
 
 
 
@@ -223,19 +242,10 @@ Under Mac OS X, enables or disables space for a resize tab at the
 
 @defmethod[(suspend-flush) void?]{
 
-Drawing to a canvas's drawing context actually renders into an
+See @racket[canvas<%>] for information on canvas flushing.
-offscreen buffer. The buffer is automatically flushed to the screen by
-a background thread, explicitly via the @method[canvas<%> flush] method, 
-or explicitly via @racket[flush-display] --- unless flushing has been disabled for the canvas.
-The @method[canvas<%> suspend-flush] method suspends flushing for a
-canvas until a matching @method[canvas<%> resume-flush] calls; calls to
-@method[canvas<%> suspend-flush] and @method[canvas<%> resume-flush] can
-be nested, in which case flushing is suspended until the outermost
-@method[canvas<%> suspend-flush] is balanced by a @method[canvas<%>
-resume-flush].
 
-On some platforms, beware that suspending flushing for a canvas can
+Beware that suspending flushing for a canvas can discourage refreshes
-discourage refreshes for other windows in the same frame.}
+for other windows in the same frame on some platforms.}
 
 
 @defmethod[(warp-pointer [x (integer-in 0 10000)]

collects/scribblings/gui/diagrams.rkt

@@ -11,8 +11,10 @@
            menu-diagram
            editor-diagram
            snip-diagram
+           editor-snip-diagram
            style-diagram
-           admin-diagram
+           snip-list-diagram
+           editor-admin-diagram
            stream-diagram)
 
   (define (diagram->table d)
@@ -125,11 +127,21 @@ DIAG
    |- string-snip%
    |   |- tab-snip%
    |- image-snip%
+   |- editor-snip% (not provided by racket/snip)
+
+  snip-admin%
+DIAG
+)
+
+  (define editor-snip-diagram
+#<<DIAG
+  snip%
    |- editor-snip%
 DIAG
 )
 
-  (define admin-diagram
+ 
+  (define editor-admin-diagram
 #<<DIAG
   editor-canvas%
  
@@ -145,13 +157,20 @@ DIAG
   style<%>         style-delta%       add-color<%>
   style-list%                         mult-color<%>
 DIAG
+)
+
+  (define snip-list-diagram
+#<<DIAG
+  snip-class%
+  snip-class-list<%>
+DIAG
 )
 
   (define stream-diagram
 #<<DIAG
  editor-data%
- editor-data-class%                     snip-class%
+ editor-data-class%
- editor-data-class-list<%>              snip-class-list<%>
+ editor-data-class-list<%>
  
  editor-stream-in%                 editor-stream-out%
  editor-stream-in-base%            editor-stream-out-base%

collects/scribblings/gui/editor-canvas-class.scrbl

@@ -71,7 +71,9 @@ The @scheme[style] list can contain the following flags:
                              method}
 
  @item{@scheme['transparent] --- the canvas is ``erased'' before an
-                             update using its parent window's background}
+                             update using its parent window's background; see @racket[canvas<%>]
+                             for information on the interaction of @racket['transparent] and 
+                             offscreen buffering}
 
 ]
 

collects/scribblings/gui/editor-classes.scrbl

@@ -8,13 +8,13 @@ Editors:
 
 @diagram->table[editor-diagram]
 
-Snips:
+Editor Snips:
 
-@diagram->table[snip-diagram]
+@diagram->table[editor-snip-diagram]
 
 Displays, Administrators, and Mappings:
 
-@diagram->table[admin-diagram]
+@diagram->table[editor-admin-diagram]
 
 Styles:
 
@@ -44,18 +44,10 @@ Alphabetical:
 @include-section["editor-stream-out-base-class.scrbl"]
 @include-section["editor-stream-out-bytes-base-class.scrbl"]
 @include-section["editor-wordbreak-map-class.scrbl"]
-@include-section["image-snip-class.scrbl"]
 @include-section["keymap-class.scrbl"]
 @include-section["mult-color-intf.scrbl"]
 @include-section["pasteboard-class.scrbl"]
-@include-section["readable-snip-intf.scrbl"]
-@include-section["snip-class.scrbl"]
-@include-section["snip-admin-class.scrbl"]
-@include-section["snip-class-class.scrbl"]
-@include-section["snip-class-list-intf.scrbl"]
-@include-section["string-snip-class.scrbl"]
 @include-section["style-intf.scrbl"]
 @include-section["style-delta-class.scrbl"]
 @include-section["style-list-class.scrbl"]
-@include-section["tab-snip-class.scrbl"]
 @include-section["text-class.scrbl"]

collects/scribblings/gui/gui.scrbl

@@ -43,6 +43,7 @@ Both parts of the toolbox rely extensively on the
 @include-section["win-classes.scrbl"]
 @include-section["win-funcs.scrbl"]
 @include-section["editor-overview.scrbl"]
+@include-section["snip-classes.scrbl"]
 @include-section["editor-classes.scrbl"]
 @include-section["editor-funcs.scrbl"]
 @include-section["wxme.scrbl"]

collects/scribblings/gui/snip-admin-class.scrbl

@@ -320,4 +320,70 @@ Queues an update for the cursor in the @techlink{display} for this
 
 Does nothing.
 
-}}}
+}}
+
+
+@defmethod[(get-line-spacing)
+           (and/c real? (not/c negative?))]{
+
+@methspec{
+
+Returns the spacing inserted by the snip's editor between each
+line. 
+}
+@methimpl{
+
+Returns @scheme[0.0]
+
+}}
+
+@defmethod[(get-selected-text-color)
+           void?]{
+
+@methspec{
+
+Returns the color that is used to draw selected text or @scheme[#f] if
+selected text is drawn with its usual color.
+}
+@methimpl{
+
+Returns @scheme[#f].
+}}
+
+
+@defmethod[(call-with-busy-cursor [thunk (-> any)])
+           any]{
+
+@methspec{
+
+Calls @scheme[thunk] while changing the cursor to a watch cursor for
+all windows in the current eventspace.
+
+}
+
+@methimpl{
+
+Does nothing.
+}}
+
+@defmethod[(get-tabs [length (or/c (box/c exact-nonnegative-integer?) #f) #f]
+                     [tab-width (or/c (box/c real?) #f) #f]
+                     [in-units (or/c (box/c any/c) #f) #f])
+           (listof real?)]{
+
+@methspec{
+Returns the current tab-position array as a list.
+
+@boxisfillnull[(scheme length) @elem{the length of the tab array (and therefore the returned 
+list)}]
+@boxisfillnull[(scheme tab-width) @elem{the width used for tabs past the 
+end of the tab array}]
+@boxisfillnull[(scheme in-units) @elem{@scheme[#t] if the tabs are specified in
+canvas units or @scheme[#f] if they are specified in space-widths}]
+}
+
+@methimpl{
+Returns @scheme[null].
+}
+}
+}

collects/scribblings/gui/snip-classes.scrbl

@@ -0,0 +1,32 @@
+#lang scribble/doc
+@(require "common.ss"
+          "diagrams.ss")
+
+@title[#:style '(toc quiet)]{Snip Classes}
+
+@;@defmodule*/no-declare[(racket/snip)]
+
+The @racketmodname[racket/snip] collection provides access to the
+@tech{snip} classes @emph{without} depending on
+@racketmodname[racket/gui].  
+
+Snips and Administrators:
+
+@diagram->table[snip-diagram]
+
+Snip Lists:
+
+@diagram->table[snip-list-diagram]
+
+Alphabetical:
+
+@local-table-of-contents[]
+
+@include-section["image-snip-class.scrbl"]
+@include-section["readable-snip-intf.scrbl"]
+@include-section["snip-class.scrbl"]
+@include-section["snip-admin-class.scrbl"]
+@include-section["snip-class-class.scrbl"]
+@include-section["snip-class-list-intf.scrbl"]
+@include-section["string-snip-class.scrbl"]
+@include-section["tab-snip-class.scrbl"]

collects/tests/gracket/dc.rktl

@@ -218,6 +218,88 @@
     (send bm3 get-argb-pixels 0 0 70 70 s3)
     (test #t 'same-scaled (equal? s2 s3))))
 
+;; ----------------------------------------
+;; Test some masking combinations
+
+(let ()
+  (define u (make-object bitmap% 2 2))
+  (define mu (make-object bitmap% 2 2))
+  (send u set-argb-pixels 0 0 2 2
+        (bytes 255 100 0 0
+               255 0 0 0
+               255 100 0 0
+               255 255 255 255))
+  (send mu set-argb-pixels 0 0 2 2
+        (bytes 255 0 0 0
+               255 255 255 255
+               255 0 0 0
+               255 255 255 255))
+  (send u set-loaded-mask mu)
+  (define (try-draw nonce-color mode expect 
+                    #:bottom? [bottom? #f])
+    (let* ((b&w? (not (eq? mode 'color)))
+           (bm (make-object bitmap% 2 2 b&w?))
+           (dc (make-object bitmap-dc% bm)))
+      (send dc clear)
+      (when (eq? mode 'black)
+        (send dc set-brush "black" 'solid)
+        (send dc draw-rectangle 0 0 2 2))
+      ;; Check that draw-bitmap-section really uses the
+      ;; section, even in combination with a mask.
+      (send dc draw-bitmap-section u 
+            0 (if bottom? 1 0)
+            0 (if bottom? 1 0) 2 1
+            'solid nonce-color (send u get-loaded-mask))
+      (send dc set-bitmap #f)
+      (let ([s (make-bytes (* 2 2 4))])
+        (send bm get-argb-pixels 0 0 2 2 s)
+        (when b&w? (send bm get-argb-pixels 0 0 2 2 s #t))
+        (test expect 'masked-draw s))))
+  (define usual-expect (bytes 255 100 0 0
+                              255 255 255 255
+                              255 255 255 255
+                              255 255 255 255))
+  (try-draw (make-object color% "green") 'color usual-expect)
+  (try-draw (make-object color%) 'color usual-expect)
+  (try-draw (make-object color%) 'white
+            ;; For b&w destination, check that the
+            ;;  alpha is consistent with the drawn pixels
+            (bytes 255 0 0 0
+                   0 255 255 255
+                   0 255 255 255
+                   0 255 255 255))
+  (send mu set-argb-pixels 0 0 2 2
+        (bytes 255 255 255 255
+               255 255 255 255
+               255 0 0 0
+               255 0 0 0))
+  (try-draw (make-object color%) 'black
+            #:bottom? #t
+            ;; Another b&w destination test, this time
+            ;; with a mask that forces black pixels to
+            ;; white:
+            (bytes 255 0 0 0
+                   255 0 0 0
+                   255 0 0 0
+                   0 255 255 255))
+  (send mu set-argb-pixels 0 0 2 2
+        (bytes 255 255 255 255
+               255 0 0 0
+               255 255 255 255
+               255 0 0 0))
+  (try-draw (make-object color%) 'color
+            (bytes 255 255 255 255
+                   255 0 0 0
+                   255 255 255 255
+                   255 255 255 255))
+  (let ([dc (make-object bitmap-dc% mu)])
+    (send dc erase)
+    (send dc set-pen "white" 1 'transparent)
+    (send dc set-brush "black" 'solid)
+    (send dc draw-rectangle 0 0 1 1)
+    (send dc set-bitmap #f))
+  (try-draw (make-object color%) 'color usual-expect))
+
 ;; ----------------------------------------
 
 (report-errs)

collects/tests/gracket/draw.rkt

@@ -660,7 +660,9 @@
 			    ; Bitmap copying:
 			    (when (and (not no-bitmaps?) last?)
 			      (let ([x 5] [y 165])
-				(let ([mred-icon (get-icon)])
+				(let ([bg (send dc get-background)]
+                                      [mred-icon (get-icon)])
+                                  (send dc set-background "YELLOW")
 				  (case mask-ex-mode
 				    [(plt plt-mask plt^plt mred^plt)
 				     (let* ([plt (get-plt)]
@@ -711,19 +713,20 @@
                                            mred-icon)]
                                     [(mred~)
                                      (send dc draw-bitmap (get-rotated) x y 'opaque)]
-                                    [(mred^mred~ opaque-mred^mred~ red-mred^mred~)
+                                    [(mred^mred~ opaque-mred^mred~ red-mred^mred~ opaque-red-mred^mred~)
                                      (send dc draw-bitmap mred-icon x y 
-                                           (if (eq? mask-ex-mode 'opaque-mred^mred~)
+                                           (if (memq mask-ex-mode '(opaque-mred^mred~ opaque-red-mred^mred~))
                                                'opaque
                                                'solid)
                                            (send the-color-database find-color 
-                                                 (if (eq? mask-ex-mode 'red-mred^mred~)
+                                                 (if (memq mask-ex-mode '(red-mred^mred~ opaque-red-mred^mred~))
                                                      "RED"
                                                      "BLACK"))
                                            (get-rotated))]
                                     [else
                                      ;; simple draw
-                                     (send dc draw-bitmap mred-icon x y 'xor)]))
+                                     (send dc draw-bitmap mred-icon x y 'xor)])
+                                  (send dc set-background bg))
 				(set! x (+ x (send (get-icon) get-width)))
 				(let ([black (send the-color-database find-color "BLACK")]
 				      [red (send the-color-database find-color "RED")]
@@ -1191,13 +1194,14 @@
     (make-object button% "Clock" hp2.5 (lambda (b e) (do-clock #f)))
     (make-object choice% #f
 		 '("MrEd XOR" "PLT Middle" "PLT ^ MrEd" "MrEd ^ PLT" "MrEd ^ MrEd" 
-		   "MrEd~" "MrEd ^ MrEd~" "M^M~ Opaque" "M^M~ Red"
+		   "MrEd~ Opaque" "MrEd ^ MrEd~" "M^M~ Opaque" "M^M~ Red" "M^M~ Rd Opq"
 		   "PLT^PLT")
 		 hp2.5
 		 (lambda (self event)
 		   (send canvas set-mask-ex-mode 
 			 (list-ref '(mred plt plt-mask mred^plt mred^mred 
-					  mred~ mred^mred~ opaque-mred^mred~ red-mred^mred~
+					  mred~ mred^mred~ opaque-mred^mred~ 
+                                          red-mred^mred~ opaque-red-mred^mred~
 					  plt^plt)
 				   (send self get-selection)))))
     (make-object check-box% "Kern" hp2.5

collects/tests/gracket/wxme.rkt

@@ -7,7 +7,7 @@
                   clipboard-client%
                   key-event%
                   mouse-event%)
-         mred/private/wxme/snip
+         racket/snip
          mred/private/wxme/mline
          mred/private/wxme/style
          mred/private/wxme/editor