trace-logger --> current-trace-procedures

racket/syndicate/trace.rkt

@@ -1,6 +1,6 @@
 #lang racket/base
 
-(provide trace-logger
+(provide current-trace-procedures
          trace-turn-begin
          trace-turn-end
          trace-actor-spawn
@@ -51,11 +51,13 @@
 
 (struct trace-notification (source sink type detail) #:prefab)
 
-(define trace-logger (make-logger 'syndicate-trace))
+(define current-trace-procedures (make-parameter '()))
 
 (define-syntax-rule (notify! src snk typ det)
-  (when (log-level? trace-logger 'info)
+  (let ((trace-procedures (current-trace-procedures)))
-    (log-message trace-logger 'info typ "" (trace-notification src snk typ det) #f)))
+    (when (pair? trace-procedures)
+      (define n (trace-notification src snk typ det))
+      (for-each (lambda (procedure) (procedure n)) trace-procedures))))
 
 (define (cons-pid pid)
   (if pid

racket/syndicate/trace/stderr.rkt

@@ -165,13 +165,20 @@
                (format-pids sink)
                (pretty-format body)))]))
 
-(define (display-trace)
+(define (install-trace-procedure!)
-  (define receiver (make-log-receiver trace-logger 'info))
+  (define logger (make-logger 'syndicate-trace))
+  (define (trace-via-logger n)
+    (log-message logger 'info (trace-notification-type n) "" n #f))
+  (current-trace-procedures (cons trace-via-logger (current-trace-procedures)))
+  logger)
+
+(define ((display-trace logger))
+  (define receiver (make-log-receiver logger 'info))
   (parameterize ((pretty-print-columns 100))
     (let loop ()
       (match-define (vector level message-string data event-name) (sync receiver))
       (display-notification data)
       (loop))))
 
-(void (when (not #f) ;; TODO
+(void (when (not (set-empty? flags))
-	(thread display-trace)))
+        (thread (display-trace (install-trace-procedure!)))))