From 2466fe61c1494396317a136b87827febce061dd1 Mon Sep 17 00:00:00 2001 From: Tony Garnock-Jones Date: Sat, 21 Jun 2014 11:06:33 -0400 Subject: [PATCH] Make pretty-printed output a little wider --- minimart/trace/stderr.rkt | 197 +++++++++++++++++++------------------- 1 file changed, 99 insertions(+), 98 deletions(-) diff --git a/minimart/trace/stderr.rkt b/minimart/trace/stderr.rkt index 630ff20..7a7cc6d 100644 --- a/minimart/trace/stderr.rkt +++ b/minimart/trace/stderr.rkt @@ -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)))