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

fixed error reporting and brought back the red arrows for the stack trace

Browse Source 
svn: r8172
This commit is contained in:
Robby Findler 2008-01-01 01:55:04 +00:00
parent 63e8522426
commit 16ed718c71
5 changed files with 63 additions and 57 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

53
collects/drscheme/private/debug.ss
View File

@ -64,6 +64,16 @@ profile todo:
(define (get-cm-key) cm-key)
;; cms->srclocs : continuation-marks -> (listof srcloc)
(define (cms->srclocs cms)
(map
(λ (x) (make-srcloc (list-ref x 0)
(list-ref x 1)
(list-ref x 2)
(list-ref x 3)
(list-ref x 4)))
(continuation-mark-set->list cms cm-key)))
;; error-delta : (instanceof style-delta%)
(define error-delta (make-object style-delta% 'change-style 'italic))
(send error-delta set-delta-foreground (make-object color% 255 0 0))
@ -271,9 +281,7 @@ profile todo:
(let ([cms
(and (exn? exn)
(continuation-mark-set? (exn-continuation-marks exn))
(continuation-mark-set->list
(exn-continuation-marks exn)
cm-key))])
(cms->srclocs (exn-continuation-marks exn)))])
(when (and cms
(pair? cms))
(print-bug-to-stderr msg cms))
@ -290,16 +298,7 @@ profile todo:
;; don't get erased if this output were to happen after the insertion
(flush-output (current-error-port))
(highlight-errors srcs-to-display
(and cms
(filter
(λ (x)
(and (pair? x)
(is-a? (car x) text:basic<%>)
(pair? (cdr x))
(number? (cadr x))
(number? (cddr x))))
cms))))))
(highlight-errors srcs-to-display cms))))
;; display-srcloc-in-error : src-loc -> void
;; prints out the src location information for src-to-display
@ -334,7 +333,7 @@ profile todo:
(fprintf (current-error-port) "::~a" pos)]))
(display ": " (current-error-port)))))
;; find-src-to-display : exn (union #f (listof (list* <src> number number)))
;; find-src-to-display : exn (union #f (listof srcloc))
;; -> (listof srclocs)
;; finds the source location to display, choosing between
;; the stack trace and the exception record.
@ -351,13 +350,7 @@ profile todo:
[(and (exn:srclocs? exn)
(ormap has-info? ((exn:srclocs-accessor exn) exn)))
((exn:srclocs-accessor exn) exn)]
[(pair? cms)
(let ([fst (car cms)])
(list (make-srcloc (car fst)
#f
#f
(cadr fst)
(cddr fst))))]
[(pair? cms) (list (car cms))]
[else '()])))
@ -431,10 +424,12 @@ profile todo:
(syntax-source src-stx)]
[else #f])]
[position (or (syntax-position src-stx) 0)]
[span (or (syntax-span src-stx) 0)])
[span (or (syntax-span src-stx) 0)]
[line (or (syntax-line src-stx) 0)]
[column (or (syntax-column src-stx) 0)])
(if source
(with-syntax ([expr expr]
[mark (list* source position span)]
[mark (list source line column position span)]
[cm-key cm-key])
(syntax
(with-continuation-mark 'cm-key
@ -489,7 +484,7 @@ profile todo:
(super-new)))
;; show-backtrace-window : string
;; (listof mark?)
;; (listof srcloc?)
;; ->
;; void
(define (show-backtrace-window error-text dis)
@ -580,14 +575,16 @@ profile todo:
;; void
;; shows one frame of the continuation
(define (show-frame editor-canvas text di)
(let* ([debug-source (car di)]
[start (cadr di)]
[span (cddr di)]
(let* ([debug-source (srcloc-source di)]
[line (srcloc-line di)]
[column (srcloc-column di)]
[start (srcloc-position di)]
[span (srcloc-span di)]
[fn (get-filename debug-source)]
[start-pos (send text last-position)])
;; make hyper link to the file
(send text insert (format "~a: ~a-~a" fn start (+ start span)))
(send text insert (format "~a: ~a:~a" fn line column))
(let ([end-pos (send text last-position)])
(send text insert " ")
(send text change-style

50
collects/drscheme/private/rep.ss
View File

@ -33,6 +33,8 @@ TODO
(lib "default-lexer.ss" "syntax-color"))
(provide rep@)
(define-struct unsaved-editor (editor))
(define-syntax stacktrace-name (string->uninterned-symbol "this-is-the-funny-name"))
@ -234,9 +236,7 @@ TODO
(parameterize ([current-eventspace drscheme:init:system-eventspace])
(queue-callback
(λ ()
(send rep highlight-errors
src-locs
(filter (λ (x) (is-a? (car x) text%)) stack)))))))))
(send rep highlight-errors src-locs stack))))))))
(define (main-user-eventspace-thread?)
(let ([rep (current-rep)])
@ -725,8 +725,6 @@ TODO
;; error-ranges : (union false? (cons (list file number number) (listof (list file number number))))
(define error-ranges #f)
;; error-arrows : (union #f (listof (cons editor<%> number)))
(define error-arrows #f)
(define/public (get-error-ranges) error-ranges)
(define internal-reset-callback void)
(define internal-reset-error-arrows-callback void)
@ -749,21 +747,32 @@ TODO
;; =Kernel= =handler=
;; highlight-errors : (listof srcloc)
;; (union #f (listof (list (is-a?/c text:basic<%>) number number)))
;; (union #f (listof srcloc))
;; -> (void)
(define/public (highlight-errors raw-locs error-arrows)
(let ([locs (filter (λ (loc) (and (is-a? (srcloc-source loc) text:basic<%>)
(number? (srcloc-position loc))
(number? (srcloc-span loc))))
(map (λ (srcloc)
(if (send definitions-text port-name-matches? (srcloc-source srcloc))
(make-srcloc definitions-text
(srcloc-line srcloc)
(srcloc-column srcloc)
(srcloc-position srcloc)
(srcloc-span srcloc))
srcloc))
raw-locs))])
(define/public (highlight-errors raw-locs raw-error-arrows)
(let* ([cleanup-locs
(λ (locs)
(filter (λ (loc) (and (is-a? (srcloc-source loc) text:basic<%>)
(number? (srcloc-position loc))
(number? (srcloc-span loc))))
(map (λ (srcloc)
(cond
[(send definitions-text port-name-matches? (srcloc-source srcloc))
(make-srcloc definitions-text
(srcloc-line srcloc)
(srcloc-column srcloc)
(srcloc-position srcloc)
(srcloc-span srcloc))]
[(unsaved-editor? (srcloc-source srcloc))
(make-srcloc (unsaved-editor-editor (srcloc-source srcloc))
(srcloc-line srcloc)
(srcloc-column srcloc)
(srcloc-position srcloc)
(srcloc-span srcloc))]
[else srcloc]))
locs)))]
[locs (cleanup-locs raw-locs)]
[error-arrows (and raw-error-arrows (cleanup-locs raw-error-arrows))])
(reset-highlighting)
(set! error-ranges locs)
@ -784,8 +793,7 @@ TODO
(let ([filtered-arrows
(remove-duplicate-error-arrows
(filter
(λ (arr)
(embedded-in? (car arr) definitions-text))
(λ (arr) (embedded-in? (srcloc-source arr) definitions-text))
error-arrows))])
(send definitions-text set-error-arrows filtered-arrows)))

8
collects/drscheme/private/tool-contracts.ss
View File

@ -353,7 +353,7 @@
(drscheme:debug:show-backtrace-window
(string?
(listof any/c)
(listof srcloc?)
. -> .
void?)
(error-message dis)
@ -372,10 +372,8 @@
"Returns a key used with \\scheme|contination-mark-set->list|."
"The contination mark set attached to an exception record"
"for the user's program may use this mark. If it does,"
"each mark on the continuation is the same type as"
"the input to"
"@flink drscheme:debug:open-and-highlight-in-file %"
".")
"each mark on the continuation is a list of the fields"
"of a srcloc object.")
;
;

6
collects/drscheme/private/unit.ss
View File

@ -653,8 +653,8 @@ module browser threading seems wrong.
(send dc set-pen old-pen)))))
(define/private (draw-arrow dc dx dy pt1 pt2)
(let-values ([(x1 y1) (find-poss (car pt1) (cadr pt1) (+ (cadr pt1) 1))]
[(x2 y2) (find-poss (car pt2) (cadr pt2) (+ (cadr pt2) 1))])
(let-values ([(x1 y1) (find-poss (srcloc-source pt1) (- (srcloc-position pt1) 1) (srcloc-position pt1))]
[(x2 y2) (find-poss (srcloc-source pt2) (- (srcloc-position pt2) 1) (srcloc-position pt2))])
(drscheme:arrow:draw-arrow dc x1 y1 x2 y2 dx dy)))
(inherit dc-location-to-editor-location)
@ -677,7 +677,7 @@ module browser threading seems wrong.
(set! error-arrows arrows)
(invalidate-bitmap-cache))
(field [error-arrows #f])
(define error-arrows #f)
(super-new)

3
doc/release-notes/drscheme/HISTORY
View File

@ -4,6 +4,9 @@
. renamed the get-special-menu method to get-insert-menu
. drscheme:debug:show-backtrace-window
now accepts srcloc structures.
------------------------------
Version 372
------------------------------