From b4fb55dd2ea4374fccce928cdcc3a00d3444b898 Mon Sep 17 00:00:00 2001 From: Vincent St-Amour Date: Thu, 28 Jun 2012 11:03:25 -0400 Subject: [PATCH] Have PR display options on a separate toolbar. --- .../typed-racket/optimizer/tool/display.rkt | 5 +- collects/typed-racket/optimizer/tool/tool.rkt | 132 ++++++++++++------ 2 files changed, 88 insertions(+), 49 deletions(-) diff --git a/collects/typed-racket/optimizer/tool/display.rkt b/collects/typed-racket/optimizer/tool/display.rkt index 3c9625366f..10b607eec9 100644 --- a/collects/typed-racket/optimizer/tool/display.rkt +++ b/collects/typed-racket/optimizer/tool/display.rkt @@ -14,14 +14,11 @@ (define tt-style-delta (new style-delta%)) (send tt-style-delta set-family 'modern) -(define ((popup-callback entry check-boxes) ed start end) +(define ((popup-callback entry) ed start end) (match-define (report-entry subs start end badness) entry) (define win (new frame% [label "Performance Report"] [width popup-width] [height popup-height])) (define pane (new text% [auto-wrap #t])) - (for ([x (in-list check-boxes)]) - (match-define `(,l ,v ,c) x) - (new check-box% [label l] [parent win] [callback c] [value (v)])) (define canvas (new editor-canvas% [parent win] [editor pane] [style '(no-hscroll)])) (for-each (format-sub-report-entry pane) subs) diff --git a/collects/typed-racket/optimizer/tool/tool.rkt b/collects/typed-racket/optimizer/tool/tool.rkt index 19739cd44e..e1a2664ce7 100644 --- a/collects/typed-racket/optimizer/tool/tool.rkt +++ b/collects/typed-racket/optimizer/tool/tool.rkt @@ -7,8 +7,7 @@ (require "report.rkt" "display.rkt") -(provide performance-report-drracket-button - tool@) +(provide tool@) ;; DrRacket tool for reporting missed optimizations in the editor. @@ -24,7 +23,7 @@ (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))) + (send (send drr-frame get-definitions-text) add-highlights drr-frame))) (define highlights-mixin (mixin ((class->interface text%)) () @@ -33,6 +32,7 @@ insert get-text) + (define drr-frame #f) ; set when the frame calls `add-highlights' (define highlights '()) (define color-table #f) @@ -41,21 +41,10 @@ ;; sub, show it. ;; Note: at the point where these are called, report entries have ;; a single sub. - (define labels+filters - `(("Report missed optimizations?" . ,missed-opt-report-entry?) - ("Report optimizations?" . ,opt-report-entry?))) - (define filters (map cdr labels+filters)) ; all enabled by default - (define check-boxes - ;; We can't create the actual check-box% here since we don't know its - ;; parent. Instead, we package up the necessary bits. - (for/list ([(l f) (in-pairs labels+filters)]) - (list l ; label - (lambda () (memq f filters)) ; value - (lambda _ ; callback - (if (memq f filters) - (set! filters (remq f filters)) - (set! filters (cons f filters))) - (add-highlights #:use-cache? #t))))) + (define filters '()) + ;; called by the frame, where the check-boxes are + (define/public (set-filters new-fs) + (set! filters new-fs)) (define/private (highlight-entry l) (match l @@ -64,13 +53,15 @@ "lightgreen" (vector-ref color-table badness))]) (send this highlight-range start end color #f 'high) - (send this set-clickback start end (popup-callback l check-boxes)) + (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]) + (define/public (add-highlights [frame #f] #:use-cache? [use-cache? #f]) + (when frame (set! drr-frame frame)) (clear-highlights) + (and drr-frame (send drr-frame show-performance-report-panel #t)) (unless (and report-cache use-cache?) (set! report-cache (generate-report this))) (define report @@ -84,7 +75,7 @@ (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 + (define new-highlights (let loop ([report report]) (cond [(null? report) highlights] @@ -98,7 +89,8 @@ [`(,start ,end . ,rest ) (send this unhighlight-range . h) (send this remove-clickback start end)])) - (set! highlights '())) + (set! highlights '()) + (and drr-frame (send drr-frame show-performance-report-panel #f))) (define/augment (on-insert start len) (clear-highlights)) @@ -107,32 +99,82 @@ (super-new))) + (define-unit tool@ + (import drracket:tool^) (export drracket:tool-exports^) + (define (phase1) (void)) (define (phase2) (void)) - (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 - (new switchable-button% - (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) - (cons btn (remq btn l))))))) - (drracket:get/extend:extend-unit-frame button-mixin)) -(define performance-report-drracket-button - (list - "Performance Report" - performance-report-bitmap - performance-report-callback)) + (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 + (new switchable-button% + (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) + (cons btn (remq btn l))))))) + + (drracket:get/extend:extend-unit-frame button-mixin) + + (define toolbar-mixin + (mixin (drracket:unit:frame<%>) () + (super-new) + + (inherit get-definitions-text) + + (define definitions (send this get-definitions-text)) + + ;; filters : Listof (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 check-boxes + `(("Report missed optimizations?" . ,missed-opt-report-entry?) + ("Report optimizations?" . ,opt-report-entry?))) + (define filters (map cdr check-boxes)) ; all enabled by default + (define/public (get-filters) filters) + (send definitions set-filters filters) ; push changes + + (define panel #f) + + (define (show-panel) + (define p (new horizontal-panel% + [parent (send this get-area-container)] + [stretchable-height #f])) + (set! panel p) + (for ([(l f) (in-pairs check-boxes)]) + (new check-box% + [label l] + [parent panel] + [callback (lambda _ + (if (memq f filters) + (set! filters (remq f filters)) + (set! filters (cons f filters))) + ;; push changes + (send definitions set-filters filters) + ;; redraw + (send definitions add-highlights #:use-cache? #t))] + [value (memq f filters)]))) + (define (hide-panel) + (when panel + (send (send this get-area-container) delete-child panel) + (set! panel #f))) + + (define/public (show-performance-report-panel t/f) + (if t/f (show-panel) (hide-panel))))) + + (drracket:get/extend:extend-unit-frame toolbar-mixin))