diff --git a/collects/typed-scheme/optimizer/tool/display.rkt b/collects/typed-scheme/optimizer/tool/display.rkt index 8310ca5ccb..784170a1a9 100644 --- a/collects/typed-scheme/optimizer/tool/display.rkt +++ b/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) diff --git a/collects/typed-scheme/optimizer/tool/report-sig.rkt b/collects/typed-scheme/optimizer/tool/report-sig.rkt new file mode 100644 index 0000000000..e5302f8895 --- /dev/null +++ b/collects/typed-scheme/optimizer/tool/report-sig.rkt @@ -0,0 +1,3 @@ +#lang racket/signature + +generate-report diff --git a/collects/typed-scheme/optimizer/tool/report-structs.rkt b/collects/typed-scheme/optimizer/tool/report-structs.rkt new file mode 100644 index 0000000000..09216f94c9 --- /dev/null +++ b/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)) diff --git a/collects/typed-scheme/optimizer/tool/report.rkt b/collects/typed-scheme/optimizer/tool/report.rkt index 706664c55d..0615506fea 100644 --- a/collects/typed-scheme/optimizer/tool/report.rkt +++ b/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)))) diff --git a/collects/typed-scheme/optimizer/tool/tool.rkt b/collects/typed-scheme/optimizer/tool/tool.rkt index 2647346faf..bab56adbeb 100644 --- a/collects/typed-scheme/optimizer/tool/tool.rkt +++ b/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"