added optional 3rd argument to drscheme:language:add-snip-value to support initializing the user's namespace

svn: r3910
This commit is contained in:
Robby Findler 2006-07-31 16:16:43 +00:00
parent 48334f51be
commit 0db2249a33
4 changed files with 63 additions and 38 deletions

View File

@ -229,6 +229,7 @@
simple-module-based-language-config-panel simple-module-based-language-config-panel
add-snip-value add-snip-value
setup-setup-values
register-capability register-capability
capability-registered? capability-registered?

View File

@ -1128,9 +1128,10 @@
;; ;;
(define to-snips null) (define to-snips null)
(define-struct to-snip (predicate? >value)) (define-struct to-snip (predicate? >value setup-thunk))
(define (add-snip-value predicate constructor) (define add-snip-value
(set! to-snips (cons (make-to-snip predicate constructor) to-snips))) (opt-lambda (predicate constructor [setup-thunk void])
(set! to-snips (cons (make-to-snip predicate constructor setup-thunk) to-snips))))
(define (value->snip v) (define (value->snip v)
(ormap (λ (to-snip) (and ((to-snip-predicate? to-snip) v) (ormap (λ (to-snip) (and ((to-snip-predicate? to-snip) v)
@ -1138,6 +1139,8 @@
to-snips)) to-snips))
(define (to-snip-value? v) (define (to-snip-value? v)
(ormap (λ (to-snip) ((to-snip-predicate? to-snip) v)) to-snips)) (ormap (λ (to-snip) ((to-snip-predicate? to-snip) v)) to-snips))
(define (setup-setup-values)
(for-each (λ (t) ((to-snip-setup-thunk t))) to-snips))
(define capabilities '()) (define capabilities '())

View File

@ -33,6 +33,27 @@ TODO
(lib "default-lexer.ss" "syntax-color")) (lib "default-lexer.ss" "syntax-color"))
(provide rep@) (provide rep@)
(define-syntax stacktrace-name (string->uninterned-symbol "this-is-the-funny-name"))
;; this macro wraps its argument expression in some code in a non-tail manner
;; so that a new name gets put onto the mzscheme stack. DrScheme's exception
;; handlers trims the stack starting at this point to avoid showing drscheme's
;; internals on the stack in the REPL.
(define-syntax (with-stacktrace-name stx)
(syntax-case stx ()
[(_ e)
(with-syntax ([my-funny-name (syntax-local-value #'stacktrace-name)])
(syntax
(let ([my-funny-name (λ () (begin0 e (random 1)))])
((if (zero? (random 1))
my-funny-name
values)))))]))
(define stacktrace-runtime-name
(let-syntax ([m (λ (x) (with-syntax ([x (syntax-local-value #'stacktrace-name)])
(syntax 'x)))])
(m)))
(define rep@ (define rep@
(unit/sig drscheme:rep^ (unit/sig drscheme:rep^
@ -227,9 +248,8 @@ TODO
(current-thread))))) (current-thread)))))
(define (cut-out-top-of-stack exn) (define (cut-out-top-of-stack exn)
(let ([initial-stack (continuation-mark-set->context (exn-continuation-marks exn))]) (let ([initial-stack (continuation-mark-set->context (exn-continuation-marks exn))])
(let loop ([stack (reverse initial-stack)] (let loop ([stack initial-stack])
[hit-2? #f])
(cond (cond
[(null? stack) [(null? stack)
(unless (exn:break? exn) (unless (exn:break? exn)
@ -241,27 +261,17 @@ TODO
[else [else
(let ([top (car stack)]) (let ([top (car stack)])
(cond (cond
[(is-cut? top 'cut-stacktrace-above-here1) [(cut-here? top) null]
(if hit-2? [else (cons top (loop (cdr stack)))]))]))))
(reverse (cdr stack))
(begin
(fprintf (current-error-port) "ACK! found 1 without 2\n")
initial-stack))]
[(is-cut? top 'cut-stacktrace-above-here2)
(if hit-2?
(reverse (cdr stack))
(loop (cdr stack) #t))]
[else
(loop (cdr stack) hit-2?)]))]))))
;; is-cut? : any symbol -> boolean ;; is-cut? : any symbol -> boolean
;; determines if this stack entry is really ;; determines if this stack entry is really
(define (is-cut? top sym) (define (cut-here? top)
(and (pair? top) (and (pair? top)
(let* ([fn-name (car top)] (let* ([fn-name (car top)]
[srcloc (cdr top)] [srcloc (cdr top)]
[source (and srcloc (srcloc-source srcloc))]) [source (and srcloc (srcloc-source srcloc))])
(and (eq? fn-name sym) (and (eq? fn-name stacktrace-runtime-name)
(path? source) (path? source)
(let loop ([path source] (let loop ([path source]
[pieces '(#"rep.ss" #"private" #"drscheme" #"collects")]) [pieces '(#"rep.ss" #"private" #"drscheme" #"collects")])
@ -1048,13 +1058,7 @@ TODO
(λ () (λ ()
(let loop () (let loop ()
(let ([sexp/syntax/eof (let ([sexp/syntax/eof (with-stacktrace-name (get-sexp/syntax/eof))])
;; this named thunk & application helps drscheme know to cut
;; off part of the stack trace. (too bad not all of it ...)
((rec cut-stacktrace-above-here1
(λ ()
(begin0 (get-sexp/syntax/eof)
(void)))))])
(unless (eof-object? sexp/syntax/eof) (unless (eof-object? sexp/syntax/eof)
(call-with-break-parameterization (call-with-break-parameterization
(get-user-break-parameterization) (get-user-break-parameterization)
@ -1064,10 +1068,8 @@ TODO
;; break exn. ;; break exn.
(λ () (λ ()
(call-with-values (call-with-values
(rec cut-stacktrace-above-here1 (λ ()
(λ () (with-stacktrace-name (eval-syntax sexp/syntax/eof)))
(begin0 (eval-syntax sexp/syntax/eof)
(void))))
(λ x (display-results x))))) (λ x (display-results x)))))
(loop)))) (loop))))
(set! cleanup? #t)) (set! cleanup? #t))
@ -1210,6 +1212,21 @@ TODO
(let ([run-on-user-thread (lambda (t) (queue-user/wait t))]) (let ([run-on-user-thread (lambda (t) (queue-user/wait t))])
run-on-user-thread)) run-on-user-thread))
;; setup the special repl values
(let ([raised-exn? #f]
[exn #f])
(queue-user/wait
(λ () ; =User=, =No-Breaks=
(with-handlers ((void (λ (x)
(set! exn x)
(set! raised-exn? #t))))
(drscheme:language:setup-setup-values))))
(when raised-exn?
(fprintf
(current-error-port)
"copied exn raised when setting up snip values (thunk passed as third argume to drscheme:language:add-snip-value)\n")
(raise exn)))
;; installs the teachpacks ;; installs the teachpacks
;; must happen after language is initialized. ;; must happen after language is initialized.
(queue-user/wait (queue-user/wait

View File

@ -966,15 +966,19 @@
(drscheme:language:add-snip-value (drscheme:language:add-snip-value
(-> (-> any/c boolean?) (opt-> ((-> any/c boolean?)
(-> any/c (is-a?/c snip%)) (-> any/c (is-a?/c snip%)))
void?) ((-> any/c))
(test-value convert-value) void?)
(test-value convert-value (setup-thunk void))
"Registers a handler to convert values into snips as they are printed in the REPL." "Registers a handler to convert values into snips as they are printed in the REPL."
"" ""
"The \\var{test-snip} argument is called to determine if this handler can convert the value" "The \\var{test-snip} argument is called to determine if this handler can convert the value "
"and the \\var{convert-value} argument is called to build a snip." "and the \\var{convert-value} argument is called to build a snip. "
"Both functions are called on the user's thread and with the user's settings.") "The (optional) \\var{setup-thunk} is called just after the user's namespace and other "
"setings are built, but before any of the user's code is evaluated."
""
"All three functions are called on the user's thread and with the user's settings.")
(drscheme:language:extend-language-interface (drscheme:language:extend-language-interface
(interface? (interface?