diff --git a/racket/syndicate/trace.rkt b/racket/syndicate/trace.rkt index 94977b9..ffcbb9b 100644 --- a/racket/syndicate/trace.rkt +++ b/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) - (log-message trace-logger 'info typ "" (trace-notification src snk typ det) #f))) + (let ((trace-procedures (current-trace-procedures))) + (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 diff --git a/racket/syndicate/trace/stderr.rkt b/racket/syndicate/trace/stderr.rkt index 56b1725..c3741c3 100644 --- a/racket/syndicate/trace/stderr.rkt +++ b/racket/syndicate/trace/stderr.rkt @@ -165,13 +165,20 @@ (format-pids sink) (pretty-format body)))])) -(define (display-trace) - (define receiver (make-log-receiver trace-logger 'info)) +(define (install-trace-procedure!) + (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 - (thread display-trace))) +(void (when (not (set-empty? flags)) + (thread (display-trace (install-trace-procedure!)))))