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

Remove highlights after editing.

Browse Source
This commit is contained in:
Vincent St-Amour 2011-06-23 17:00:57 -04:00
parent 14be886288
commit 2ecec626b3
2 changed files with 42 additions and 12 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
collects/typed-scheme/info.rkt
View File

@ -2,3 +2,5 @@
(define scribblings '(("scribblings/ts-reference.scrbl" (multi-page) (language 4))
("scribblings/ts-guide.scrbl" (multi-page) (language 5))))
(define drracket-tools '(("optimizer/tool/tool.rkt")))
(define drracket-tool-names '("Performance Report"))

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

@ -1,12 +1,14 @@
#lang racket/base
(require racket/unit racket/class racket/port racket/list
racket/gui/base mrlib/switchable-button)
(require racket/class racket/port racket/list
racket/gui/base mrlib/switchable-button
racket/unit drracket/tool)
(require (prefix-in tr: typed-scheme/typed-reader)
typed-scheme/optimizer/logging)
(provide performance-report-drracket-button)
(provide performance-report-drracket-button
tool@)
;; DrRacket tool for reporting missed optimizations in the editor.
@ -23,6 +25,8 @@
(send bdc set-bitmap #f)
bmp))
(define highlights '())
;; performance-report-callback : drracket:unit:frame<%> -> void
(define (performance-report-callback drr-frame)
(define defs (send drr-frame get-definitions-text)) ; : text%
@ -40,15 +44,17 @@
(expand (tr:read-syntax portname input)))))
(set! log (reverse log))
;; highlight
(for ([l (in-list log)])
(let ([stx (log-entry-stx l)]
[pos (sub1 (log-entry-pos l))]
;; opt or missed opt?
[opt? (regexp-match #rx"^TR opt:" (log-entry-msg l))])
(send defs highlight-range
pos
(+ pos (syntax-span stx))
(if opt? "lightgreen" "pink"))))
(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))]
;; opt or missed opt?
[opt? (regexp-match #rx"^TR opt:" (log-entry-msg l))]
[color (if opt? "lightgreen" "pink")])
(send defs highlight-range pos end color)
(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
@ -56,6 +62,28 @@
(for ([l (in-list log)])
(displayln (log-entry-msg l)))))))
(define remove-highlights-mixin
(mixin ((class->interface text%)) ()
(inherit begin-edit-sequence
end-edit-sequence
insert
get-text)
(define (clear-highlights)
(for ([h (in-list highlights)])
(send this unhighlight-range . h)))
(define/augment (after-insert start len)
(clear-highlights))
(define/augment (after-delete start len)
(clear-highlights))
(super-new)))
(define-unit tool@
(import drracket:tool^)
(export drracket:tool-exports^)
(define (phase1) (void))
(define (phase2) (void))
(drracket:get/extend:extend-definitions-text remove-highlights-mixin))
(define performance-report-drracket-button
(list
"Performance Report"