diff --git a/prospect/core.rkt b/prospect/core.rkt index 20a4b70..8b29a8f 100644 --- a/prospect/core.rkt +++ b/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)) diff --git a/prospect/demand-matcher.rkt b/prospect/demand-matcher.rkt index 553159e..b089cee 100644 --- a/prospect/demand-matcher.rkt +++ b/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)) diff --git a/prospect/mux.rkt b/prospect/mux.rkt index b007bdf..ce6c731 100644 --- a/prospect/mux.rkt +++ b/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)) diff --git a/prospect/patch.rkt b/prospect/patch.rkt index 16f3557..adc6c37 100644 --- a/prospect/patch.rkt +++ b/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) diff --git a/prospect/pretty.rkt b/prospect/pretty.rkt index 0bc9a0b..199dd6e 100644 --- a/prospect/pretty.rkt +++ b/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)))