Added trace-define, trace-let, trace-lambda

In racket/collects/racket/trace.rkt

pkgs/racket-pkgs/racket-doc/scribblings/reference/trace.scrbl

@@ -3,7 +3,8 @@
           scribble/eval)
 
 @(begin (define ev (make-base-eval))
-        (ev '(require racket/trace)))
+        (ev '(require racket/trace))
+        (ev '(require (for-syntax racket/base))))
 
 @title{Tracing}
 
@@ -49,6 +50,79 @@ The result of a @racket[trace] expression is @|void-const|.
 
 }
 
+@defform*[((trace-define id expr)
+           (trace-define (head args) body ...+))]{
+
+The @racket[trace-define] form is short-hand for first defining a
+function then tracing it. This form supports all @racket[define] forms.
+
+@examples[#:eval ev
+(trace-define (f x) (if (zero? x) 0 (add1 (f (sub1 x)))))
+(f 5)
+]
+
+@examples[#:eval ev
+(trace-define ((+n n) x) (+ n x))
+(map (+n 5) (list 1 3 4))
+]}
+
+@defform*[((trace-define-syntax id expr)
+           (trace-define-syntax (head args) body ...+))]{
+
+The @racket[trace-define-syntax] form is short-hand for first defining a
+macro then tracing it. This form supports all @racket[define-syntax] forms.
+
+For example:
+
+@examples[#:eval ev
+(trace-define-syntax fact
+  (syntax-rules ()
+    [(_ x) 120]))
+(fact 5)
+]
+
+By default, @racket[trace] prints out syntax objects when tracing a
+macro. This can result in too much output if you do not need to see,
+e.g., source information. To get more readable output, try this:
+
+@examples[#:eval ev
+  (require (for-syntax racket/trace))
+  (begin-for-syntax
+    (current-trace-print-args
+      (let ([ctpa (current-trace-print-args)])
+        (lambda (s l kw l2 n)
+          (ctpa s (map syntax->datum l) kw l2 n))))
+    (current-trace-print-results
+      (let ([ctpr (current-trace-print-results)])
+        (lambda (s l n)
+         (ctpr s (map syntax->datum l) n)))))
+
+  (trace-define-syntax fact
+  (syntax-rules ()
+    [(_ x) #'120]))
+  (fact 5)]}
+
+@defform[(trace-lambda [#:name id] args expr)]{
+
+The @racket[trace-lambda] form enables tracing an anonymous function. This
+form will attempt to infer a name using
+@racket[syntax-local-infer-name], or a name can be specified using the
+optional @racket[#:name] argument.  A syntax error is raised if a name
+is not given and a name cannot be inferred.
+
+@examples[#:eval ev
+  ((trace-lambda (x) 120) 5)]}
+
+@defform[(trace-let id ([arg expr] ...+) body ...+)]{
+
+The @racket[trace-let] form enables tracing a named let.
+
+@examples[#:eval ev
+  (trace-let f ([x 5])
+    (if (zero? x)
+        1
+        (* x (f (sub1 x)))))]}
+
 @defform[(untrace id ...)]{
 
 Undoes the effects of the @racket[trace] form for each @racket[id],

pkgs/racket-pkgs/racket-test/tests/racket/trace.rktl

@@ -69,4 +69,43 @@
         (list ">(f (1 2 3) #:q #&18)"
               "<((1 2 3) 1)")))
 
+(test
+  (list ">(verbose-fact 2)"
+        "> (verbose-fact 1)"
+        "> >(verbose-fact 0)"
+        "< <1"
+        "> >(verbose-fact 0)"
+        "< <1"
+        "< 1"
+        "> (verbose-fact 1)"
+        "> >(verbose-fact 0)"
+        "< <1"
+        "> >(verbose-fact 0)"
+        "< <1"
+        "< 1"
+        "<2")
+  'trace-define
+  (trace-output
+    (trace-define (verbose-fact x)
+      (if (zero? x)
+        (begin (displayln 1) 1)
+        (begin (displayln (* x (verbose-fact (sub1 x))))
+               (* x (verbose-fact (sub1 x))))))
+    (parameterize ([current-output-port (open-output-nowhere)]) (verbose-fact 2))))
+
+(test
+  (list ">(fact 120)"
+        "<120")
+  'trace-lambda-named
+  (trace-output
+    ((trace-lambda #:name fact (x) x) 120)))
+
+(let ([tout (trace-output ((trace-lambda (x) x) 120))])
+  (local-require racket/match)
+  (test #t
+        'trace-lambda-anonymous
+        (match tout
+          [(list (pregexp #px">\\(.+\\.rktl?:\\d+:\\d+ 120\\)") "<120") #t]
+          [_ #f])))
+
 (report-errs)

racket/collects/racket/trace.rkt

@@ -1,34 +1,35 @@
 #lang racket/base
 
-(require racket/pretty
+(module trace-et-al racket/base
+  (require racket/pretty
            (for-syntax racket/base))
 
-(provide trace untrace
+  (provide trace untrace
            current-trace-print-results
            current-trace-print-args
            trace-call
            current-trace-notify
            current-prefix-out current-prefix-in)
 
-(define max-dash-space-depth 10)
+  (define max-dash-space-depth 10)
-(define number-nesting-depth 6)
+  (define number-nesting-depth 6)
-(define current-prefix-out (make-parameter "<"))
+  (define current-prefix-out (make-parameter "<"))
-(define current-prefix-in (make-parameter ">"))
+  (define current-prefix-in (make-parameter ">"))
 
-(define (as-spaces s)
+  (define (as-spaces s)
     (make-string (string-length s) #\space))
 
-(define-struct prefix-entry (for-first for-rest))
+  (define-struct prefix-entry (for-first for-rest))
 
-(define prefixes (make-hash))
+  (define prefixes (make-hash))
 
-(define (lookup-prefix n label)
+  (define (lookup-prefix n label)
     (hash-ref prefixes (cons n label) (lambda () #f)))
 
-(define (insert-prefix n label first rest)
+  (define (insert-prefix n label first rest)
     (hash-set! prefixes (cons n label) (make-prefix-entry first rest)))
 
-(define (construct-prefixes level label)
+  (define (construct-prefixes level label)
     (let loop ([n level]
               [first (list label)]
               [rest '(" ")])
@@ -49,7 +50,7 @@
                       (cons (format " ~a" label) first)
                       (cons "  " rest))]))))
 
-(define (build-prefixes level label)
+  (define (build-prefixes level label)
     (let ([p (lookup-prefix level label)])
       (if p
         (values (prefix-entry-for-first p)
@@ -59,7 +60,7 @@
           (insert-prefix level label first rest)
           (values first rest)))))
 
-(define current-trace-notify
+  (define current-trace-notify
     (make-parameter (lambda (s)
                       (display s)
                       (newline))
@@ -71,7 +72,7 @@
                                               p))
                       p)))
 
-(define (as-trace-notify thunk)
+  (define (as-trace-notify thunk)
     (let ([p (open-output-bytes)])
       (parameterize ([current-output-port p])
         (thunk))
@@ -80,17 +81,17 @@
                                 (sub1 (file-position p)))])
         ((current-trace-notify) (bytes->string/utf-8 b)))))
 
-(define -:trace-print-args
+  (define -:trace-print-args
     (lambda (name args kws kw-vals level)
       (as-trace-notify
         (lambda ()
           ((current-trace-print-args) name args kws kw-vals level)))))
 
-(struct plain (val)
+  (struct plain (val)
           #:property prop:custom-write (lambda (p port mode)
                                         (write (plain-val p) port)))
 
-(define current-trace-print-args
+  (define current-trace-print-args
     (make-parameter
       (lambda (name args kws kw-vals level)
         (let-values (((first rest)
@@ -131,13 +132,13 @@
                 (pretty-write (append (cons name args)
                                       (apply append (map list kws kw-vals))))]))))))
 
-(define -:trace-print-results
+  (define -:trace-print-results
     (lambda (name results level)
       (as-trace-notify
         (lambda ()
           ((current-trace-print-results) name results level)))))
 
-(define current-trace-print-results
+  (define current-trace-print-results
     (make-parameter
       (lambda (name results level)
         (let-values (((first rest)
@@ -174,17 +175,17 @@
                   (for-each pretty-print (cdr results))))))))))
 
 
-;; A traced-proc struct instance acts like a procedure,
+  ;; A traced-proc struct instance acts like a procedure,
-;;  but preserves the original, too.
+  ;;  but preserves the original, too.
-(define-values (struct:traced-proc make-traced-proc traced-proc? traced-proc-ref traced-proc-set!)
+  (define-values (struct:traced-proc make-traced-proc traced-proc? traced-proc-ref traced-proc-set!)
     (make-struct-type 'traced-proc #f 2 0 #f
                       (list (cons prop:procedure 0))
                       (current-inspector) #f (list 0 1)))
 
-;; Install traced versions of a given set of procedures.  The traced
+  ;; Install traced versions of a given set of procedures.  The traced
-;;  versions are also given, so that they can be constructed to have
+  ;;  versions are also given, so that they can be constructed to have
-;;  a nice name.
+  ;;  a nice name.
-(define (do-trace ids procs setters traced-procs)
+  (define (do-trace ids procs setters traced-procs)
     (for-each (lambda (id proc)
                 (unless (procedure? proc)
                   (error 'trace
@@ -202,21 +203,21 @@
                             proc))))
               procs setters traced-procs))
 
-;; Key used for a continuation mark to indicate
+  ;; Key used for a continuation mark to indicate
-;;  the nesting depth:
+  ;;  the nesting depth:
-(define -:trace-level-key (gensym))
+  (define -:trace-level-key (gensym))
 
-(define trace-call
+  (define trace-call
     (make-keyword-procedure
       (lambda (id f kws vals . args)
         (do-traced id args kws vals f))
       (lambda (id f . args)
         (do-traced id args '() '() f))))
 
-;; Apply a traced procedure to arguments, printing arguments
+  ;; Apply a traced procedure to arguments, printing arguments
-;; and results. We set and inspect the -:trace-level-key continuation
+  ;; and results. We set and inspect the -:trace-level-key continuation
-;; mark a few times to detect tail calls.
+  ;; mark a few times to detect tail calls.
-(define (do-traced id args kws kw-vals real-value)
+  (define (do-traced id args kws kw-vals real-value)
     (let* ([levels (continuation-mark-set->list
                     (current-continuation-marks)
                     -:trace-level-key)]
@@ -261,13 +262,13 @@
                                                                 ;; Return the results:
                                                                 (apply values results))))))))))
 
-(define-for-syntax (check-ids stx ids)
+  (define-for-syntax (check-ids stx ids)
                     (for ([id (in-list (syntax->list ids))])
                       (unless (identifier? id)
                         (raise-syntax-error #f "not an identifier" stx id)))
                     #t)
 
-(define-syntax (trace stx)
+  (define-syntax (trace stx)
     (syntax-case stx ()
       [(_ id ...) (check-ids stx #'(id ...))
                   (with-syntax ([(tid ...)
@@ -287,9 +288,62 @@
                                 tid)
                               ...)))]))
 
-(define-syntax (untrace stx)
+  (define-syntax (untrace stx)
     (syntax-case stx ()
       [(_ id ...) (check-ids stx #'(id ...))
                   #'(begin (when (traced-proc? id)
                             (set! id (traced-proc-ref id 1)))
-              ...)]))
+                          ...)])))
+
+(module chez-like racket/base
+  (require
+    (only-in (submod ".." trace-et-al) trace)
+    (for-syntax
+      racket/base
+      syntax/define
+      syntax/name
+      syntax/parse
+      (only-in (submod ".." trace-et-al) trace)))
+
+  (provide trace-define trace-lambda trace-let trace-define-syntax)
+
+  (define-syntax (trace-define stx)
+    (syntax-case stx ()
+      [(_ e ...)
+      (let-values ([(name def) (normalize-definition stx #'lambda)])
+        #`(begin (define #,name #,def) (trace #,name)))]))
+
+  (define-syntax trace-let
+    (syntax-rules ()
+      [(_ name ([x* e*] ...) body ...)
+      ((letrec ([name (lambda (x* ...) body ...)]) (trace name) name)
+        e* ...)]))
+
+  (define-syntax (trace-lambda stx)
+    (define (infer-name-or-error)
+      (or (syntax-local-infer-name stx)
+        (raise-syntax-error
+          'trace-lambda
+          "Could not infer name; give a name explicitly using #:name"
+          stx)))
+    (syntax-parse stx
+      [(_ (~optional (~seq #:name name:id) #:defaults ([name #`#,(infer-name-or-error)])) args body:expr ...)
+      #'(let ([name (lambda args body ...)]) (trace name) name)]))
+
+  (define-syntax (trace-define-syntax stx)
+    (syntax-case stx ()
+      [(_ e ...)
+      (let-values ([(name def) (normalize-definition stx #'lambda)])
+        #`(define-syntax #,name
+            (let ([#,name #,def]) (trace #,name) #,name)))])))
+
+(require 'trace-et-al 'chez-like)
+(provide trace untrace
+         current-trace-print-results
+         current-trace-print-args
+         trace-call
+         current-trace-notify
+         current-prefix-out current-prefix-in
+
+         trace-define trace-let trace-lambda
+         trace-define-syntax)