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

Handle irritants without source location properly.

Browse Source
This commit is contained in:
Vincent St-Amour 2011-06-28 14:02:27 -04:00
parent 00d23a4535
commit ff5ca8a234
1 changed files with 23 additions and 14 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -44,29 +44,38 @@
(expand (tr:read-syntax portname input))))) (expand (tr:read-syntax portname input)))))
(set! log (reverse log)) (set! log (reverse log))
(define (highlight-irritant i) (define (highlight-irritant i)
(let ([res (list (sub1 (syntax-position i)) (define pos (syntax-position i))
(sub1 (+ (syntax-position i) (syntax-span i))) (and pos
"red" #f 'high 'hollow-ellipse)]) (let ([start (sub1 pos)]
(send defs highlight-range . res) [end (sub1 (+ pos (syntax-span i)))]
res)) [color "red"]
[caret-space #f]
[style 'hollow-ellipse])
;; high priority, to display above the coloring
(send defs highlight-range start end color caret-space 'high style)
;; info needed to remove the highlight
(list start end color caret-space style))))
;; highlight ;; highlight
(define new-highlights (define new-highlights
(for/list ([l (in-list log)]) (for/list ([l (in-list log)])
(match l (match l
[(log-entry kind msg stx (app sub1 pos)) [(log-entry kind msg stx (? number? pos))
(let* ([end (+ pos (syntax-span stx))] (let* ([start (sub1 pos)]
[end (+ start (syntax-span stx))]
[opt? (opt-log-entry? l)] ;; opt or missed opt? [opt? (opt-log-entry? l)] ;; opt or missed opt?
[color (if opt? "lightgreen" "pink")]) [color (if opt? "lightgreen" "pink")])
(send defs highlight-range pos end color) (send defs highlight-range start end color)
(send defs set-clickback pos end (send defs set-clickback start end
(lambda (ed start end) (lambda (ed start end)
(message-box "Performance Report" msg))) (message-box "Performance Report" msg)))
(list (list pos end color) ; record highlights to undo them later (cons (list start end color) ; record highlights to undo them later
;; missed optimizations have irritants, circle them ;; missed optimizations have irritants, circle them
(if opt? (if opt?
'() '()
(filter values ; remove irritants w/o location
(map highlight-irritant (map highlight-irritant
(missed-opt-log-entry-irritants l)))))]))) (missed-opt-log-entry-irritants l))))))]
[_ '()]))) ; no source location, don't highlight anything
(set! highlights (append (apply append new-highlights) highlights))) (set! highlights (append (apply append new-highlights) highlights)))
(define remove-highlights-mixin (define remove-highlights-mixin
@ -78,7 +87,7 @@
(define (clear-highlights) (define (clear-highlights)
(for ([h (in-list highlights)]) (for ([h (in-list highlights)])
(match h (match h
[(list start end color) [`(,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)])))
(define/augment (after-insert start len) (define/augment (after-insert start len)