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

Use various shades of pink/red for highlights depending on the badness.

Browse Source
This commit is contained in:
Vincent St-Amour 2011-06-29 10:45:07 -04:00
parent 47af9d51bc
commit d33c13e0f6
1 changed files with 71 additions and 37 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

72
collects/typed-scheme/optimizer/tool/tool.rkt
View File

@ -21,6 +21,28 @@
(define (performance-report-callback drr-frame)
(send (send drr-frame get-definitions-text) add-highlights))
(define lowest-badness-color (make-object color% "pink"))
(define highest-badness-color (make-object color% "red"))
;; the higher the badness, the closer to red the highlight should be
(define (make-color-table max-badness)
(define min-g (send highest-badness-color green))
(define max-g (send lowest-badness-color green))
(define min-b (send highest-badness-color blue))
(define max-b (send lowest-badness-color blue))
(define delta-g (- max-g min-g))
(define delta-b (- max-b min-b))
(define bucket-size-g (quotient delta-g max-badness))
(define bucket-size-b (quotient delta-b max-badness))
(build-vector (add1 max-badness) ; to index directly using badness
(lambda (x)
(make-object
color%
255
;; clipping, since the first (unused, for
;; badness of 0) would have invalid components
(min 255 (- max-g (* (sub1 x) bucket-size-g)))
(min 255 (- max-b (* (sub1 x) bucket-size-b)))))))
(define remove-highlights-mixin
(mixin ((class->interface text%)) ()
(inherit begin-edit-sequence
@ -29,21 +51,8 @@
get-text)
(define highlights '())
(define color-table #f)
(define/public (add-highlights)
(define portname (send this get-port-name))
(define input (open-input-text-editor this))
(port-count-lines! input)
(define log '())
(with-intercepted-tr-logging
(lambda (l)
(set! log (cons (cdr (vector-ref l 2)) ; log-entry struct
log)))
(lambda ()
(parameterize ([current-namespace (make-base-namespace)]
[read-accept-reader #t])
(expand (tr:read-syntax portname input)))))
(set! log (reverse log))
(define (highlight-irritant i)
(define pos (syntax-position i))
(and pos
@ -57,15 +66,17 @@
start end color caret-space 'high style)
;; info needed to remove the highlight
(list start end color caret-space style))))
;; highlight
(define new-highlights
(for/list ([l (in-list log)])
(define (highlight-entry l)
(match l
[(log-entry kind msg stx (? number? pos))
(let* ([start (sub1 pos)]
[end (+ start (syntax-span stx))]
[opt? (opt-log-entry? l)] ;; opt or missed opt?
[color (if opt? "lightgreen" "pink")])
[color (if opt?
"lightgreen"
(vector-ref color-table
(missed-opt-log-entry-badness l)))])
(send this highlight-range start end color)
(send this set-clickback start end
(lambda (ed start end)
@ -78,7 +89,30 @@
(filter values ; remove irritants w/o location
(map highlight-irritant
(missed-opt-log-entry-irritants l))))))]
[_ '()]))) ; no source location, don't highlight anything
[_ '()])) ; no source location, don't highlight anything
(define/public (add-highlights)
(define portname (send this get-port-name))
(define input (open-input-text-editor this))
(port-count-lines! input)
(define log '())
;; generate the log
(with-intercepted-tr-logging
(lambda (l)
(set! log (cons (cdr (vector-ref l 2)) ; log-entry struct
log)))
(lambda ()
(parameterize ([current-namespace (make-base-namespace)]
[read-accept-reader #t])
(expand (tr:read-syntax portname input)))))
(define max-badness
(for/fold ([max-badness 0])
([l (in-list log)]
#:when (missed-opt-log-entry? l))
(max max-badness (missed-opt-log-entry-badness l))))
(unless (= max-badness 0) ; no missed opts, color table code would error
(set! color-table (make-color-table max-badness)))
(define new-highlights (map highlight-entry log))
(set! highlights (append (apply append new-highlights) highlights)))
(define (clear-highlights)