From 44b1499301c327e6547b86611f0fe0a4d8000099 Mon Sep 17 00:00:00 2001
From: Matthew Flatt <mflatt@racket-lang.org>
Date: Mon, 28 Jul 2008 14:45:16 +0000
Subject: [PATCH] add current-trace-notify

svn: r10941
---
 collects/mzlib/scribblings/trace.scrbl | 16 ++++++++---
 collects/mzlib/trace.ss                | 37 +++++++++++++++++++++++++-
 2 files changed, 49 insertions(+), 4 deletions(-)

diff --git a/collects/mzlib/scribblings/trace.scrbl b/collects/mzlib/scribblings/trace.scrbl
index e2a2f6390d..d63795242b 100644
--- a/collects/mzlib/scribblings/trace.scrbl
+++ b/collects/mzlib/scribblings/trace.scrbl
@@ -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)].}
diff --git a/collects/mzlib/trace.ss b/collects/mzlib/trace.ss
index bd703509e3..e04c657ad6 100644
--- a/collects/mzlib/trace.ss
+++ b/collects/mzlib/trace.ss
@@ -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!)