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%))
(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)

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

@ -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
@ -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,12 +99,17 @@
(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)
@ -129,10 +126,55 @@
(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-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))