1#lang racket/base 2 3(module trace-et-al racket/base 4 (require racket/pretty 5 (for-syntax racket/base)) 6 7 (provide trace untrace 8 current-trace-print-results 9 current-trace-print-args 10 trace-call 11 current-trace-notify 12 current-prefix-out current-prefix-in) 13 14 (define max-dash-space-depth 10) 15 (define number-nesting-depth 6) 16 (define current-prefix-out (make-parameter "<" #f 'current-prefix-out)) 17 (define current-prefix-in (make-parameter ">" #f 'current-prefix-in)) 18 19 (define (as-spaces s) 20 (make-string (string-length s) #\space)) 21 22 (define-struct prefix-entry (for-first for-rest)) 23 24 (define prefixes (make-hash)) 25 26 (define (lookup-prefix n label) 27 (hash-ref prefixes (cons n label) (lambda () #f))) 28 29 (define (insert-prefix n label first rest) 30 (hash-set! prefixes (cons n label) (make-prefix-entry first rest))) 31 32 (define (construct-prefixes level label) 33 (let loop ([n level] 34 [first (list label)] 35 [rest '(" ")]) 36 (if (>= n max-dash-space-depth) 37 (let-values ([(pre-first pre-rest) 38 (build-prefixes number-nesting-depth label)]) 39 (let ((s (number->string level))) 40 (values 41 (string-append pre-first "[" s "] ") 42 (string-append pre-rest " " (as-spaces s) " ")))) 43 (cond 44 [(= n 0) (values (apply string-append (reverse first)) 45 (apply string-append (reverse rest)))] 46 [(= n 1) (loop (- n 1) 47 (cons '" " first) 48 (cons '" " rest))] 49 [else (loop (- n 2) 50 (cons (format " ~a" label) first) 51 (cons " " rest))])))) 52 53 (define (build-prefixes level label) 54 (let ([p (lookup-prefix level label)]) 55 (if p 56 (values (prefix-entry-for-first p) 57 (prefix-entry-for-rest p)) 58 (let-values (((first rest) 59 (construct-prefixes level label))) 60 (insert-prefix level label first rest) 61 (values first rest))))) 62 63 (define current-trace-notify 64 (make-parameter (lambda (s) 65 (display s) 66 (newline)) 67 (lambda (p) 68 (unless (and (procedure? p) 69 (procedure-arity-includes? p 1)) 70 (raise-argument-error 'current-trace-notify 71 "(any/c . -> . any)" 72 p)) 73 p) 74 'current-trace-notify)) 75 76 (define (as-trace-notify thunk) 77 (let ([p (open-output-bytes)]) 78 (parameterize ([current-output-port p]) 79 (thunk)) 80 (let ([b (get-output-bytes p #t 0 81 ;; drop newline: 82 (sub1 (file-position p)))]) 83 ((current-trace-notify) (bytes->string/utf-8 b))))) 84 85 (define -:trace-print-args 86 (lambda (name args kws kw-vals level) 87 (as-trace-notify 88 (lambda () 89 ((current-trace-print-args) name args kws kw-vals level))))) 90 91 (struct plain (val) 92 #:property prop:custom-write (lambda (p port mode) 93 (write (plain-val p) port))) 94 95 (define current-trace-print-args 96 (make-parameter 97 (lambda (name args kws kw-vals level) 98 (let-values (((first rest) 99 (build-prefixes level (current-prefix-in)))) 100 (parameterize ((pretty-print-print-line 101 (lambda (n port offset width) 102 (display 103 (if n 104 (if (zero? n) first (format "\n~a" rest)) 105 "\n") 106 port) 107 (if n 108 (if (zero? n) 109 (string-length first) 110 (string-length rest)) 111 0)))) 112 ;; Printing the function call in a way that adapts to 113 ;; different value printing --- currently a hack 114 (cond 115 [(print-as-expression) 116 ;; In expression mode, represent a function call as a 117 ;; transparent structure, so that it prints as a constructor 118 ;; application. Also, protect keywords for keyword arguments 119 ;; so that they print without quoting. 120 (let ([args (append args 121 (apply append (map (lambda (kw val) 122 (list (plain kw) val)) 123 kws 124 kw-vals)))]) 125 (let-values ([(struct: make- ? -ref -set!) 126 (make-struct-type name #f 127 (length args) 0 #f 128 null #f #f null #f 129 name)]) 130 (pretty-print (apply make- args))))] 131 [else 132 ;; In non-expression mode, just use `write': 133 (pretty-write (append (cons name args) 134 (apply append (map list kws kw-vals))))])))) 135 #f 136 'current-trace-print-args)) 137 138 (define -:trace-print-results 139 (lambda (name results level) 140 (as-trace-notify 141 (lambda () 142 ((current-trace-print-results) name results level))))) 143 144 (define current-trace-print-results 145 (make-parameter 146 (lambda (name results level) 147 (let-values (((first rest) 148 (build-prefixes level (current-prefix-out)))) 149 (parameterize ((pretty-print-print-line 150 (lambda (n port offset width) 151 (display 152 (if n 153 (if (zero? n) first (format "\n~a" rest)) 154 "\n") 155 port) 156 (if n 157 (if (zero? n) 158 (string-length first) 159 (string-length rest)) 160 0)))) 161 (cond 162 ((null? results) 163 (pretty-display "*** no values ***")) 164 ((null? (cdr results)) 165 (pretty-print (car results))) 166 (else 167 (pretty-print (car results)) 168 (parameterize ((pretty-print-print-line 169 (lambda (n port offset width) 170 (display 171 (if n 172 (if (zero? n) rest (format "\n~a" rest)) 173 "\n") 174 port) 175 (if n 176 (string-length rest) 177 0)))) 178 (for-each pretty-print (cdr results)))))))))) 179 180 181 ;; A traced-proc struct instance acts like a procedure, 182 ;; but preserves the original, too. 183 (define-values (struct:traced-proc make-traced-proc traced-proc? traced-proc-ref traced-proc-set!) 184 (make-struct-type 'traced-proc #f 2 0 #f 185 (list (cons prop:procedure 0)) 186 (current-inspector) #f (list 0 1))) 187 188 ;; Install traced versions of a given set of procedures. The traced 189 ;; versions are also given, so that they can be constructed to have 190 ;; a nice name. 191 (define (do-trace ids procs setters traced-procs) 192 (for-each (lambda (id proc) 193 (unless (procedure? proc) 194 (error 'trace 195 "the value of ~s is not a procedure: ~e" id proc))) 196 ids procs) 197 (for-each (lambda (proc setter traced-proc) 198 (unless (traced-proc? proc) 199 (setter (make-traced-proc 200 (let-values ([(a) (procedure-arity proc)] 201 [(req allowed) (procedure-keywords proc)]) 202 (procedure-reduce-keyword-arity traced-proc 203 a 204 req 205 allowed)) 206 proc)))) 207 procs setters traced-procs)) 208 209 ;; Key used for a continuation mark to indicate 210 ;; the nesting depth: 211 (define -:trace-level-key (gensym)) 212 213 (define trace-call 214 (make-keyword-procedure 215 (lambda (id f kws vals . args) 216 (do-traced id args kws vals f)) 217 (lambda (id f . args) 218 (do-traced id args '() '() f)))) 219 220 ;; Apply a traced procedure to arguments, printing arguments 221 ;; and results. We set and inspect the -:trace-level-key continuation 222 ;; mark a few times to detect tail calls. 223 (define (do-traced id args kws kw-vals real-value) 224 (let* ([levels (continuation-mark-set->list 225 (current-continuation-marks) 226 -:trace-level-key)] 227 [level (if (null? levels) 0 (car levels))]) 228 ;; Tentatively push the new depth level: 229 (with-continuation-mark -:trace-level-key (add1 level) 230 ;; Check for tail-call => car of levels replaced, 231 ;; which means that the first two new marks are 232 ;; not consecutive: 233 (let ([new-levels (continuation-mark-set->list 234 (current-continuation-marks) 235 -:trace-level-key)]) 236 (if (and (pair? (cdr new-levels)) 237 (> (car new-levels) (add1 (cadr new-levels)))) 238 ;; Tail call: reset level and just call real-value. 239 ;; (This is in tail position to the call to `do-traced'.) 240 ;; We don't print the results, because the original 241 ;; call will. 242 (begin 243 (-:trace-print-args id args kws kw-vals (sub1 level)) 244 (with-continuation-mark -:trace-level-key (car levels) 245 (if (null? kws) 246 (apply real-value args) 247 (keyword-apply real-value kws kw-vals args)))) 248 ;; Not a tail call; push the old level, again, to ensure 249 ;; that when we push the new level, we have consecutive 250 ;; levels associated with the mark (i.e., set up for 251 ;; tail-call detection the next time around): 252 (begin 253 (-:trace-print-args id args kws kw-vals level) 254 (with-continuation-mark -:trace-level-key level 255 (call-with-values 256 (lambda () 257 (with-continuation-mark -:trace-level-key (add1 level) 258 (if (null? kws) 259 (apply real-value args) 260 (keyword-apply real-value kws kw-vals args)))) 261 (lambda results 262 (flush-output) 263 ;; Print the results: 264 (-:trace-print-results id results level) 265 ;; Return the results: 266 (apply values results)))))))))) 267 268 (define-for-syntax (check-ids stx ids) 269 (for ([id (in-list (syntax->list ids))]) 270 (unless (identifier? id) 271 (raise-syntax-error #f "not an identifier" stx id))) 272 #t) 273 274 (define-syntax (trace stx) 275 (syntax-case stx () 276 [(_ id ...) (check-ids stx #'(id ...)) 277 (with-syntax ([(tid ...) 278 (for/list ([id (in-list (syntax->list #'(id ...)))]) 279 (let ([tid (format "traced-~a" (syntax-e id))]) 280 (datum->syntax id (string->symbol tid) #f)))] 281 [(kw-proc ...) 282 (for/list ([id (in-list (syntax->list #'(id ...)))]) 283 (quasisyntax/loc id 284 (lambda (kws vals . args) 285 (do-traced '#,id args kws vals real-value))))] 286 [(plain-proc ...) 287 (for/list ([id (in-list (syntax->list #'(id ...)))]) 288 (quasisyntax/loc id 289 (lambda args 290 (do-traced '#,id args null null real-value))))]) 291 #`(do-trace 292 '(id ...) 293 (list id ...) 294 (list (lambda (v) (set! id v)) ...) 295 (list (let* ([real-value id] 296 [tid (make-keyword-procedure kw-proc plain-proc)]) 297 tid) 298 ...)))])) 299 300 (define-syntax (untrace stx) 301 (syntax-case stx () 302 [(_ id ...) (check-ids stx #'(id ...)) 303 #'(begin (when (traced-proc? id) 304 (set! id (traced-proc-ref id 1))) 305 ...)]))) 306 307(module chez-like racket/base 308 (require 309 (only-in (submod ".." trace-et-al) trace) 310 (for-syntax 311 racket/base 312 syntax/define 313 syntax/name 314 syntax/parse 315 (only-in (submod ".." trace-et-al) trace))) 316 317 (provide trace-define trace-lambda trace-let trace-define-syntax) 318 319 (define-syntax (trace-define stx) 320 (syntax-case stx () 321 [(_ e ...) 322 (let-values ([(name def) (normalize-definition stx #'lambda)]) 323 #`(begin #,(quasisyntax/loc stx (define #,name #,def)) (trace #,name)))])) 324 325 (define-syntax trace-let 326 (syntax-rules () 327 [(_ name ([x* e*] ...) body ...) 328 ((letrec ([name (lambda (x* ...) body ...)]) (trace name) name) 329 e* ...)])) 330 331 (define-syntax (trace-lambda stx) 332 (define (infer-name-or-error) 333 (or (syntax-local-infer-name stx) 334 (raise-syntax-error 335 'trace-lambda 336 "Could not infer name; give a name explicitly using #:name" 337 stx))) 338 (syntax-parse stx 339 [(_ (~optional (~seq #:name name:id) #:defaults ([name (datum->syntax stx (infer-name-or-error) 340 stx)])) 341 args body:expr ...) 342 #`(let ([name #,(quasisyntax/loc stx (lambda args body ...))]) (trace name) name)])) 343 344 (define-syntax (trace-define-syntax stx) 345 (syntax-case stx () 346 [(_ e ...) 347 (let-values ([(name def) (normalize-definition stx #'lambda)]) 348 (quasisyntax/loc stx 349 (define-syntax #,name 350 (let ([#,name #,def]) (trace #,name) #,name))))]))) 351 352(require 'trace-et-al 'chez-like) 353(provide trace untrace 354 current-trace-print-results 355 current-trace-print-args 356 trace-call 357 current-trace-notify 358 current-prefix-out current-prefix-in 359 360 trace-define trace-let trace-lambda 361 trace-define-syntax) 362