Split tool into multiple files.

collects/typed-scheme/optimizer/tool/display.rkt

@@ -0,0 +1,35 @@
+#lang racket/base
+
+(require racket/string racket/pretty racket/class racket/gui/base
+         unstable/sequence)
+
+(provide format-message make-color-table)
+
+(define (format-message stxs+msgs)
+  (string-join (for/list ([(stx msg) (in-pairs stxs+msgs)])
+                 (format "~a\n~a"
+                         (pretty-format (syntax->datum stx))
+                         msg))
+               "\n\n"))
+
+(define lowest-badness-color  (make-object color% "pink"))
+(define highest-badness-color (make-object color% "red"))
+;; the higher the badness, the closer to red the highlight should be
+(define (make-color-table max-badness)
+  (define min-g (send highest-badness-color green))
+  (define max-g (send lowest-badness-color  green))
+  (define min-b (send highest-badness-color blue))
+  (define max-b (send lowest-badness-color  blue))
+  (define delta-g (- max-g min-g))
+  (define delta-b (- max-b min-b))
+  (define bucket-size-g (quotient delta-g max-badness))
+  (define bucket-size-b (quotient delta-b max-badness))
+  (build-vector (add1 max-badness) ; to index directly using badness
+                (lambda (x)
+                  (make-object
+                   color%
+                   255
+                   ;; clipping, since the first (unused, for
+                   ;; badness of 0) would have invalid components
+                   (min 255 (- max-g (* (sub1 x) bucket-size-g)))
+                   (min 255 (- max-b (* (sub1 x) bucket-size-b)))))))

collects/typed-scheme/optimizer/tool/report.rkt

@@ -0,0 +1,96 @@
+#lang racket/base
+
+(require racket/class racket/gui/base racket/match)
+
+(require (prefix-in tr: typed-scheme/typed-reader)
+         typed-scheme/optimizer/logging)
+
+(provide (struct-out report-entry)
+         (struct-out opt-report-entry)
+         (struct-out missed-opt-report-entry)
+         generate-report)
+
+;; Similar to the log-entry family of structs, but geared towards GUI display.
+;; Also designed to contain info for multiple overlapping log entries.
+;; stxs+msgs is a list of syntax-message pairs
+(struct report-entry (stxs+msgs start end))
+(struct opt-report-entry        report-entry ())
+(struct missed-opt-report-entry report-entry (badness irritants))
+
+
+(define (generate-report this)
+  (collapse-report (log->report (generate-log this))))
+
+
+(define (generate-log this)
+  (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)))))
+  log)
+
+;; converts log-entry structs to report-entry structs for further
+;; processing
+(define (log->report log)
+  (define (log-entry->report-entry l)
+    (match l
+      [(log-entry kind msg stx (? number? pos))
+       (define stxs+msgs `((,stx . ,msg)))
+       (define start     (sub1 pos))
+       (define end       (+ start (syntax-span stx)))
+       (if (opt-log-entry? l)
+           (opt-report-entry stxs+msgs start end)
+           (missed-opt-report-entry stxs+msgs start end
+                                    (missed-opt-log-entry-badness   l)
+                                    (missed-opt-log-entry-irritants l)))]
+      [_ #f])) ; no source location, ignore
+  (filter values (map log-entry->report-entry log)))
+
+(define (merge-entries prev l)
+  (define new-stxs+msgs
+    (append (report-entry-stxs+msgs prev) (report-entry-stxs+msgs l)))
+  (match (list prev l)
+    [`(,(missed-opt-report-entry ss+ms1 start1 end1 bad1 irr1)
+       ,(missed-opt-report-entry ss+ms2 start2 end2 bad2 irr2))
+     ;; we take start1 and end1 since prev includes l
+     (missed-opt-report-entry new-stxs+msgs start1 end1
+                              (+ bad1 bad2) (append irr1 irr2))]
+    [(or `(,(missed-opt-report-entry ss+ms1 start1 end1 bad irr)
+           ,(report-entry ss+ms2 start2 end2))
+         `(,(report-entry ss+ms1 start1 end1)
+           ,(missed-opt-report-entry ss+ms2 start2 end2 bad irr)))
+     ;; since missed opts are more important to report, they win
+     (missed-opt-report-entry new-stxs+msgs start1 end1 bad irr)]
+    [`(,(report-entry ss+ms1 start1 end1) ,(report-entry ss+ms2 start2 end2))
+     ;; both are opts
+     (report-entry new-stxs+msgs start1 end1)]))
+
+;; detect overlapping reports and merge them
+(define (collapse-report orig-report)
+  ;; sort in order of starting point
+  (define report (sort orig-report < #:key report-entry-start))
+  (define-values (new-report _)
+    (for/fold ([new-report '()]
+               [prev #f])
+        ([l (in-list report)])
+      (match* (prev l)
+        [((report-entry stxs+msgs1 start1 end1)
+          (report-entry stxs+msgs2 start2 end2))
+         (=> unmatch)
+         (if (< start2 end1) ; l in within prev
+             ;; merge the two
+             (values (cons (merge-entries prev l) (cdr new-report))
+                     ;; we don't advance, since we merged
+                     prev)
+             (unmatch))]
+        [(prev l) ; no overlap, just add to the list
+         (values (cons l new-report) l)])))
+  new-report)

collects/typed-scheme/optimizer/tool/tool.rkt

@@ -1,12 +1,9 @@
 #lang racket/base
 
-(require racket/class racket/port racket/list racket/match racket/string
+(require racket/class racket/port racket/list racket/match
-         racket/gui/base mrlib/switchable-button
+         racket/gui/base racket/unit drracket/tool)
-         racket/unit drracket/tool
-         unstable/sequence)
 
-(require (prefix-in tr: typed-scheme/typed-reader)
+(require "report.rkt" "display.rkt")
-         typed-scheme/optimizer/logging)
 
 (provide performance-report-drracket-button
          tool@)
@@ -22,35 +19,6 @@
 (define (performance-report-callback drr-frame)
   (send (send drr-frame get-definitions-text) add-highlights))
 
-(define lowest-badness-color  (make-object color% "pink"))
-(define highest-badness-color (make-object color% "red"))
-;; the higher the badness, the closer to red the highlight should be
-(define (make-color-table max-badness)
-  (define min-g (send highest-badness-color green))
-  (define max-g (send lowest-badness-color  green))
-  (define min-b (send highest-badness-color blue))
-  (define max-b (send lowest-badness-color  blue))
-  (define delta-g (- max-g min-g))
-  (define delta-b (- max-b min-b))
-  (define bucket-size-g (quotient delta-g max-badness))
-  (define bucket-size-b (quotient delta-b max-badness))
-  (build-vector (add1 max-badness) ; to index directly using badness
-                (lambda (x)
-                  (make-object
-                   color%
-                   255
-                   ;; clipping, since the first (unused, for
-                   ;; badness of 0) would have invalid components
-                   (min 255 (- max-g (* (sub1 x) bucket-size-g)))
-                   (min 255 (- max-b (* (sub1 x) bucket-size-b)))))))
-
-;; Similar to the log-entry family of structs, but geared towards GUI display.
-;; Also designed to contain info for multiple overlapping log entries.
-;; stxs+msgs is a list of syntax-message pairs
-(struct report-entry (stxs+msgs start end))
-(struct opt-report-entry        report-entry ())
-(struct missed-opt-report-entry report-entry (badness irritants))
-
 (define highlights-mixin
   (mixin ((class->interface text%)) ()
     (inherit begin-edit-sequence
@@ -75,11 +43,6 @@
              ;; info needed to remove the highlight
              (list start end color caret-space style))))
 
-    (define (format-message stxs+msgs)
-      (string-join (for/list ([(stx msg) (in-pairs stxs+msgs)])
-                     (format "~a\n~a" (syntax->datum stx) msg))
-                   "\n\n"))
-
     (define (highlight-entry l)
       (match l
         [(report-entry stxs+msgs start end)
@@ -102,62 +65,8 @@
                              (map highlight-irritant
                                   (missed-opt-report-entry-irritants l))))))]))
 
-    (define (generate-log)
-      (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)))))
-      log)
-
-    ;; converts log-entry structs to report-entry structs for further
-    ;; processing
-    (define (log->report log)
-      (define (log-entry->report-entry l)
-        (match l
-          [(log-entry kind msg stx (? number? pos))
-           (define stxs+msgs `((,stx . ,msg)))
-           (define start     (sub1 pos))
-           (define end       (+ start (syntax-span stx)))
-           (if (opt-log-entry? l)
-               (opt-report-entry stxs+msgs start end)
-               (missed-opt-report-entry stxs+msgs start end
-                                        (missed-opt-log-entry-badness   l)
-                                        (missed-opt-log-entry-irritants l)))]
-          [_ #f])) ; no source location, ignore
-      (filter values (map log-entry->report-entry log)))
-
-    ;; detect overlapping reports and merge them
-    (define (collapse-report orig-report)
-      ;; sort in order of starting point
-      (define report (sort orig-report < #:key report-entry-start))
-      (define-values (new-report _)
-        (for/fold ([new-report '()]
-                   [prev #f])
-            ([l (in-list report)])
-          (match* (prev l)
-            [((report-entry stxs+msgs1 start1 end1)
-              (report-entry stxs+msgs2 start2 end2))
-             (=> unmatch)
-             (if (< start2 end1) ; l in within prev
-                 ;; merge the two
-                 (values (cons (merge-entries prev l) (cdr new-report))
-                         ;; we don't advance, since we merged
-                         prev)
-                 (unmatch))]
-            [(prev l) ; no overlap, just add to the list
-             (values (cons l new-report) l)])))
-      new-report)
-
     (define/public (add-highlights)
-      (define report (collapse-report (log->report (generate-log))))
+      (define report (generate-report this))
       (define max-badness
         (for/fold ([max-badness 0])
             ([l (in-list report)]
@@ -183,25 +92,6 @@
 
     (super-new)))
 
-(define (merge-entries prev l)
-  (define new-stxs+msgs
-    (append (report-entry-stxs+msgs prev) (report-entry-stxs+msgs l)))
-  (match (list prev l)
-    [`(,(missed-opt-report-entry ss+ms1 start1 end1 bad1 irr1)
-       ,(missed-opt-report-entry ss+ms2 start2 end2 bad2 irr2))
-     ;; we take start1 and end1 since prev includes l
-     (missed-opt-report-entry new-stxs+msgs start1 end1
-                              (+ bad1 bad2) (append irr1 irr2))]
-    [(or `(,(missed-opt-report-entry ss+ms1 start1 end1 bad irr)
-           ,(report-entry ss+ms2 start2 end2))
-         `(,(report-entry ss+ms1 start1 end1)
-           ,(missed-opt-report-entry ss+ms2 start2 end2 bad irr)))
-     ;; since missed opts are more important to report, they win
-     (missed-opt-report-entry new-stxs+msgs start1 end1 bad irr)]
-    [`(,(report-entry ss+ms1 start1 end1) ,(report-entry ss+ms2 start2 end2))
-     ;; both are opts
-     (report-entry new-stxs+msgs start1 end1)]))
-
 (define-unit tool@
   (import drracket:tool^)
   (export drracket:tool-exports^)