More flexible state printing during tracing

prospect/core.rkt

@@ -63,6 +63,7 @@
 (require "patch.rkt")
 (require "trace.rkt")
 (require "mux.rkt")
+(require "pretty.rkt")
 (module+ test (require rackunit))
 
 ;; Events = Patches ∪ Messages
@@ -97,7 +98,11 @@
                runnable-pids ;; (Setof PID)
                behaviors ;; (HashTable PID Behavior)
                states ;; (HashTable PID Any)
-               ) #:transparent)
+               )
+  #:transparent
+  #:methods gen:prospect-pretty-printable
+  [(define (prospect-pretty-print w [p (current-output-port)])
+     (pretty-print-world w p))])
 
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 
@@ -362,11 +367,7 @@
   (for ([pid (set-union (hash-keys (mux-interest-table mux)) (hash-keys states))])
     (fprintf p " ---- process ~a, behavior ~v, STATE:\n" pid (hash-ref behaviors pid #f))
     (define state (hash-ref states pid #f))
-    (display (indented-port-output 6 (lambda (p)
-                                       (if (world? state)
-                                           (pretty-print-world state p)
-                                           (pretty-write state p))))
-             p)
+    (display (indented-port-output 6 (lambda (p) (prospect-pretty-print state p))) p)
     (newline p)
     (fprintf p "      process ~a, behavior ~v, CLAIMS:\n" pid (hash-ref behaviors pid #f))
     (display (indented-port-output 6 (lambda (p)

prospect/pretty.rkt

@@ -0,0 +1,28 @@
+#lang racket/base
+
+(provide gen:prospect-pretty-printable
+         prospect-pretty-print
+
+         exn->string ;; required from web-server/private/util
+         string-indent
+         indented-port-output)
+
+(require racket/generic)
+(require racket/pretty)
+(require (only-in web-server/private/util exn->string))
+(require (only-in racket/string string-join string-split))
+
+(define-generics prospect-pretty-printable
+  (prospect-pretty-print prospect-pretty-printable [port])
+  #:defaults ([(lambda (x) #t)
+               (define (prospect-pretty-print v [p (current-output-port)])
+                 (pretty-write v p))]))
+
+(define (string-indent amount s)
+  (define pad (make-string amount #\space))
+  (string-join (for/list [(line (string-split s "\n"))] (string-append pad line)) "\n"))
+
+(define (indented-port-output amount f)
+  (define p (open-output-string))
+  (f p)
+  (string-indent amount (get-output-string p)))

prospect/trace.rkt

@@ -8,14 +8,9 @@
 	 trace-process-step
 	 trace-process-step-result
          trace-internal-action
-	 trace-internal-action-result
+	 trace-internal-action-result)
 
-         exn->string ;; required from web-server/private/util
-         string-indent
-         indented-port-output)
-
-(require (only-in web-server/private/util exn->string))
-(require (only-in racket/string string-join string-split))
+(require "pretty.rkt")
 
 (define trace-logger (make-logger 'minimart-trace))
 
@@ -58,12 +53,3 @@
 ;; (Option PID) Action World Transition -> Void
 (define (trace-internal-action-result pid a w t)
   (record-trace-event 'internal-action-result (list (cons-pid pid) a w t)))
-
-(define (string-indent amount s)
-  (define pad (make-string amount #\space))
-  (string-join (for/list [(line (string-split s "\n"))] (string-append pad line)) "\n"))
-
-(define (indented-port-output amount f)
-  (define p (open-output-string))
-  (f p)
-  (string-indent amount (get-output-string p)))

prospect/trace/stderr.rkt

@@ -10,6 +10,8 @@
 (require "../core.rkt")
 (require "../trace.rkt")
 (require "../mux.rkt")
+(require "../endpoint.rkt")
+(require "../pretty.rkt")
 
 (define (env-aref varname default alist)
   (define key (or (getenv varname) default))
@@ -75,11 +77,6 @@
 (define (output fmt . args)
   (apply fprintf (current-error-port) fmt args))
 
-(define (output-state state)
-  (cond
-   [(world? state) (pretty-print-world state)]
-   [else (pretty-write state (current-error-port))]))
-
 (define (boring-state? state)
   (or (and (world? state) world-is-boring?)
       (void? state)))
@@ -118,7 +115,7 @@
 	   (when (not (boring-state? st))
 	     (with-color YELLOW
                (output "~a's state just before the event:\n" pidstr)
-               (output-state st))))]
+               (prospect-pretty-print st (current-error-port)))))]
         [('process-step-result (list pids e beh st exn t))
 	 (define pidstr (format-pids pids))
 	 (define relevant-exn? (and show-exceptions? exn))
@@ -140,7 +137,7 @@
 	 (when (exn-and-not (and show-process-states-pre? (not (boring-state? st))))
            (with-color YELLOW
              (output "~a's state just before the event:\n" pidstr)
-             (output-state st)))
+             (prospect-pretty-print st (current-error-port))))
 	 (when relevant-exn?
 	   (with-color WHITE-ON-RED
              (output "Process ~a ~v died with exception:\n~a\n"
@@ -156,7 +153,7 @@
 	       (when (not (equal? st (transition-state t)))
 		 (with-color YELLOW
                    (output "~a's state just after the event:\n" pidstr)
-                   (output-state (transition-state t)))))))]
+                   (prospect-pretty-print (transition-state t) (current-error-port)))))))]
 	[('internal-action (list pids a old-w))
          (define pidstr (format-pids pids))
          (define oldcount (hash-count (world-behaviors old-w)))
@@ -203,7 +200,7 @@
                           newcount))
                 (unless (boring-state? state)
                   (output "~a's initial state:\n" newpidstr)
-                  (output-state state))
+                  (prospect-pretty-print state (current-error-port)))
                 (unless (matcher-empty? interests)
                   (output "~a's initial interests:\n" newpidstr)
                   (pretty-print-matcher interests (current-error-port))))]