Greatly improve pretty-printing of many prospect structures
This commit is contained in:
parent
85450362fb
commit
29042830e2
|
@ -412,17 +412,13 @@
|
||||||
'())))
|
'())))
|
||||||
|
|
||||||
(define (pretty-print-world w [p (current-output-port)])
|
(define (pretty-print-world w [p (current-output-port)])
|
||||||
(local-require racket/pretty)
|
|
||||||
(match-define (world mux qs runnable behaviors states) w)
|
(match-define (world mux qs runnable behaviors states) w)
|
||||||
(fprintf p "WORLD:\n")
|
(fprintf p "WORLD:\n")
|
||||||
(fprintf p " - ~a queued actions\n" (queue-length qs))
|
(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 runnable pids ~a\n" (set-count runnable) (set->list runnable))
|
||||||
(fprintf p " - ~a live processes (~a with claims)\n"
|
(fprintf p " - ~a live processes\n" (hash-count states))
|
||||||
(hash-count states)
|
(fprintf p " - ")
|
||||||
(hash-count (mux-interest-table mux)))
|
(display (indented-port-output 3 (lambda (p) (prospect-pretty-print mux p)) #:first-line? #f) p)
|
||||||
(fprintf p " - next pid: ~a\n" (mux-next-pid mux))
|
|
||||||
(fprintf p " - routing table:\n")
|
|
||||||
(pretty-print-matcher (mux-routing-table mux) p)
|
|
||||||
(for ([pid (set-union (hash-keys (mux-interest-table mux)) (hash-keys states))])
|
(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))
|
(fprintf p " ---- process ~a, behavior ~v, STATE:\n" pid (hash-ref behaviors pid #f))
|
||||||
(define state (hash-ref states pid #f))
|
(define state (hash-ref states pid #f))
|
||||||
|
|
|
@ -5,6 +5,7 @@
|
||||||
(require racket/match)
|
(require racket/match)
|
||||||
(require "core.rkt")
|
(require "core.rkt")
|
||||||
(require "drivers/timer.rkt")
|
(require "drivers/timer.rkt")
|
||||||
|
(require "pretty.rkt")
|
||||||
|
|
||||||
(provide (except-out (struct-out demand-matcher) demand-matcher)
|
(provide (except-out (struct-out demand-matcher) demand-matcher)
|
||||||
(rename-out [make-demand-matcher demand-matcher])
|
(rename-out [make-demand-matcher demand-matcher])
|
||||||
|
@ -23,7 +24,10 @@
|
||||||
decrease-handler ;; ChangeHandler
|
decrease-handler ;; ChangeHandler
|
||||||
current-demand ;; (Setof (Listof Any))
|
current-demand ;; (Setof (Listof Any))
|
||||||
current-supply) ;; (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)).
|
;; A ChangeHandler is a ((Constreeof Action) Any* -> (Constreeof Action)).
|
||||||
;; It is called with an accumulator of actions so-far-computed as its
|
;; 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 (patch base-interests (matcher-empty))
|
||||||
(patch-seq* (map projection->pattern projections))
|
(patch-seq* (map projection->pattern projections))
|
||||||
(sub (timer-expired timer-id ?))))))
|
(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))
|
||||||
|
|
|
@ -10,7 +10,8 @@
|
||||||
mux-route-message
|
mux-route-message
|
||||||
mux-interests-of
|
mux-interests-of
|
||||||
compute-patches
|
compute-patches
|
||||||
compute-affected-pids)
|
compute-affected-pids
|
||||||
|
pretty-print-mux)
|
||||||
|
|
||||||
(require racket/set)
|
(require racket/set)
|
||||||
(require racket/match)
|
(require racket/match)
|
||||||
|
@ -18,6 +19,7 @@
|
||||||
(require "patch.rkt")
|
(require "patch.rkt")
|
||||||
(require "trace.rkt")
|
(require "trace.rkt")
|
||||||
(require "tset.rkt")
|
(require "tset.rkt")
|
||||||
|
(require "pretty.rkt")
|
||||||
|
|
||||||
;; A PID is a Nat.
|
;; A PID is a Nat.
|
||||||
;; A Label is a PID or 'meta.
|
;; A Label is a PID or 'meta.
|
||||||
|
@ -25,7 +27,11 @@
|
||||||
(struct mux (next-pid ;; PID
|
(struct mux (next-pid ;; PID
|
||||||
routing-table ;; (Matcherof (Setof Label))
|
routing-table ;; (Matcherof (Setof Label))
|
||||||
interest-table ;; (HashTable Label Matcher)
|
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)
|
(define (mux-interests-of m label)
|
||||||
(hash-ref (mux-interest-table m) label (matcher-empty)))
|
(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))
|
||||||
|
|
|
@ -40,12 +40,17 @@
|
||||||
(require racket/match)
|
(require racket/match)
|
||||||
(require "route.rkt")
|
(require "route.rkt")
|
||||||
(require "tset.rkt")
|
(require "tset.rkt")
|
||||||
|
(require "pretty.rkt")
|
||||||
(module+ test (require rackunit))
|
(module+ test (require rackunit))
|
||||||
|
|
||||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||||
|
|
||||||
;; Patches
|
;; 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
|
;; Claims, Interests, Locations, and Advertisements
|
||||||
(struct observe (claim) #:prefab)
|
(struct observe (claim) #:prefab)
|
||||||
|
|
|
@ -11,10 +11,14 @@
|
||||||
(require racket/pretty)
|
(require racket/pretty)
|
||||||
(require (only-in racket/string string-join string-split))
|
(require (only-in racket/string string-join string-split))
|
||||||
(require "exn-util.rkt")
|
(require "exn-util.rkt")
|
||||||
|
(require "route.rkt")
|
||||||
|
|
||||||
(define-generics prospect-pretty-printable
|
(define-generics prospect-pretty-printable
|
||||||
(prospect-pretty-print prospect-pretty-printable [port])
|
(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)])
|
(define (prospect-pretty-print v [p (current-output-port)])
|
||||||
(pretty-write v p))]))
|
(pretty-write v p))]))
|
||||||
|
|
||||||
|
@ -22,7 +26,10 @@
|
||||||
(define pad (make-string amount #\space))
|
(define pad (make-string amount #\space))
|
||||||
(string-join (for/list [(line (string-split s "\n"))] (string-append pad line)) "\n"))
|
(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))
|
(define p (open-output-string))
|
||||||
(f p)
|
(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)))
|
||||||
|
|
Loading…
Reference in New Issue