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

Improve the backtrace window to make it show both the errortrace and the

Browse Source 
racket-level stack traces
This commit is contained in:
Robby Findler 2011-10-18 10:54:42 -05:00
parent 1e237d56d1
commit e011633b6f
3 changed files with 114 additions and 36 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

84
collects/drracket/private/debug.rkt
View File

@ -277,24 +277,29 @@ profile todo:
#:definitions-text [defs (let ([rep (drracket:rep:current-rep)])
(and rep
(send rep get-definitions-text)))])
(let* ([stack (or pre-stack
(if (exn? exn)
(let* ([stack1 (or pre-stack '())]
[stack2 (if (exn? exn)
(map cdr (filter cdr (continuation-mark-set->context (exn-continuation-marks exn))))
'()))]
[src-locs (if (exn:srclocs? exn)
((exn:srclocs-accessor exn) exn)
(if (null? stack)
'()
(list (car stack))))]
'())]
[src-locs (cond
[(exn:srclocs? exn)
((exn:srclocs-accessor exn) exn)]
[(pair? stack1)
(list (car stack1))]
[(pair? stack2)
(list (car stack2))]
[else '()])]
[port-name-matches-cache (make-hasheq)]
[stack-editions (map (λ (x) (srcloc->edition/pair defs ints x port-name-matches-cache)) stack)]
[stack1-editions (map (λ (x) (srcloc->edition/pair defs ints x port-name-matches-cache)) stack1)]
[stack2-editions (map (λ (x) (srcloc->edition/pair defs ints x port-name-matches-cache)) stack2)]
[src-locs-edition (and (pair? src-locs)
(srcloc->edition/pair defs ints (car src-locs) port-name-matches-cache))])
(print-planet-icon-to-stderr exn)
(unless (exn:fail:user? exn)
(unless (null? stack)
(print-bug-to-stderr msg stack stack-editions defs ints))
(unless (and (null? stack1)
(null? stack2))
(print-bug-to-stderr msg stack1 stack1-editions stack2 stack2-editions defs ints))
(display-srclocs-in-error src-locs src-locs-edition))
(display msg (current-error-port))
(when (exn:fail:syntax? exn)
@ -310,7 +315,9 @@ profile todo:
(λ ()
;; need to make sure that the user's eventspace is still the same
;; and still running here?
(send ints highlight-errors src-locs stack)))))))
(send ints highlight-errors src-locs (if (null? stack1)
stack2
stack1))))))))
(define (srcloc->edition/pair defs ints srcloc [port-name-matches-cache #f])
(let ([src (srcloc-source srcloc)])
@ -397,12 +404,12 @@ profile todo:
(get-output-string sp)))
;; =User=
(define (print-bug-to-stderr msg cms editions defs ints)
(define (print-bug-to-stderr msg cms1 editions1 cms2 editions2 defs ints)
(when (port-writes-special? (current-error-port))
(let ([note% (if (mf-bday?) mf-note% bug-note%)])
(when note%
(let ([note (new note%)])
(send note set-callback (λ () (show-backtrace-window/edition-pairs msg cms editions defs ints)))
(send note set-callback (λ () (show-backtrace-window/edition-pairs/two msg cms1 editions1 cms2 editions2 defs ints)))
(write-special note (current-error-port))
(display #\space (current-error-port)))))))
@ -623,16 +630,46 @@ profile todo:
(show-backtrace-window/edition-pairs error-text dis (map (λ (x) #f) dis) defs rep)))
(define (show-backtrace-window/edition-pairs error-text dis editions defs ints)
(show-backtrace-window/edition-pairs/two error-text dis editions '() '() defs ints))
(define (show-backtrace-window/edition-pairs/two error-text dis1 editions1 dis2 editions2 defs ints)
(reset-backtrace-window)
(letrec ([text (make-object (text:wide-snip-mixin text:hide-caret/selection%))]
[mf-bday-note (when (mf-bday?)
(when (mf-bday?)
(instantiate message% ()
(label (string-constant happy-birthday-matthias))
(parent (send current-backtrace-window get-area-container))))]
[ec (make-object (canvas:color-mixin canvas:wide-snip%)
(send current-backtrace-window get-area-container)
text)]
[di-vec (list->vector dis)]
(parent (send current-backtrace-window get-area-container))))
(define tab-panel
(if (and (pair? dis1) (pair? dis2))
(new tab-panel%
[choices (list "Errortrace" "Builtin")]
[parent (send current-backtrace-window get-area-container)]
[callback
(λ (a b)
(send tab-panel change-children
(λ (l) (if (zero? (send tab-panel get-selection))
(list ec1)
(list ec2)))))])
(new panel% [parent (send current-backtrace-window get-area-container)])))
(define text1 (and (pair? dis1) (new (text:wide-snip-mixin text:hide-caret/selection%))))
(define ec1 (and (pair? dis1)
(new (canvas:color-mixin canvas:wide-snip%)
[parent tab-panel]
[editor text1])))
(define text2 (and (pair? dis2) (new (text:wide-snip-mixin text:hide-caret/selection%))))
(define ec2 (and (pair? dis2)
(new (canvas:color-mixin canvas:wide-snip%)
[parent tab-panel]
[editor text2])))
(when (pair? dis1)
(add-one-set-to-frame text1 ec1 error-text dis1 editions1 defs ints))
(when (pair? dis2)
(add-one-set-to-frame text2 ec2 error-text dis2 editions2 defs ints))
(when (and (pair? dis1) (pair? dis2))
(send tab-panel change-children (λ (l) (list ec1)))))
(define (add-one-set-to-frame text ec error-text dis editions defs ints)
(letrec ([di-vec (list->vector dis)]
[editions-vec (list->vector editions)]
[index 0]
[how-many-at-once 15]
@ -739,8 +776,9 @@ profile todo:
(send text insert (render-bindings/snip bindings))))
(send text insert #\newline)
(when (and start span)
(insert-context editor-canvas text debug-source start span defs ints)
(send text insert #\newline)))
(send text insert #\newline))))
;; insert-context : (instanceof editor-canvas%)
;; (instanceof text%)

1
collects/drracket/private/drsig.rkt
View File

@ -72,6 +72,7 @@
hide-backtrace-window
show-backtrace-window
show-backtrace-window/edition-pairs
show-backtrace-window/edition-pairs/two
open-and-highlight-in-file
small-planet-bitmap

49
collects/drracket/tool-lib.rkt
View File

@ -502,7 +502,11 @@ all of the names in the tools library, for use defining keybindings
drracket:debug:show-backtrace-window/edition-pairs
(-> string?
(listof srcloc?)
(listof (or/c #f (cons/c (λ (x) (and (weak-box? x)
(listof
(or/c
#f
(cons/c (λ (x)
(and (weak-box? x)
(let ([v (weak-box-value x)])
(or (not v)
(is-a?/c v editor<%>)))))
@ -511,16 +515,51 @@ all of the names in the tools library, for use defining keybindings
(or/c #f (is-a?/c drracket:rep:text<%>))
void?)
(error-message dis editions-pairs defs ints)
@{Same as @racket[drracket:debug:show-backtrace-window/edition-pairs/two],
where the @racket[_dis2] and @racket[_editions-pairs2] arguments
are both @racket['()]})
(proc-doc/names
drracket:debug:show-backtrace-window/edition-pairs/two
(-> string?
(listof srcloc?)
(listof
(or/c
#f
(cons/c (λ (x)
(and (weak-box? x)
(let ([v (weak-box-value x)])
(or (not v)
(is-a?/c v editor<%>)))))
number?)))
(listof srcloc?)
(listof
(or/c
#f
(cons/c (λ (x)
(and (weak-box? x)
(let ([v (weak-box-value x)])
(or (not v)
(is-a?/c v editor<%>)))))
number?)))
(or/c #f (is-a?/c drracket:unit:definitions-text<%>))
(or/c #f (is-a?/c drracket:rep:text<%>))
void?)
(error-message dis1 editions-pairs1 dis2 editions-pairs2 defs ints)
@{Shows the backtrace window you get when clicking on the bug in
DrRacket's REPL.
The @racket[error-message] argument is the text of the error,
@racket[dis] is the debug information, extracted from the
@racket[dis1] and @racket[dis2] are the stacktrace information,
extracted from the
continuation mark in the exception record, using
@racket[errortrace-key].
@racket[errortrace-key] and using
@racket[continuation-mark-set->context].
The @racket[editions] argument indicates the editions of any editors
that are open editing the files corresponding to the source locations
The @racket[editions1] and @racket[editions2] arguments indicate
the editions of any editors
that are open editing the files corresponding to the source locations.
The lists must have the same length as @racket[dis1] and @racket[dis2].
The @racket[defs] argument should be non-@racket[#f] if there are
possibly stacktrace frames that contain unsaved versions of the