diff --git a/collects/drscheme/private/debug.ss b/collects/drscheme/private/debug.ss index b4a8e8f547..311f793299 100644 --- a/collects/drscheme/private/debug.ss +++ b/collects/drscheme/private/debug.ss @@ -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* 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 diff --git a/collects/drscheme/private/rep.ss b/collects/drscheme/private/rep.ss index 22e16a3409..031ab469b7 100644 --- a/collects/drscheme/private/rep.ss +++ b/collects/drscheme/private/rep.ss @@ -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))) diff --git a/collects/drscheme/private/tool-contracts.ss b/collects/drscheme/private/tool-contracts.ss index 4a85ea3c3c..f6d50393a7 100644 --- a/collects/drscheme/private/tool-contracts.ss +++ b/collects/drscheme/private/tool-contracts.ss @@ -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.") ; ; diff --git a/collects/drscheme/private/unit.ss b/collects/drscheme/private/unit.ss index 93bb4776c3..83b821842b 100644 --- a/collects/drscheme/private/unit.ss +++ b/collects/drscheme/private/unit.ss @@ -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) diff --git a/doc/release-notes/drscheme/HISTORY b/doc/release-notes/drscheme/HISTORY index 9944f56cd3..1028c0e348 100644 --- a/doc/release-notes/drscheme/HISTORY +++ b/doc/release-notes/drscheme/HISTORY @@ -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 ------------------------------