summarise-ground-state with SIGUSR2
This commit is contained in:
parent
4a39a03a0a
commit
d442f4890f
|
@ -64,6 +64,7 @@
|
||||||
(define YELLOW-ON-RED ";1;33;41")
|
(define YELLOW-ON-RED ";1;33;41")
|
||||||
(define WHITE-ON-RED ";1;37;41")
|
(define WHITE-ON-RED ";1;37;41")
|
||||||
(define WHITE-ON-GREEN ";1;37;42")
|
(define WHITE-ON-GREEN ";1;37;42")
|
||||||
|
(define WHITE-ON-BLUE ";1;37;44")
|
||||||
(define GREY-ON-RED ";37;41")
|
(define GREY-ON-RED ";37;41")
|
||||||
(define GREY-ON-GREEN ";37;42")
|
(define GREY-ON-GREEN ";37;42")
|
||||||
(define RED ";31")
|
(define RED ";31")
|
||||||
|
@ -115,7 +116,7 @@
|
||||||
(define (forget-process! process-names pids)
|
(define (forget-process! process-names pids)
|
||||||
(hash-remove! process-names pids))
|
(hash-remove! process-names pids))
|
||||||
|
|
||||||
(define (display-notification the-notification process-names)
|
(define (display-notification the-notification process-names ground-state-box)
|
||||||
(match-define (trace-notification source sink type detail) the-notification)
|
(match-define (trace-notification source sink type detail) the-notification)
|
||||||
(match* (type detail)
|
(match* (type detail)
|
||||||
[('turn-begin (process name _beh state))
|
[('turn-begin (process name _beh state))
|
||||||
|
@ -125,6 +126,7 @@
|
||||||
(output "~a turn begins\n" (format-pids process-names sink))))]
|
(output "~a turn begins\n" (format-pids process-names sink))))]
|
||||||
[('turn-end (process name _beh state))
|
[('turn-end (process name _beh state))
|
||||||
(ensure-process-named! process-names sink name)
|
(ensure-process-named! process-names sink name)
|
||||||
|
(when (null? sink) (set-box! ground-state-box state))
|
||||||
(when show-turns?
|
(when show-turns?
|
||||||
(with-color BLUE
|
(with-color BLUE
|
||||||
(output "~a turn ends\n" (format-pids process-names sink))
|
(output "~a turn ends\n" (format-pids process-names sink))
|
||||||
|
@ -192,6 +194,9 @@
|
||||||
(format-pids process-names sink)
|
(format-pids process-names sink)
|
||||||
(pretty-format body)))]))
|
(pretty-format body)))]))
|
||||||
|
|
||||||
|
(define (summarise-ground-state state)
|
||||||
|
(syndicate-pretty-print state (current-error-port)))
|
||||||
|
|
||||||
(define (install-trace-procedure!)
|
(define (install-trace-procedure!)
|
||||||
(define logger (make-logger 'syndicate-trace))
|
(define logger (make-logger 'syndicate-trace))
|
||||||
(define (trace-via-logger n)
|
(define (trace-via-logger n)
|
||||||
|
@ -204,11 +209,15 @@
|
||||||
(dynamic-require 'unix-signals 'capture-signal!)))
|
(dynamic-require 'unix-signals 'capture-signal!)))
|
||||||
(and capture-signal!
|
(and capture-signal!
|
||||||
(begin (capture-signal! 'SIGUSR1)
|
(begin (capture-signal! 'SIGUSR1)
|
||||||
(dynamic-require 'unix-signals 'next-signal-evt))))
|
(capture-signal! 'SIGUSR2)
|
||||||
|
(let ((lookup-signal-name (dynamic-require 'unix-signals 'lookup-signal-name)))
|
||||||
|
(handle-evt (dynamic-require 'unix-signals 'next-signal-evt)
|
||||||
|
lookup-signal-name)))))
|
||||||
|
|
||||||
(define ((display-trace logger))
|
(define ((display-trace logger))
|
||||||
(define receiver (make-log-receiver logger 'info))
|
(define receiver (make-log-receiver logger 'info))
|
||||||
(define process-names (make-hash))
|
(define process-names (make-hash))
|
||||||
|
(define ground-state-box (box #f))
|
||||||
(name-process! process-names '() 'ground) ;; by convention
|
(name-process! process-names '() 'ground) ;; by convention
|
||||||
(define next-signal-evt (check-for-unix-signals-support!))
|
(define next-signal-evt (check-for-unix-signals-support!))
|
||||||
(parameterize ((pretty-print-columns 100))
|
(parameterize ((pretty-print-columns 100))
|
||||||
|
@ -216,15 +225,21 @@
|
||||||
(sync (handle-evt receiver
|
(sync (handle-evt receiver
|
||||||
(lambda (v)
|
(lambda (v)
|
||||||
(match-define (vector level message-string data event-name) v)
|
(match-define (vector level message-string data event-name) v)
|
||||||
(display-notification data process-names)
|
(display-notification data process-names ground-state-box)
|
||||||
(loop)))
|
(loop)))
|
||||||
(if next-signal-evt
|
(if next-signal-evt
|
||||||
(handle-evt next-signal-evt
|
(handle-evt next-signal-evt
|
||||||
(lambda (_signum)
|
(lambda (signame)
|
||||||
|
(match signame
|
||||||
|
['SIGUSR1
|
||||||
(with-color WHITE-ON-GREEN
|
(with-color WHITE-ON-GREEN
|
||||||
(output "\e[2J\e[HProcess name table:\n")
|
(output "\e[2J\e[HProcess name table:\n")
|
||||||
(for [((pid name) (in-hash process-names))]
|
(for [((pid name) (in-hash process-names))]
|
||||||
(output "\t~v\t--> ~v\n" pid name)))
|
(output "\t~v\t--> ~v\n" pid name)))]
|
||||||
|
['SIGUSR2
|
||||||
|
(with-color WHITE-ON-BLUE
|
||||||
|
(output "\e[2J\e[HGround routing table:\n")
|
||||||
|
(summarise-ground-state (unbox ground-state-box)))])
|
||||||
(loop)))
|
(loop)))
|
||||||
never-evt)))))
|
never-evt)))))
|
||||||
|
|
||||||
|
|
Loading…
Reference in New Issue