suzanne.soy/racket
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

Have PR display options on a separate toolbar.

Browse Source
This commit is contained in:
Vincent St-Amour 2012-06-28 11:03:25 -04:00
parent e659e188ea
commit b4fb55dd2e
2 changed files with 88 additions and 49 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

5
collects/typed-racket/optimizer/tool/display.rkt
View File

@ -14,14 +14,11 @@
(define tt-style-delta (new style-delta%)) (define tt-style-delta (new style-delta%))
(send tt-style-delta set-family 'modern) (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) (match-define (report-entry subs start end badness) entry)
(define win (new frame% [label "Performance Report"] (define win (new frame% [label "Performance Report"]
[width popup-width] [height popup-height])) [width popup-width] [height popup-height]))
(define pane (new text% [auto-wrap #t])) (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 (define canvas
(new editor-canvas% [parent win] [editor pane] [style '(no-hscroll)])) (new editor-canvas% [parent win] [editor pane] [style '(no-hscroll)]))
(for-each (format-sub-report-entry pane) subs) (for-each (format-sub-report-entry pane) subs)

132
collects/typed-racket/optimizer/tool/tool.rkt
View File

@ -7,8 +7,7 @@
(require "report.rkt" "display.rkt") (require "report.rkt" "display.rkt")
(provide performance-report-drracket-button (provide tool@)
tool@)
;; DrRacket tool for reporting missed optimizations in the editor. ;; DrRacket tool for reporting missed optimizations in the editor.
@ -24,7 +23,7 @@
(define interactions (send drr-frame get-interactions-text)) (define interactions (send drr-frame get-interactions-text))
(send interactions reset-console) (send interactions reset-console)
(send interactions run-in-evaluation-thread (lambda () (raise e))))]) (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 (define highlights-mixin
(mixin ((class->interface text%)) () (mixin ((class->interface text%)) ()
@ -33,6 +32,7 @@
insert insert
get-text) get-text)
(define drr-frame #f) ; set when the frame calls `add-highlights'
(define highlights '()) (define highlights '())
(define color-table #f) (define color-table #f)
@ -41,21 +41,10 @@
;; sub, show it. ;; sub, show it.
;; Note: at the point where these are called, report entries have ;; Note: at the point where these are called, report entries have
;; a single sub. ;; a single sub.
(define labels+filters (define filters '())
`(("Report missed optimizations?" . ,missed-opt-report-entry?) ;; called by the frame, where the check-boxes are
("Report optimizations?" . ,opt-report-entry?))) (define/public (set-filters new-fs)
(define filters (map cdr labels+filters)) ; all enabled by default (set! filters new-fs))
(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/private (highlight-entry l) (define/private (highlight-entry l)
(match l (match l
@ -64,13 +53,15 @@
"lightgreen" "lightgreen"
(vector-ref color-table badness))]) (vector-ref color-table badness))])
(send this highlight-range start end color #f 'high) (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 ;; record highlight to undo it later
(list start end color))])) (list start end color))]))
(define report-cache #f) (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) (clear-highlights)
(and drr-frame (send drr-frame show-performance-report-panel #t))
(unless (and report-cache use-cache?) (unless (and report-cache use-cache?)
(set! report-cache (generate-report this))) (set! report-cache (generate-report this)))
(define report (define report
@ -84,7 +75,7 @@
(apply max (cons 0 (map report-entry-badness report)))) (apply max (cons 0 (map report-entry-badness report))))
(unless (= max-badness 0) ; no missed opts, color table code would error (unless (= max-badness 0) ; no missed opts, color table code would error
(set! color-table (make-color-table max-badness))) (set! color-table (make-color-table max-badness)))
(define new-highlights (define new-highlights
(let loop ([report report]) (let loop ([report report])
(cond (cond
[(null? report) highlights] [(null? report) highlights]
@ -98,7 +89,8 @@
[`(,start ,end . ,rest ) [`(,start ,end . ,rest )
(send this unhighlight-range . h) (send this unhighlight-range . h)
(send this remove-clickback start end)])) (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) (define/augment (on-insert start len)
(clear-highlights)) (clear-highlights))
@ -107,32 +99,82 @@
(super-new))) (super-new)))
(define-unit tool@ (define-unit tool@
(import drracket:tool^) (import drracket:tool^)
(export drracket:tool-exports^) (export drracket:tool-exports^)
(define (phase1) (void)) (define (phase1) (void))
(define (phase2) (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 (drracket:get/extend:extend-definitions-text highlights-mixin)
(list
"Performance Report" (define button-mixin
performance-report-bitmap (mixin (drracket:unit:frame<%>) ()
performance-report-callback)) (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))