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

PR 10431, plus support for ->* with keywords in proc-doc

Browse Source 
svn: r15926
This commit is contained in:
Robby Findler 2009-09-08 22:53:12 +00:00
parent bc25b75eb3
commit 390145821a
5 changed files with 124 additions and 66 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -272,7 +272,14 @@ profile todo:
;; error-display-handler/stacktrace : string any (listof srcloc) -> void
;; =User=
(define (error-display-handler/stacktrace msg exn [pre-stack #f])
(define (error-display-handler/stacktrace
msg exn
[pre-stack #f]
#:interactions-text [ints (drscheme:rep:current-rep)]
#:definitions-text [defs (let ([rep (drscheme:rep:current-rep)])
(and rep
(send rep get-definitions-text)))])
(let* ([stack (or pre-stack
(if (exn? exn)
(map cdr (filter cdr (continuation-mark-set->context (exn-continuation-marks exn))))
@ -282,15 +289,12 @@ profile todo:
(if (null? stack)
'()
(list (car stack))))]
[rep (let ([rep (drscheme:rep:current-rep)])
(and (is-a? rep drscheme:rep:text<%>)
rep))]
[stack-editions (map (λ (x) (srcloc->edition/pair rep x)) stack)]
[stack-editions (map (λ (x) (srcloc->edition/pair defs ints x)) stack)]
[src-locs-edition (and (pair? src-locs)
(srcloc->edition/pair rep (car src-locs)))])
(srcloc->edition/pair defs ints (car src-locs)))])
(print-planet-icon-to-stderr exn)
(unless (null? stack)
(print-bug-to-stderr msg stack stack-editions rep))
(print-bug-to-stderr msg stack stack-editions defs ints))
(display-srclocs-in-error src-locs src-locs-edition)
(display msg (current-error-port))
(when (exn:fail:syntax? exn)
@ -298,28 +302,29 @@ profile todo:
(show-syntax-error-context (current-error-port) exn)))
(newline (current-error-port))
(flush-output (current-error-port))
(when (and rep
(when (and ints
(eq? (current-error-port)
(send rep get-err-port)))
(send ints get-err-port)))
(parameterize ([current-eventspace drscheme:init:system-eventspace])
(queue-callback
(λ ()
;; need to make sure that the user's eventspace is still the same
;; and still running here?
(send rep highlight-errors src-locs stack)))))))
(send ints highlight-errors src-locs stack)))))))
(define (srcloc->edition/pair rep srcloc)
(define (srcloc->edition/pair defs ints 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))]
ints
(send ints port-name-matches? src))
(cons (make-weak-box ints) (send ints 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))]
defs
(send defs port-name-matches? src))
(cons (make-weak-box defs) (send defs get-edition-number))]
[(path? src)
(let ([frame (send (group:get-the-frame-group) locate-file src)])
(and frame
@ -386,12 +391,12 @@ profile todo:
(get-output-string sp)))
;; =User=
(define (print-bug-to-stderr msg cms editions rep)
(define (print-bug-to-stderr msg cms editions defs ints)
(when (port-writes-special? (current-error-port))
(let ([note% (if (mf-bday?) mf-note% bug-note%)])
(when note%
(let ([note (new note%)])
(send note set-callback (λ () (show-backtrace-window/edition-pairs msg cms editions rep)))
(send note set-callback (λ () (show-backtrace-window/edition-pairs msg cms editions defs ints)))
(write-special note (current-error-port))
(display #\space (current-error-port)))))))
@ -601,13 +606,13 @@ profile todo:
;; (listof srcloc?)
;; ->
;; void
(define (show-backtrace-window error-text dis/exn [rep #f])
(define (show-backtrace-window error-text dis/exn [rep #f] [defs #f])
(let ([dis (if (exn? dis/exn)
(cms->srclocs (exn-continuation-marks dis/exn))
dis/exn)])
(show-backtrace-window/edition-pairs error-text dis (map (λ (x) #f) dis/exn) rep)))
(show-backtrace-window/edition-pairs error-text dis (map (λ (x) #f) dis/exn) defs rep)))
(define (show-backtrace-window/edition-pairs error-text dis editions rep)
(define (show-backtrace-window/edition-pairs error-text dis editions defs ints)
(reset-backtrace-window)
(letrec ([text (make-object (text:wide-snip-mixin text:hide-caret/selection%))]
[mf-bday-note (when (mf-bday?)
@ -631,7 +636,7 @@ profile todo:
(cond
[(and (< n (vector-length di-vec))
(< n (+ index how-many-at-once)))
(show-frame ec text (vector-ref di-vec n) (vector-ref editions-vec n) rep)
(show-frame ec text (vector-ref di-vec n) (vector-ref editions-vec n) defs ints)
(loop (+ n 1))]
[else
(set! index n)]))
@ -692,11 +697,11 @@ profile todo:
;; show-frame : (instanceof editor-canvas%)
;; (instanceof text%)
;; st-mark?
;; rep
;; def ints // definitions and interactions texts
;; ->
;; void
;; shows one frame of the continuation
(define (show-frame editor-canvas text di edition rep)
(define (show-frame editor-canvas text di edition defs ints)
(let* ([debug-source (srcloc-source di)]
[fn (get-filename debug-source)]
[line (srcloc-line di)]
@ -724,31 +729,23 @@ profile todo:
(send text insert (render-bindings/snip bindings))))
(send text insert #\newline)
(insert-context editor-canvas text debug-source start span rep)
(insert-context editor-canvas text debug-source start span defs ints)
(send text insert #\newline)))
;; insert-context : (instanceof editor-canvas%)
;; (instanceof text%)
;; debug-info
;; number
;; rep
;; defs ints // definitions and interactions texts
;; ->
;; void
(define (insert-context editor-canvas text file start span rep)
(define (insert-context editor-canvas text file start span defs ints)
(let-values ([(from-text close-text)
(cond
[(and rep (send rep port-name-matches? file))
(values rep void)]
[(and rep (send (send rep get-definitions-text) port-name-matches? file))
(values (send rep get-definitions-text) void)]
#;
[(symbol? file)
;; can this case happen?
(let ([text (new text:basic%)])
(if (send text load-file (symbol->string file))
(values text
(λ () (send text on-close)))
(values #f (λ () (void)))))]
[(and ints (send ints port-name-matches? file))
(values ints void)]
[(and defs (send defs port-name-matches? file))
(values defs void)]
[(path? file)
(let ([file (with-handlers ((exn:fail? (λ (x) #f)))
(normal-case-path (normalize-path file)))])

3
collects/drscheme/syncheck.ss
View File

@ -1205,7 +1205,8 @@ If the namespace does not, they are colored the unbound color.
(drscheme:debug:error-display-handler/stacktrace
msg
exn
'())
'()
#:definitions-text definitions-text)
(semaphore-post error-display-semaphore)))

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

@ -298,9 +298,14 @@ all of the names in the tools library, for use defining keybindings
(proc-doc/names
drscheme:debug:error-display-handler/stacktrace
(->* (string? any/c)
((or/c false/c (listof srcloc?)))
((or/c false/c (listof srcloc?))
#:definitions-text (or/c #f (is-a?/c drscheme:unit:definitions-text<%>))
#:interactions-text (or/c #f (is-a?/c drscheme:rep:text<%>))
)
any/c)
((msg exn) ((stack #f)))
((msg exn) ((stack #f)
(defs #f)
(ints #f)))
@{Displays the error message represented by the string, adding
embellishments like those that appears in the DrScheme REPL,
specifically a clickable icon for the stack trace (if the srcloc location is not empty),
@ -386,9 +391,10 @@ all of the names in the tools library, for use defining keybindings
(or (not v)
(is-a?/c v editor<%>)))))
number?)))
(or/c #f (is-a?/c drscheme:unit:definitions-text<%>))
(or/c #f (is-a?/c drscheme:rep:text<%>))
void?)
(error-message dis editions-pairs rep)
(error-message dis editions-pairs defs ints)
@{Shows the backtrace window you get when clicking on the bug in
DrScheme's REPL.
@ -400,10 +406,14 @@ all of the names in the tools library, for use defining keybindings
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
The @scheme[defs] 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.
definitions window from drscheme. Similarly, the @scheme[ints] argument
should be non-@scheme[#f] if there are possibly stacktrace frames that contain
unsaved versions of the interactions window.
Use
@scheme[drscheme:rep:current-rep] to get the rep during evaluation of a program.
})
@ -413,10 +423,12 @@ all of the names in the tools library, for use defining keybindings
(or/c exn?
(listof srcloc?)
(non-empty-listof (cons/c string? (listof srcloc?)))))
((or/c #f (is-a?/c drscheme:rep:text<%>)))
((or/c #f (is-a?/c drscheme:rep:text<%>))
(or/c #f (is-a?/c drscheme:unit:definitions-text<%>)))
void?)
((error-message dis)
((rep #f)))
((rep #f)
(defs #f)))
@{Shows the backtrace window you get when clicking on the bug in
DrScheme's REPL.
@ -428,17 +440,20 @@ all of the names in the tools library, for use defining keybindings
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<%>)))))
(or/c #f (is-a?/c drscheme:unit:definitions-text<%>))
(or/c #f (cons/c (let ([weak-box-containing-an-editor?
(λ (x) (and (weak-box? x)
(let ([v (weak-box-value x)])
(or (not v)
(is-a?/c v editor<%>)))))])
weak-box-containing-an-editor?)
number?)))
(srcloc rep)
(srcloc ints defs)
@{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,
The @scheme[ints] and @scheme[defs] arguments are 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.
})

58
collects/scribble/srcdoc.ss
View File

@ -117,15 +117,55 @@
(syntax-case #'names ()
[((mandatory-names ...)
((optional-names optional-default) ...))
(begin
(unless (= (length (syntax->list #'(mandatory-names ...)))
(length (syntax->list #'(mandatory ...))))
(raise-syntax-error #f "mismatched mandatory argument list and domain contract count" stx))
(unless (= (length (syntax->list #'(optional-names ...)))
(length (syntax->list #'(optional ...))))
(raise-syntax-error #f "mismatched mandatory argument list and domain contract count" stx))
#'([(id (mandatory-names mandatory) ... (optional-names optional optional-default) ...)
result]))]
(let ([build-mandatories/optionals
(λ (names contracts extras)
(let ([names-length (length names)]
[contracts-length (length contracts)])
(let loop ([contracts contracts]
[names names]
[extras extras])
(cond
[(and (null? names) (null? contracts)) '()]
[(or (null? names) (null? contracts))
(raise-syntax-error #f
(format "mismatched ~a argument list count and domain contract count (~a)"
(if extras "optional" "mandatory")
(if (null? names)
"ran out of names"
"ran out of contracts"))
stx)]
[else
(let ([fst-name (car names)]
[fst-ctc (car contracts)])
(if (keyword? (syntax-e fst-ctc))
(begin
(unless (pair? (cdr contracts))
(raise-syntax-error #f
"keyword not followed by a contract"
stx))
(cons (if extras
(list fst-ctc fst-name (cadr contracts) (car extras))
(list fst-ctc fst-name (cadr contracts)))
(loop (cddr contracts)
(cdr names)
(if extras
(cdr extras)
extras))))
(cons (if extras
(list fst-name fst-ctc (car extras))
(list fst-name fst-ctc))
(loop (cdr contracts) (cdr names) (if extras
(cdr extras)
extras)))))]))))])
#`([(id #,@(build-mandatories/optionals (syntax->list #'(mandatory-names ...))
(syntax->list #'(mandatory ...))
#f)
#,@(build-mandatories/optionals (syntax->list #'(optional-names ...))
(syntax->list #'(optional ...))
(syntax->list #'(optional-default ...))))
result]))]
[(mandatory-names optional-names)
(begin
(syntax-case #'mandatory-names ()

11
collects/scribblings/scribble/srcdoc.scrbl
View File

@ -71,10 +71,14 @@ to get core Scheme forms and basic Scribble functions to use in
documentation expressions.}
@defform*/subs[#:literals (-> ->* case->)
[(proc-doc/names id contract (arg-id ...) desc-expr)
(proc-doc/names id case-contract ((arg-id ...) ...) desc-expr)]
[(proc-doc/names id contract ((arg-id ...) ((arg-id default-expr) ...)) desc-expr)
(proc-doc/names id case-contract ((arg-id ...) ((arg-id default-expr) ...)) desc-expr)]
([contract (-> arg ... result)
(->* (mandatory ...) (optional ...) result)]
[mandatory contract-expr
(code:line keyword contract-expr)]
[optional contract-expr
(code:line keyword contract-expr)]
[case-contract (case-> (-> arg ... result) ...)])]{
When used in @scheme[provide/doc], exports @scheme[id] with the
@ -84,7 +88,8 @@ just like using @scheme[provide/contract].
The @scheme[arg-id]s specify the names of arguments, which are not
normally written as part of a contract. They are combined with the
contract expression to generate the description of the binding in the
documentation via @scheme[defproc].
documentation via @scheme[defproc]. The @scheme[(arg-id default-expr)]
pairs specify the names and default values of the optional arguments.
The @scheme[desc-expr] is a documentation-time expression that
produces prose to describe the exported binding---that is, the last