69 lines
2.2 KiB
Scheme
69 lines
2.2 KiB
Scheme
(module xml-box mzscheme
|
|
(require (lib "contract.ss")
|
|
"shared.ss"
|
|
(prefix kernel: (lib "kerncase.ss" "syntax")))
|
|
|
|
(provide/contract [rewrite-xml-box (syntax? ; stx to rewrite
|
|
(syntax? . -> . syntax?) ; rewriter for non-xml-box subcomponents
|
|
. -> .
|
|
syntax?)]) ; rewritten
|
|
|
|
|
|
(define (rewrite-xml-box stx rewrite-other)
|
|
|
|
(define (recur stx)
|
|
(rewrite-xml-box stx rewrite-other))
|
|
|
|
(define (rewrite-xml-error)
|
|
(error 'rewrite-xml-box "unexpected syntax in expansion of xml box: ~e" stx))
|
|
|
|
(case (stepper-syntax-property stx 'stepper-hint)
|
|
[(from-scheme-box from-splice-box) (rewrite-other stx)]
|
|
[(from-xml-box #f)
|
|
(stepper-syntax-property
|
|
(kernel:kernel-syntax-case stx #f
|
|
[var-stx (identifier? (syntax var-stx)) (rewrite-xml-error)]
|
|
|
|
[(lambda . clause) (rewrite-xml-error)]
|
|
|
|
[(case-lambda . clauses) (rewrite-xml-error)]
|
|
|
|
[(if test then) (rewrite-xml-error)]
|
|
|
|
[(if test then else) (rewrite-xml-error)]
|
|
|
|
[(begin . bodies) (rewrite-xml-error)]
|
|
|
|
[(begin0 . bodies) (rewrite-xml-error)]
|
|
|
|
[(let-values . clause) (rewrite-xml-error)]
|
|
|
|
[(letrec-values . clause) (rewrite-xml-error)]
|
|
|
|
[(set! var val) (rewrite-xml-error)]
|
|
|
|
[(quote _) stx]
|
|
|
|
[(quote-syntax _) (rewrite-xml-error)]
|
|
|
|
[(with-continuation-mark key mark body) (rewrite-xml-error)]
|
|
|
|
[(#%app . exprs)
|
|
(rebuild-stx (map recur (syntax->list #`exprs)) stx)]
|
|
|
|
[(#%datum . _) stx]
|
|
|
|
[(#%top . var) (rewrite-xml-error)]
|
|
|
|
[else (error 'syntax-object-iterator "unknown expr: ~a" stx)])
|
|
'stepper-hint
|
|
'from-xml-box)]
|
|
|
|
[else
|
|
(error 'rewrite-xml-box "unexpected stepper-hint \"~v\" on syntax from xml box: ~e"
|
|
(stepper-syntax-property stx 'stepper-hint)
|
|
stx)])))
|
|
|
|
|
|
|