diff --git a/collects/typed-racket/optimizer/tool/tool.rkt b/collects/typed-racket/optimizer/tool/tool.rkt index ffb6c9b0e5..c1e86550b5 100644 --- a/collects/typed-racket/optimizer/tool/tool.rkt +++ b/collects/typed-racket/optimizer/tool/tool.rkt @@ -2,7 +2,7 @@ (require racket/class racket/port racket/list racket/match unstable/sequence racket/gui/base racket/unit drracket/tool mrlib/switchable-button - images/compile-time + images/compile-time framework (for-syntax racket/base images/icons/misc images/icons/style)) (require "report.rkt" "display.rkt") @@ -33,77 +33,6 @@ ,(match-lambda [(sub-report-entry s m 'mzc) #t] [_ #f])))) -(define highlights-mixin - (mixin ((class->interface text%)) () - (inherit begin-edit-sequence - end-edit-sequence - insert - get-text) - - (define highlights '()) - (define color-table #f) - - ;; filters : Listof (sub-report-entry -> Bool) - ;; If any of these predicates return true for a given log entry's - ;; sub, show it. - ;; Note: at the point where these are called, report entries have - ;; a single sub. - (define filters (map cdr check-boxes)) ; all enabled by default - (define/public (get-filters) filters) - (define/public (set-filters! new-fs) (set! filters new-fs)) - - (define/private (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 #f 'high) - (send this set-clickback start end (popup-callback l)) - ;; record highlight to undo it later - (list start end color))])) - - (define report-cache #f) - (define/public (add-highlights #:use-cache? [use-cache? #f]) - (clear-highlights) - (send (send this get-tab) show-performance-report-panel) - (unless (and report-cache use-cache?) - (set! report-cache (generate-report this))) - (define report - (collapse-report - (for/list ([entry (in-list report-cache)] - ;; At this point, report enties have a single sub. - #:when (for/or ([f (in-list filters)]) - (f (first (report-entry-subs entry))))) - entry))) - (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 - (let loop ([report report]) - (cond - [(null? report) highlights] - [else (cons (highlight-entry (car report)) - (loop (cdr report)))]))) - (set! highlights new-highlights)) - - (define/public (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 '()) - (send (send this get-tab) hide-performance-report-panel)) - - (define/augment (on-insert start len) - (clear-highlights)) - (define/augment (on-delete start len) - (clear-highlights)) - - (super-new))) - (define-unit tool@ @@ -113,20 +42,87 @@ (define (phase1) (void)) (define (phase2) (void)) + (define highlights-mixin + (mixin (text:basic<%> drracket:unit:definitions-text<%>) () + (inherit highlight-range unhighlight-range + set-clickback remove-clickback + get-tab) + + (define highlights '()) + (define color-table #f) + + ;; filters : Listof (sub-report-entry -> Bool) + ;; If any of these predicates return true for a given log entry's + ;; sub, show it. + ;; Note: at the point where these are called, report entries have + ;; a single sub. + (init-field [filters (map cdr check-boxes)]) ; all enabled by default + + (define/private (highlight-entry l) + (match l + [(report-entry subs start end badness) + (let ([color (if (= badness 0) + "lightgreen" + (vector-ref color-table badness))]) + (highlight-range start end color #f 'high) + (set-clickback start end (popup-callback l)) + ;; record highlight to undo it later + (list start end color))])) + + (define report-cache #f) + (define/public (add-highlights #:use-cache? [use-cache? #f]) + (clear-highlights) + (send (get-tab) show-performance-report-panel) + (unless (and report-cache use-cache?) + (set! report-cache (generate-report this))) + (define report + (collapse-report + (for/list ([entry (in-list report-cache)] + ;; At this point, report enties have a single sub. + #:when (for/or ([f (in-list filters)]) + (f (first (report-entry-subs entry))))) + entry))) + (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 + (let loop ([report report]) + (cond + [(null? report) highlights] + [else (cons (highlight-entry (car report)) + (loop (cdr report)))]))) + (set! highlights new-highlights)) + + (define/public (clear-highlights) + (for ([h (in-list highlights)]) + (match h + [`(,start ,end . ,rest ) + (unhighlight-range . h) + (remove-clickback start end)])) + (set! highlights '()) + (send (get-tab) hide-performance-report-panel)) + + (define/augment (on-insert start len) + (clear-highlights)) + (define/augment (on-delete start len) + (clear-highlights)) + + (super-new))) + (drracket:get/extend:extend-definitions-text highlights-mixin) (define button-mixin (mixin (drracket:unit:frame<%>) () (super-new) - (inherit get-button-panel get-definitions-text) - (inherit register-toolbar-button) - (let ((btn + (inherit get-button-panel register-toolbar-button) + (let ([btn (new switchable-button% - (label "Performance Report") - (callback (lambda (btn) - (performance-report-callback this))) - (parent (get-button-panel)) - (bitmap performance-report-bitmap)))) + [label "Performance Report"] + [callback (lambda (btn) + (performance-report-callback this))] + [parent (get-button-panel)] + [bitmap performance-report-bitmap])]) (register-toolbar-button btn) (send (get-button-panel) change-children (λ (l) @@ -138,31 +134,30 @@ (mixin (drracket:unit:tab<%>) () (super-new) - (inherit get-defs) + (inherit get-defs get-frame) - (define panel #f) - (define/public (get-panel) panel) ; called when switching tabs + (init-field [panel #f]) (define/public (show-performance-report-panel) (set! panel (new horizontal-panel% [parent (send (send this get-frame) get-area-container)] [stretchable-height #f])) - (define definitions (send this get-defs)) + (define definitions (get-defs)) (new button% [label "Clear"] [parent panel] [callback (lambda _ (send definitions clear-highlights))]) - (define filters (send definitions get-filters)) + (define filters (get-field filters definitions)) (for ([(l f) (in-pairs check-boxes)]) (new check-box% [label l] [parent panel] [callback (lambda _ - (send definitions set-filters! (if (memq f filters) - (remq f filters) - (cons f filters))) + (set-field! filters definitions (if (memq f filters) + (remq f filters) + (cons f filters))) ;; redraw (send definitions add-highlights #:use-cache? #t))] [value (memq f filters)])) @@ -170,8 +165,7 @@ (define/public (hide-performance-report-panel [close #t]) (when panel - (send (send (send this get-frame) get-area-container) - delete-child panel) + (send (send (get-frame) get-area-container) delete-child panel) (when close ; if we just switch tabs, keep panel around to restore it (set! panel #f)))))) @@ -182,7 +176,7 @@ (super-new) (define/augment (on-tab-change old-tab new-tab) (send old-tab hide-performance-report-panel #f) ; don't close it - (when (send new-tab get-panel) ; if it was open before + (when (get-field panel new-tab) ; if it was open before (send new-tab show-performance-report-panel))))) (drracket:get/extend:extend-unit-frame tab-switch-mixin))