(module pp-syntax mzscheme
(require (lib "pretty.ss"))
(provide unexpand unexpand-to-datum pp-syntax)
(pretty-print-columns 70)
(define (self-evaluating? o)
(or (boolean? o)
(number? o)
(string? o)
(char? o)))
(define (smap f . sl)
(define (->list o)
(if (syntax? o) (syntax->list o) o))
(apply map f (map ->list sl)))
(define (pp-expr so)
(define pe pp-expr)
(define (pe* sl) (smap pe sl))
(syntax-case so (lambda if begin begin0 let-values letrec-values set!
with-continuation-mark #%datum #%app #%top and or)
[(if e1 e2 (#%datum . #f))
(pe #`(and #,(pe #'e1) #,(pe #'e2)))]
[(and e1 ... (and e2 ...))
(pe #'(and e1 ... e2 ...))]
[(and (and e1 ...) e2 ...)
(pe #'(and e1 ... e2 ...))]
[(and expr ...)
#`(and #,@(pe* #'(expr ...)))]
[(let-values (((or-part1) x)) (if or-part2 or-part3 y))
(and (and (identifier? #'or-part2)
(identifier? #'or-part3))
(eq? (syntax-e #'or-part1) (syntax-e #'or-part2))
(eq? (syntax-e #'or-part2) (syntax-e #'or-part3)))
(pe #`(or #,(pe #'x) #,(pe #'y)))]
[(or expr1 ... (or expr2 ...))
(pe #'(or expr1 ... expr2 ...))]
[(or (or expr1 ...) expr2 ...)
(pe #'(or expr1 ... expr2 ...))]
[(or expr ...)
#`(or #,@(pe* #'(expr ...)))]
[(lambda formals expr ...)
#`(lambda formals #,@(pe* #'(expr ...)))]
[(if expr1 expr2)
#`(if #,(pe #'expr1) #,(pe #'expr2))]
[(if expr1 expr2 expr3)
#`(if #,(pe #'expr1) #,(pe #'expr2) #,(pe #'expr3))]
[(begin expr ...)
#`(begin #,@(pe* #'(expr ...)))]
[(begin0 expr ...)
#`(begin0 #,@(pe* #'(expr ...)))]
[(let-values (((id) expr) ...) body ...)
#`(let #,(smap list #'(id ...) (pe* #'(expr ...)))
#,@(pe* #'(body ...)))]
[(letrec-values (((id) expr) ...) body ...)
#`(letrec #,(smap list #'(id ...) (pe* #'(expr ...)))
#,@(pe* #'(body ...)))]
[(set! var expr)
#`(set! var #,(pe #'expr))]
[(with-continuation-mark expr1 expr2 expr3)
#`(with-continuation-mark #,(pe #'expr1) #,(pe #'expr2) #,(pe #'expr3))]
[(#%datum . o)
(self-evaluating? (syntax-object->datum #'o))
#'o]
[(#%app expr ...)
(smap pe #'(expr ...))]
[(#%top . id)
#'id]
[_
so]))
(define (pp-general-top-level-expr so)
(syntax-case so (define-values define-syntaxes define-values-for-syntax
require require-for-syntax require-for-template)
[(define-values (var) expr)
#`(define var #,(pp-expr #'expr))]
[(define-values (var ...) expr)
#`(define-values (var ...) #,(pp-expr #'expr))]
[(define-syntaxes id expr)
#`(define-syntax id #,(pp-expr #'expr))]
[(define-syntaxes (id ...) expr)
#`(define-syntaxes (id ...) #,(pp-expr #'expr))]
[(define-values-for-syntax (var ...) expr)
#`(define-values-for-syntax (var ...) #,(pp-expr #'expr))]
[(require require-spec ...)
#'(require require-spec ...)]
[(require-for-syntax require-spec ...)
#'(require-for-syntax require-spec ...)]
[(require-for-template require-spec ...)
#'(require-for-template require-spec ...)]
[_
(pp-expr so)]))
(define (pp-top-level-expr so)
(syntax-case so (module begin #%plain-module-begin)
[(module id name (#%plain-module-begin module-level-expr ...))
#`(module id name (#%plain-module-begin #,@(smap pp-module-level-expr #'(module-level-expr ...))))]
[(begin top-level-expr ...)
#`(begin #,@(pp-top-level-expr #'(top-level-expr ...)))]
[_
(pp-general-top-level-expr so)]))
(define (pp-module-level-expr so)
(syntax-case so (provide begin)
[(provide provide-spec ...)
#'(provide provide-spec ...)]
[(begin module-level-expr ...)
#`(begin #,@(smap pp-module-level-expr #'(module-level-expr ...)))]
[_
(pp-general-top-level-expr so)]))
(define (unexpand so)
(pp-module-level-expr
(expand so)))
(define (unexpand-to-datum so)
(syntax-object->datum
#`#,(unexpand so)))
(define (pp-syntax so)
(pretty-display
(unexpand-to-datum so)))
)