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

Add check-boxes to toggle the filtering.

Browse Source
This commit is contained in:
Vincent St-Amour 2011-12-14 15:37:59 -05:00
parent 31e36f4c6e
commit e87272adb9
2 changed files with 28 additions and 7 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,11 +14,14 @@
(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) ed start end) (define ((popup-callback entry check-boxes) 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)

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

@ -1,6 +1,6 @@
#lang racket/base #lang racket/base
(require racket/class racket/port racket/list racket/match (require racket/class racket/port racket/list racket/match unstable/sequence
racket/gui/base racket/unit drracket/tool mrlib/switchable-button racket/gui/base racket/unit drracket/tool mrlib/switchable-button
images/compile-time images/compile-time
(for-syntax racket/base images/icons/misc images/icons/style)) (for-syntax racket/base images/icons/misc images/icons/style))
@ -36,12 +36,26 @@
(define highlights '()) (define highlights '())
(define color-table #f) (define color-table #f)
;; Listof (report-entry -> Bool) ;; filters : Listof (report-entry -> Bool)
;; If any of these predicates return true for a given log entry's ;; If any of these predicates return true for a given log entry's
;; 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 filters (list missed-opt-report-entry? opt-report-entry?)) (define labels+filters
`(("Report missed optimizations?" . ,missed-opt-report-entry?)
("Report optimization?" . ,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/private (highlight-entry l) (define/private (highlight-entry l)
(match l (match l
@ -50,14 +64,18 @@
"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)) (send this set-clickback start end (popup-callback l check-boxes))
;; record highlight to undo it later ;; record highlight to undo it later
(list start end color))])) (list start end color))]))
(define/public (add-highlights) (define report-cache #f)
(define/public (add-highlights #:use-cache? [use-cache? #f])
(clear-highlights)
(unless (and report-cache use-cache?)
(set! report-cache (generate-report this)))
(define report (define report
(collapse-report (collapse-report
(for/list ([entry (in-list (generate-report this))] (for/list ([entry (in-list report-cache)]
;; At this point, report enties have a single sub. ;; At this point, report enties have a single sub.
#:when (for/or ([f (in-list filters)]) #:when (for/or ([f (in-list filters)])
(f (first (report-entry-subs entry))))) (f (first (report-entry-subs entry)))))