From e6888828b58095c3e11d6d441b3cd6ff509b52dd Mon Sep 17 00:00:00 2001 From: Robby Findler Date: Fri, 26 Apr 2013 10:21:34 -0500 Subject: [PATCH] adjust online compilation so that the stack trace attached to an exception is available by clicking the "Copy" menu item in the bottom bar --- collects/drracket/private/expanding-place.rkt | 31 +++++++- collects/drracket/private/module-language.rkt | 73 +++++++++++++------ .../drracket/private/syncheck/online-comp.rkt | 1 + 3 files changed, 80 insertions(+), 25 deletions(-) diff --git a/collects/drracket/private/expanding-place.rkt b/collects/drracket/private/expanding-place.rkt index 6683ac559f..f72833d59a 100644 --- a/collects/drracket/private/expanding-place.rkt +++ b/collects/drracket/private/expanding-place.rkt @@ -1,6 +1,7 @@ #lang racket/base (require racket/place racket/port + racket/list "eval-helpers.rkt" compiler/cm syntax/readerr) @@ -258,10 +259,24 @@ (regexp-match #rx"expand: unbound identifier" (exn-message main-exn))) 'exn:variable] [else 'exn])) + + (define (format-srcloc srcloc) + (define pos + (cond + [(and (srcloc-line srcloc) + (srcloc-column srcloc)) + (format ":~a:~a" (srcloc-line srcloc) (srcloc-column srcloc))] + [(srcloc-line srcloc) + (format ":~a" (srcloc-line srcloc))] + [(srcloc-position srcloc) + (format "::~a" (srcloc-position srcloc))] + [else ""])) + (format "~a~a" (srcloc-source srcloc) pos)) + (define exn-infos (for/list ([an-exn (in-list (cons main-exn extra-exns))]) (vector - (trim-message + (trim-message (if (exn? an-exn) (regexp-replace* #rx"[ \t]*\n[ \t]*" (exn-message an-exn) " ") (format "uncaught exn: ~s" an-exn))) @@ -276,6 +291,20 @@ (srcloc-span srcloc))) < #:key (λ (x) (vector-ref x 0))) + '()) + (if (exn? an-exn) + (let ([ctxt + (continuation-mark-set->context + (exn-continuation-marks an-exn))]) + (for/list ([ctxt-elem (if (< (length ctxt) 100) + ctxt + (take ctxt 100))]) + (define name (car ctxt-elem)) + (define loc (cdr ctxt-elem)) + (cond + [(not name) (format-srcloc loc)] + [(not loc) (format "~a" name)] + [else (format "~a:~a" (format-srcloc loc) name)]))) '())))) (place-channel-put response-pc diff --git a/collects/drracket/private/module-language.rkt b/collects/drracket/private/module-language.rkt index db352c94d1..d7b4f174a3 100644 --- a/collects/drracket/private/module-language.rkt +++ b/collects/drracket/private/module-language.rkt @@ -1016,7 +1016,7 @@ [(and (dirty? running-status) our-turn?) (set-bottom-bar-status/pending)] [(and (dirty? running-status) (not our-turn?)) - (send (get-defs) set-bottom-bar-status (list (vector "" '())) #f #f)] + (send (get-defs) set-bottom-bar-status (list (vector "" '() '())) #f #f)] [(clean? running-status) (if (clean-error-messages+locs running-status) (send (get-defs) set-bottom-bar-status @@ -1024,6 +1024,7 @@ #t #t) (send (get-defs) set-bottom-bar-status (list (vector (string-constant online-expansion-finished) + '() '())) #f #f))])) @@ -1031,6 +1032,7 @@ (define/private (set-bottom-bar-status/pending) (send (get-defs) set-bottom-bar-status (list (vector (string-constant online-expansion-pending) + '() '())) #f #f)) @@ -1167,23 +1169,45 @@ (update-frame-expand-error))) (define/public (update-frame-expand-error) (when (eq? (get-tab) (send (send (get-tab) get-frame) get-current-tab)) + (define (matching-srcloc error/status-message-str+srcloc) + (for/or ([pos+span-vec (vector-ref error/status-message-str+srcloc 1)]) + (define pos (vector-ref pos+span-vec 0)) + (define span (vector-ref pos+span-vec 1)) + (and (equal? (send (get-tab) get-defs) + (srcloc-source bottom-bar-most-recent-jumped-to-loc)) + (equal? (srcloc-position bottom-bar-most-recent-jumped-to-loc) + pos) + (equal? (srcloc-span bottom-bar-most-recent-jumped-to-loc) + span)))) + (define msgs + (cond + [bottom-bar-most-recent-jumped-to-loc + (for/list ([error/status-message-str+srcloc (in-list error/status-message-strs+srclocs)] + #:when (matching-srcloc error/status-message-str+srcloc)) + (vector-ref error/status-message-str+srcloc 0))] + [else + (list (vector-ref (list-ref error/status-message-strs+srclocs error/status-index) 0))])) + (define (combine-msg vec) + (define msg (vector-ref vec 0)) + (define stack (vector-ref vec 2)) + (apply + string-append + (cons + msg + (for/list ([stack stack]) + (format "\n ~a" stack))))) + (define copy-msg + (cond + [bottom-bar-most-recent-jumped-to-loc + (for/list ([error/status-message-str+srcloc (in-list error/status-message-strs+srclocs)] + #:when (matching-srcloc error/status-message-str+srcloc)) + (combine-msg error/status-message-str+srcloc))] + [else + (combine-msg (list-ref error/status-message-strs+srclocs error/status-index))])) (send (send (get-tab) get-frame) set-expand-error/status error/status-message-hidden? - (cond - [bottom-bar-most-recent-jumped-to-loc - (for/list ([error/status-message-str+srcloc (in-list error/status-message-strs+srclocs)] - #:when (for/or ([pos+span-vec (vector-ref error/status-message-str+srcloc 1)]) - (define pos (vector-ref pos+span-vec 0)) - (define span (vector-ref pos+span-vec 1)) - (and (equal? (send (get-tab) get-defs) - (srcloc-source bottom-bar-most-recent-jumped-to-loc)) - (equal? (srcloc-position bottom-bar-most-recent-jumped-to-loc) - pos) - (equal? (srcloc-span bottom-bar-most-recent-jumped-to-loc) - span)))) - (vector-ref error/status-message-str+srcloc 0))] - [else - (list (vector-ref (list-ref error/status-message-strs+srclocs error/status-index) 0))]) + msgs + copy-msg error/status-message-err? (cond [(null? error/status-message-strs+srclocs) 0] @@ -1519,17 +1543,20 @@ root) (define expand-error-msgs #f) + (define expand-error-msgs+stack "") (define expand-error-msg-is-err? #f) (define expand-error-srcloc-count 0) (define expand-error-hidden? #f) - (define/public (set-expand-error/status hidden? msgs err? srcloc-count) + (define/public (set-expand-error/status hidden? msgs msgs+stacks err? srcloc-count) (unless (and (equal? expand-error-hidden? hidden?) (equal? expand-error-msgs msgs) + (equal? expand-error-msgs+stack msgs+stacks) (equal? expand-error-msg-is-err? err?) (equal? expand-error-srcloc-count srcloc-count)) (set! expand-error-hidden? hidden?) (set! expand-error-msgs msgs) + (set! expand-error-msgs+stack msgs+stacks) (set! expand-error-msg-is-err? err?) (set! expand-error-srcloc-count srcloc-count) (when expand-error-message @@ -1541,7 +1568,7 @@ (if (memq expand-error-panel l) l (append l (list expand-error-panel)))))) - (send expand-error-message set-msgs expand-error-msgs expand-error-msg-is-err?) + (send expand-error-message set-msgs expand-error-msgs expand-error-msg-is-err? expand-error-msgs+stack) (send expand-error-button-parent-panel change-children (λ (l) (list (cond @@ -1685,11 +1712,12 @@ (define error-message% (class canvas% - (init-field msgs err?) + (init-field msgs err? [copy-msg ""]) (inherit refresh get-dc get-client-size popup-menu) - (define/public (set-msgs _msgs _err?) + (define/public (set-msgs _msgs _err? _copy-msg) (set! msgs _msgs) (set! err? _err?) + (set! copy-msg _copy-msg) (set-the-height/dc-font (preferences:get 'framework:standard-style-list:font-size)) (refresh)) (define/override (on-event evt) @@ -1702,10 +1730,7 @@ [callback (λ (itm evt) (send the-clipboard set-clipboard-string - (apply - string-append - (for/list ([msg (in-list msgs)]) - (format "~a\n" msg))) + copy-msg (send evt get-time-stamp)))])) (popup-menu m (+ (send evt get-x) 1) diff --git a/collects/drracket/private/syncheck/online-comp.rkt b/collects/drracket/private/syncheck/online-comp.rkt index 6a01101702..48d5bb2b49 100644 --- a/collects/drracket/private/syncheck/online-comp.rkt +++ b/collects/drracket/private/syncheck/online-comp.rkt @@ -75,6 +75,7 @@ (define (go expanded path the-source orig-cust) (parameterize ([current-max-to-send-at-once 50]) (with-handlers ((exn:fail? (λ (x) + (printf "exception noticed in online-comp.rkt\n") (printf "~a\n" (exn-message x)) (printf "---\n") (for ([x (in-list