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

264
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?) (define (show-backtrace-window/edition-pairs error-text dis editions rep)
(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)]
(λ () [editions-vec (list->vector editions)]
(let ([start-pos (send text get-start-position)] [index 0]
[end-pos (send text get-end-position)]) [how-many-at-once 15]
(send text begin-edit-sequence) [show-next-dis
(send text set-position (send text last-position)) (λ ()
(let loop ([n index]) (let ([start-pos (send text get-start-position)]
(cond [end-pos (send text get-end-position)])
[(and (< n (vector-length di-vec)) (send text begin-edit-sequence)
(< n (+ index how-many-at-once))) (send text set-position (send text last-position))
(show-frame ec text (vector-ref di-vec n) rep) (let loop ([n index])
(loop (+ n 1))] (cond
[else [(and (< n (vector-length di-vec))
(set! index n)])) (< n (+ index how-many-at-once)))
(show-frame ec text (vector-ref di-vec n) (vector-ref editions-vec n) rep)
;; add 'more frames' link (loop (+ n 1))]
(when (< index (vector-length di-vec)) [else
(let ([end-of-current (send text last-position)]) (set! index n)]))
(send text insert #\newline)
(let ([hyper-start (send text last-position)]) ;; add 'more frames' link
(send text insert (when (< index (vector-length di-vec))
(let* ([num-left (let ([end-of-current (send text last-position)])
(- (vector-length di-vec) (send text insert #\newline)
index)] (let ([hyper-start (send text last-position)])
[num-to-show (send text insert
(min how-many-at-once (let* ([num-left
num-left)]) (- (vector-length di-vec)
(if (= num-left 1) index)]
(string-constant last-stack-frame) [num-to-show
(format (if (num-left . <= . num-to-show) (min how-many-at-once
(string-constant last-stack-frames) num-left)])
(string-constant next-stack-frames)) (if (= num-left 1)
num-to-show)))) (string-constant last-stack-frame)
(let ([hyper-end (send text last-position)]) (format (if (num-left . <= . num-to-show)
(send text change-style (gui-utils:get-clickback-delta (string-constant last-stack-frames)
(preferences:get 'framework:white-on-black?)) (string-constant next-stack-frames))
hyper-start hyper-end) num-to-show))))
(send text set-clickback (let ([hyper-end (send text last-position)])
hyper-start hyper-end (send text change-style (gui-utils:get-clickback-delta
(λ x (preferences:get 'framework:white-on-black?))
(send text begin-edit-sequence) hyper-start hyper-end)
(send text lock #f) (send text set-clickback
(send text delete end-of-current (send text last-position)) hyper-start hyper-end
(show-next-dis) (λ x
(send text set-position (send text begin-edit-sequence)
(send text last-position) (send text lock #f)
(send text last-position)) (send text delete end-of-current (send text last-position))
(send text lock #t) (show-next-dis)
(send text end-edit-sequence))) (send text set-position
(send text last-position)
(send text insert #\newline) (send text last-position))
(send text set-paragraph-alignment (send text last-paragraph) 'center))))) (send text lock #t)
(send text end-edit-sequence)))
(send text set-position start-pos end-pos)
(send text end-edit-sequence)))]) (send text insert #\newline)
(send current-backtrace-window set-alignment 'center 'center) (send text set-paragraph-alignment (send text last-paragraph) 'center)))))
(send current-backtrace-window reflow-container)
(send text auto-wrap #t) (send text set-position start-pos end-pos)
(send text set-autowrap-bitmap #f) (send text end-edit-sequence)))])
(send text insert error-text) (send current-backtrace-window set-alignment 'center 'center)
(send text insert "\n\n") (send current-backtrace-window reflow-container)
(send text change-style error-delta 0 (- (send text last-position) 1)) (send text auto-wrap #t)
(show-next-dis) (send text set-autowrap-bitmap #f)
(send text set-position 0 0) (send text insert error-text)
(send text lock #t) (send text insert "\n\n")
(send text hide-caret #t) (send text change-style error-delta 0 (- (send text last-position) 1))
(send current-backtrace-window show #t)))) (show-next-dis)
(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,9 +64,13 @@
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

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].
(proc-doc/names
drscheme:debug:srcloc->edition/pair
(-> srcloc?
(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 should be non-@scheme[#f] if there are The @scheme[rep] argument is used to map source locations,
possibly stacktrace frames that contain unsaved versions of the in the case that the source location corresponds to the definitions
definitions text or the repl from drscheme. Use window (when it has not been saved) or the interactions window.
@scheme[drscheme:rep:current-rep] to get the rep.
}) })

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

@ -94,7 +94,7 @@ WARNING: printf is rebound in the body of the unit to always
position-location position-locations position-location position-locations
position-line line-start-position line-end-position position-line line-start-position line-end-position
get-extent get-filename run-after-edit-sequence) get-extent get-filename run-after-edit-sequence)
(define port-name-identifier #f) (define port-name-identifier #f)
(define/public (get-port-name) (define/public (get-port-name)
(let* ([b (box #f)] (let* ([b (box #f)]
@ -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")