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

Separate each entry into multiple editors, for finer-grained control.

Browse Source
This commit is contained in:
Vincent St-Amour 2011-07-13 17:27:02 -04:00
parent ac3b487a9f
commit d7cb6fcc75
1 changed files with 32 additions and 24 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -7,15 +7,6 @@
(provide popup-callback make-color-table) (provide popup-callback make-color-table)
(define (format-message stx msg)
(let* ([location (format "~a:~a: " (syntax-line stx) (syntax-column stx))]
[message (format "~a~a\n\n~a" location (syntax->datum stx) msg)]
[start (string-length location)]
[len (string-length (format "~a" (syntax->datum stx)))])
;; return the message, the starting location of the syntax object and
;; its end location
(values message start (+ start len))))
(define popup-width 500) (define popup-width 500)
(define popup-height 300) (define popup-height 300)
@ -37,31 +28,48 @@
;; editor, to simplify irritant highlighting ;; editor, to simplify irritant highlighting
(define ((format-sub-report-entry pane) s) (define ((format-sub-report-entry pane) s)
(match-define (sub-report-entry stx msg) s) (match-define (sub-report-entry stx msg) s)
(define-values (message stx-start stx-end) (format-message stx msg))
(define text (new text:basic% [auto-wrap #t])) ;; the location, the syntax and the message are in separate editors
;; display the message, which includes source location and syntax (define location-text (new text:basic% [auto-wrap #t]))
(send text insert-port (open-input-string message)) (define location (format "~a:~a:" (syntax-line stx) (syntax-column stx)))
(send location-text insert-port (open-input-string location))
(send location-text lock #t)
;; add to the main editor
(send pane insert
(new editor-snip% [editor location-text] [with-border? #f]))
(define syntax-text (new text:basic%)) ; will have a scrollbar
;; typeset the syntax as code ;; typeset the syntax as code
(send text change-style tt-style-delta stx-start stx-end) (send syntax-text change-style tt-style-delta)
(send syntax-text insert-port
(open-input-string (format "~a" (syntax->datum stx))))
;; circle irritants, if necessary ;; circle irritants, if necessary
(when (missed-opt-report-entry? s) (when (missed-opt-report-entry? s)
(for ([i (in-list (missed-opt-report-entry-irritants s))] (for ([i (in-list (missed-opt-report-entry-irritants s))]
#:when (syntax-position i)) #:when (syntax-position i))
(define start-index (- (syntax-position i) (syntax-position stx))) (define start (- (syntax-position i) (syntax-position stx)))
(define start (+ start-index stx-start))
(define len (syntax-span i)) (define len (syntax-span i))
;; will be off if there are comments inside an irritant (span will be ;; will be off if there are comments inside an irritant (span will be
;; higher than what's actually displayed), but unless we make the ;; higher than what's actually displayed), but unless we make the
;; located version of irritants available, this is the best we can do ;; located version of irritants available, this is the best we can do
(send text highlight-range (send syntax-text highlight-range
start (+ start len) "red" #f 'high 'hollow-ellipse))) start (+ start len) "red" #f 'high 'hollow-ellipse)))
;; adjust display (send syntax-text lock #t)
(send text set-max-width (- popup-width 20)) ; minus the scrollbar (send pane insert
(send text auto-wrap #t) (new editor-snip% [editor syntax-text] [max-width popup-width]
(send text lock #t)
;; add to the main editor
(send pane insert (new editor-snip% [editor text] [max-width popup-width]
[with-border? #f] [bottom-margin 10])) [with-border? #f] [bottom-margin 10]))
(define message-text (new text:basic% [auto-wrap #t]))
(send message-text insert-port (open-input-string msg))
;; adjust display
(send message-text set-max-width (- popup-width 20)) ; minus the scrollbar
(send message-text auto-wrap #t)
(send message-text lock #t)
(send pane insert
(new editor-snip% [editor message-text] [max-width popup-width]
[with-border? #f] [top-margin 10] [bottom-margin 15]))
;; to place the next sub-entry below
(send pane insert-port (open-input-string "\n"))) (send pane insert-port (open-input-string "\n")))
(define lowest-badness-color (make-object color% "pink")) (define lowest-badness-color (make-object color% "pink"))