diff --git a/prospect/core.rkt b/prospect/core.rkt index 4ae49b7..453c6a7 100644 --- a/prospect/core.rkt +++ b/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) diff --git a/prospect/pretty.rkt b/prospect/pretty.rkt new file mode 100644 index 0000000..2e6465c --- /dev/null +++ b/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))) diff --git a/prospect/trace.rkt b/prospect/trace.rkt index 2ef29f2..e278246 100644 --- a/prospect/trace.rkt +++ b/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))) diff --git a/prospect/trace/stderr.rkt b/prospect/trace/stderr.rkt index e4eb6fc..8104727 100644 --- a/prospect/trace/stderr.rkt +++ b/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))))]