Unitize performance report, to get access to some DrRacket internals.

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

@@ -2,7 +2,7 @@
 
 (require racket/string racket/class racket/gui/base racket/match racket/port
          framework syntax/to-string
-         "report.rkt"
+         "report-structs.rkt"
          unstable/sequence unstable/pretty)
 
 (provide popup-callback make-color-table)

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

@@ -0,0 +1,3 @@
+#lang racket/signature
+
+generate-report

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

@@ -0,0 +1,18 @@
+#lang racket/base
+
+(provide (struct-out report-entry)
+         (struct-out sub-report-entry)
+         (struct-out opt-report-entry)
+         (struct-out missed-opt-report-entry))
+
+;; Similar to the log-entry family of structs, but geared towards GUI display.
+;; Also designed to contain info for multiple overlapping log entries.
+;; - subs is a list of sub-report-entry, corresponding to all the entries
+;;   between start and end
+;; - badness is 0 for a report-entry containing only optimizations
+;;   otherwise, it's the sum for all the subs
+(struct report-entry (subs start end badness))
+;; multiple of these can be contained in a report-entry
+(struct sub-report-entry (stx msg))
+(struct opt-report-entry        sub-report-entry ())
+(struct missed-opt-report-entry sub-report-entry (badness irritants))

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

@@ -1,28 +1,15 @@
-#lang racket/base
+#lang racket/unit
 
 (require racket/class racket/gui/base racket/match
-         unstable/syntax)
+         unstable/syntax drracket/tool
+         unstable/logging)
 
-(require (prefix-in tr: typed-scheme/typed-reader)
-         typed-scheme/optimizer/logging)
+(require typed-scheme/optimizer/logging
+         "report-sig.rkt" "report-structs.rkt")
 
-(provide (struct-out report-entry)
-         (struct-out sub-report-entry)
-         (struct-out opt-report-entry)
-         (struct-out missed-opt-report-entry)
-         generate-report)
+(import drracket:tool^)
+(export report^)
 
-;; Similar to the log-entry family of structs, but geared towards GUI display.
-;; Also designed to contain info for multiple overlapping log entries.
-;; - subs is a list of sub-report-entry, corresponding to all the entries
-;;   between start and end
-;; - badness is 0 for a report-entry containing only optimizations
-;;   otherwise, it's the sum for all the subs
-(struct report-entry (subs start end badness))
-;; multiple of these can be contained in a report-entry
-(struct sub-report-entry (stx msg))
-(struct opt-report-entry        sub-report-entry ())
-(struct missed-opt-report-entry sub-report-entry (badness irritants))
 
 (define (generate-report this)
   (collapse-report (log->report (generate-log this))))

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

@@ -3,7 +3,7 @@
 (require racket/class racket/port racket/list racket/match
          racket/gui/base racket/unit drracket/tool)
 
-(require "report.rkt" "display.rkt")
+(require "display.rkt" "report-sig.rkt" "report.rkt" "report-structs.rkt")
 
 (provide performance-report-drracket-button
          tool@)
@@ -17,60 +17,74 @@
 
 ;; performance-report-callback : drracket:unit:frame<%> -> void
 (define (performance-report-callback drr-frame)
-  (send (send drr-frame get-definitions-text) add-highlights))
+  (with-handlers
+      ([exn?
+        ;; typechecking failed, report in the interactions window
+        (lambda (e)
+          (define interactions (send drr-frame get-interactions-text))
+          (send interactions reset-console)
+          (send interactions run-in-evaluation-thread (lambda () (raise e))))])
+    (send (send drr-frame get-definitions-text) add-highlights)))
 
-(define highlights-mixin
-  (mixin ((class->interface text%)) ()
-    (inherit begin-edit-sequence
-             end-edit-sequence
-             insert
-             get-text)
-
-    (define highlights  '())
-    (define color-table #f)
-
-    (define (highlight-entry l)
-      (match l
-        [(report-entry subs start end badness)
-         (let ([color (if (= badness 0)
-                          "lightgreen"
-                          (vector-ref color-table badness))])
-           (send this highlight-range start end color)
-           (send this set-clickback start end (popup-callback l))
-           ;; record highlight to undo it later
-           (list start end color))]))
-
-    (define/public (add-highlights)
-      (define report (generate-report this))
-      (define max-badness
-        (apply max (cons 0 (map report-entry-badness report))))
-      (unless (= max-badness 0) ; no missed opts, color table code would error
-        (set! color-table (make-color-table max-badness)))
-      (define new-highlights (map highlight-entry report))
-      (set! highlights (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)]))
-      (set! highlights '()))
-
-    (define/augment (after-insert start len)
-      (clear-highlights))
-    (define/augment (after-delete start len)
-      (clear-highlights))
-
-    (super-new)))
-
-(define-unit tool@
-  (import drracket:tool^)
+(define-unit pre-tool@
+  (import drracket:tool^ report^)
   (export drracket:tool-exports^)
+
   (define (phase1) (void))
   (define (phase2) (void))
+
+  (define highlights-mixin
+    (mixin ((class->interface text%)) ()
+      (inherit begin-edit-sequence
+               end-edit-sequence
+               insert
+               get-text)
+
+      (define highlights  '())
+      (define color-table #f)
+
+      (define (highlight-entry l)
+        (match l
+          [(report-entry subs start end badness)
+           (let ([color (if (= badness 0)
+                            "lightgreen"
+                            (vector-ref color-table badness))])
+             (send this highlight-range start end color)
+             (send this set-clickback start end (popup-callback l))
+             ;; record highlight to undo it later
+             (list start end color))]))
+
+      (define/public (add-highlights)
+        (define report (generate-report this))
+        (define max-badness
+          (apply max (cons 0 (map report-entry-badness report))))
+        (unless (= max-badness 0) ; no missed opts, color table code would error
+          (set! color-table (make-color-table max-badness)))
+        (define new-highlights (map highlight-entry report))
+        (set! highlights (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)]))
+        (set! highlights '()))
+
+      (define/augment (after-insert start len)
+        (clear-highlights))
+      (define/augment (after-delete start len)
+        (clear-highlights))
+
+      (super-new)))
+
   (drracket:get/extend:extend-definitions-text highlights-mixin))
 
+(define-compound-unit/infer tool@
+  (import drracket:tool^)
+  (export drracket:tool-exports^)
+  (link pre-tool@ report@))
+
 (define performance-report-drracket-button
   (list
    "Performance Report"