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

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

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

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

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

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

@ -502,25 +502,64 @@ all of the names in the tools library, for use defining keybindings
drracket:debug:show-backtrace-window/edition-pairs drracket:debug:show-backtrace-window/edition-pairs
(-> string? (-> string?
(listof srcloc?) (listof srcloc?)
(listof (or/c #f (cons/c (λ (x) (and (weak-box? x) (listof
(let ([v (weak-box-value x)]) (or/c
(or (not v) #f
(is-a?/c v editor<%>))))) (cons/c (λ (x)
number?))) (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:unit:definitions-text<%>))
(or/c #f (is-a?/c drracket:rep:text<%>)) (or/c #f (is-a?/c drracket:rep:text<%>))
void?) void?)
(error-message dis editions-pairs defs ints) (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 @{Shows the backtrace window you get when clicking on the bug in
DrRacket's REPL. DrRacket's REPL.
The @racket[error-message] argument is the text of the error, 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 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 The @racket[editions1] and @racket[editions2] arguments indicate
that are open editing the files corresponding to the source locations 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 The @racket[defs] argument should be non-@racket[#f] if there are
possibly stacktrace frames that contain unsaved versions of the possibly stacktrace frames that contain unsaved versions of the