From 47af9d51bcfd52c3ea278732ae4eb3077ef90e8e Mon Sep 17 00:00:00 2001
From: Vincent St-Amour <stamourv@racket-lang.org>
Date: Tue, 28 Jun 2011 18:07:18 -0400
Subject: [PATCH] Make performance-report state local, to support multiple
 files at once.

---
 collects/typed-scheme/optimizer/tool/tool.rkt | 110 ++++++++++--------
 1 file changed, 59 insertions(+), 51 deletions(-)

diff --git a/collects/typed-scheme/optimizer/tool/tool.rkt b/collects/typed-scheme/optimizer/tool/tool.rkt
index 8b24275798..28fcad0b1b 100644
--- a/collects/typed-scheme/optimizer/tool/tool.rkt
+++ b/collects/typed-scheme/optimizer/tool/tool.rkt
@@ -17,58 +17,9 @@
    bitmap%
    (collection-file-path "performance-report.png" "icons") 'png/mask))
 
-(define highlights '())
-
 ;; performance-report-callback : drracket:unit:frame<%> -> void
 (define (performance-report-callback drr-frame)
-  (define defs     (send drr-frame get-definitions-text)) ; : text%
-  (define portname (send defs      get-port-name))
-  (define input    (open-input-text-editor defs))
-  (port-count-lines! input)
-  (define log '())
-  (with-intercepted-tr-logging
-   (lambda (l)
-     (set! log (cons (cdr (vector-ref l 2)) ; log-entry struct
-                     log)))
-   (lambda ()
-     (parameterize ([current-namespace  (make-base-namespace)]
-                    [read-accept-reader #t])
-       (expand (tr:read-syntax portname input)))))
-  (set! log (reverse log))
-  (define (highlight-irritant i)
-    (define pos (syntax-position i))
-    (and pos
-         (let ([start (sub1 pos)]
-               [end   (sub1 (+ pos (syntax-span i)))]
-               [color "red"]
-               [caret-space #f]
-               [style 'hollow-ellipse])
-           ;; high priority, to display above the coloring
-           (send defs highlight-range start end color caret-space 'high style)
-           ;; info needed to remove the highlight
-           (list start end color caret-space style))))
-  ;; highlight
-  (define new-highlights
-    (for/list ([l (in-list log)])
-      (match l
-        [(log-entry kind msg stx (? number? pos))
-         (let* ([start (sub1 pos)]
-                [end   (+ start (syntax-span stx))]
-                [opt?  (opt-log-entry? l)] ;; opt or missed opt?
-                [color (if opt? "lightgreen" "pink")])
-           (send defs highlight-range start end color)
-           (send defs set-clickback start end
-                 (lambda (ed start end)
-                   (message-box "Performance Report" msg)))
-           (cons (list start end color) ; record highlights to undo them later
-                 ;; missed optimizations have irritants, circle them
-                 (if opt?
-                     '()
-                     (filter values ; remove irritants w/o location
-                             (map highlight-irritant
-                                  (missed-opt-log-entry-irritants l))))))]
-        [_ '()]))) ; no source location, don't highlight anything
-  (set! highlights (append (apply append new-highlights) highlights)))
+  (send (send drr-frame get-definitions-text) add-highlights))
 
 (define remove-highlights-mixin
   (mixin ((class->interface text%)) ()
@@ -76,16 +27,73 @@
              end-edit-sequence
              insert
              get-text)
+
+    (define highlights '())
+
+    (define/public (add-highlights)
+      (define portname (send this get-port-name))
+      (define input    (open-input-text-editor this))
+      (port-count-lines! input)
+      (define log '())
+      (with-intercepted-tr-logging
+       (lambda (l)
+         (set! log (cons (cdr (vector-ref l 2)) ; log-entry struct
+                         log)))
+       (lambda ()
+         (parameterize ([current-namespace  (make-base-namespace)]
+                        [read-accept-reader #t])
+           (expand (tr:read-syntax portname input)))))
+      (set! log (reverse log))
+      (define (highlight-irritant i)
+        (define pos (syntax-position i))
+        (and pos
+             (let ([start (sub1 pos)]
+                   [end   (sub1 (+ pos (syntax-span i)))]
+                   [color "red"]
+                   [caret-space #f]
+                   [style 'hollow-ellipse])
+               ;; high priority, to display above the coloring
+               (send this highlight-range
+                     start end color caret-space 'high style)
+               ;; info needed to remove the highlight
+               (list start end color caret-space style))))
+      ;; highlight
+      (define new-highlights
+        (for/list ([l (in-list log)])
+          (match l
+            [(log-entry kind msg stx (? number? pos))
+             (let* ([start (sub1 pos)]
+                    [end   (+ start (syntax-span stx))]
+                    [opt?  (opt-log-entry? l)] ;; opt or missed opt?
+                    [color (if opt? "lightgreen" "pink")])
+               (send this highlight-range start end color)
+               (send this set-clickback start end
+                     (lambda (ed start end)
+                       (message-box "Performance Report" msg)))
+               ;; record highlights to undo them later
+               (cons (list start end color)
+                     ;; missed optimizations have irritants, circle them
+                     (if opt?
+                         '()
+                         (filter values ; remove irritants w/o location
+                                 (map highlight-irritant
+                                      (missed-opt-log-entry-irritants l))))))]
+            [_ '()]))) ; no source location, don't highlight anything
+      (set! highlights (append (apply append new-highlights) highlights)))
+
     (define (clear-highlights)
       (for ([h (in-list highlights)])
         (match h
           [`(,start ,end . ,rest )
            (send this unhighlight-range . h)
-           (send this remove-clickback start end)])))
+           (send this remove-clickback start end)]))
+      (set! highlights '()))
+
     (define/augment (after-insert start len)
       (clear-highlights))
     (define/augment (after-delete start len)
       (clear-highlights))
+
     (super-new)))
 
 (define-unit tool@