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

PRS 10379 and 10377

Browse Source 
svn: r15795
This commit is contained in:
Robby Findler 2009-08-25 04:51:05 +00:00
parent d162f8b316
commit fcfa572e02
7 changed files with 257 additions and 127 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -14,9 +14,9 @@ profile todo:
errortrace/stacktrace errortrace/stacktrace
scheme/class scheme/class
scheme/path scheme/path
framework
scheme/gui/base scheme/gui/base
string-constants string-constants
framework
framework/private/bday framework/private/bday
"embedded-snip-utils.ss" "embedded-snip-utils.ss"
"drsig.ss" "drsig.ss"
@ -98,14 +98,20 @@ profile todo:
(define/public (set-callback cb) (set! callback cb)) (define/public (set-callback cb) (set! callback cb))
(define/public (get-callback) callback) (define/public (get-callback) callback)
(define in-bounds? #f)
(define grabbed? #f) (define grabbed? #f)
(define clicked? #f)
(define mouse-x #f) (define (set-clicked new-grabbed? new-in-bounds? dc)
(define mouse-y #f) (let ([needs-invalidate? (not (eq? (and grabbed? in-bounds?)
(and new-grabbed? new-in-bounds?)))])
(set! grabbed? new-grabbed?)
(set! in-bounds? new-in-bounds?)
(when needs-invalidate?
(invalidate dc))))
(define/override (draw dc x y left top right bottom dx dy draw-caret) (define/override (draw dc x y left top right bottom dx dy draw-caret)
(super draw dc x y left top right bottom dx dy draw-caret) (super draw dc x y left top right bottom dx dy draw-caret)
(when clicked? (when (and in-bounds? grabbed?)
(let ([brush (send dc get-brush)] (let ([brush (send dc get-brush)]
[pen (send dc get-pen)]) [pen (send dc get-pen)])
(let-values ([(w h) (get-w/h dc)]) (let-values ([(w h) (get-w/h dc)])
@ -116,23 +122,21 @@ profile todo:
(send dc set-brush brush))))) (send dc set-brush brush)))))
(define/override (on-event dc x y editorx editory evt) (define/override (on-event dc x y editorx editory evt)
(cond (let-values ([(w h) (get-w/h dc)])
[(send evt button-down? 'left) (let ([in-bounds? (and (<= (- (send evt get-x) x) w)
(set! grabbed? #t) (<= (- (send evt get-y) y) h))])
(set! clicked? #t) (cond
(set! mouse-x x) [(send evt button-down? 'left)
(invalidate dc)] (set-clicked #t in-bounds? dc)]
[(send evt leaving?) [(send evt button-up? 'left)
(set! clicked? #f) (let ([admin (send this get-admin)])
(set! mouse-x #f) (when admin
(set! mouse-y #f) (send (send admin get-editor) set-caret-owner #f 'global)))
(invalidate dc)] (when (and grabbed? in-bounds?)
[(send evt button-up? 'left) (callback))
(when clicked? (set-clicked #f in-bounds? dc)]
(callback)) [else
(set! grabbed? #f) (set-clicked grabbed? in-bounds? dc)]))))
(set! clicked? #f)
(invalidate dc)]))
(define/private (invalidate dc) (define/private (invalidate dc)
(let ([admin (get-admin)]) (let ([admin (get-admin)])
@ -280,11 +284,14 @@ profile todo:
(list (car stack))))] (list (car stack))))]
[rep (let ([rep (drscheme:rep:current-rep)]) [rep (let ([rep (drscheme:rep:current-rep)])
(and (is-a? rep drscheme:rep:text<%>) (and (is-a? rep drscheme:rep:text<%>)
rep))]) rep))]
[stack-editions (map (λ (x) (srcloc->edition/pair rep x)) stack)]
[src-locs-edition (and (pair? src-locs)
(srcloc->edition/pair rep (car src-locs)))])
(print-planet-icon-to-stderr exn) (print-planet-icon-to-stderr exn)
(unless (null? stack) (unless (null? stack)
(print-bug-to-stderr msg stack rep)) (print-bug-to-stderr msg stack stack-editions rep))
(display-srclocs-in-error src-locs) (display-srclocs-in-error src-locs src-locs-edition)
(display msg (current-error-port)) (display msg (current-error-port))
(when (exn:fail:syntax? exn) (when (exn:fail:syntax? exn)
(show-syntax-error-context (current-error-port) exn)) (show-syntax-error-context (current-error-port) exn))
@ -300,6 +307,26 @@ profile todo:
;; and still running here? ;; and still running here?
(send rep highlight-errors src-locs stack))))))) (send rep highlight-errors src-locs stack)))))))
(define (srcloc->edition/pair rep srcloc)
(let ([src (srcloc-source srcloc)])
(cond
[(and (or (symbol? src)
(path? src))
(send rep port-name-matches? src))
(cons (make-weak-box rep) (send rep get-edition-number))]
[(and (or (symbol? src)
(path? src))
(send (send rep get-definitions-text) port-name-matches? src))
(cons (make-weak-box (send rep get-definitions-text))
(send (send rep get-definitions-text) get-edition-number))]
[(path? src)
(let ([frame (send (group:get-the-frame-group) locate-frame src)])
(and frame
(is-a? frame drscheme:unit:frame<%>)
(cons (make-weak-box (send frame get-definitions-text))
(send (send frame get-definitions-text) get-edition-number))))]
[else #f])))
;; =User= ;; =User=
(define (print-planet-icon-to-stderr exn) (define (print-planet-icon-to-stderr exn)
(when (exn:fail:contract2? exn) (when (exn:fail:contract2? exn)
@ -358,19 +385,19 @@ profile todo:
(get-output-string sp))) (get-output-string sp)))
;; =User= ;; =User=
(define (print-bug-to-stderr msg cms rep) (define (print-bug-to-stderr msg cms editions rep)
(when (port-writes-special? (current-error-port)) (when (port-writes-special? (current-error-port))
(let ([note% (if (mf-bday?) mf-note% bug-note%)]) (let ([note% (if (mf-bday?) mf-note% bug-note%)])
(when note% (when note%
(let ([note (new note%)]) (let ([note (new note%)])
(send note set-callback (λ () (show-backtrace-window msg cms rep))) (send note set-callback (λ () (show-backtrace-window/edition-pairs msg cms editions rep)))
(write-special note (current-error-port)) (write-special note (current-error-port))
(display #\space (current-error-port))))))) (display #\space (current-error-port)))))))
;; display-srclocs-in-error : (listof src-loc) -> void ;; display-srclocs-in-error : (listof src-loc) -> void
;; prints out the src location information for src-to-display ;; prints out the src location information for src-to-display
;; as it would appear in an error message ;; as it would appear in an error message
(define (display-srclocs-in-error srcs-to-display) (define (display-srclocs-in-error srcs-to-display edition-pair)
(unless (null? srcs-to-display) (unless (null? srcs-to-display)
(let ([src-to-display (car srcs-to-display)]) (let ([src-to-display (car srcs-to-display)])
(let* ([src (srcloc-source src-to-display)] (let* ([src (srcloc-source src-to-display)]
@ -383,7 +410,7 @@ profile todo:
(when (port-writes-special? (current-error-port)) (when (port-writes-special? (current-error-port))
(let ([note (new file-note%)]) (let ([note (new file-note%)])
(send note set-callback (send note set-callback
(λ () (open-and-highlight-in-file srcs-to-display))) (λ () (open-and-highlight-in-file srcs-to-display edition-pair)))
(write-special note (current-error-port)) (write-special note (current-error-port))
(display #\space (current-error-port))))))] (display #\space (current-error-port))))))]
[do-src [do-src
@ -577,85 +604,89 @@ profile todo:
(let ([dis (if (exn? dis/exn) (let ([dis (if (exn? dis/exn)
(cms->srclocs (exn-continuation-marks dis/exn)) (cms->srclocs (exn-continuation-marks dis/exn))
dis/exn)]) dis/exn)])
(reset-backtrace-window) (show-backtrace-window/edition-pairs error-text dis (map (λ (x) #f) dis/exn) rep)))
(letrec ([text (make-object (text:wide-snip-mixin text:hide-caret/selection%))]
[mf-bday-note (when (mf-bday?)
(instantiate message% ()
(label (string-constant happy-birthday-matthias))
(parent (send current-backtrace-window get-area-container))))]
[ec (make-object (canvas:color-mixin canvas:wide-snip%)
(send current-backtrace-window get-area-container)
text)]
[di-vec (list->vector dis)]
[index 0]
[how-many-at-once 15]
[show-next-dis
(λ ()
(let ([start-pos (send text get-start-position)]
[end-pos (send text get-end-position)])
(send text begin-edit-sequence)
(send text set-position (send text last-position))
(let loop ([n index])
(cond
[(and (< n (vector-length di-vec))
(< n (+ index how-many-at-once)))
(show-frame ec text (vector-ref di-vec n) rep)
(loop (+ n 1))]
[else
(set! index n)]))
;; add 'more frames' link (define (show-backtrace-window/edition-pairs error-text dis editions rep)
(when (< index (vector-length di-vec)) (reset-backtrace-window)
(let ([end-of-current (send text last-position)]) (letrec ([text (make-object (text:wide-snip-mixin text:hide-caret/selection%))]
(send text insert #\newline) [mf-bday-note (when (mf-bday?)
(let ([hyper-start (send text last-position)]) (instantiate message% ()
(send text insert (label (string-constant happy-birthday-matthias))
(let* ([num-left (parent (send current-backtrace-window get-area-container))))]
(- (vector-length di-vec) [ec (make-object (canvas:color-mixin canvas:wide-snip%)
index)] (send current-backtrace-window get-area-container)
[num-to-show text)]
(min how-many-at-once [di-vec (list->vector dis)]
num-left)]) [editions-vec (list->vector editions)]
(if (= num-left 1) [index 0]
(string-constant last-stack-frame) [how-many-at-once 15]
(format (if (num-left . <= . num-to-show) [show-next-dis
(string-constant last-stack-frames) (λ ()
(string-constant next-stack-frames)) (let ([start-pos (send text get-start-position)]
num-to-show)))) [end-pos (send text get-end-position)])
(let ([hyper-end (send text last-position)]) (send text begin-edit-sequence)
(send text change-style (gui-utils:get-clickback-delta (send text set-position (send text last-position))
(preferences:get 'framework:white-on-black?)) (let loop ([n index])
hyper-start hyper-end) (cond
(send text set-clickback [(and (< n (vector-length di-vec))
hyper-start hyper-end (< n (+ index how-many-at-once)))
(λ x (show-frame ec text (vector-ref di-vec n) (vector-ref editions-vec n) rep)
(send text begin-edit-sequence) (loop (+ n 1))]
(send text lock #f) [else
(send text delete end-of-current (send text last-position)) (set! index n)]))
(show-next-dis)
(send text set-position
(send text last-position)
(send text last-position))
(send text lock #t)
(send text end-edit-sequence)))
(send text insert #\newline) ;; add 'more frames' link
(send text set-paragraph-alignment (send text last-paragraph) 'center))))) (when (< index (vector-length di-vec))
(let ([end-of-current (send text last-position)])
(send text insert #\newline)
(let ([hyper-start (send text last-position)])
(send text insert
(let* ([num-left
(- (vector-length di-vec)
index)]
[num-to-show
(min how-many-at-once
num-left)])
(if (= num-left 1)
(string-constant last-stack-frame)
(format (if (num-left . <= . num-to-show)
(string-constant last-stack-frames)
(string-constant next-stack-frames))
num-to-show))))
(let ([hyper-end (send text last-position)])
(send text change-style (gui-utils:get-clickback-delta
(preferences:get 'framework:white-on-black?))
hyper-start hyper-end)
(send text set-clickback
hyper-start hyper-end
(λ x
(send text begin-edit-sequence)
(send text lock #f)
(send text delete end-of-current (send text last-position))
(show-next-dis)
(send text set-position
(send text last-position)
(send text last-position))
(send text lock #t)
(send text end-edit-sequence)))
(send text set-position start-pos end-pos) (send text insert #\newline)
(send text end-edit-sequence)))]) (send text set-paragraph-alignment (send text last-paragraph) 'center)))))
(send current-backtrace-window set-alignment 'center 'center)
(send current-backtrace-window reflow-container) (send text set-position start-pos end-pos)
(send text auto-wrap #t) (send text end-edit-sequence)))])
(send text set-autowrap-bitmap #f) (send current-backtrace-window set-alignment 'center 'center)
(send text insert error-text) (send current-backtrace-window reflow-container)
(send text insert "\n\n") (send text auto-wrap #t)
(send text change-style error-delta 0 (- (send text last-position) 1)) (send text set-autowrap-bitmap #f)
(show-next-dis) (send text insert error-text)
(send text set-position 0 0) (send text insert "\n\n")
(send text lock #t) (send text change-style error-delta 0 (- (send text last-position) 1))
(send text hide-caret #t) (show-next-dis)
(send current-backtrace-window show #t)))) (send text set-position 0 0)
(send text lock #t)
(send text hide-caret #t)
(send current-backtrace-window show #t)))
;; show-frame : (instanceof editor-canvas%) ;; show-frame : (instanceof editor-canvas%)
;; (instanceof text%) ;; (instanceof text%)
@ -664,13 +695,13 @@ profile todo:
;; -> ;; ->
;; void ;; void
;; shows one frame of the continuation ;; shows one frame of the continuation
(define (show-frame editor-canvas text di rep) (define (show-frame editor-canvas text di edition rep)
(let* ([debug-source (srcloc-source di)] (let* ([debug-source (srcloc-source di)]
[fn (get-filename debug-source)]
[line (srcloc-line di)] [line (srcloc-line di)]
[column (srcloc-column di)] [column (srcloc-column di)]
[start (srcloc-position di)] [start (srcloc-position di)]
[span (srcloc-span di)] [span (srcloc-span di)]
[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
@ -683,8 +714,8 @@ profile todo:
end-pos) end-pos)
(send text set-clickback (send text set-clickback
start-pos end-pos start-pos end-pos
(λ x (λ (ed start end)
(open-and-highlight-in-file (list (make-srcloc debug-source #f #f start span)))))) (open-and-highlight-in-file (list di) edition))))
;; make bindings hier-list ;; make bindings hier-list
(let ([bindings (st-mark-bindings di)]) (let ([bindings (st-mark-bindings di)])
@ -823,7 +854,7 @@ profile todo:
untitled)))) untitled))))
;; open-and-highlight-in-file : (or/c srcloc (listof srcloc)) -> void ;; open-and-highlight-in-file : (or/c srcloc (listof srcloc)) -> void
(define (open-and-highlight-in-file raw-srcloc) (define (open-and-highlight-in-file raw-srcloc [edition-pair #f])
(let* ([srclocs (if (srcloc? raw-srcloc) (list raw-srcloc) raw-srcloc)] (let* ([srclocs (if (srcloc? raw-srcloc) (list raw-srcloc) raw-srcloc)]
[sources (filter values (map srcloc-source srclocs))]) [sources (filter values (map srcloc-source srclocs))])
(unless (null? sources) (unless (null? sources)
@ -856,6 +887,13 @@ profile todo:
(send frame get-interactions-text))]) (send frame get-interactions-text))])
(when frame (when frame
(send frame show #t)) (send frame show #t))
(when (let ([wbv (weak-box-value (car edition-pair))])
(and wbv (eq? editor wbv)))
(unless (= (cdr edition-pair) (send editor get-edition-number))
(message-box (string-constant drscheme)
(string-constant editor-changed-since-srcloc-recorded)
frame
'(ok caution))))
(when (and rep editor) (when (and rep editor)
(when (is-a? editor text:basic<%>) (when (is-a? editor text:basic<%>)
(send rep highlight-errors same-src-srclocs '()) (send rep highlight-errors same-src-srclocs '())

4
collects/drscheme/private/drsig.ss
View File

@ -64,10 +64,14 @@
hide-backtrace-window hide-backtrace-window
show-backtrace-window show-backtrace-window
show-backtrace-window/edition-pairs
open-and-highlight-in-file open-and-highlight-in-file
small-planet-bitmap small-planet-bitmap
srcloc->edition/pair
;show-error-and-highlight ;show-error-and-highlight
;print-bug-to-stderr ;print-bug-to-stderr
;display-srclocs-in-error ;display-srclocs-in-error

82
collects/drscheme/tool-lib.ss
View File

@ -1,5 +1,4 @@
#reader scribble/reader #lang at-exp scheme/base
#lang scheme/base
#| #|
@ -357,11 +356,56 @@ all of the names in the tools library, for use defining keybindings
(proc-doc/names (proc-doc/names
drscheme:debug:open-and-highlight-in-file drscheme:debug:open-and-highlight-in-file
((or/c srcloc? (listof srcloc?)) . -> . void?) (->* ((or/c srcloc? (listof srcloc?)))
(debug-info) ((or/c #f (cons/c (λ (x) (and (weak-box? x)
(let ([v (weak-box-value x)])
(or (not v)
(is-a?/c v editor<%>)))))
number?)))
void?)
((debug-info)
((edition-pair #f)))
@{This function opens a DrScheme to display @{This function opens a DrScheme to display
@scheme[debug-info]. Only the src the position @scheme[debug-info]. Only the src the position
and the span fields of the srcloc are considered.}) and the span fields of the srcloc are considered.
The @scheme[edition-pair] is used to determine if a
warning message is shown when before opening the file.
If the @scheme[edition-pair] is not @scheme[#f], it is compared
with the result of @method[text:basic<%> get-edition-number]
of the editor that is loaded to determine if the file has been
edited since the source location was recorded. If so, it
puts up a warning dialog message to that effect.})
(proc-doc/names
drscheme:debug:show-backtrace-window/edition-pairs
(-> string?
(listof srcloc?)
(listof (or/c #f (cons/c (λ (x) (and (weak-box? x)
(let ([v (weak-box-value x)])
(or (not v)
(is-a?/c v editor<%>)))))
number?)))
(or/c #f (is-a?/c drscheme:rep:text<%>))
void?)
(error-message dis editions-pairs rep)
@{Shows the backtrace window you get when clicking on the bug in
DrScheme's REPL.
The @scheme[error-message] argument is the text of the error,
@scheme[dis] is the debug information, extracted from the
continuation mark in the exception record, using
@scheme[errortrace-key].
The @scheme[editions] argument indicates the editions of any editors
that are open editing the files corresponding to the source locations
The @scheme[rep] argument should be non-@scheme[#f] if there are
possibly stacktrace frames that contain unsaved versions of the
definitions text or the repl from drscheme. Use
@scheme[drscheme:rep:current-rep] to get the rep.
})
(proc-doc/names (proc-doc/names
drscheme:debug:show-backtrace-window drscheme:debug:show-backtrace-window
@ -376,15 +420,27 @@ all of the names in the tools library, for use defining keybindings
@{Shows the backtrace window you get when clicking on the bug in @{Shows the backtrace window you get when clicking on the bug in
DrScheme's REPL. DrScheme's REPL.
The @scheme[error-message] argument is the text of the error, This function simply calls @scheme[drscheme:debug:show-backtrace-window/edition-pairs],
@scheme[dis] is the debug information, extracted from the using @scheme[drscheme:debug:srcloc->edition/pair].
continuation mark in the exception record, using })
@scheme[errortrace-key].
The @scheme[rep] argument should be non-@scheme[#f] if there are (proc-doc/names
possibly stacktrace frames that contain unsaved versions of the drscheme:debug:srcloc->edition/pair
definitions text or the repl from drscheme. Use (-> srcloc?
@scheme[drscheme:rep:current-rep] to get the rep. (or/c #f (is-a?/c drscheme:rep:text<%>))
(or/c #f (cons/c (λ (x) (and (weak-box? x)
(let ([v (weak-box-value x)])
(or (not v)
(is-a?/c v editor<%>)))))
number?)))
(srcloc rep)
@{Constructs a edition pair from a source location,
returning the current edition of the editor editing
the source location (if any).
The @scheme[rep] argument is used to map source locations,
in the case that the source location corresponds to the definitions
window (when it has not been saved) or the interactions window.
}) })

7
collects/framework/private/text.ss
View File

@ -541,14 +541,21 @@ WARNING: printf is rebound in the body of the unit to always
(define (get-styles-fixed) styles-fixed?) (define (get-styles-fixed) styles-fixed?)
(define (set-styles-fixed b) (set! styles-fixed? b)) (define (set-styles-fixed b) (set! styles-fixed? b))
(define edition 0)
(define/public (get-edition-number) edition)
(define/augment (on-insert start len) (define/augment (on-insert start len)
(begin-edit-sequence) (begin-edit-sequence)
(inner (void) on-insert start len)) (inner (void) on-insert start len))
(define/augment (after-insert start len) (define/augment (after-insert start len)
(set! edition (+ edition 1))
(when styles-fixed? (when styles-fixed?
(change-style (get-fixed-style) start (+ start len) #f)) (change-style (get-fixed-style) start (+ start len) #f))
(inner (void) after-insert start len) (inner (void) after-insert start len)
(end-edit-sequence)) (end-edit-sequence))
(define/augment (after-delete start len)
(set! edition (+ edition 1))
(inner (void) after-delete start len))
(define/public (move/copy-to-edit dest-edit start end dest-position) (define/public (move/copy-to-edit dest-edit start end dest-position)
(split-snip start) (split-snip start)

8
collects/scribblings/framework/text.scrbl
View File

@ -134,6 +134,14 @@
@method[text:basic<%> port-name-matches?]. @method[text:basic<%> port-name-matches?].
} }
@defmethod[(get-edition-number) exact-nonnegative-integer?]{
Returns a number that increments everytime something in
the editor changes.
The number is updated in @xmethod[text% after-insert] and
@xmethod[text% after-delete].
}
} }
@defmixin[text:basic-mixin (editor:basic<%> text%) (text:basic<%>)]{ @defmixin[text:basic-mixin (editor:basic<%> text%) (text:basic<%>)]{
This mixin implements the basic functionality needed for This mixin implements the basic functionality needed for

14
collects/scribblings/tools/rep.scrbl
View File

@ -91,6 +91,20 @@ The @scheme[complete-program?] argument determines if the
}} }}
@defmethod[(evaluate-from-port [port input-port?]
[complete-program? boolean?]
[cleanup (-> void)])
any]{
Evaluates the program in the @scheme[port] argument. If @scheme[complete-program?]
is @scheme[#t], this method calls the
@method[drscheme:language:language<%> front-end/complete-program] to evaluate
the program. If it is @scheme[#f], it calls
@method[drscheme:language:language<%> front-end/interaction] method.
When evaluation finishes, it calls @scheme[cleanup] on the user's main thread.
This method must be called from the drscheme main thread.
}
@defmethod[#:mode augment (after-many-evals) any]{ @defmethod[#:mode augment (after-many-evals) any]{
Called from the drscheme main thread after Called from the drscheme main thread after
@method[drscheme:rep:text% evaluate-from-port] finishes (no matter @method[drscheme:rep:text% evaluate-from-port] finishes (no matter

3
collects/string-constants/english-string-constants.ss
View File

@ -229,6 +229,9 @@ please adhere to these guidelines:
(needs-execute-defns-edited (needs-execute-defns-edited
"WARNING: The definitions window has changed. Click Run.") "WARNING: The definitions window has changed. Click Run.")
(editor-changed-since-srcloc-recorded
"This editor has been changed since the source location was recorded, so the highlighted region may no longer correspond to the correct source location.")
(file-is-not-saved "The file \"~a\" is not saved.") (file-is-not-saved "The file \"~a\" is not saved.")
(save "Save") (save "Save")
(close-anyway "Close Anyway") (close-anyway "Close Anyway")