Greatly improve pretty-printing of many prospect structures

prospect/core.rkt

@@ -412,17 +412,13 @@
 		  '())))
 
 (define (pretty-print-world w [p (current-output-port)])
-  (local-require racket/pretty)
   (match-define (world mux qs runnable behaviors states) w)
   (fprintf p "WORLD:\n")
   (fprintf p " - ~a queued actions\n" (queue-length qs))
   (fprintf p " - ~a runnable pids ~a\n" (set-count runnable) (set->list runnable))
-  (fprintf p " - ~a live processes (~a with claims)\n"
-           (hash-count states)
-           (hash-count (mux-interest-table mux)))
-  (fprintf p " - next pid: ~a\n" (mux-next-pid mux))
-  (fprintf p " - routing table:\n")
-  (pretty-print-matcher (mux-routing-table mux) p)
+  (fprintf p " - ~a live processes\n" (hash-count states))
+  (fprintf p " - ")
+  (display (indented-port-output 3 (lambda (p) (prospect-pretty-print mux p)) #:first-line? #f) p)
   (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))

prospect/demand-matcher.rkt

@@ -5,6 +5,7 @@
 (require racket/match)
 (require "core.rkt")
 (require "drivers/timer.rkt")
+(require "pretty.rkt")
 
 (provide (except-out (struct-out demand-matcher) demand-matcher)
 	 (rename-out [make-demand-matcher demand-matcher])
@@ -23,7 +24,10 @@
 			decrease-handler        ;; ChangeHandler
                         current-demand          ;; (Setof (Listof Any))
                         current-supply)         ;; (Setof (Listof Any))
-	#:transparent)
+  #:transparent
+  #:methods gen:prospect-pretty-printable
+  [(define (prospect-pretty-print s [p (current-output-port)])
+     (pretty-print-demand-matcher s p))])
 
 ;; A ChangeHandler is a ((Constreeof Action) Any* -> (Constreeof Action)).
 ;; It is called with an accumulator of actions so-far-computed as its
@@ -140,3 +144,19 @@
           (patch-seq (patch base-interests (matcher-empty))
                      (patch-seq* (map projection->pattern projections))
                      (sub (timer-expired timer-id ?))))))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(define (pretty-print-demand-matcher s [p (current-output-port)])
+  (match-define (demand-matcher demand-spec
+                                supply-spec
+                                increase-handler
+                                decrease-handler
+                                current-demand
+                                current-supply)
+    s)
+  (fprintf p "DEMAND MATCHER:\n")
+  (fprintf p " - demand-spec: ~v\n" demand-spec)
+  (fprintf p " - supply-spec: ~v\n" supply-spec)
+  (fprintf p " - demand: ~v\n" current-demand)
+  (fprintf p " - supply: ~v\n" current-supply))

prospect/mux.rkt

@@ -10,7 +10,8 @@
          mux-route-message
          mux-interests-of
          compute-patches
-         compute-affected-pids)
+         compute-affected-pids
+         pretty-print-mux)
 
 (require racket/set)
 (require racket/match)
@@ -18,6 +19,7 @@
 (require "patch.rkt")
 (require "trace.rkt")
 (require "tset.rkt")
+(require "pretty.rkt")
 
 ;; A PID is a Nat.
 ;; A Label is a PID or 'meta.
@@ -25,7 +27,11 @@
 (struct mux (next-pid ;; PID
              routing-table ;; (Matcherof (Setof Label))
              interest-table ;; (HashTable Label Matcher)
-             ) #:transparent)
+             )
+  #:transparent
+  #:methods gen:prospect-pretty-printable
+  [(define (prospect-pretty-print m [p (current-output-port)])
+     (pretty-print-mux m p))])
 
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 
@@ -100,3 +106,14 @@
 
 (define (mux-interests-of m label)
   (hash-ref (mux-interest-table m) label (matcher-empty)))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(define (pretty-print-mux m [p (current-output-port)])
+  (match-define (mux next-pid routing-table interest-table) m)
+  (fprintf p "MUX:\n")
+  (fprintf p " - ~a labelled entities with claims\n" (hash-count interest-table))
+  (fprintf p " - next label: ~a\n" next-pid)
+  (fprintf p " - routing-table:\n")
+  (display (indented-port-output 3 (lambda (p) (pretty-print-matcher routing-table p))) p)
+  (newline p))

prospect/patch.rkt

@@ -40,12 +40,17 @@
 (require racket/match)
 (require "route.rkt")
 (require "tset.rkt")
+(require "pretty.rkt")
 (module+ test (require rackunit))
 
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 
 ;; Patches
-(struct patch (added removed) #:prefab)
+(struct patch (added removed)
+  #:transparent
+  #:methods gen:prospect-pretty-printable
+  [(define (prospect-pretty-print d [p (current-output-port)])
+     (pretty-print-patch d p))])
 
 ;; Claims, Interests, Locations, and Advertisements
 (struct observe (claim) #:prefab)

prospect/pretty.rkt

@@ -11,10 +11,14 @@
 (require racket/pretty)
 (require (only-in racket/string string-join string-split))
 (require "exn-util.rkt")
+(require "route.rkt")
 
 (define-generics prospect-pretty-printable
   (prospect-pretty-print prospect-pretty-printable [port])
-  #:defaults ([(lambda (x) #t)
+  #:defaults ([(lambda (x) (and (not (eq? x #f)) (matcher? x)))
+               (define (prospect-pretty-print m [p (current-output-port)])
+                 (pretty-print-matcher m p))]
+              [(lambda (x) #t)
                (define (prospect-pretty-print v [p (current-output-port)])
                  (pretty-write v p))]))
 
@@ -22,7 +26,10 @@
   (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 (indented-port-output amount f #:first-line? [first-line? #t])
   (define p (open-output-string))
   (f p)
-  (string-indent amount (get-output-string p)))
+  (define fully-indented (string-indent amount (get-output-string p)))
+  (if first-line?
+      fully-indented
+      (substring fully-indented amount)))