trace-logger --> current-trace-procedures
This commit is contained in:
parent
ca1c0f6645
commit
fb3ed65831
|
@ -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
|
||||
|
|
|
@ -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!)))))
|
||||
|
|
Loading…
Reference in New Issue