121 lines
3.8 KiB
Racket
121 lines
3.8 KiB
Racket
#lang racket/base
|
|
(require racket/pretty
|
|
"model/trace.rkt"
|
|
"model/reductions.rkt"
|
|
"model/reductions-config.rkt"
|
|
"model/steps.rkt"
|
|
"syntax-browser/partition.rkt"
|
|
"syntax-browser/pretty-helper.rkt")
|
|
(provide expand/step-text
|
|
stepper-text)
|
|
|
|
(define expand/step-text
|
|
(case-lambda
|
|
[(stx) (expand/step-text stx #f)]
|
|
[(stx show)
|
|
(define s (stepper-text stx (->show-function show)))
|
|
(s 'all)]))
|
|
|
|
(define stepper-text
|
|
(case-lambda
|
|
[(stx) (internal-stepper stx #f)]
|
|
[(stx show) (internal-stepper stx (->show-function show))]))
|
|
|
|
;; internal procedures
|
|
|
|
(define (internal-stepper stx show?)
|
|
(define steps (get-steps stx show?))
|
|
(define used-steps null)
|
|
(define partition (new-bound-partition))
|
|
(define dispatch
|
|
(case-lambda
|
|
[() (dispatch 'next)]
|
|
[(sym)
|
|
(case sym
|
|
((next)
|
|
(if (pair? steps)
|
|
(begin (show-step (car steps) partition)
|
|
(set! used-steps (cons (car steps) used-steps))
|
|
(set! steps (cdr steps)))
|
|
#f))
|
|
((prev)
|
|
(if (pair? used-steps)
|
|
(begin (show-step (car used-steps) partition)
|
|
(set! steps (cons (car used-steps) steps))
|
|
(set! used-steps (cdr used-steps)))
|
|
#f))
|
|
((all)
|
|
(when (pair? steps)
|
|
(dispatch 'next)
|
|
(dispatch 'all))))]))
|
|
dispatch)
|
|
|
|
(define (get-steps stx show?)
|
|
(define deriv (trace stx))
|
|
(define steps
|
|
(parameterize ((macro-policy show?))
|
|
(reductions deriv)))
|
|
(define (ok? x)
|
|
(or (rewrite-step? x) (misstep? x)))
|
|
(filter ok? steps))
|
|
|
|
(define (show-step step partition)
|
|
(cond [(step? step)
|
|
(display (step-type->string (protostep-type step)))
|
|
(newline)
|
|
(show-term (step-term1 step) partition)
|
|
(display " ==>")
|
|
(newline)
|
|
(show-term (step-term2 step) partition)
|
|
(newline)]
|
|
[(misstep? step)
|
|
(display (exn-message (misstep-exn step)))
|
|
(newline)
|
|
(show-term (misstep-term1 step) partition)]))
|
|
|
|
(define (show-term stx partition)
|
|
(define-values (datum flat=>stx stx=>flat)
|
|
(table stx partition 0 'always))
|
|
(define identifier-list
|
|
(filter identifier? (hash-map stx=>flat (lambda (k v) k))))
|
|
(define (pp-size-hook obj display-like? port)
|
|
(cond [(syntax-dummy? obj)
|
|
(let ((ostring (open-output-string)))
|
|
((if display-like? display write)
|
|
(syntax-dummy-val obj)
|
|
ostring)
|
|
(string-length (get-output-string ostring)))]
|
|
[else #f]))
|
|
(define (pp-print-hook obj display-like? port)
|
|
(cond [(syntax-dummy? obj)
|
|
((if display-like? display write) (syntax-dummy-val obj) port)]
|
|
[else
|
|
(error 'pretty-print-hook "unexpected special value: ~e" obj)]))
|
|
(define (pp-better-style-table)
|
|
(pretty-print-extend-style-table (pretty-print-current-style-table)
|
|
(map car extended-style-list)
|
|
(map cdr extended-style-list)))
|
|
(parameterize
|
|
([pretty-print-size-hook pp-size-hook]
|
|
[pretty-print-print-hook pp-print-hook]
|
|
[pretty-print-current-style-table (pp-better-style-table)])
|
|
(pretty-print/defaults datum)))
|
|
|
|
(define (->show-function show)
|
|
(cond [(procedure? show)
|
|
show]
|
|
[(list? show)
|
|
(lambda (id)
|
|
(ormap (lambda (x) (free-identifier=? x id))
|
|
show))]
|
|
[(eq? show #f)
|
|
(lambda (id) #t)]
|
|
[else
|
|
(error 'expand/trace-text
|
|
"expected procedure or list of identifiers for macros to show; got: ~e"
|
|
show)]))
|
|
|
|
(define extended-style-list
|
|
'((define-values . define)
|
|
(define-syntaxes . define-syntax)))
|