Make pretty-printed output a little wider
This commit is contained in:
parent
bc3e5be900
commit
2466fe61c1
|
@ -74,107 +74,108 @@
|
||||||
|
|
||||||
(define (display-trace)
|
(define (display-trace)
|
||||||
(define receiver (make-log-receiver trace-logger 'info))
|
(define receiver (make-log-receiver trace-logger 'info))
|
||||||
(let loop ()
|
(parameterize ((pretty-print-columns 100))
|
||||||
(match-define (vector level message-string data event-name) (sync receiver))
|
(let loop ()
|
||||||
(match* (event-name data)
|
(match-define (vector level message-string data event-name) (sync receiver))
|
||||||
[('process-step (list pids e p exn t))
|
(match* (event-name data)
|
||||||
(define pidstr (format-pids pids))
|
[('process-step (list pids e p exn t))
|
||||||
(define relevant-exn? (and show-exceptions? exn))
|
|
||||||
(match e
|
|
||||||
[#f
|
|
||||||
(when (or relevant-exn? show-events?)
|
|
||||||
(with-color YELLOW (output "~a was polled for changes.\n" pidstr)))]
|
|
||||||
[(routing-update g)
|
|
||||||
(when (or relevant-exn? show-events?)
|
|
||||||
(with-color YELLOW
|
|
||||||
(output "~a received a routing-update:\n" pidstr)
|
|
||||||
(pretty-print-gestalt g (current-error-port))))]
|
|
||||||
[(message body meta-level feedback?)
|
|
||||||
(when (or relevant-exn? show-events?)
|
|
||||||
(with-color YELLOW
|
|
||||||
(output "~a received ~a at metalevel ~a:\n"
|
|
||||||
pidstr
|
|
||||||
(if feedback? "feedback" "a message")
|
|
||||||
meta-level)
|
|
||||||
(pretty-write body (current-error-port))))])
|
|
||||||
(when (or relevant-exn? show-process-states-pre?)
|
|
||||||
(when (or relevant-exn? (not (boring-state? (process-state p))))
|
|
||||||
(with-color YELLOW
|
|
||||||
(output "~a's state just before the event:\n" pidstr)
|
|
||||||
(output-state (process-state p)))))
|
|
||||||
(when relevant-exn?
|
|
||||||
(with-color WHITE-ON-RED
|
|
||||||
(output "Process ~a died with exception:\n~a\n"
|
|
||||||
pidstr
|
|
||||||
(exn->string exn))))
|
|
||||||
(when (or relevant-exn? show-process-states-post?)
|
|
||||||
(when t
|
|
||||||
(unless (boring-state? (transition-state t))
|
|
||||||
(when (not (equal? (process-state p) (transition-state t)))
|
|
||||||
(with-color YELLOW
|
|
||||||
(output "~a's state just after the event:\n" pidstr)
|
|
||||||
(output-state (transition-state t)))))))]
|
|
||||||
[('internal-step (list pids a old-w t))
|
|
||||||
(when t ;; inert worlds don't change interestingly
|
|
||||||
(define pidstr (format-pids pids))
|
(define pidstr (format-pids pids))
|
||||||
(define new-w (transition-state t))
|
(define relevant-exn? (and show-exceptions? exn))
|
||||||
(define old-processes (world-process-table old-w))
|
(match e
|
||||||
(define new-processes (world-process-table new-w))
|
[#f
|
||||||
(define newcount (hash-count new-processes))
|
(when (or relevant-exn? show-events?)
|
||||||
(match a
|
(with-color YELLOW (output "~a was polled for changes.\n" pidstr)))]
|
||||||
[(process gestalt behavior state)
|
|
||||||
(when (or show-process-lifecycle? show-actions?)
|
|
||||||
(define newpid (set-first (set-subtract (hash-keys new-processes)
|
|
||||||
(hash-keys old-processes))))
|
|
||||||
(define newpidstr (format-pids (cons newpid (cdr pids)))) ;; replace parent pid
|
|
||||||
(with-color BRIGHT-GREEN
|
|
||||||
(output "~a ~v spawned from ~a (~a total processes now)\n"
|
|
||||||
newpidstr
|
|
||||||
behavior
|
|
||||||
pidstr
|
|
||||||
newcount))
|
|
||||||
(unless (boring-state? state)
|
|
||||||
(output "~a's initial state:\n" newpidstr)
|
|
||||||
(output-state state))
|
|
||||||
(unless (gestalt-empty? gestalt)
|
|
||||||
(output "~a's initial gestalt:\n" newpidstr)
|
|
||||||
(pretty-print-gestalt gestalt (current-error-port))))]
|
|
||||||
[(quit)
|
|
||||||
(when (or show-process-lifecycle? show-actions?)
|
|
||||||
(match (hash-ref old-processes (car pids) (lambda () #f))
|
|
||||||
[#f (void)]
|
|
||||||
[(process gestalt behavior state)
|
|
||||||
(with-color BRIGHT-RED
|
|
||||||
(output "~a ~v exited (~a total processes now)\n"
|
|
||||||
pidstr
|
|
||||||
(if (trigger-guard? state)
|
|
||||||
(trigger-guard-handler state)
|
|
||||||
behavior)
|
|
||||||
newcount))
|
|
||||||
(unless (boring-state? state)
|
|
||||||
(output "~a's final state:\n" pidstr)
|
|
||||||
(output-state state))
|
|
||||||
(unless (gestalt-empty? gestalt)
|
|
||||||
(output "~a's final gestalt:\n" pidstr)
|
|
||||||
(pretty-print-gestalt gestalt (current-error-port)))]))]
|
|
||||||
[(routing-update g)
|
[(routing-update g)
|
||||||
(when show-actions?
|
(when (or relevant-exn? show-events?)
|
||||||
(output "~a performed a routing-update:\n" pidstr)
|
(with-color YELLOW
|
||||||
(pretty-print-gestalt g (current-error-port)))]
|
(output "~a received a routing-update:\n" pidstr)
|
||||||
|
(pretty-print-gestalt g (current-error-port))))]
|
||||||
[(message body meta-level feedback?)
|
[(message body meta-level feedback?)
|
||||||
(when show-actions?
|
(when (or relevant-exn? show-events?)
|
||||||
(output "~a sent ~a at metalevel ~a:\n"
|
(with-color YELLOW
|
||||||
pidstr
|
(output "~a received ~a at metalevel ~a:\n"
|
||||||
(if feedback? "feedback" "a message")
|
pidstr
|
||||||
meta-level)
|
(if feedback? "feedback" "a message")
|
||||||
(pretty-write body (current-error-port)))])
|
meta-level)
|
||||||
(when show-world-gestalt?
|
(pretty-write body (current-error-port))))])
|
||||||
(when (not (equal? (world-full-gestalt old-w) (world-full-gestalt new-w)))
|
(when (or relevant-exn? show-process-states-pre?)
|
||||||
(with-color BRIGHT-BLUE
|
(when (or relevant-exn? (not (boring-state? (process-state p))))
|
||||||
(output "~a's full gestalt:\n" (format-pids (cdr pids)))
|
(with-color YELLOW
|
||||||
(pretty-print-gestalt (world-full-gestalt new-w)
|
(output "~a's state just before the event:\n" pidstr)
|
||||||
(current-error-port))))))])
|
(output-state (process-state p)))))
|
||||||
(loop)))
|
(when relevant-exn?
|
||||||
|
(with-color WHITE-ON-RED
|
||||||
|
(output "Process ~a died with exception:\n~a\n"
|
||||||
|
pidstr
|
||||||
|
(exn->string exn))))
|
||||||
|
(when (or relevant-exn? show-process-states-post?)
|
||||||
|
(when t
|
||||||
|
(unless (boring-state? (transition-state t))
|
||||||
|
(when (not (equal? (process-state p) (transition-state t)))
|
||||||
|
(with-color YELLOW
|
||||||
|
(output "~a's state just after the event:\n" pidstr)
|
||||||
|
(output-state (transition-state t)))))))]
|
||||||
|
[('internal-step (list pids a old-w t))
|
||||||
|
(when t ;; inert worlds don't change interestingly
|
||||||
|
(define pidstr (format-pids pids))
|
||||||
|
(define new-w (transition-state t))
|
||||||
|
(define old-processes (world-process-table old-w))
|
||||||
|
(define new-processes (world-process-table new-w))
|
||||||
|
(define newcount (hash-count new-processes))
|
||||||
|
(match a
|
||||||
|
[(process gestalt behavior state)
|
||||||
|
(when (or show-process-lifecycle? show-actions?)
|
||||||
|
(define newpid (set-first (set-subtract (hash-keys new-processes)
|
||||||
|
(hash-keys old-processes))))
|
||||||
|
(define newpidstr (format-pids (cons newpid (cdr pids)))) ;; replace parent pid
|
||||||
|
(with-color BRIGHT-GREEN
|
||||||
|
(output "~a ~v spawned from ~a (~a total processes now)\n"
|
||||||
|
newpidstr
|
||||||
|
behavior
|
||||||
|
pidstr
|
||||||
|
newcount))
|
||||||
|
(unless (boring-state? state)
|
||||||
|
(output "~a's initial state:\n" newpidstr)
|
||||||
|
(output-state state))
|
||||||
|
(unless (gestalt-empty? gestalt)
|
||||||
|
(output "~a's initial gestalt:\n" newpidstr)
|
||||||
|
(pretty-print-gestalt gestalt (current-error-port))))]
|
||||||
|
[(quit)
|
||||||
|
(when (or show-process-lifecycle? show-actions?)
|
||||||
|
(match (hash-ref old-processes (car pids) (lambda () #f))
|
||||||
|
[#f (void)]
|
||||||
|
[(process gestalt behavior state)
|
||||||
|
(with-color BRIGHT-RED
|
||||||
|
(output "~a ~v exited (~a total processes now)\n"
|
||||||
|
pidstr
|
||||||
|
(if (trigger-guard? state)
|
||||||
|
(trigger-guard-handler state)
|
||||||
|
behavior)
|
||||||
|
newcount))
|
||||||
|
(unless (boring-state? state)
|
||||||
|
(output "~a's final state:\n" pidstr)
|
||||||
|
(output-state state))
|
||||||
|
(unless (gestalt-empty? gestalt)
|
||||||
|
(output "~a's final gestalt:\n" pidstr)
|
||||||
|
(pretty-print-gestalt gestalt (current-error-port)))]))]
|
||||||
|
[(routing-update g)
|
||||||
|
(when show-actions?
|
||||||
|
(output "~a performed a routing-update:\n" pidstr)
|
||||||
|
(pretty-print-gestalt g (current-error-port)))]
|
||||||
|
[(message body meta-level feedback?)
|
||||||
|
(when show-actions?
|
||||||
|
(output "~a sent ~a at metalevel ~a:\n"
|
||||||
|
pidstr
|
||||||
|
(if feedback? "feedback" "a message")
|
||||||
|
meta-level)
|
||||||
|
(pretty-write body (current-error-port)))])
|
||||||
|
(when show-world-gestalt?
|
||||||
|
(when (not (equal? (world-full-gestalt old-w) (world-full-gestalt new-w)))
|
||||||
|
(with-color BRIGHT-BLUE
|
||||||
|
(output "~a's full gestalt:\n" (format-pids (cdr pids)))
|
||||||
|
(pretty-print-gestalt (world-full-gestalt new-w)
|
||||||
|
(current-error-port))))))])
|
||||||
|
(loop))))
|
||||||
|
|
||||||
(void (when (not (set-empty? flags))
|
(void (when (not (set-empty? flags))
|
||||||
(thread display-trace)))
|
(thread display-trace)))
|
||||||
|
|
Loading…
Reference in New Issue