From cda64e40da21ef9e639faa82f741bfd736edf245 Mon Sep 17 00:00:00 2001
From: Robby Findler <robby@racket-lang.org>
Date: Wed, 7 Jan 2009 15:44:07 +0000
Subject: [PATCH] opened up the trace library a little more to make it more
 useable for Redex

svn: r13027
---
 collects/mzlib/scribblings/trace.scrbl | 23 ++++++++++
 collects/mzlib/trace.ss                | 58 +++++++++++++-------------
 2 files changed, 52 insertions(+), 29 deletions(-)

diff --git a/collects/mzlib/scribblings/trace.scrbl b/collects/mzlib/scribblings/trace.scrbl
index d63795242b..148a86f9a9 100644
--- a/collects/mzlib/scribblings/trace.scrbl
+++ b/collects/mzlib/scribblings/trace.scrbl
@@ -56,3 +56,26 @@ 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)].}
+
+@defproc[(trace-apply [id symbol?] [proc procedure?] [kws (listof keyword)] [kw-vals list?] [arg any/c] ...) any/c]{
+
+Calls @scheme[proc] with the arguments supplied in
+@scheme[args], @scheme[kws], and @scheme[kw-vals]. Also prints out the
+trace information during the call, as described above in the docs for
+@scheme[trace], using @scheme[id] as the name of @scheme[proc].
+
+}
+
+@defparam[current-trace-print-args trace-print-args 
+	  (-> symbol?
+              (listof keyword?)
+              list? 
+              list?
+              number?)]{
+
+The value of this parameter is invoked to print out the arguments of a
+traced call. It receives the name of the function, the function's
+ordinary arguments, its keywords, the values of the keywords, and a
+number indicating the depth of the call.
+
+}
\ No newline at end of file
diff --git a/collects/mzlib/trace.ss b/collects/mzlib/trace.ss
index e04c657ad6..21c47e026c 100644
--- a/collects/mzlib/trace.ss
+++ b/collects/mzlib/trace.ss
@@ -4,19 +4,16 @@
            (for-syntax scheme/base))
 
   (provide trace untrace
+           current-trace-print-args trace-apply
            current-trace-notify)
 
   (define max-dash-space-depth 10)
   (define number-nesting-depth 6)
 
-  (define as-spaces
-    (lambda (s)
-      (let ((n (string-length s)))
-	(apply string-append
-	       (let loop ((k n))
-		 (if (zero? k) '("")
-		     (cons " " (loop (sub1 k)))))))))
-
+  (define (as-spaces s)
+    (build-string (string-length s)
+                  (lambda (i) #\space)))
+  
   (define-struct prefix-entry (for-first for-rest))
 
   (define prefixes (make-vector 20 #f))
@@ -101,28 +98,29 @@
     (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)))
-	(parameterize ((pretty-print-print-line
-			(lambda (n port offset width)
-			  (display
-			   (if n
-			       (if (zero? n) first
-				   (format "~n~a" rest))
-			       (format "~n"))
-			   port)
-			  (if n
-			      (if (zero? n)
-				  (string-length first)
-				  (string-length rest))
-			      0))))
-	  (pretty-print (append (cons name args)
-                                (apply append (map list kws kw-vals))))))))
+         ((current-trace-print-args) name args kws kw-vals level)))))
 
+  (define current-trace-print-args
+    (make-parameter
+     (lambda (name args kws kw-vals level)
+       (let-values (((first rest)
+                     (build-prefixes level)))
+         (parameterize ((pretty-print-print-line
+                         (lambda (n port offset width)
+                           (display
+                            (if n
+                                (if (zero? n) first
+                                    (format "~n~a" rest))
+                                (format "~n"))
+                            port)
+                           (if n
+                               (if (zero? n)
+                                   (string-length first)
+                                   (string-length rest))
+                               0))))
+           (pretty-print (append (cons name args)
+                                 (apply append (map list kws kw-vals)))))))))
+  
   (define -:trace-print-results
     (lambda (name results level)
       (as-trace-notify
@@ -197,6 +195,8 @@
   ;;  the nesting depth:
   (define -:trace-level-key (gensym))
 
+  (define (trace-apply id f kws kw-vals . args) (do-traced id args kws kw-vals f))
+  
   ;; Apply a traced procedure to arguments, printing arguments
   ;; and results. We set and inspect the -:trace-level-key continuation
   ;; mark a few times to detect tail calls.