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

PR 9186

Browse Source 
svn: r8601
This commit is contained in:
Robby Findler 2008-02-09 14:52:01 +00:00
parent f22f94b345
commit a1b8ba51ad
2 changed files with 84 additions and 81 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -495,86 +495,89 @@ profile todo:
;; (listof srcloc?) ;; (listof srcloc?)
;; -> ;; ->
;; void ;; void
(define (show-backtrace-window error-text dis) (define (show-backtrace-window error-text dis/exn)
(reset-backtrace-window) (let ([dis (if (exn? dis/exn)
(letrec ([text (make-object (text:wide-snip-mixin text:hide-caret/selection%))] (cms->srclocs (exn-continuation-marks dis/exn))
[mf-bday-note (when (mf-bday?) dis/exn)])
(instantiate message% () (reset-backtrace-window)
(label (string-constant happy-birthday-matthias)) (letrec ([text (make-object (text:wide-snip-mixin text:hide-caret/selection%))]
(parent (send current-backtrace-window get-area-container))))] [mf-bday-note (when (mf-bday?)
[ec (make-object (canvas:color-mixin canvas:wide-snip%) (instantiate message% ()
(send current-backtrace-window get-area-container) (label (string-constant happy-birthday-matthias))
text)] (parent (send current-backtrace-window get-area-container))))]
[di-vec (list->vector dis)] [ec (make-object (canvas:color-mixin canvas:wide-snip%)
[index 0] (send current-backtrace-window get-area-container)
[how-many-at-once 15] text)]
[show-next-dis [di-vec (list->vector dis)]
(λ () [index 0]
(let ([start-pos (send text get-start-position)] [how-many-at-once 15]
[end-pos (send text get-end-position)]) [show-next-dis
(send text begin-edit-sequence) (λ ()
(send text set-position (send text last-position)) (let ([start-pos (send text get-start-position)]
(let loop ([n index]) [end-pos (send text get-end-position)])
(cond (send text begin-edit-sequence)
[(and (< n (vector-length di-vec)) (send text set-position (send text last-position))
(< n (+ index how-many-at-once))) (let loop ([n index])
(show-frame ec text (vector-ref di-vec n)) (cond
(loop (+ n 1))] [(and (< n (vector-length di-vec))
[else (< n (+ index how-many-at-once)))
(set! index n)])) (show-frame ec text (vector-ref di-vec n))
(loop (+ n 1))]
[else
(set! index n)]))
;; add 'more frames' link ;; add 'more frames' link
(when (< index (vector-length di-vec)) (when (< index (vector-length di-vec))
(let ([end-of-current (send text last-position)]) (let ([end-of-current (send text last-position)])
(send text insert #\newline) (send text insert #\newline)
(let ([hyper-start (send text last-position)]) (let ([hyper-start (send text last-position)])
(send text insert (send text insert
(let* ([num-left (let* ([num-left
(- (vector-length di-vec) (- (vector-length di-vec)
index)] index)]
[num-to-show [num-to-show
(min how-many-at-once (min how-many-at-once
num-left)]) num-left)])
(if (= num-left 1) (if (= num-left 1)
(string-constant last-stack-frame) (string-constant last-stack-frame)
(format (if (num-left . <= . num-to-show) (format (if (num-left . <= . num-to-show)
(string-constant last-stack-frames) (string-constant last-stack-frames)
(string-constant next-stack-frames)) (string-constant next-stack-frames))
num-to-show)))) num-to-show))))
(let ([hyper-end (send text last-position)]) (let ([hyper-end (send text last-position)])
(send text change-style (gui-utils:get-clickback-delta (send text change-style (gui-utils:get-clickback-delta
(preferences:get 'framework:white-on-black?)) (preferences:get 'framework:white-on-black?))
hyper-start hyper-end) hyper-start hyper-end)
(send text set-clickback (send text set-clickback
hyper-start hyper-end hyper-start hyper-end
(λ x (λ x
(send text begin-edit-sequence) (send text begin-edit-sequence)
(send text lock #f) (send text lock #f)
(send text delete end-of-current (send text last-position)) (send text delete end-of-current (send text last-position))
(show-next-dis) (show-next-dis)
(send text set-position (send text set-position
(send text last-position) (send text last-position)
(send text last-position)) (send text last-position))
(send text lock #t) (send text lock #t)
(send text end-edit-sequence))) (send text end-edit-sequence)))
(send text insert #\newline) (send text insert #\newline)
(send text set-paragraph-alignment (send text last-paragraph) 'center))))) (send text set-paragraph-alignment (send text last-paragraph) 'center)))))
(send text set-position start-pos end-pos) (send text set-position start-pos end-pos)
(send text end-edit-sequence)))]) (send text end-edit-sequence)))])
(send current-backtrace-window set-alignment 'center 'center) (send current-backtrace-window set-alignment 'center 'center)
(send current-backtrace-window reflow-container) (send current-backtrace-window reflow-container)
(send text auto-wrap #t) (send text auto-wrap #t)
(send text set-autowrap-bitmap #f) (send text set-autowrap-bitmap #f)
(send text insert error-text) (send text insert error-text)
(send text insert "\n\n") (send text insert "\n\n")
(send text change-style error-delta 0 (- (send text last-position) 1)) (send text change-style error-delta 0 (- (send text last-position) 1))
(show-next-dis) (show-next-dis)
(send text set-position 0 0) (send text set-position 0 0)
(send text lock #t) (send text lock #t)
(send text hide-caret #t) (send text hide-caret #t)
(send current-backtrace-window show #t))) (send current-backtrace-window show #t))))
;; show-frame : (instanceof editor-canvas%) ;; show-frame : (instanceof editor-canvas%)
;; (instanceof text%) ;; (instanceof text%)

2
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 srcloc?) (or/c exn? (listof srcloc?))
. -> . . -> .
void?) void?)
(error-message dis) (error-message dis)