Extract utilities for tracing
This commit is contained in:
parent
4efe18bfe0
commit
84ec153a1e
|
@ -6,24 +6,11 @@
|
||||||
(require racket/set)
|
(require racket/set)
|
||||||
(require racket/match)
|
(require racket/match)
|
||||||
(require racket/pretty)
|
(require racket/pretty)
|
||||||
(require racket/exn)
|
|
||||||
(require (only-in racket/string string-join string-split))
|
(require (only-in racket/string string-join string-split))
|
||||||
|
(require "util.rkt")
|
||||||
(require "../core.rkt")
|
(require "../core.rkt")
|
||||||
(require "../dataspace.rkt")
|
|
||||||
(require "../hierarchy.rkt")
|
|
||||||
(require "../trace.rkt")
|
(require "../trace.rkt")
|
||||||
(require "../mux.rkt")
|
|
||||||
(require "../pretty.rkt")
|
(require "../pretty.rkt")
|
||||||
(require "../trie.rkt")
|
|
||||||
(require "../tset.rkt")
|
|
||||||
|
|
||||||
(define (env-aref varname default alist)
|
|
||||||
(define key (or (getenv varname) default))
|
|
||||||
(cond [(assoc key alist) => cadr]
|
|
||||||
[else (error 'env-aref
|
|
||||||
"Expected environment variable ~a to contain one of ~v; got ~v"
|
|
||||||
(map car alist)
|
|
||||||
key)]))
|
|
||||||
|
|
||||||
(define colored-output? (env-aref "SYNDICATE_COLOR" "true" '(("true" #t) ("false" #f))))
|
(define colored-output? (env-aref "SYNDICATE_COLOR" "true" '(("true" #t) ("false" #f))))
|
||||||
|
|
||||||
|
@ -79,16 +66,6 @@
|
||||||
(define BRIGHT-BLUE ";1;34")
|
(define BRIGHT-BLUE ";1;34")
|
||||||
(define NORMAL "")
|
(define NORMAL "")
|
||||||
|
|
||||||
(define (format-pids process-names pids)
|
|
||||||
(define pidstr
|
|
||||||
(match pids
|
|
||||||
['() "ground"]
|
|
||||||
[(cons 'meta rest) (format "context of ~a" (format-pids process-names rest))]
|
|
||||||
[_ (string-join (map number->string (reverse pids)) ":")]))
|
|
||||||
(match (hash-ref process-names pids #f)
|
|
||||||
[#f pidstr]
|
|
||||||
[name (format "~a a.k.a ~v" pidstr name)]))
|
|
||||||
|
|
||||||
(define (output fmt . args)
|
(define (output fmt . args)
|
||||||
(apply fprintf (current-error-port) fmt args))
|
(apply fprintf (current-error-port) fmt args))
|
||||||
|
|
||||||
|
@ -100,10 +77,6 @@
|
||||||
(begin0 (begin expr ...)
|
(begin0 (begin expr ...)
|
||||||
(reset-color!))))
|
(reset-color!))))
|
||||||
|
|
||||||
(define (extract-leaf-pids sink p)
|
|
||||||
(for/list [(pid (in-set (extract-patch-pids p)))]
|
|
||||||
(cons pid (cdr sink))))
|
|
||||||
|
|
||||||
(define (ensure-process-named! process-names pids expected-name)
|
(define (ensure-process-named! process-names pids expected-name)
|
||||||
(define current-name (hash-ref process-names pids #f))
|
(define current-name (hash-ref process-names pids #f))
|
||||||
(when (not (equal? current-name expected-name))
|
(when (not (equal? current-name expected-name))
|
||||||
|
|
|
@ -0,0 +1,32 @@
|
||||||
|
#lang racket/base
|
||||||
|
|
||||||
|
(provide env-aref
|
||||||
|
format-pids
|
||||||
|
extract-leaf-pids)
|
||||||
|
|
||||||
|
(require racket/set)
|
||||||
|
(require racket/match)
|
||||||
|
(require (only-in racket/string string-join))
|
||||||
|
(require "../patch.rkt")
|
||||||
|
|
||||||
|
(define (env-aref varname default alist)
|
||||||
|
(define key (or (getenv varname) default))
|
||||||
|
(cond [(assoc key alist) => cadr]
|
||||||
|
[else (error 'env-aref
|
||||||
|
"Expected environment variable ~a to contain one of ~v; got ~v"
|
||||||
|
(map car alist)
|
||||||
|
key)]))
|
||||||
|
|
||||||
|
(define (format-pids process-names pids)
|
||||||
|
(define pidstr
|
||||||
|
(match pids
|
||||||
|
['() "ground"]
|
||||||
|
[(cons 'meta rest) (format "context of ~a" (format-pids process-names rest))]
|
||||||
|
[_ (string-join (map number->string (reverse pids)) ":")]))
|
||||||
|
(match (hash-ref process-names pids #f)
|
||||||
|
[#f pidstr]
|
||||||
|
[name (format "~a a.k.a ~v" pidstr name)]))
|
||||||
|
|
||||||
|
(define (extract-leaf-pids sink p)
|
||||||
|
(for/list [(pid (in-set (extract-patch-pids p)))]
|
||||||
|
(cons pid (cdr sink))))
|
Loading…
Reference in New Issue