improve drracket's response to an unhappy aspell program

Specifically, two things:

 - make drracket more careful to not crash when aspell
   doesn't behave, and

 - have a more careful test when clicking the menu item
   (it now does a trial run of aspell instead of just
    looking for the binary)

closes PR 13242 (I realize there is still a feature
request mentioned in the audit trail of that PR, but
since the main problem is fixed, I'll consider that
to just be something separate)

original commit: c5330194a9a992a8f34781327ff0975624399660

collects/framework/main.rkt

@@ -72,6 +72,12 @@
     in a GUI, and the color to use. The colors are used to show the nesting
     structure in the parens.})
  
+ (thing-doc
+  color:misspelled-text-color-style-name
+  string?
+  @{The name of the style used to color misspelled words. See also 
+    @method[color:text<%> get-spell-check-strings].})
+ 
  (proc-doc/names
   text:range? (-> any/c boolean?) (arg)
   @{Determines if @racket[arg] is an instance of the @tt{range} struct.})

collects/framework/private/aspell.rkt

@@ -1,11 +1,14 @@
 #lang racket/base
 (require racket/system
          racket/match
-         racket/contract)
+         racket/contract
+         racket/port
+         string-constants)
 
 (provide/contract
  [query-aspell (-> (and/c string? (not/c #rx"[\n]")) (listof (list/c number? number?)))]
- [find-aspell-binary-path (-> (or/c path? #f))])
+ [find-aspell-binary-path (-> (or/c path? #f))]
+ [aspell-problematic? (-> (or/c string? #f))])
 
 (define aspell-candidate-paths
   '("/usr/bin" 
@@ -25,6 +28,41 @@
             (and (file-exists? c2)
                  c2)))))
 
+(define (start-aspell asp)
+  (define aspell? (regexp-match? #rx"aspell" (path->string asp)))
+  (apply process* asp "-a" (if aspell? '("--encoding=utf-8") '())))
+
+(define (aspell-problematic?)
+  (define asp (find-aspell-binary-path))
+  (cond
+    [(not asp)
+     (string-constant cannot-find-ispell-or-aspell-path)]
+    [else
+     (define proc-lst (start-aspell asp))
+     (define stdout (list-ref proc-lst 0))
+     (define stderr (list-ref proc-lst 3))
+     (close-output-port (list-ref proc-lst 1)) ;; close stdin
+     (close-input-port stdout)
+     (define sp (open-output-string))
+     (copy-port stderr sp)
+     (define errmsg (get-output-string sp))
+     (close-input-port stderr)
+     (cond
+       [(not (equal? errmsg ""))
+        (string-append
+         (format (string-constant spell-program-wrote-to-stderr-on-startup) asp)
+         "\n\n"
+         errmsg)]
+       [else #f])]))
+
+(define asp-logger (make-logger 'framework/aspell (current-logger)))
+(define-syntax-rule 
+  (asp-log arg)
+  (when (log-level? asp-logger 'debug)
+    (asp-log/proc arg)))
+(define (asp-log/proc arg)
+  (log-message asp-logger 'debug arg (current-continuation-marks)))
+
 (define aspell-req-chan (make-channel))
 (define aspell-thread #f)
 (define (start-aspell-thread)
@@ -40,12 +78,13 @@
                  (set! already-attempted-aspell? #t)
                  (define asp (find-aspell-binary-path))
                  (when asp
-                   (define aspell? (regexp-match? #rx"aspell" (path->string asp)))
+                   (set! aspell-proc (start-aspell asp))
-                   (set! aspell-proc (apply process* asp "-a" (if aspell? '("--encoding=utf-8") '())))
+                   (define line (with-handlers ((exn:fail? exn-message))
-                   (define line (read-line (list-ref aspell-proc 0)))
+                                  (read-line (list-ref aspell-proc 0))))
-                   (log-info (format "framework: started speller: ~a" line))
+                   (asp-log (format "framework: started speller: ~a" line))
                    
-                   (when (regexp-match #rx"[Aa]spell" line)
+                   (when (and (string? line)
+                              (regexp-match #rx"[Aa]spell" line))
                      ;; put aspell in "terse" mode 
                      (display "!\n" (list-ref aspell-proc 1))
                      (flush-output (list-ref aspell-proc 1)))
@@ -57,11 +96,11 @@
                         (define l (with-handlers ((exn:fail? void))
                                     (read-line stderr)))
                         (when (string? l)
-                          (log-warning (format "aspell-proc stderr: ~a" l))
+                          (asp-log (format "aspell-proc stderr: ~a" l))
                           (loop))))))))
              
              (define (shutdown-aspell why)
-               (log-warning (format "aspell.rkt: shutdown connection to aspell: ~a" why))
+               (asp-log (format "aspell.rkt: shutdown connection to aspell: ~a" why))
                (define proc (list-ref aspell-proc 4))
                (close-input-port (list-ref aspell-proc 0))
                (close-output-port (list-ref aspell-proc 1))
@@ -94,7 +133,12 @@
                          (define check-on-aspell (sync/timeout .5 stdout))
                          (cond
                            [check-on-aspell
-                            (define l (read-line stdout))
+                            (define l (with-handlers ((exn:fail? (λ (x)
+                                                                   (asp-log
+                                                                    (format "error reading stdout of aspell process: ~a"
+                                                                            (exn-message x)))
+                                                                   eof)))
+                                        (read-line stdout)))
                             (cond
                               [(eof-object? l) 
                                (send-resp '())

collects/framework/private/color.rkt

@@ -6,9 +6,8 @@ added reset-regions
 added get-regions
 |#
 
-(require mzlib/class
+(require racket/class
-         mzlib/thread
+         racket/gui/base
-         mred
          syntax-color/token-tree
          syntax-color/paren-tree
          syntax-color/default-lexer
@@ -237,13 +236,11 @@ added get-regions
         (start-colorer token-sym->style get-token pairs)))
     
     ;; ---------------------- Multi-threading ---------------------------
-    ;; A list of (vector style number number) that indicate how to color the buffer
+    ;; The editor revision when the last coloring was started
-    (define colorings null)
+    (define revision-when-started-parsing #f)
-    ;; The coroutine object for tokenizing the buffer
-    (define tok-cor #f)
-    ;; The editor revision when tok-cor was created
-    (define rev #f)
 
+    ;; The editor revision when after the last edit to the buffer
+    (define revision-after-last-edit #f)
     
     (inherit change-style begin-edit-sequence end-edit-sequence highlight-range
              get-style-list in-edit-sequence? get-start-position get-end-position
@@ -275,17 +272,7 @@ added get-regions
       (update-lexer-state-observers)
       (set! restart-callback #f)
       (set! force-recolor-after-freeze #f)
-      (set! colorings null)
+      (set! revision-when-started-parsing #f))
-      (when tok-cor
-        (coroutine-kill tok-cor))
-      (set! tok-cor #f)
-      (set! rev #f))
-    
-    ;; Actually color the buffer.
-    (define/private (color)
-      (for ([clr (in-list colorings)])
-        (change-style (vector-ref clr 0) (vector-ref clr 1) (vector-ref clr 2) #f))
-      (set! colorings '()))
     
     ;; Discard extra tokens at the first of invalid-tokens
     (define/private (sync-invalid ls)
@@ -302,25 +289,49 @@ added get-regions
             (set-lexer-state-invalid-tokens-mode! ls mode))
           (sync-invalid ls))))
     
-    (define/private (re-tokenize ls in in-start-pos in-lexer-mode enable-suspend)
+    (define/private (re-tokenize-move-to-next-ls start-time did-something?)
-      (enable-suspend #f)
+      (cond
+        [(null? re-tokenize-lses) 
+         ;; done: return #t
+         #t]
+        [else
+         (define ls (car re-tokenize-lses))
+         (set! re-tokenize-lses (cdr re-tokenize-lses))
+         (define in
+           (open-input-text-editor this 
+                                   (lexer-state-current-pos ls)
+                                   (lexer-state-end-pos ls)
+                                   (λ (x) #f)))
+         (port-count-lines! in)
+         (continue-re-tokenize start-time did-something? ls in
+                               (lexer-state-current-pos ls)
+                               (lexer-state-current-lexer-mode ls))]))
+    
+    (define re-tokenize-lses #f)
+    
+    (define/private (continue-re-tokenize start-time did-something? ls in in-start-pos lexer-mode)
+      (cond
+        [(and did-something? ((+ start-time 20.0) . <= . (current-inexact-milliseconds)))
+         #f]
+        [else
          ;(define-values (_line1 _col1 pos-before) (port-next-location in))
          (define-values (lexeme type data new-token-start new-token-end backup-delta new-lexer-mode) 
-        (get-token in in-start-pos in-lexer-mode))
+           (get-token in in-start-pos lexer-mode))
          ;(define-values (_line2 _col2 pos-after) (port-next-location in))
-      (enable-suspend #t)
+         (cond
-      (unless (eq? 'eof type)
+           [(eq? 'eof type) 
+            (re-tokenize-move-to-next-ls start-time #t)]
+           [else
             (unless (exact-nonnegative-integer? new-token-start)
               (error 'color:text<%> "expected an exact nonnegative integer for the token start, got ~e" new-token-start))
             (unless (exact-nonnegative-integer? new-token-end)
               (error 'color:text<%> "expected an exact nonnegative integer for the token end, got ~e" new-token-end))
             (unless (exact-nonnegative-integer? backup-delta)
               (error 'color:text<%> "expected an exact nonnegative integer for the backup delta, got ~e" backup-delta))
-        (unless (0 . < . (- new-token-end new-token-start))
+            (unless (new-token-start . < . new-token-end)
-          (error 'color:text<%> "expected the distance between the start and end position for each token to be positive, but start was ~e and end was ~e" new-token-start new-token-end))
+              (error 'color:text<%>
-        (enable-suspend #f)
+                     "expected the distance between the start and end position for each token to be positive, but start was ~e and end was ~e"
-        #; (printf "~s at ~a to ~a\n" lexeme (+ in-start-pos (sub1 new-token-start))
+                     new-token-start new-token-end))
-                   (+ in-start-pos (sub1 new-token-end)))
             (let ((len (- new-token-end new-token-start)))
               #;
               (unless (= len (- pos-after pos-before))
@@ -352,10 +363,9 @@ added get-regions
                  (insert-last! (lexer-state-tokens ls)
                                (lexer-state-invalid-tokens ls))
                  (set-lexer-state-invalid-tokens-start! ls +inf.0)
-             (enable-suspend #t)]
+                 (re-tokenize-move-to-next-ls start-time #t)]
                 [else
-             (enable-suspend #t)
+                 (continue-re-tokenize start-time #t ls in in-start-pos new-lexer-mode)]))])]))
-             (re-tokenize ls in in-start-pos new-lexer-mode enable-suspend)]))))
 
     (define/private (add-colorings type in-start-pos new-token-start new-token-end)
       (define sp (+ in-start-pos (sub1 new-token-start)))
@@ -376,22 +386,23 @@ added get-regions
                            [lp 0])
                   (cond
                     [(null? spellos) 
-                     (set! colorings (cons (vector color (+ sp lp) (+ sp (string-length str)))
+                     (add-coloring color (+ sp lp) (+ sp (string-length str)))]
-                                           colorings))]
                     [else
                      (define err (car spellos))
                      (define err-start (list-ref err 0))
                      (define err-len (list-ref err 1))
-                     (set! colorings (list* (vector color (+ pos lp) (+ pos err-start))
+                     (add-coloring misspelled-color (+ pos err-start) (+ pos err-start err-len))
-                                            (vector misspelled-color (+ pos err-start) (+ pos err-start err-len))
+                     (add-coloring color (+ pos lp) (+ pos err-start))
-                                            colorings))
                      (loop (cdr spellos) (+ err-start err-len))]))
                 (loop (cdr strs)
                       (+ pos (string-length str) 1))))]
            [else
-            (set! colorings (cons (vector color sp ep) colorings))])]
+            (add-coloring color sp ep)])]
         [else
-         (set! colorings (cons (vector color sp ep) colorings))]))
+         (add-coloring color sp ep)]))
+    
+    (define/private (add-coloring color sp ep) 
+      (change-style color sp ep #f))
     
     (define/private (show-tree t)
       (printf "Tree:\n")
@@ -486,52 +497,19 @@ added get-regions
     
     (define/private (colorer-driver)
       (unless (andmap lexer-state-up-to-date? lexer-states)
-        #;(printf "revision ~a\n" (get-revision-number))
-        (unless (and tok-cor (= rev (get-revision-number)))
-          (when tok-cor
-            (coroutine-kill tok-cor))
-          #;(printf "new coroutine\n")
-          (set! tok-cor
-                (coroutine
-                 (λ (enable-suspend)
-                   (parameterize ((port-count-lines-enabled #t))
-                     (for-each
-                      (lambda (ls)
-                        (re-tokenize ls
-                                     (begin
-                                       (enable-suspend #f)
-                                       (begin0
-                                         (open-input-text-editor this 
-                                                                 (lexer-state-current-pos ls)
-                                                                 (lexer-state-end-pos ls)
-                                                                 (λ (x) #f))
-                                         (enable-suspend #t)))
-                                     (lexer-state-current-pos ls)
-                                     (lexer-state-current-lexer-mode ls)
-                                     enable-suspend))
-                      lexer-states)))))
-          (set! rev (get-revision-number)))
-        (with-handlers ((exn:fail?
-                         (λ (exn)
-                           (parameterize ((print-struct #t))
-                             ((error-display-handler) 
-                              (format "exception in colorer thread: ~s" exn)
-                              exn))
-                           (set! tok-cor #f))))
-          #;(printf "begin lexing\n")
-          (when (coroutine-run 10 tok-cor)
-            (for-each (lambda (ls)
-                        (set-lexer-state-up-to-date?! ls #t))
-                      lexer-states)
-            (update-lexer-state-observers)))
-        #;(printf "end lexing\n")
-        #;(printf "begin coloring\n")
-        ;; This edit sequence needs to happen even when colors is null
-        ;; for the paren highlighter.
         (begin-edit-sequence #f #f)
-        (color)
+        (c-log "starting to color")
+        (set! re-tokenize-lses lexer-states)
+        (define finished? (re-tokenize-move-to-next-ls (current-inexact-milliseconds) #f))
+        (c-log (format "coloring stopped ~a" (if finished? "because it finished" "with more to do")))
+        (when finished?
+          (for ([ls (in-list lexer-states)])
+            (set-lexer-state-up-to-date?! ls #t))
+          (update-lexer-state-observers)
+          (c-log "updated observers"))
+        (c-log "starting end-edit-sequence")
         (end-edit-sequence)
-        #;(printf "end coloring\n")))
+        (c-log "finished end-edit-sequence")))
     
     (define/private (colorer-callback)
       (cond
@@ -1148,3 +1126,9 @@ added get-regions
 (define text-mode% (text-mode-mixin mode:surrogate-text%))
 
 (define misspelled-text-color-style-name "Misspelled Text")
+
+(define logger (make-logger 'framework/colorer (current-logger)))
+(define-syntax-rule
+  (c-log exp)
+  (when (log-level? logger 'debug)
+    (log-message logger 'debug exp (current-inexact-milliseconds))))

collects/framework/private/follow-log.rkt

@@ -0,0 +1,225 @@
+#lang racket/base
+
+(require racket/list
+         racket/class
+         racket/match
+         racket/pretty
+         racket/gui/base
+         framework/private/logging-timer)
+
+#|
+
+This file sets up a log receiver and then
+starts up DrRacket. It catches log messages and 
+organizes them on event boundaries, printing
+out the ones that take the longest
+(possibly dropping those where a gc occurs)
+
+The result shows, for each gui event, the
+log messages that occured during its dynamic
+extent as well as the number of milliseconds
+from the start of the gui event before the
+log message was reported.
+
+|#
+
+
+(define lr (make-log-receiver (current-logger)
+                              'debug 'racket/engine
+                              'debug 'GC
+                              'debug 'gui-event
+                              'debug 'framework/colorer
+                              'debug 'timeline))
+
+(define top-n-events 50)
+(define drop-gc? #t)
+(define start-right-away? #f)
+
+(define log-done-chan (make-channel))
+(define bt-done-chan (make-channel))
+
+(define start-log-chan (make-channel))
+(void 
+ (thread
+  (λ ()
+    (let loop () 
+      (sync start-log-chan)
+      (let loop ([events '()])
+        (sync
+         (handle-evt
+          lr
+          (λ (info)
+            (loop (cons info events))))
+         (handle-evt
+          log-done-chan
+          (λ (resp-chan)
+            (channel-put resp-chan events)))))
+      (loop)))))
+
+(define thread-to-watch (current-thread))
+(let ([win (get-top-level-windows)])
+  (unless (null? win)
+    (define fr-thd (eventspace-handler-thread (send (car win) get-eventspace)))
+    (unless (eq? thread-to-watch fr-thd)
+      (eprintf "WARNING: current-thread and eventspace thread aren't the same thread\n"))))
+(define start-bt-chan (make-channel))
+(void 
+ (thread
+  (λ ()
+    (let loop () 
+      (sync start-bt-chan)
+      (let loop ([marks '()])
+        (sync
+         (handle-evt
+          (alarm-evt (+ (current-inexact-milliseconds) 10))
+          (λ (_)
+            (loop (cons (continuation-marks thread-to-watch)
+                        marks))))
+         (handle-evt
+          bt-done-chan
+          (λ (resp-chan)
+            (define stacks (map continuation-mark-set->context marks))
+            (channel-put resp-chan stacks)))))
+      (loop)))))
+
+(define controller-frame-eventspace (make-eventspace))
+(define f (parameterize ([current-eventspace controller-frame-eventspace])
+            (new frame% [label "Log Follower"])))
+(define sb (new button% [label "Start Following Log"] [parent f]
+               [callback
+                (λ (_1 _2)
+                  (sb-callback))]))
+(define sb2 (new button% [label "Start Collecting Backtraces"] [parent f]
+                 [callback
+                  (λ (_1 _2)
+                    (start-bt-callback))]))
+(define db (new button% [label "Stop && Dump"] [parent f] [enabled #f]
+                [callback
+                 (λ (_1 _2)
+                   (cond
+                     [following-log?
+                      (define resp (make-channel))
+                      (channel-put log-done-chan resp)
+                      (show-results (channel-get resp))
+                      (send db enable #f)
+                      (send sb enable #t)
+                      (send sb2 enable #t)
+                      (set! following-log? #f)]
+                     [following-bt?
+                      (define resp (make-channel))
+                      (channel-put bt-done-chan resp)
+                      (define stacks (channel-get resp))
+                      (show-bt-results stacks)
+                      (send db enable #f)
+                      (send sb enable #t)
+                      (send sb2 enable #t)
+                      (set! following-bt? #f)]))]))
+
+(define following-log? #f)
+(define following-bt? #f)
+
+(define (sb-callback)
+  (set! following-log? #t)
+  (send sb enable #f)
+  (send sb2 enable #f)
+  (send db enable #t)
+  (channel-put start-log-chan #t))
+
+(define (start-bt-callback)
+  (set! following-bt? #t)
+  (send sb enable #f)
+  (send sb2 enable #f)
+  (send db enable #t)
+  (channel-put start-bt-chan #t))
+
+(send f show #t)
+
+(define (show-bt-results stacks)
+  (define top-frame (make-hash))
+  (for ([stack (in-list stacks)])
+    (unless (null? stack)
+      (define k (car stack))
+      (hash-set! top-frame k (cons stack (hash-ref top-frame k '())))))
+  (define sorted (sort (hash-map top-frame (λ (x y) y)) > #:key length))
+  (printf "top 10: ~s\n" (map length (take sorted (min (length sorted) 10))))
+  (define most-popular (cadr sorted))
+  (for ([x (in-range 10)])
+    (printf "---- next stack\n")
+    (pretty-print (list-ref most-popular (random (length most-popular))))
+    (printf "\n"))
+  (void))
+
+(struct gui-event (start end name) #:prefab)
+
+(define (show-results evts)
+  (define gui-events (filter (λ (x) 
+                               (define i (vector-ref x 2))
+                               (and (gui-event? i)
+                                    (number? (gui-event-end i))))
+                             evts))
+  (define interesting-gui-events
+    (take (sort gui-events > #:key (λ (x) 
+                                     (define i (vector-ref x 2))
+                                     (- (gui-event-end i)
+                                        (gui-event-start i))))
+          top-n-events))
+    
+  (define with-other-events
+    (for/list ([gui-evt (in-list interesting-gui-events)])
+      (match (vector-ref gui-evt 2)
+        [(gui-event start end name)
+         (define in-the-middle
+           (append (map (λ (x) (list (list 'δ (- (get-start-time x) start)) x))
+                        (sort
+                         (filter (λ (x) (and (not (gui-event? (vector-ref x 2)))
+                                             (<= start (get-start-time x) end)))
+                                 evts)
+                         <
+                         #:key get-start-time))
+                   (list (list (list 'δ (- end start)) 'end-of-gui-event))))
+         (list* (- end start)
+                gui-evt
+                in-the-middle)])))
+  
+  (define (has-a-gc-event? x)
+    (define in-the-middle (cddr x))
+    (ormap (λ (x) 
+             (and (vector? (list-ref x 1))
+                  (gc-info? (vector-ref (list-ref x 1) 2))))
+           in-the-middle))
+  
+  (pretty-print
+   (if drop-gc?
+       (filter (λ (x) (not (has-a-gc-event? x)))
+               with-other-events)
+       with-other-events)))
+
+(struct gc-info (major? pre-amount pre-admin-amount code-amount
+                        post-amount post-admin-amount
+                        start-process-time end-process-time
+                        start-time end-time)
+  #:prefab)
+(struct engine-info (msec name) #:prefab)
+
+(define (get-start-time x)
+  (cond
+    [(gc-info? (vector-ref x 2))
+     (gc-info-start-time (vector-ref x 2))]
+    [(engine-info? (vector-ref x 2))
+     (engine-info-msec (vector-ref x 2))]
+    [(regexp-match #rx"framework" (vector-ref x 1))
+     (vector-ref x 2)]
+    [(timeline-info? (vector-ref x 2))
+     (timeline-info-milliseconds (vector-ref x 2))]         
+    [else
+     (unless (regexp-match #rx"^GC: 0:MST @" (vector-ref x 1))
+       (eprintf "unk: ~s\n" x))
+     0]))
+
+
+(module+ main
+  (when start-right-away?
+    (parameterize ([current-eventspace controller-frame-eventspace])
+      (queue-callback sb-callback)))
+  (dynamic-require 'drracket #f))
+

collects/framework/private/frame.rkt

@@ -796,9 +796,14 @@
              [ec (new position-canvas%
                       [parent panel]
                       [button-up
-                       (λ ()
+                       (λ (evt)
+                         (cond
+                           [(or (send evt get-alt-down)
+                                (send evt get-control-down))
+                            (dynamic-require 'framework/private/follow-log #f)]
+                           [else
                             (collect-garbage)
-                         (update-memory-text))]
+                            (update-memory-text)]))]
                       [init-width "99.99 MB"])])
         (set! memory-canvases (cons ec memory-canvases))
         (update-memory-text)
@@ -890,6 +895,7 @@
     (inherit min-client-height min-client-width get-dc get-client-size refresh)
     (init init-width)
     (init-field [button-up #f])
+    (init-field [char-typed void])
     (define str "")
     (define/public (set-str _str)
       (set! str _str)
@@ -913,7 +919,11 @@
           (let-values ([(cw ch) (get-client-size)])
             (when (and (<= (send evt get-x) cw)
                        (<= (send evt get-y) ch))
-              (button-up))))))
+              (if (procedure-arity-includes? button-up 1)
+                  (button-up evt)
+                  (button-up)))))))
+    (define/override (on-char evt)
+      (char-typed evt))
     (super-new (style '(transparent no-focus)))
     (let ([dc (get-dc)])
       (let-values ([(_1 th _2 _3) (send dc get-text-extent str)])

collects/framework/private/keymap.rkt

@@ -337,7 +337,7 @@
            
            [mouse-popup-menu 
             (λ (edit event)
-              (when (send event button-down?)
+              (when (send event button-up?)
                 (let ([a (send edit get-admin)])
                   (when a
                     (let ([m (make-object popup-menu%)])

collects/framework/private/logging-timer.rkt

@@ -0,0 +1,66 @@
+#lang racket/base
+
+(require racket/gui/base
+         racket/class
+         (for-syntax racket/base))
+
+(define timeline-logger (make-logger 'timeline (current-logger)))
+
+(provide logging-timer%
+         (struct-out timeline-info)
+         log-timeline)
+
+(define logging-timer%
+  (class timer%
+    (init notify-callback)
+    (define name (object-name notify-callback))
+    (define wrapped-notify-callback
+      (λ ()
+        (log-timeline
+         (format "~a timer fired" name)
+         (notify-callback))))
+    (super-new [notify-callback wrapped-notify-callback])
+    (define/override (start msec [just-once? #f])
+      (log-timeline (format "~a timer started; msec ~s just-once? ~s" name msec just-once?))
+      (super start msec just-once?))))
+
+
+(define-syntax (log-timeline stx)
+  (syntax-case stx ()
+    [(_ info-string expr)
+     #'(log-timeline/proc 
+        (and (log-level? timeline-logger 'debug)
+             info-string)
+        (λ () expr))]
+    [(_ info-string)
+     #'(log-timeline/proc 
+        (and (log-level? timeline-logger 'debug)
+             info-string)
+        #f)]))
+
+(define (log-timeline/proc info expr)
+  (define start-time (current-inexact-milliseconds))
+  (when info
+    (log-message timeline-logger 'debug 
+                 (format "~a start" info)
+                 (timeline-info (if expr 'start 'once)
+                                (current-process-milliseconds)
+                                start-time)))
+  (when expr 
+    (begin0
+      (expr)
+      (when info
+        (define end-time (current-inexact-milliseconds))
+        (log-message timeline-logger 'debug 
+                     (format "~a   end; delta ms ~a" info (- end-time start-time))
+                     (timeline-info start-time
+                                    end-time
+                                    (current-inexact-milliseconds)))))))
+
+
+;; what : (or/c 'start 'once flonum)
+;;    flonum means that this is an 'end' event and there should be
+;;    a start event corresponding to it with that milliseconds 
+;; process-milliseconds : fixnum
+;; milliseconds : flonum -- time of this event
+(struct timeline-info (what process-milliseconds milliseconds) #:transparent)

collects/framework/private/text.rkt

@@ -11,7 +11,8 @@
          "autocomplete.rkt"
          mred/mred-sig
          mrlib/interactive-value-port
-         racket/list)
+         racket/list
+         "logging-timer.rkt")
 (require setup/xref
          scribble/xref
          scribble/manual-struct)
@@ -1063,7 +1064,7 @@
       (when searching-str
         (unless timer
           (set! timer 
-                (new timer% 
+                (new logging-timer% 
                      [notify-callback 
                       (λ () 
                         (run-after-edit-sequence
@@ -1536,7 +1537,7 @@
     ;; have not yet been propogated to the delegate
     (define todo '())
     
-    (define timer (new timer% 
+    (define timer (new logging-timer% 
                        [notify-callback
                         (λ ()
                           ;; it should be the case that todo is always '() when the delegate is #f
@@ -3854,7 +3855,9 @@ designates the character that triggers autocompletion
 ;; draws line numbers on the left hand side of a text% object
 (define line-numbers-mixin
   (mixin ((class->interface text%) editor:standard-style-list<%>) (line-numbers<%>)
-    (inherit get-visible-line-range
+    (inherit begin-edit-sequence
+             end-edit-sequence
+             get-visible-line-range
              get-visible-position-range
              last-line
              line-location
@@ -4193,6 +4196,7 @@ designates the character that triggers autocompletion
       (when (showing-line-numbers?)
         (define dc (get-dc))
         (when dc
+          (begin-edit-sequence #f #f)
           (define bx (box 0))
           (define by (box 0))
           (define tw (text-width dc (number-space+1)))
@@ -4208,7 +4212,8 @@ designates the character that triggers autocompletion
                                        tw
                                        th)
               (unless (= line (last-line))
-                (loop (+ line 1))))))))
+                (loop (+ line 1)))))
+          (end-edit-sequence))))
     
     (super-new)
     (setup-padding)))

collects/framework/test.rkt

@@ -253,22 +253,26 @@
 
 (define object-tag 'test:find-object)
 
-;; find-object : class (union string (object -> boolean)) -> object
+;; find-object : class (union string regexp (object -> boolean)) -> object
 (define (find-object obj-class b-desc)
   (λ ()
     (cond
       [(or (string? b-desc)
+           (regexp? b-desc)
            (procedure? b-desc))
        (let* ([active-frame (test:get-active-top-level-window)]
               [_ (unless active-frame
                    (error object-tag
-                          "could not find object: ~a, no active frame" 
+                          "could not find object: ~e, no active frame" 
                           b-desc))]
               [child-matches?
                (λ (child)
                  (cond
                    [(string? b-desc)
                     (equal? (send child get-label) b-desc)]
+                   [(regexp? b-desc)
+                    (and (send child get-label)
+                         (regexp-match? b-desc (send child get-label)))]
                    [(procedure? b-desc)
                     (b-desc child)]))]
               [found
@@ -287,13 +291,13 @@
                         (send panel get-children)))])
          (or found
              (error object-tag 
-                    "no object of class ~a named ~e in active frame"
+                    "no object of class ~e named ~e in active frame"
                     obj-class
                     b-desc)))]
       [(is-a? b-desc obj-class) b-desc]
       [else (error 
              object-tag
-             "expected either a string or an object of class ~a as input, received: ~a"
+             "expected either a string or an object of class ~e as input, received: ~e"
              obj-class b-desc)])))
 
 
@@ -936,7 +940,8 @@
  (proc-doc/names
   test:keystroke
   (->* ((or/c char? symbol?))
-       ((listof (symbols 'alt 'control 'meta 'shift 'noalt 'nocontrol 'nometea 'noshift)))
+       ((listof (or/c 'alt 'control 'meta 'shift 
+                      'noalt 'nocontrol 'nometea 'noshift)))
        void?)
   ((key)
    ((modifier-list null)))
@@ -973,10 +978,11 @@
  (proc-doc/names
   test:mouse-click
   (->*
-   ((symbols 'left 'middle 'right)
+   ((or/c 'left 'middle 'right)
     (and/c exact? integer?)
     (and/c exact? integer?))
-   ((listof (symbols 'alt 'control 'meta 'shift 'noalt 'nocontrol 'nometa 'noshift)))
+   ((listof (or/c 'alt 'control 'meta 'shift 'noalt
+                  'nocontrol 'nometa 'noshift)))
    void?)
   ((button x y)
    ((modifiers null)))
@@ -985,7 +991,7 @@
   @method[canvas<%> on-event] method.
   Use @racket[test:button-push] to click on a button.
   
-  On the Macintosh, @racket['right] corresponds to holding down the command
+  Under Mac OS X, @racket['right] corresponds to holding down the command
   modifier key while clicking and @racket['middle] cannot be generated.
   
   Under Windows, @racket['middle] can only be generated if the user has a

collects/mred/mred-sig.rkt

@@ -78,6 +78,7 @@ frame%
 gauge%
 get-choices-from-user
 get-color-from-user
+get-current-mouse-state
 get-default-shortcut-prefix
 get-directory
 get-display-count

collects/mred/private/mrcanvas.rkt

@@ -19,7 +19,8 @@
 
 (define canvas-default-size 20) ; a default size for canvases tht fits borders without losing client sizes
 (define canvas-scroll-size 10)
-(define canvas-control-border-extra (case (system-type)
+(define canvas-control-border-extra
+  (case (system-type)
     [(windows) 2]
     [else 0]))
 

collects/mred/private/mred.rkt

@@ -116,6 +116,7 @@
 	     event-dispatch-handler
 	     eventspace?
 	     flush-display
+             get-current-mouse-state
 	     get-highlight-background-color
              get-highlight-text-color
 	     get-the-editor-data-class-list

collects/mred/private/mritem.rkt

@@ -600,7 +600,10 @@
      [find-string (entry-point (lambda (x)
                                  (check-label-string '(method list-control<%> find-string) x)
                                  (do-find-string x)))]
-
+     [delete (entry-point (lambda (n)
+                            (check-item 'delete n)
+                            (send this -delete-list-item n)
+                            (send wx delete n)))]
      [-append-list-string (lambda (i)
                             (set! content (append content (list i))))]
      [-set-list-string (lambda (i s)
@@ -843,10 +846,6 @@
                          (set! column-labels (append column-labels (list label)))
                          (send wx append-column label))))]
      
-     [delete (entry-point (lambda (n)
-                            (check-item 'delete n)
-                            (send this -delete-list-item n)
-                            (send wx delete n)))]
      [get-data (entry-point (lambda (n) (check-item 'get-data n) (send wx get-data n)))]
      [get-label-font (lambda () (send wx get-label-font))]
      [get-selections (entry-point (lambda () (send wx get-selections)))]

collects/mred/private/mrmenu.rkt

@@ -465,6 +465,6 @@
 (define (menu-or-bar-parent who p)
   (unless (or (is-a? p internal-menu<%>) (is-a? p menu-bar%))
     (unless (is-a? p menu-item-container<%>)
-      (raise-arguments-error (constructor-name who) "(is-a?/c menu-item-container<%>)" p))
+      (raise-argument-error (constructor-name who) "(is-a?/c menu-item-container<%>)" p))
     (raise-arguments-error (who->name who) "invalid parent;\n given parent is not an instance of a built-in menu item container class"
                            "given parent" p)))

collects/mred/private/snipfile.rkt

@@ -91,15 +91,17 @@
                      void))))
             ;; General case, which handles non-text context:
             (with-method ([gsp (text get-snip-position)]
-			  [grn (text get-revision-number)])
+                          [grn (text get-revision-number)]
+                          [fs (text find-snip)])
               (let-values ([(pipe-r pipe-w) (make-pipe)])
                 (let* ([get-text-generic (generic wx:snip% get-text)]
                        [get-count-generic (generic wx:snip% get-count)]
                        [next-generic (generic wx:snip% next)]
                        [revision (grn)]
                        [next? #f]
+                       [snip-end-position (+ (gsp snip) (send-generic snip get-count-generic))]
                        [update-str-to-snip
-			(lambda (to-str)
+                        (lambda (skip to-str)
                           (if snip
                               (let ([snip-start (gsp snip)])
                                 (cond
@@ -109,8 +111,9 @@
                                    0]
                                   [(is-a? snip wx:string-snip%)
                                    (set! next? #t)
-				  (let ([c (min (send-generic snip get-count-generic) (- end snip-start))])
+                                   (let ([c (min (- (send-generic snip get-count-generic) skip)
-				    (write-string (send-generic snip get-text-generic 0 c) pipe-w)
+                                                 (- end snip-start))])
+                                     (write-string (send-generic snip get-text-generic skip c) pipe-w)
                                      (read-bytes-avail!* to-str pipe-r))]
                                   [else
                                    (set! next? #f)
@@ -120,13 +123,18 @@
                                 0)))]
                        [next-snip
                         (lambda (to-str)
-			  (unless (= revision (grn))
+                          (cond
-			    (raise-arguments-error 
+                            [(= revision (grn))
-			     'text-input-port 
-			     "editor has changed since port was opened"
-			     "editor" text))
                              (set! snip (send-generic snip next-generic))
-			  (update-str-to-snip to-str))]
+                             (set! snip-end-position (and snip (+ (gsp snip) (send-generic snip get-count-generic))))
+                             (update-str-to-snip 0 to-str)]
+                            [else
+                             (set! revision (grn))
+                             (define old-snip-end-position snip-end-position)
+                             (set! snip (fs snip-end-position 'after-or-none))
+                             (define snip-start-position (and snip (gsp snip)))
+                             (set! snip-end-position (and snip (+ snip-start-position (send-generic snip get-count-generic))))
+                             (update-str-to-snip (if snip (- old-snip-end-position snip-start-position) 0) to-str)]))]
                        [read-chars (lambda (to-str)
                                      (cond
                                        [next?
@@ -171,7 +179,7 @@
                                      (- end snip-start))])
                         (set! next? #t)
                         (display (send-generic snip get-text-generic skip c) pipe-w))
-		      (update-str-to-snip empty-string))
+                      (update-str-to-snip 0 empty-string))
                   port)))))))
 
   (define (jump-to-submodule in-port expected-module k)

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

@@ -68,6 +68,8 @@
     (tellv (get-cocoa)
            insertItemWithTitle: #:type _NSString lbl 
            atIndex: #:type _NSInteger (number)))
+  (define/public (delete i)
+    (tellv (get-cocoa) removeItemAtIndex: #:type _NSInteger i))
 
   (define/override (maybe-register-as-child parent on?)
     (register-as-child parent on?)))

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

@@ -63,6 +63,7 @@
    display-origin
    display-count
    flush-display
+   get-current-mouse-state
    fill-private-color
    cancel-quit
    get-control-font-face

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

@@ -6,6 +6,7 @@
          ffi/unsafe
          ffi/unsafe/objc
          "utils.rkt"
+         "const.rkt"
          "types.rkt"
          "frame.rkt"
          "window.rkt"
@@ -63,9 +64,10 @@
  file-creator-and-type
  file-selector
  key-symbol-to-menu-key
- needs-grow-box-spacer?)
+ needs-grow-box-spacer?
+ get-current-mouse-state)
 
-(import-class NSScreen NSCursor NSMenu)
+(import-class NSScreen NSCursor NSMenu NSEvent)
 
 (define (find-graphical-system-path what)
   #f)
@@ -192,3 +194,28 @@
 
 (define (needs-grow-box-spacer?)
   (not (version-10.7-or-later?)))
+
+;; ------------------------------------------------------------
+;; Mouse and modifier-key state
+
+(define (get-current-mouse-state)
+  (define posn (tell #:type _NSPoint NSEvent mouseLocation))
+  (define buttons (tell #:type _NSUInteger NSEvent pressedMouseButtons))
+  (define mods (tell #:type _NSUInteger NSEvent modifierFlags))
+  (define (maybe v mask sym)
+    (if (zero? (bitwise-and v mask))
+        null
+        (list sym)))
+  (define h (let ([f (tell #:type _NSRect (tell NSScreen mainScreen) frame)])
+              (NSSize-height (NSRect-size f))))
+  (values (make-object point% 
+                       (->long (NSPoint-x posn))
+                       (->long (- (- h (NSPoint-y posn)) (get-menu-bar-height))))
+          (append
+           (maybe buttons #x1 'left)
+           (maybe buttons #x2 'right)
+           (maybe mods NSShiftKeyMask 'shift)
+           (maybe mods NSCommandKeyMask 'meta)
+           (maybe mods NSAlternateKeyMask 'alt)
+           (maybe mods NSControlKeyMask 'control)
+           (maybe mods NSAlphaShiftKeyMask 'caps))))

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

@@ -604,6 +604,10 @@
                (- y (client-y-offset))))))
     (define/public (client-y-offset) 0)
 
+    (define event-position-wrt-wx #f)
+    (define/public (set-event-positions-wrt wx)
+      (set! event-position-wrt-wx wx))
+
     (define/public (is-view?) #t)
     (define/public (window-point-to-view pos)
       (let ([pos (if (is-view?)
@@ -611,8 +615,17 @@
                            convertPoint: #:type _NSPoint pos
                            fromView: #f)
                      pos)])
-        (values (NSPoint-x pos)
+        (define x (NSPoint-x pos))
-                (flip-client (NSPoint-y pos)))))
+        (define y (flip-client (NSPoint-y pos)))
+        (cond
+         [event-position-wrt-wx
+          (define xb (box (->long x)))
+          (define yb (box (->long y)))
+          (internal-client-to-screen xb yb)
+          (send event-position-wrt-wx internal-screen-to-client xb yb)
+          (values (unbox xb) (unbox yb))]
+         [else (values x y)])))
+                
 
     (define/public (get-x)
       (->long (NSPoint-x (NSRect-origin (get-frame)))))
@@ -799,6 +812,8 @@
     (define/public (refresh-all-children) (void))
 
     (define/public (screen-to-client xb yb)
+      (internal-screen-to-client xb yb))
+    (define/public (internal-screen-to-client xb yb)
       (let ([p (tell #:type _NSPoint (get-cocoa-content) 
                      convertPoint: #:type _NSPoint
                      (tell #:type _NSPoint (get-cocoa-window)
@@ -810,6 +825,8 @@
         (set-box! yb (inexact->exact (floor (flip-client (NSPoint-y p)))))))
 
     (define/public (client-to-screen xb yb [flip-y? #t])
+      (internal-client-to-screen xb yb flip-y?))
+    (define/public (internal-client-to-screen xb yb [flip-y? #t])
       (let* ([p (tell #:type _NSPoint (get-cocoa-window)
                       convertBaseToScreen:
                       #:type _NSPoint

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

@@ -438,12 +438,23 @@
 
 (define event-dispatch-handler (make-parameter really-dispatch-event))
 
+(define event-logger (make-logger 'gui-event (current-logger)))
+;; start? : boolean -- indicates if this is a start of an event being handled or not
+;; msec : start time if start? is #t, delta from start to end if start? is #f
+;; name : (or/c #f symbol?)
+(struct gui-event (start end name) #:prefab)
+
 (define (handle-event thunk e)
   (call-with-continuation-prompt ; to delimit continuations
    (lambda ()
      (call-with-continuation-prompt ; to delimit search for dispatch-event-key
       (lambda ()
         ;; communicate the thunk to `really-dispatch-event':
+        (define before (current-inexact-milliseconds))
+        (when (log-level? event-logger 'debug)
+          (log-message event-logger 'debug 
+                       "starting to handle an event"
+                       (gui-event before #f (object-name thunk))))
         (let ([b (box thunk)])
           ;; use the event-dispatch handler:
           (with-continuation-mark dispatch-event-key b
@@ -452,7 +463,13 @@
           ;; to the original one, then do so now:
           (when (unbox b)
             (set-box! b #f)
-            (thunk))))
+            (thunk)))
+        (define after (current-inexact-milliseconds))
+        (when (log-level? event-logger 'debug)
+          (log-message event-logger 'debug 
+                       (format "handled an event: ~a msec"  
+                               (- after before))
+                       (gui-event before after (object-name thunk)))))
       dispatch-event-prompt))))
 
 (define yield

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

@@ -78,9 +78,12 @@
      (set! ignore-clicked? #t)
      (gtk_combo_box_set_active gtk i)
      (set! ignore-clicked? #f)))
+
   (define/public (get-selection)
     (gtk_combo_box_get_active gtk))
+
   (define/public (number) count)
+
   (define/public (clear)
     (atomically
      (set! ignore-clicked? #t)
@@ -88,6 +91,7 @@
        (gtk_combo_box_remove_text gtk 0))
      (set! count 0)
      (set! ignore-clicked? #f)))
+
   (public [-append append])
   (define (-append l)
     (atomically
@@ -96,5 +100,7 @@
      (gtk_combo_box_append_text gtk l)
      (when (= count 1)
        (set-selection 0))
-     (set! ignore-clicked? #f))))
+     (set! ignore-clicked? #f)))
 
+  (define/public (delete i)
+    (gtk_combo_box_remove_text gtk i)))

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

@@ -22,7 +22,8 @@
               display-origin
               display-size
 	      display-count
-              location->window))
+              location->window
+              get-current-mouse-state))
 
 ;; ----------------------------------------
 
@@ -57,6 +58,13 @@
 (define-gtk gtk_window_resize (_fun _GtkWidget _int _int -> _void))
 
 (define-gdk gdk_window_set_cursor (_fun _GdkWindow _pointer -> _void))
+(define-gdk gdk_screen_get_root_window (_fun _GdkScreen -> _GdkWindow))
+(define-gdk gdk_window_get_pointer (_fun _GdkWindow 
+                                         (x : (_ptr o _int))
+                                         (y : (_ptr o _int))
+                                         (mods : (_ptr o _uint))
+                                         -> _GdkWindow
+                                         -> (values x y mods)))
 
 (define-gtk gtk_window_iconify (_fun _GtkWindow -> _void))
 (define-gtk gtk_window_deiconify (_fun _GtkWindow -> _void))
@@ -169,7 +177,7 @@
          (values vbox-gtk panel-gtk))))
     (gtk_widget_show vbox-gtk)
     (gtk_widget_show panel-gtk)
-    (connect-key-and-mouse gtk)
+    (connect-enter-and-leave gtk)
 
     (unless is-dialog?
       (gtk_window_set_icon_list gtk (cdr (force icon-pixbufs+glist))))
@@ -424,7 +432,7 @@
     (define/override (call-pre-on-char w e)
       (pre-on-char w e))
 
-    (define/override (client-to-screen x y)
+    (define/override (internal-client-to-screen x y)
       (gtk_window_set_gravity gtk GDK_GRAVITY_STATIC)
       (let-values ([(dx dy) (gtk_window_get_position gtk)]
                    [(cdx cdy) (get-client-delta)])
@@ -543,3 +551,24 @@
                  [fh (send f get-height)])
              (<= fy y (+ fy fh)))
            f))))
+
+;; ----------------------------------------
+
+(define (get-current-mouse-state)
+  (define-values (x y mods) (gdk_window_get_pointer
+                             (gdk_screen_get_root_window
+                              (gdk_screen_get_default))))
+  (define (maybe mask sym)
+    (if (zero? (bitwise-and mods mask))
+        null
+        (list sym)))
+  (values (make-object point% x y)
+          (append
+           (maybe GDK_BUTTON1_MASK 'left)
+           (maybe GDK_BUTTON2_MASK 'middle)
+           (maybe GDK_BUTTON3_MASK 'right)
+           (maybe GDK_SHIFT_MASK 'shift)
+           (maybe GDK_LOCK_MASK 'caps)
+           (maybe GDK_CONTROL_MASK 'control)
+           (maybe GDK_MOD1_MASK 'alt)
+           (maybe GDK_META_MASK 'meta))))

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

@@ -64,6 +64,7 @@
    display-origin
    display-count
    flush-display
+   get-current-mouse-state
    fill-private-color
    cancel-quit
    get-control-font-face

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

@@ -35,6 +35,7 @@
 
               connect-focus
               connect-key-and-mouse
+              connect-enter-and-leave
               do-button-event
 
               (struct-out GtkRequisition) _GtkRequisition-pointer
@@ -293,6 +294,10 @@
     (let ([wx (gtk->wx gtk)]) (when wx (send wx leave-window)))
     (do-button-event gtk event #f #t)))
 
+(define (connect-enter-and-leave gtk)
+  (connect-enter gtk)
+  (connect-leave gtk))
+
 (define (connect-key-and-mouse gtk [skip-press? #f])
   (connect-key-press gtk)
   (connect-key-release gtk)
@@ -300,8 +305,7 @@
   (connect-button-press gtk)
   (unless skip-press? (connect-button-release gtk))
   (connect-pointer-motion gtk)
-  (connect-enter gtk)
+  (connect-enter-and-leave gtk))
-  (connect-leave gtk))
 
 (define (do-button-event gtk event motion? crossing?)
   (let ([type (if motion?
@@ -341,7 +345,16 @@
                            [(1) 'left-up]
                            [(3) 'right-up]
                            [else 'middle-up])])]
-		 [m (new mouse-event%
+                 [m (let-values ([(x y) (send wx
+                                              adjust-event-position
+                                              (->long ((if motion? 
+                                                           GdkEventMotion-x 
+                                                           (if crossing? GdkEventCrossing-x GdkEventButton-x))
+                                                       event))
+                                              (->long ((if motion? GdkEventMotion-y 
+                                                           (if crossing? GdkEventCrossing-y GdkEventButton-y))
+                                                       event)))])
+                      (new mouse-event%
                            [event-type type]
                            [left-down (case type
                                         [(left-down) #t]
@@ -355,13 +368,8 @@
                                          [(right-down) #t]
                                          [(right-up) #f]
                                          [else (bit? modifiers GDK_BUTTON3_MASK)])]
-			 [x (->long ((if motion? 
+                           [x x]
-					 GdkEventMotion-x 
+                           [y y]
-					 (if crossing? GdkEventCrossing-x GdkEventButton-x))
-				     event))]
-			 [y (->long ((if motion? GdkEventMotion-y 
-					 (if crossing? GdkEventCrossing-y GdkEventButton-y))
-				     event))]
                            [shift-down (bit? modifiers GDK_SHIFT_MASK)]
                            [control-down (bit? modifiers GDK_CONTROL_MASK)]
                            [meta-down (bit? modifiers GDK_META_MASK)]
@@ -369,7 +377,7 @@
                            [time-stamp ((if motion? GdkEventMotion-time 
                                             (if crossing? GdkEventCrossing-time GdkEventButton-time))
                                         event)]
-			 [caps-down (bit? modifiers GDK_LOCK_MASK)])])
+                           [caps-down (bit? modifiers GDK_LOCK_MASK)]))])
              (if (send wx handles-events? gtk)
                  (begin
                    (queue-window-event wx (lambda ()
@@ -693,17 +701,34 @@
     (define/public (refresh-all-children) (void))
 
     (define/public (screen-to-client x y)
+      (internal-screen-to-client x y))
+    (define/public (internal-screen-to-client x y)
       (let ([xb (box 0)]
             [yb (box 0)])
-        (client-to-screen xb yb)
+        (internal-client-to-screen xb yb)
         (set-box! x (- (unbox x) (unbox xb)))
         (set-box! y (- (unbox y) (unbox yb)))))
     (define/public (client-to-screen x y)
+      (internal-client-to-screen x y))
+    (define/public (internal-client-to-screen x y)
       (let-values ([(dx dy) (get-client-delta)])
-        (send parent client-to-screen x y)
+        (send parent internal-client-to-screen x y)
         (set-box! x (+ (unbox x) save-x dx))
         (set-box! y (+ (unbox y) save-y dy))))
 
+    (define event-position-wrt-wx #f)
+    (define/public (set-event-positions-wrt wx)
+      (set! event-position-wrt-wx wx))
+    
+    (define/public (adjust-event-position x y)
+      (if event-position-wrt-wx
+          (let ([xb (box x)]
+                [yb (box y)])
+            (internal-client-to-screen xb yb)
+            (send event-position-wrt-wx internal-screen-to-client xb yb)
+            (values (unbox xb) (unbox yb)))
+          (values x y)))
+
     (define/public (get-client-delta)
       (values 0 0))
 

collects/mred/private/wx/platform.rkt

@@ -50,6 +50,7 @@
                 display-origin
 		display-count
                 flush-display
+                get-current-mouse-state
                 fill-private-color
                 cancel-quit
                 get-control-font-face

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

@@ -102,13 +102,13 @@
        (SendMessageW hwnd CB_RESETCONTENT 0 0)
        (set! num-choices 0)))
 
-
     (public [append* append])
     (define (append* str)
       (atomically
        (SendMessageW/str hwnd CB_ADDSTRING 0 str)
        (set! num-choices (add1 num-choices))
-       (when (= 1 num-choices) (set-selection 0))))))
+       (when (= 1 num-choices) (set-selection 0))))
-
-
 
+    (define/public (delete i)
+      (set! num-choices (sub1 num-choices))
+      (void (SendMessageW hwnd CB_DELETESTRING i 0)))))

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

@@ -617,6 +617,7 @@
 (define CB_SETCURSEL #x014E)
 (define CB_GETCURSEL #x0147)
 (define CB_ADDSTRING #x0143)
+(define CB_DELETESTRING #x0144)
 (define CB_RESETCONTENT #x014B)
 
 (define CBN_SELENDOK 9)

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

@@ -64,6 +64,7 @@
    display-origin
    display-count
    flush-display
+   get-current-mouse-state
    fill-private-color
    cancel-quit
    get-control-font-face

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

@@ -43,6 +43,7 @@
   get-highlight-text-color
   check-for-break)
  flush-display
+ get-current-mouse-state
  fill-private-color
  play-sound
  location->window
@@ -116,3 +117,26 @@
 (define (check-for-break) #f)
 
 (define (needs-grow-box-spacer?) #f)
+
+(define-user32 GetCursorPos (_wfun (p : (_ptr o _POINT)) -> (r : _BOOL)
+                                   -> (if r
+                                          p
+                                          (failed 'GetCursorPos))))
+(define-user32 GetAsyncKeyState (_wfun _int -> _SHORT))
+(define-user32 GetSystemMetrics (_wfun _int -> _int))
+(define SM_SWAPBUTTON 23)
+(define (get-current-mouse-state)
+  (define p (GetCursorPos))
+  (define (maybe vk sym)
+    (if (negative? (GetAsyncKeyState vk))
+        (list sym)
+        null))
+  (define swapped? (not (zero? (GetSystemMetrics SM_SWAPBUTTON))))
+  (values (make-object point% (POINT-x p) (POINT-y p))
+          (append
+           (maybe (if swapped? VK_RBUTTON VK_LBUTTON) 'left)
+           (maybe (if swapped? VK_LBUTTON VK_RBUTTON) 'right)
+           (maybe VK_LSHIFT 'shift)
+           (maybe VK_CONTROL 'control)
+           (maybe VK_MENU 'alt)
+           (maybe VK_CAPITAL 'caps))))

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

@@ -412,12 +412,29 @@
 
   (define/public (on-resized) (void))
 
+  (define event-position-wrt-wx #f)
+  (define/public (set-event-positions-wrt wx)
+    (set! event-position-wrt-wx wx))
+
+  (define/private (adjust-event-position x y)
+    (if event-position-wrt-wx
+        (let ([xb (box x)]
+              [yb (box y)])
+          (internal-client-to-screen xb yb)
+          (send event-position-wrt-wx internal-screen-to-client xb yb)
+          (values (unbox xb) (unbox yb)))
+        (values x y)))
+
   (define/public (screen-to-client x y)
+    (internal-screen-to-client x y))
+  (define/public (internal-screen-to-client x y)
     (let ([p (make-POINT (unbox x) (unbox y))])
       (ScreenToClient (get-client-hwnd) p)
       (set-box! x (POINT-x p))
       (set-box! y (POINT-y p))))
   (define/public (client-to-screen x y)
+    (internal-client-to-screen x y))
+  (define/public (internal-client-to-screen x y)
     (let ([p (make-POINT (unbox x) (unbox y))])
       (ClientToScreen (get-client-hwnd) p)
       (set-box! x (POINT-x p))
@@ -607,6 +624,7 @@
           [bit? (lambda (v b) (not (zero? (bitwise-and v b))))])
       (let ([make-e 
              (lambda (type)
+               (define-values (mx my) (adjust-event-position x y))
                (new mouse-event%
                     [event-type type]
                     [left-down (case type
@@ -621,8 +639,8 @@
                                   [(right-down) #t]
                                   [(right-up) #f]
                                   [else (bit? flags MK_RBUTTON)])]
-                    [x x]
+                    [x mx]
-                    [y y]
+                    [y my]
                     [shift-down (bit? flags MK_SHIFT)]
                     [control-down (bit? flags MK_CONTROL)]
                     [meta-down #f]

collects/mred/private/wxlitem.rkt

@@ -59,7 +59,7 @@
   (define wx-label-panel%
     (class wx-control-horizontal-panel% 
       (init proxy parent label style font halign valign)
-      (inherit area-parent skip-enter-leave-events)
+      (inherit area-parent skip-enter-leave-events set-event-positions-wrt)
       (define c #f)
 
       (define/override (enable on?) (if c (send c enable on?) (void)))
@@ -77,9 +77,21 @@
       (define/public (set-label s) (when l (send l set-label s)))
       (define/public (get-label) (and l (send l get-label)))
 
+      (define/override (client-to-screen x y)
+        (if c
+            (send c client-to-screen x y)
+            (super client-to-screen x y)))
+      (define/override (screen-to-client x y)
+        (if c
+            (send c screen-to-client x y)
+            (super screen-to-client x y)))
+
       (define/public (get-p) p)
       (define/public (set-c v sx? sy?) 
         (set! c v)
+        (set-event-positions-wrt c)
+        (when l (send l set-event-positions-wrt c))
+        (when p (send p set-event-positions-wrt c))
         (send c stretchable-in-x sx?)
         (send c stretchable-in-y sy?)
         (send c skip-subwindow-events? #t))))
@@ -113,7 +125,8 @@
        (get-selection)
        (number)
        (clear)
-       (append lbl))
+       (append lbl)
+       (delete i))
 
       (stretchable-in-y #f)
       (stretchable-in-x #f)))

collects/mred/private/wxpanel.rkt

@@ -54,6 +54,7 @@
                    (unless (negative? h) (set! height h)))]
        [get-x (lambda () pos-x)]
        [get-y (lambda () pos-y)]
+       [set-event-positions-wrt (lambda (c) (void))]
        [get-width (lambda () width)]
        [get-height (lambda () height)]
        [adopt-child (lambda (c) (send (get-parent) adopt-child c))])

collects/mrlib/graph.rkt

@@ -3,6 +3,7 @@
            racket/list
            racket/math
            racket/gui/base
+           racket/match
            (for-syntax racket/base)
            racket/contract)
   
@@ -387,8 +388,7 @@
                (invalidate-to-children/parents new-currently-over dc))
              new-currently-overs))))
       
-      (define/public (on-mouse-over-snips snips)
+      (define/public (on-mouse-over-snips snips) (void))
-	(void))
         
       ;; set-equal : (listof snip) (listof snip) -> boolean
       ;; typically lists will be small (length 1),
@@ -401,57 +401,42 @@
       ;; invalidate-to-children/parents : snip dc -> void
       ;; invalidates the region containing this snip and
       ;; all of its children and parents.
-      (inherit invalidate-bitmap-cache)
       (define/private (invalidate-to-children/parents snip dc)
         (when (is-a? snip graph-snip<%>)
-          (let* ([parents-and-children (append (get-all-parents snip)
+          (define-values (_1 text-height _2 _3) (send dc get-text-extent "Label" #f #f 0))
-                                               (get-all-children snip))]
+          (define parents-and-children (append (get-all-parents snip)
-                 [rects (eliminate-redundancies (get-rectangles snip parents-and-children))]
+                                               (get-all-children snip)))
-                 [or/c (or/c-rects rects)]
+          (define rects (get-rectangles snip parents-and-children))
-                 [text-height (call-with-values 
+          (for ([rect (in-list rects)])
-                               (λ () (send dc get-text-extent "Label" #f #f 0))
+            (save-rectangle-to-invalidate
-                               (λ (w h a s) h))]
+             (- (rect-left rect) text-height)
-                 [invalidate-rect
-                  (lambda (rect)
-                    (invalidate-bitmap-cache (- (rect-left rect) text-height)
              (- (rect-top rect)  text-height)
-                                             (+ (- (rect-right rect)
+             (+ (rect-right rect) text-height)
-                                                   (rect-left rect))
+             (+ (rect-bottom rect) text-height)))))
-                                                text-height)
-                                             (+ (- (rect-bottom rect)
-                                                   (rect-top rect))
-                                                   text-height)))])
-            (cond
-              [(< (rect-area or/c)
-                  (apply + (map (lambda (x) (rect-area x)) rects)))
-               (invalidate-rect or/c)]
-              [else
-               (for-each invalidate-rect rects)]))))
       
-      ;; (listof rect) -> (listof rect)
+      (define pending-invalidate-rectangle #f)
-      (define/private (eliminate-redundancies rects)
+      (define pending-invalidate-rectangle-timer #f)
-        (let loop ([rects rects]
+      (inherit invalidate-bitmap-cache)
-                   [acc null])
+      (define/private (run-pending-invalidate-rectangle)
-          (cond
+        (define the-pending-invalidate-rectangle pending-invalidate-rectangle)
-            [(null? rects) acc]
+        (set! pending-invalidate-rectangle #f)
-            [else (let ([r (car rects)])
+        (invalidate-bitmap-cache . the-pending-invalidate-rectangle))
-                    (cond
-                      [(or (ormap (lambda (other-rect) (rect-included-in? r other-rect))
-                                  (cdr rects))
-                           (ormap (lambda (other-rect) (rect-included-in? r other-rect))
-                                  acc))
-                       (loop (cdr rects)
-                             acc)]
-                      [else 
-                       (loop (cdr rects) 
-                             (cons r acc))]))])))
       
-      ;; rect-included-in? : rect rect -> boolean
+      (define/private (save-rectangle-to-invalidate l t r b)
-      (define/private (rect-included-in? r1 r2)
+        (unless pending-invalidate-rectangle-timer
-        (and ((rect-left r1) . >= . (rect-left r2))
+          (set! pending-invalidate-rectangle-timer 
-             ((rect-top r1) . >= . (rect-top r2))
+                (new timer% [notify-callback
-             ((rect-right r1) . <= . (rect-right r2))
+                             (λ () (run-pending-invalidate-rectangle))])))
-             ((rect-bottom r1) . <= . (rect-bottom r2))))
+        (add-to-pending-indvalidate-rectangle l t r b)
+        (send pending-invalidate-rectangle-timer start 20 #t))
+      
+      (define/private (add-to-pending-indvalidate-rectangle l t r b)
+        (set! pending-invalidate-rectangle
+              (match pending-invalidate-rectangle
+                [(list l2 t2 r2 b2)
+                 (list (min l l2) (min t t2) (max r r2) (max b b2))]
+                [#f
+                 (list l t r b)])))
 
       ;; get-rectangles : snip (listof snip) -> rect
       ;; computes the rectangles that need to be invalidated for connecting 
@@ -519,7 +504,11 @@
           (let ([old-font (send dc get-font)])
             (when edge-label-font
               (send dc set-font edge-label-font))
-            (draw-edges dc left top right bottom dx dy)
+            (cond
+              [pending-invalidate-rectangle
+               (add-to-pending-indvalidate-rectangle left top right bottom)]
+              [else
+               (draw-edges dc left top right bottom dx dy)])
             (when edge-label-font
               (send dc set-font old-font))))
         (super on-paint before? dc left top right bottom dx dy draw-caret))

collects/mrlib/private/regmk.rkt

@@ -1,4 +1,7 @@
-#lang racket
+#lang racket/base
+
+(require (for-syntax racket/base))
+
 (provide define-struct/reg-mk
          id->constructor
          (struct-out point)

collects/scribblings/framework/color.scrbl

@@ -154,6 +154,17 @@
 
     Sets the currently active regions to be @racket[regions].
   }
+  
+  @defmethod[(get-spell-check-strings) boolean?]{
+    Returns @racket[#t] if the colorer will attempt to
+    spell-check string constants.
+  }
+  
+  @defmethod[(set-spell-check-strings [b? boolean?]) void?]{
+    If called with @racket[#t], tell the colorer to spell-check
+    string constants. Otherwise, disable spell-checking of constants.
+  }
+  
   @defmethod*[(((get-regions) (listof (list/c number? (or/c (quote end) number?)))))]{
     This returns the list of regions that are currently being colored in the
     editor.

collects/scribblings/gui/editor-intf.scrbl

@@ -1,5 +1,9 @@
 #lang scribble/doc
-@(require "common.rkt")
+@(require "common.rkt"
+          scribble/eval)
+
+@(define editor-eval (make-base-eval))
+@(editor-eval '(require racket/class))
 
 @definterface/title[editor<%> ()]{
 
@@ -206,7 +210,52 @@ See also @method[editor<%> refresh-delayed?] and @method[editor<%>
 
 If the @racket[undoable?] flag is @racket[#f], then the changes made
  in the sequence cannot be reversed through the @method[editor<%>
- undo] method. This flag is only effective for the outermost
+ undo] method. To accomplish this, the editor just does not add
+ entries to the undo log when in an edit sequence where the
+ @racket[undoable?] flag is @racket[#f]. So, for example, if an
+ @litchar{a} is inserted into the editor and then a @litchar{b}
+ is inserted, and then an un-undoable edit-sequence begins,
+ and the @litchar{a} is colored red, and then the edit-sequence ends,
+ then an undo will remove the @litchar{b}, leaving the @litchar{a}
+ colored red.
+ 
+ This behavior also means that editors can get confused. Consider
+ this program:
+ @examples[#:eval 
+           editor-eval
+           (eval:alts (define t (new text%))
+                      ;; this is a pretty horrible hack, but 
+                      ;; the sequence of calls below behaves 
+                      ;; the way they are predicted to as of
+                      ;; the moment of this commit
+                      (define t 
+                        (new (class object%
+                               (define/public (set-max-undo-history x) (void))
+                               (define/public (insert . args) (void))
+                               (define/public (begin-edit-sequence a b) (void))
+                               (define/public (end-edit-sequence) (void))
+                               (define/public (undo) (void))
+                               (define first? #t)
+                               (define/public (get-text)
+                                 (cond
+                                   [first?
+                                    (set! first? #f)
+                                    "cab"]
+                                   [else "cb"]))
+                               (super-new)))))
+           (send t set-max-undo-history 'forever)
+           (send t insert "a")
+           (send t insert "b")
+           (send t begin-edit-sequence #f #f)
+           (send t insert "c" 0 0)
+           (send t end-edit-sequence)
+           (send t get-text)
+           (send t undo)
+           (send t get-text)]
+ You might hope that the undo would remove the @litchar{b}, but it removes
+ the @litchar{a}.
+      
+ The @racket[undoable?] flag is only effective for the outermost
  @method[editor<%> begin-edit-sequence] when nested sequences are
  used. Note that, for a @racket[text%] object, the character-inserting
  version of @method[text% insert] interferes with sequence-based undo

collects/scribblings/gui/list-box-class.scrbl

@@ -157,16 +157,6 @@ style. The new column is logically the last column, and it is initially
 displayed as the last column.}
 
 
-@defmethod[(delete [n exact-nonnegative-integer?])
-           void?]{
-
-Deletes the item indexed by @racket[n]. @|lbnumnote| If @racket[n] is equal
- to or larger than the number of items in the control, @|MismatchExn|.
-
-Selected items that are not deleted remain selected, and no other
- items are selected.}
-
-
 @defmethod[(delete-column [n exact-nonnegative-integer?])
            void?]{
 

collects/scribblings/gui/list-control-intf.scrbl

@@ -36,11 +36,22 @@ Removes all user-selectable items from the control.
 
 }
 
+@defmethod[(delete [n exact-nonnegative-integer?])
+           void?]{
+
+Deletes the item indexed by @racket[n] (where items are indexed
+ from @racket[0]). If @racket[n] is equal
+ to or larger than the number of items in the control, @|MismatchExn|.
+
+Selected items that are not deleted remain selected, and no other
+ items are selected.}
+
+
 @defmethod[(find-string [s string?])
            (or/c exact-nonnegative-integer? #f)]{
 Finds a user-selectable item matching the given string. If no matching
  choice is found, @racket[#f] is returned, otherwise the index of the
- matching choice is returned (items are indexed from @racket[0]).
+ matching choice is returned (where items are indexed from @racket[0]).
 
 }
 
@@ -53,7 +64,7 @@ Returns the number of user-selectable items in the control (which is
 
 @defmethod[(get-selection)
            (or/c exact-nonnegative-integer? #f)]{
-Returns the index of the currently selected item (items are indexed
+Returns the index of the currently selected item (where items are indexed
  from @racket[0]). If the choice item currently contains no choices or no
  selections, @racket[#f] is returned.  If multiple selections are
  allowed and multiple items are selected, the index of the first
@@ -64,7 +75,7 @@ Returns the index of the currently selected item (items are indexed
 @defmethod[(get-string [n exact-nonnegative-integer?])
            (and/c immutable? label-string?)]{
 
-Returns the item for the given index (items are indexed from
+Returns the item for the given index (where items are indexed from
  @racket[0]). If the provided index is larger than the greatest index in
  the list control, @|MismatchExn|.
 
@@ -81,7 +92,7 @@ Returns the currently selected item.  If the control currently
 
 @defmethod[(set-selection [n exact-nonnegative-integer?])
            void?]{
-Selects the item specified by the given index (items are indexed from
+Selects the item specified by the given index (where items are indexed from
  @racket[0]). If the given index larger than the greatest index in the
  list control, @|MismatchExn|.
 

collects/scribblings/gui/menu-item-intf.scrbl

@@ -10,7 +10,7 @@ A @racket[menu-item<%>] object is an element within a @racket[menu%],
  @racket[menu-item<%>] object.
 
 A menu item is either a @racket[separator-menu-item%] object (merely
- a separator), of a @racket[labelled-menu-item<%>] object; the latter
+ a separator), or a @racket[labelled-menu-item<%>] object; the latter
  is more specifically an instance of either @racket[menu-item%] (a
  plain menu item), @racket[checkable-menu-item%] (a checkable menu
  item), or @racket[menu%] (a submenu).

collects/scribblings/gui/miscwin-funcs.scrbl

@@ -194,6 +194,15 @@ break is sent (via @racket[break-thread]) to the created eventspace's
 @tech{handler thread}.}
 
 
+@defproc[(get-current-mouse-state) (values (is-a?/c point%)
+                                           (listof (or/c 'left 'middle 'right
+                                                         'shift 'control 'alt 'meta 'caps)))]{
+
+Returns the current location of the mouse in screen coordinates,
+and returns a list of symbols for mouse buttons and modifier keys
+that are currently pressed.}
+
+
 @defproc[(hide-cursor-until-moved) void?]{
 
 Hides the cursor until the user moves the mouse or clicks the mouse

collects/scribblings/gui/win-overview.scrbl

@@ -951,6 +951,23 @@ Along similar lines, if a button callback captures a continuation
  captured during a button callback is therefore potentially useful
  outside of the same callback.
 
+@subsection{Logging}
+
+The GUI system logs the timing of when events are handled and how
+long they take to be handled. Each event that involves a callback
+into Racket code has two events logged, both of which use
+the @racket[gui-event] struct:
+@racketblock[(struct gui-event (start end name) #:prefab)]
+The @racket[_start] field is the result of @racket[(current-inexact-milliseconds)]
+when the event handling starts. The @racket[_end] field is 
+@racket[#f] for the log message when the event handling starts,
+and the result of @racket[(current-inexact-milliseconds)] when
+it finishes for the log message when an event finishes.
+The @racket[_name] field is
+the name of the function that handled the event; in the case of a
+@racket[queue-callback]-based event, it is the name of the thunk passed to
+@racket[queue-callback].
+
 @section[#:tag "animation"]{Animation in Canvases}
 
 The content of a canvas is buffered, so if a canvas must be redrawn,

collects/tests/gracket/editor.rktl

@@ -304,6 +304,62 @@
     (test #f 'peek-t (peek-byte-or-special i 0))
     (test 49 'read-1 (peek-byte-or-special i 1))))
 
+(let ()
+  (define t (new text%))
+  (send t insert "aa\nbb\ncc\ndd\nee\nff\n")
+  (send t insert (make-object image-snip%
+                   (collection-file-path "recycle.png" "icons")))
+  
+  (define p (open-input-text-editor t))
+  
+  (define rev-at-start (send t get-revision-number))
+  (define line1 (read-line p))
+  
+  (define sl (send t get-style-list))
+  (define d (make-object style-delta% 'change-bold))
+  (define s (send sl find-or-create-style (send sl basic-style) d))
+  (send t change-style s 6 7)
+  
+  (define rev-after-cs (send t get-revision-number))
+  (define line2 (read-line p))
+  
+  (test #t 'revision-changed (> rev-after-cs rev-at-start))
+  (test "aa" 'revision-changed-line1 line1)
+  (test "bb" 'revision-changed-line1 line2))
+
+(let ()
+  (define t (new text%))
+  (send t insert "abcd\n")
+  (send t insert (make-object image-snip%
+                   (collection-file-path "recycle.png" "icons")))
+  
+  (define (count-snips)
+    (let loop ([s (send t find-first-snip)])
+      (cond
+        [s (+ 1 (loop (send s next)))]
+        [else 0])))
+  
+  (send t split-snip 1)
+  (define before-snip-count (count-snips))
+  (define rev-at-start (send t get-revision-number))
+  
+  (define p (open-input-text-editor t))
+  
+  (define char1 (read-char p))
+  
+  (define s (send (send t get-style-list) basic-style))
+  (send t change-style s 0 4)
+  (define after-snip-count (count-snips))
+  (define rev-after-cs (send t get-revision-number))
+  
+  (define chars (string (read-char p) (read-char p) (read-char p)))
+  
+  (test 4     'snips-joined1 before-snip-count)
+  (test 3     'snips-joined2 after-snip-count)
+  (test #t     'snips-joined3 (> rev-after-cs rev-at-start))
+  (test #\a    'snips-joined4 char1)
+  (test "bcd" 'snips-joined5 chars))
+
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 ;;                            Snips and Streams                               ;;
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
@@ -325,6 +381,7 @@
         snip))
     (super-instantiate ())))
 
+
 (define snip-class (make-object (mk-number-snip-class% #t)))
 (send snip-class set-classname (format "~s" `(lib "number-snip.ss" "drscheme" "private")))
 (send (get-the-snip-class-list) add snip-class)

collects/tests/gracket/item.rkt

@@ -1556,13 +1556,11 @@
     (when (<= 0 p (sub1 (length actual-content)))
       (set! actual-content (gone actual-content p))
       (set! actual-user-data (gone actual-user-data p))))
-  (define db (if list?
+  (define db (make-object button%
-		 (make-object button%
                           "Delete" cdp
                           (lambda (b e)
                             (let ([p (send c get-selection)])
-				  (delete p))))
+                              (delete p)))))
-		 null))
   (define dab (if list?
 		  (make-object button%
 			       "Delete Above" cdp
@@ -2291,6 +2289,30 @@
 	    '(arrow bullseye cross hand ibeam watch blank size-n/s size-e/w size-ne/sw size-nw/se))
   (send f show #t))
 
+;----------------------------------------------------------------------
+
+(define (mouse)
+  (define f (new frame% 
+                 [label "Mouse"]
+                 [width 300]
+                 [height 200]))
+  (define m (new message%
+                 [parent f]
+                 [label ""]
+                 [stretchable-width #t]))
+  (send f show #t)
+  (thread (lambda ()
+            (let loop ()
+              (when (send f is-shown?)
+                (sleep 0.1)
+                (define-values (pos keys) (get-current-mouse-state))
+                (queue-callback
+                 (lambda () (send m set-label
+                                  (format "~a,~a ~a" 
+                                          (send pos get-x)
+                                          (send pos get-y)
+                                          keys))))
+                (loop))))))
 
 ;----------------------------------------------------------------------
 
@@ -2372,6 +2394,8 @@
 (make-object vertical-pane% crp) ; filler
 (make-object button% "Cursors" crp (lambda (b e) (cursors)))
 (make-object vertical-pane% crp) ; filler
+(make-object button% "Mouse" crp (lambda (b e) (mouse)))
+(make-object vertical-pane% crp) ; filler
 (make-object button% "Make Radiobox Frame" crp (lambda (b e) (radiobox-frame)))
 (define cp (make-object horizontal-pane% ap))
 (send cp stretchable-width #f)

collects/tests/gracket/mem.rkt

@@ -280,4 +280,3 @@
     (still)))
 
 (do-test)
-

collects/tests/utils/gui.rkt

@@ -1,8 +1,10 @@
-(module gui mzscheme
+#lang racket/base
-  (require mred
+
-           mzlib/class
+  (require racket/gui/base
-           mzlib/etc)
+           racket/class)
-  (provide find-labelled-window whitespace-string=?)
+  (provide find-labelled-window 
+           find-labelled-windows
+           whitespace-string=?)
   
   ;; whitespace-string=? : string string -> boolean
   ;; determines if two strings are equal, up to their whitespace.
@@ -60,50 +62,55 @@
         [else #f])))
   
   ;; whitespace-string=? tests
-  '(map (lambda (x) (apply equal? x))
+  (module+ test
-        (list (list #t (whitespace-string=? "a" "a"))
+    (require rackunit)
-              (list #f (whitespace-string=? "a" "A"))
+    (check-equal? #t (whitespace-string=? "a" "a"))
-              (list #f (whitespace-string=? "a" " "))
+    (check-equal? #f (whitespace-string=? "a" "A"))
-              (list #f (whitespace-string=? " " "A"))
+    (check-equal? #f (whitespace-string=? "a" " "))
-              (list #t (whitespace-string=? " " " "))
+    (check-equal? #f (whitespace-string=? " " "A"))
-              (list #t (whitespace-string=? " " "  "))
+    (check-equal? #t (whitespace-string=? " " " "))
-              (list #t (whitespace-string=? "  " "  "))
+    (check-equal? #t (whitespace-string=? " " "  "))
-              (list #t (whitespace-string=? "  " " "))
+    (check-equal? #t (whitespace-string=? "  " "  "))
-              (list #t (whitespace-string=? "a a" "a a"))
+    (check-equal? #t (whitespace-string=? "  " " "))
-              (list #t (whitespace-string=? "a a" "a  a"))
+    (check-equal? #t (whitespace-string=? "a a" "a a"))
-              (list #t (whitespace-string=? "a  a" "a a"))
+    (check-equal? #t (whitespace-string=? "a a" "a  a"))
-              (list #t (whitespace-string=? " a" "a"))
+    (check-equal? #t (whitespace-string=? "a  a" "a a"))
-              (list #t (whitespace-string=? "a" " a"))
+    (check-equal? #t (whitespace-string=? " a" "a"))
-              (list #t (whitespace-string=? "a " "a"))
+    (check-equal? #t (whitespace-string=? "a" " a"))
-              (list #t (whitespace-string=? "a" "a "))))
+    (check-equal? #t (whitespace-string=? "a " "a"))
+    (check-equal? #t (whitespace-string=? "a" "a ")))
 
   ;;; find-labelled-window : (union ((union #f string) -> window<%>)
   ;;;                               ((union #f string) (union #f class) -> window<%>)
   ;;;                               ((union #f string) (union class #f) area-container<%> -> window<%>))
   ;;;;  may call error, if no control with the label is found
-  (define find-labelled-window
+  (define (find-labelled-window label 
-    (opt-lambda (label 
                                 [class #f]
                                 [window (get-top-level-focus-window)]
-                 [failure (lambda ()
+                                [failure (λ ()
                                            (error 'find-labelled-window "no window labelled ~e in ~e~a"
                                                   label
                                                   window 
                                                   (if class
                                                       (format " matching class ~e" class)
                                                       "")))])
+    (define windows (find-labelled-windows label class window))
+    (cond
+      [(null? windows) (failure)]
+      [else (car windows)]))
+ 
+  (define (find-labelled-windows label [class #f] [window (get-top-level-focus-window)])
     (unless (or (not label)
                 (string? label))
-	(error 'find-labelled-window "first argument must be a string or #f, got ~e; other args: ~e ~e"
+      (error 'find-labelled-windows "first argument must be a string or #f, got ~e; other args: ~e ~e"
              label class window))
     (unless (or (class? class)
                 (not class))
-	(error 'find-labelled-window "second argument must be a class or #f, got ~e; other args: ~e ~e"
+      (error 'find-labelled-windows "second argument must be a class or #f, got ~e; other args: ~e ~e"
              class label window))
     (unless (is-a? window area-container<%>)
-	(error 'find-labelled-window "third argument must be a area-container<%>, got ~e; other args: ~e ~e"
+      (error 'find-labelled-windows "third argument must be a area-container<%>, got ~e; other args: ~e ~e"
              window label class))
-      (let ([ans
     (let loop ([window window])
       (cond
         [(and (or (not class)
@@ -111,8 +118,8 @@
               (let ([win-label (and (is-a? window window<%>)
                                     (send window get-label))])
                 (equal? label win-label)))
-                  window]
+         (list window)]
-                 [(is-a? window area-container<%>) (ormap loop (send window get-children))]
+        [(is-a? window area-container<%>) (apply append (map loop (send window get-children)))]
-                 [else #f]))])
+        [else '()])))
-	(or ans
+  
-	    (failure))))))
+