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

Have nicer information to present in pop-ups.

Browse Source
This commit is contained in:
Vincent St-Amour 2011-06-24 18:20:15 -04:00
parent 28f51f7376
commit a134e4ffb7
2 changed files with 15 additions and 23 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

8
collects/typed-scheme/optimizer/logging.rkt
View File

@ -16,7 +16,7 @@
(format "~a:~a" line col)
"(no location)")))
(struct log-entry (msg stx pos) #:prefab)
(struct log-entry (msg raw-msg stx pos) #:prefab)
;; to identify log messages that come from the optimizer
;; to be stored in the data section of log messages
@ -45,7 +45,7 @@
#:from [from "TR opt"]
#:show-badness? [show-badness? #f])
(let* ([new-message (gen-log-message msg stx from show-badness?)]
[new-entry (log-entry new-message stx (syntax-position stx))])
[new-entry (log-entry new-message msg stx (syntax-position stx))])
(set! log-so-far (cons new-entry log-so-far))))
;; once the optimizer is done, we sort the log according to source
@ -66,8 +66,8 @@
(cons optimization-log-key x)))
(sort (remove-duplicates log-so-far)
(match-lambda*
[(list (log-entry msg-x stx-x pos-x)
(log-entry msg-y stx-y pos-y))
[(list (log-entry msg-x raw-x stx-x pos-x)
(log-entry msg-y raw-y stx-y pos-y))
(cond [(not (or pos-x pos-y))
;; neither have location, sort by message
(string<? msg-x msg-y)]

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

@ -46,25 +46,17 @@
;; highlight
(define new-highlights
(for/list ([l (in-list log)])
(let* ([stx (log-entry-stx l)]
[pos (sub1 (log-entry-pos l))]
[end (+ pos (syntax-span stx))]
[msg (log-entry-msg l)]
;; opt or missed opt?
[opt? (regexp-match #rx"^TR opt:" msg)]
[color (if opt? "lightgreen" "pink")])
(send defs highlight-range pos end color)
(send defs set-clickback pos end
(lambda (ed start end)
(message-box "Performance Report" msg)))
(list pos end color)))) ; record the highlight, to undo it later
(set! highlights (append new-highlights highlights))
(message-box
"Performance Report"
(with-output-to-string
(lambda ()
(for ([l (in-list log)])
(displayln (log-entry-msg l)))))))
(match l
[(log-entry msg raw-msg stx (app sub1 pos))
(let* ([end (+ pos (syntax-span stx))]
[opt? (regexp-match #rx"^TR opt:" msg)] ;; opt or missed opt?
[color (if opt? "lightgreen" "pink")])
(send defs highlight-range pos end color)
(send defs set-clickback pos end
(lambda (ed start end)
(message-box "Performance Report" raw-msg)))
(list pos end color))]))) ; record the highlight, to undo it later
(set! highlights (append new-highlights highlights)))
(define remove-highlights-mixin
(mixin ((class->interface text%)) ()