add current-trace-notify
svn: r10941
This commit is contained in:
parent
3bcbdc1924
commit
44b1499301
|
@ -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)].}
|
||||
|
|
|
@ -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!)
|
||||
|
|
Loading…
Reference in New Issue
Block a user