Make pretty-printed output a little wider

This commit is contained in:
Tony Garnock-Jones 2014-06-21 11:06:33 -04:00
parent bc3e5be900
commit 2466fe61c1
1 changed files with 99 additions and 98 deletions

View File

@ -74,107 +74,108 @@
(define (display-trace)
(define receiver (make-log-receiver trace-logger 'info))
(let loop ()
(match-define (vector level message-string data event-name) (sync receiver))
(match* (event-name data)
[('process-step (list pids e p exn t))
(define pidstr (format-pids pids))
(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
(parameterize ((pretty-print-columns 100))
(let loop ()
(match-define (vector level message-string data event-name) (sync receiver))
(match* (event-name data)
[('process-step (list pids e p exn t))
(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)))]))]
(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 show-actions?
(output "~a performed a routing-update:\n" pidstr)
(pretty-print-gestalt g (current-error-port)))]
(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 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)))
(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 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))
(thread display-trace)))