stepper-text.rkt (4338B)
1 #lang racket/base 2 (require racket/pretty 3 racket/promise 4 "model/trace.rkt" 5 "model/reductions.rkt" 6 "model/reductions-config.rkt" 7 "model/steps.rkt" 8 "syntax-browser/partition.rkt" 9 "syntax-browser/pretty-helper.rkt" 10 "view/debug-format.rkt") 11 (provide expand/step-text 12 stepper-text) 13 14 (define (expand/step-text stx [show #f] 15 #:internal-error-file [error-file #f]) 16 (let ([s (stepper-text stx (->show-function show) #:internal-error-file error-file)]) 17 (s 'all))) 18 19 (define (stepper-text stx [show #f] 20 #:internal-error-file [error-file #f]) 21 (internal-stepper stx (->show-function show) error-file)) 22 23 ;; internal procedures 24 25 (define (internal-stepper stx show? error-file) 26 (define steps (get-steps stx show? error-file)) 27 (define used-steps null) 28 (define partition (new-macro-scopes-partition)) 29 (define dispatch 30 (case-lambda 31 [() (dispatch 'next)] 32 [(sym) 33 (case sym 34 ((next) 35 (if (pair? steps) 36 (begin (show-step (car steps) partition) 37 (set! used-steps (cons (car steps) used-steps)) 38 (set! steps (cdr steps))) 39 #f)) 40 ((prev) 41 (if (pair? used-steps) 42 (begin (show-step (car used-steps) partition) 43 (set! steps (cons (car used-steps) steps)) 44 (set! used-steps (cdr used-steps))) 45 #f)) 46 ((all) 47 (when (pair? steps) 48 (dispatch 'next) 49 (dispatch 'all))))])) 50 dispatch) 51 52 (define (get-steps stx show? error-file) 53 (let-values ([(_result events derivp) (trace* stx)]) 54 (with-handlers ([exn:fail? 55 (lambda (exn) 56 (when error-file 57 (write-debug-file error-file exn events)) 58 (raise exn))]) 59 (define deriv (force derivp)) 60 (define steps 61 (parameterize ((macro-policy show?)) 62 (reductions deriv))) 63 (define (ok? x) 64 (or (rewrite-step? x) (misstep? x))) 65 (filter ok? steps)))) 66 67 (define (show-step step partition) 68 (cond [(step? step) 69 (display (step-type->string (protostep-type step))) 70 (newline) 71 (show-term (step-term1 step) partition) 72 (display " ==>") 73 (newline) 74 (show-term (step-term2 step) partition) 75 (newline)] 76 [(misstep? step) 77 (display (exn-message (misstep-exn step))) 78 (newline) 79 (show-term (misstep-term1 step) partition)])) 80 81 (define (show-term stx partition) 82 (define-values (datum flat=>stx stx=>flat) 83 (table stx partition 0 'always #t)) 84 (define identifier-list 85 (filter identifier? (hash-map stx=>flat (lambda (k v) k)))) 86 (define (pp-size-hook obj display-like? port) 87 (cond [(syntax-dummy? obj) 88 (let ((ostring (open-output-string))) 89 ((if display-like? display write) 90 (syntax-dummy-val obj) 91 ostring) 92 (string-length (get-output-string ostring)))] 93 [else #f])) 94 (define (pp-print-hook obj display-like? port) 95 (cond [(syntax-dummy? obj) 96 ((if display-like? display write) (syntax-dummy-val obj) port)] 97 [else 98 (error 'pretty-print-hook "unexpected special value: ~e" obj)])) 99 (define (pp-better-style-table) 100 (pretty-print-extend-style-table (pretty-print-current-style-table) 101 (map car extended-style-list) 102 (map cdr extended-style-list))) 103 (parameterize 104 ([pretty-print-size-hook pp-size-hook] 105 [pretty-print-print-hook pp-print-hook] 106 [pretty-print-current-style-table (pp-better-style-table)]) 107 (pretty-print/defaults datum))) 108 109 (define (->show-function show) 110 (cond [(procedure? show) 111 show] 112 [(list? show) 113 (lambda (id) 114 (ormap (lambda (x) (free-identifier=? x id)) 115 show))] 116 [(eq? show #f) 117 (lambda (id) #t)] 118 [else 119 (error 'expand/trace-text 120 "expected procedure or list of identifiers for macros to show; got: ~e" 121 show)])) 122 123 (define extended-style-list 124 '((define-values . define) 125 (define-syntaxes . define-syntax)))