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

Abstract out popup management.

Browse Source
This commit is contained in:
Vincent St-Amour 2011-07-12 16:33:45 -04:00
parent 46b984a94b
commit e59a84dc96
2 changed files with 17 additions and 16 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

17
collects/typed-scheme/optimizer/tool/display.rkt
View File

@ -3,7 +3,7 @@
(require racket/string racket/class racket/gui/base (require racket/string racket/class racket/gui/base
unstable/sequence unstable/pretty) unstable/sequence unstable/pretty)
(provide format-message make-color-table) (provide popup-callback make-color-table)
(define (format-message stxs+msgs) (define (format-message stxs+msgs)
(string-join (for/list ([(stx msg) (in-pairs stxs+msgs)]) (string-join (for/list ([(stx msg) (in-pairs stxs+msgs)])
@ -14,6 +14,21 @@
msg)) msg))
"\n\n")) "\n\n"))
(define ((popup-callback stxs+msgs) ed start end)
(define text (new text%))
(define win (new dialog%
[label "Performance Report"]
[width 500]
[height 300]))
(define editor-canvas
(new editor-canvas% [parent win] [editor text]
[style '(no-hscroll)]))
(send text auto-wrap #t)
(send text insert-port (open-input-string
(format-message stxs+msgs)))
(send text lock #t)
(send win show #t))
(define lowest-badness-color (make-object color% "pink")) (define lowest-badness-color (make-object color% "pink"))
(define highest-badness-color (make-object color% "red")) (define highest-badness-color (make-object color% "red"))
;; the higher the badness, the closer to red the highlight should be ;; the higher the badness, the closer to red the highlight should be

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

@ -52,21 +52,7 @@
(vector-ref color-table (vector-ref color-table
(missed-opt-report-entry-badness l)))]) (missed-opt-report-entry-badness l)))])
(send this highlight-range start end color) (send this highlight-range start end color)
(send this set-clickback start end (send this set-clickback start end (popup-callback stxs+msgs))
(lambda (ed start end)
(define text (new text%))
(define win (new dialog%
[label "Performance Report"]
[width 500]
[height 300]))
(define editor-canvas
(new editor-canvas% [parent win] [editor text]
[style '(no-hscroll)]))
(send text auto-wrap #t)
(send text insert-port (open-input-string
(format-message stxs+msgs)))
(send text lock #t)
(send win show #t)))
;; record highlights to undo them later ;; record highlights to undo them later
(cons (list start end color) (cons (list start end color)
;; missed optimizations have irritants, circle them ;; missed optimizations have irritants, circle them