More flexible state printing during tracing
This commit is contained in:
parent
e8b99ae8e7
commit
2b5358ab2c
|
@ -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)
|
||||
|
|
|
@ -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)))
|
|
@ -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)))
|
||||
|
|
|
@ -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))))]
|
||||
|
|
Loading…
Reference in New Issue