PR 10009 and added tracing to metafunctions

svn: r13028

collects/redex/HISTORY

@@ -1,3 +1,8 @@
+  - Added tracing to metafunctions (see current-traced-metafunctions)
+
+  - added caching-enabled? parameter (changed how set-cache-size! 
+    works)
+
 v4.2
 
   - added white-bracket-sizing to control how the brackets

collects/redex/private/reduction-semantics.ss

@@ -5,6 +5,7 @@
          "term.ss"
          "loc-wrapper.ss"
 	 "error.ss"
+         mzlib/trace
          (lib "list.ss")
          (lib "etc.ss"))
 
@@ -1164,14 +1165,23 @@
                                                 `(,name ,@exp)
                                                 (length mtchs))]
                                   [else
-                                   (let ([ans (rhs metafunc (mtch-bindings (car mtchs)))])
+                                   (let ([ans (rhs traced-metafunc (mtch-bindings (car mtchs)))])
                                      (unless (match-pattern codom-compiled-pattern ans)
                                        (redex-error name "codomain test failed for ~s, call was ~s" ans `(,name ,@exp)))
                                      (hash-set! cache exp ans)
                                      ans)])))]))]
                       [else 
-                       cache-ref])))])
-        metafunc)
+                       cache-ref])))]
+               [ot (current-trace-print-args)]
+               [traced-metafunc (lambda (exp)
+                                  (if (or (eq? (current-traced-metafunctions) 'all)
+                                          (memq name (current-traced-metafunctions)))
+                                      (parameterize ([current-trace-print-args
+                                                      (λ (name args kws kw-args level)
+                                                        (ot name (car args) kws kw-args level))])
+                                        (trace-apply name metafunc '() '() exp))
+                                      (metafunc exp)))])
+        traced-metafunc)
       compiled-patterns
       rhss)
      (if dom-compiled-pattern
@@ -1179,6 +1189,8 @@
          (λ (exp) (and (ormap (λ (pat) (match-pattern pat exp)) compiled-patterns) 
                        #t))))))
 
+(define current-traced-metafunctions (make-parameter '()))
+
 (define-syntax (metafunction-form stx)
   (syntax-case stx ()
     [(_ id)
@@ -1788,6 +1800,7 @@
          (rename-out [metafunction-form metafunction])
          metafunction? metafunction-proc
          in-domain?
+         current-traced-metafunctions
          metafunc-proc-lang
          metafunc-proc-pict-info
          metafunc-proc-name

collects/redex/private/tl-test.ss

@@ -507,6 +507,29 @@
             'no-exn)
           'no-exn))
     
+  ;; test that tracing works properly
+  ;; note that caching comes into play here (which is why we don't see the recursive calls)
+  (let ()
+    (define-metafunction empty-language
+      [(f 0) 0]
+      [(f number) (f ,(- (term number) 1))])
+    
+    (let ([sp (open-output-string)])
+      (parameterize ([current-output-port sp])
+        (term (f 1)))
+      (test (get-output-string sp) ""))
+    
+    (let ([sp (open-output-string)])
+      (parameterize ([current-output-port sp]
+                     [current-traced-metafunctions 'all])
+        (term (f 1)))
+      (test (get-output-string sp) "|(f 1)\n|0\n"))
+    
+    (let ([sp (open-output-string)])
+      (parameterize ([current-output-port sp]
+                     [current-traced-metafunctions '(f)])
+        (term (f 1)))
+      (test (get-output-string sp) "|(f 1)\n|0\n")))
   
 
 ;                                                                                                                                

collects/redex/private/traces.ss

@@ -149,10 +149,12 @@
   ;; only changed on the reduction thread
   ;; frontier : (listof (is-a?/c graph-editor-snip%))
   (define frontier 
-    (map (lambda (expr) (build-snip snip-cache #f expr pred pp 
-                                    (dark-pen-color) (light-pen-color)
-                                    (dark-text-color) (light-text-color) #f))
-         exprs))
+    (filter
+     (λ (x) x)
+     (map (lambda (expr) (build-snip snip-cache #f expr pred pp 
+                                     (dark-pen-color) (light-pen-color)
+                                     (dark-text-color) (light-text-color) #f))
+          exprs)))
   
   ;; set-font-size : number -> void
   ;; =eventspace main thread=
@@ -516,15 +518,14 @@
 (define (build-snip cache parent-snip expr pred pp light-arrow-color dark-arrow-color dark-label-color light-label-color name)
   (let-values ([(snip new?)
                 (let/ec k
-                  (k
-                   (hash-ref
-                    cache
-                    expr
-                    (lambda ()
-                      (let ([new-snip (make-snip parent-snip expr pred pp)])
-                        (hash-set! cache expr new-snip)
-                        (k new-snip #t))))
-                   #f))])
+                  (values (hash-ref
+                           cache
+                           expr
+                           (lambda ()
+                             (let ([new-snip (make-snip parent-snip expr pred pp)])
+                               (hash-set! cache expr new-snip)
+                               (k new-snip #t))))
+                          #f))])
 
     (when parent-snip
       (send snip record-edge-label parent-snip name)

collects/redex/redex.scrbl

@@ -944,6 +944,16 @@ legtimate inputs according to @scheme[metafunction-name]'s contract,
 and @scheme[#f] otherwise.
 }
 
+@defparam[current-traced-metafunctions traced-metafunctions (or/c 'all (listof symbol?))]{
+
+Controls which metafunctions are currently being traced. If it is
+@scheme['all], all of them are. Otherwise, the elements of the list
+name the metafunctions to trace. 
+
+Defaults to @scheme['()].
+
+}
+
 @section{Testing}
 
 All of the exports in this section are provided both by

collects/redex/reduction-semantics.ss

@@ -30,7 +30,6 @@
          define-metafunction/extension
          metafunction
          in-domain?
-         
          caching-enabled?)
 
 (provide (rename-out [test-match redex-match])
@@ -45,6 +44,7 @@
          test-results)
 
 (provide/contract
+ [current-traced-metafunctions (parameter/c (or/c 'all (listof symbol?)))]
  [reduction-relation->rule-names (-> reduction-relation? (listof symbol?))]
  [language-nts (-> compiled-lang? (listof symbol?))]
  [set-cache-size! (-> number? void?)]