add current-trace-notify

svn: r10941
This commit is contained in:
Matthew Flatt 2008-07-28 14:45:16 +00:00
parent 3bcbdc1924
commit 44b1499301
2 changed files with 49 additions and 4 deletions

View File

@ -1,6 +1,7 @@
#lang scribble/doc
@(require "common.ss"
(for-label mzlib/trace))
(for-label mzlib/trace
scheme/pretty))
@mzlib[#:mode title trace]
@ -12,8 +13,9 @@ available in Chez Scheme.
Each @scheme[id] must be bound to a procedure in the environment of
the @scheme[trace] expression. Each @scheme[id] is @scheme[set!]ed to
a new procedure that traces procedure calls and returns by printing
the arguments and results of the call. If multiple values are
returned, each value is displayed starting on a separate line.
the arguments and results of the call via
@scheme[current-trace-notify]. If multiple values are returned, each
value is displayed starting on a separate line.
When traced procedures invoke each other, nested invocations are shown
by printing a nesting prefix. If the nesting depth grows to ten and
@ -46,3 +48,11 @@ the current value of a @scheme[id] is not a procedure installed by
The result of an @scheme[untrace] expression is @|void-const|.}
@defparam[current-trace-notify proc (string? . -> . any)]{
A parameter that determines the way that trace output is
displayed. The string given to @scheme[proc] is a trace; it does not
end with a newline, but it may contain internal newlines. Each call or
result is converted into a string using @scheme[pretty-print]. The
parameter's default value prints the given string followed by a newline to
@scheme[(current-output-port)].}

View File

@ -3,7 +3,8 @@
(require scheme/pretty
(for-syntax scheme/base))
(provide trace untrace)
(provide trace untrace
current-trace-notify)
(define max-dash-space-depth 10)
(define number-nesting-depth 6)
@ -75,7 +76,34 @@
(insert-prefix level first rest)
(values first rest))))))
(define current-trace-notify
(make-parameter (lambda (s)
(display s)
(newline))
(lambda (p)
(unless (and (procedure? p)
(procedure-arity-includes? p 1))
(raise-type-error 'current-trace-notify
"procedure (arity 1)"
p))
p)))
(define (as-trace-notify thunk)
(let ([p (open-output-bytes)])
(parameterize ([current-output-port p])
(thunk))
(let ([b (get-output-bytes p #t 0
;; drop newline:
(sub1 (file-position p)))])
((current-trace-notify) (bytes->string/utf-8 b)))))
(define -:trace-print-args
(lambda (name args kws kw-vals level)
(as-trace-notify
(lambda ()
(trace-print-args name args kws kw-vals level)))))
(define trace-print-args
(lambda (name args kws kw-vals level)
(let-values (((first rest)
(build-prefixes level)))
@ -96,6 +124,12 @@
(apply append (map list kws kw-vals))))))))
(define -:trace-print-results
(lambda (name results level)
(as-trace-notify
(lambda ()
(trace-print-results name results level)))))
(define trace-print-results
(lambda (name results level)
(let-values (((first rest)
(build-prefixes level)))
@ -132,6 +166,7 @@
0))))
(for-each pretty-print (cdr results)))))))))
;; A traced-proc struct instance acts like a procedure,
;; but preserves the original, too.
(define-values (struct:traced-proc make-traced-proc traced-proc? traced-proc-ref traced-proc-set!)