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

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

@ -34,6 +34,8 @@ TODO
(provide rep@) (provide rep@)
(define-struct unsaved-editor (editor))
(define-syntax stacktrace-name (string->uninterned-symbol "this-is-the-funny-name")) (define-syntax stacktrace-name (string->uninterned-symbol "this-is-the-funny-name"))
;; this macro wraps its argument expression in some code in a non-tail manner ;; this macro wraps its argument expression in some code in a non-tail manner
@ -234,9 +236,7 @@ TODO
(parameterize ([current-eventspace drscheme:init:system-eventspace]) (parameterize ([current-eventspace drscheme:init:system-eventspace])
(queue-callback (queue-callback
(λ () (λ ()
(send rep highlight-errors (send rep highlight-errors src-locs stack))))))))
src-locs
(filter (λ (x) (is-a? (car x) text%)) stack)))))))))
(define (main-user-eventspace-thread?) (define (main-user-eventspace-thread?)
(let ([rep (current-rep)]) (let ([rep (current-rep)])
@ -725,8 +725,6 @@ TODO
;; error-ranges : (union false? (cons (list file number number) (listof (list file number number)))) ;; error-ranges : (union false? (cons (list file number number) (listof (list file number number))))
(define error-ranges #f) (define error-ranges #f)
;; error-arrows : (union #f (listof (cons editor<%> number)))
(define error-arrows #f)
(define/public (get-error-ranges) error-ranges) (define/public (get-error-ranges) error-ranges)
(define internal-reset-callback void) (define internal-reset-callback void)
(define internal-reset-error-arrows-callback void) (define internal-reset-error-arrows-callback void)
@ -749,21 +747,32 @@ TODO
;; =Kernel= =handler= ;; =Kernel= =handler=
;; highlight-errors : (listof srcloc) ;; highlight-errors : (listof srcloc)
;; (union #f (listof (list (is-a?/c text:basic<%>) number number))) ;; (union #f (listof srcloc))
;; -> (void) ;; -> (void)
(define/public (highlight-errors raw-locs error-arrows) (define/public (highlight-errors raw-locs raw-error-arrows)
(let ([locs (filter (λ (loc) (and (is-a? (srcloc-source loc) text:basic<%>) (let* ([cleanup-locs
(λ (locs)
(filter (λ (loc) (and (is-a? (srcloc-source loc) text:basic<%>)
(number? (srcloc-position loc)) (number? (srcloc-position loc))
(number? (srcloc-span loc)))) (number? (srcloc-span loc))))
(map (λ (srcloc) (map (λ (srcloc)
(if (send definitions-text port-name-matches? (srcloc-source srcloc)) (cond
[(send definitions-text port-name-matches? (srcloc-source srcloc))
(make-srcloc definitions-text (make-srcloc definitions-text
(srcloc-line srcloc) (srcloc-line srcloc)
(srcloc-column srcloc) (srcloc-column srcloc)
(srcloc-position srcloc) (srcloc-position srcloc)
(srcloc-span srcloc)) (srcloc-span srcloc))]
srcloc)) [(unsaved-editor? (srcloc-source srcloc))
raw-locs))]) (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) (reset-highlighting)
(set! error-ranges locs) (set! error-ranges locs)
@ -784,8 +793,7 @@ TODO
(let ([filtered-arrows (let ([filtered-arrows
(remove-duplicate-error-arrows (remove-duplicate-error-arrows
(filter (filter
(λ (arr) (λ (arr) (embedded-in? (srcloc-source arr) definitions-text))
(embedded-in? (car arr) definitions-text))
error-arrows))]) error-arrows))])
(send definitions-text set-error-arrows filtered-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 (drscheme:debug:show-backtrace-window
(string? (string?
(listof any/c) (listof srcloc?)
. -> . . -> .
void?) void?)
(error-message dis) (error-message dis)
@ -372,10 +372,8 @@
"Returns a key used with \\scheme|contination-mark-set->list|." "Returns a key used with \\scheme|contination-mark-set->list|."
"The contination mark set attached to an exception record" "The contination mark set attached to an exception record"
"for the user's program may use this mark. If it does," "for the user's program may use this mark. If it does,"
"each mark on the continuation is the same type as" "each mark on the continuation is a list of the fields"
"the input to" "of a srcloc object.")
"@flink drscheme:debug:open-and-highlight-in-file %"
".")
; ;
; ;

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

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

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

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