0. #lang racket
1.  
2. (pretty-print-columns 100)
3.  
4. ; Notes:
5. ;  Disabling `eval-jit-enabled` affects the expansion.
6. ;  Unless disabled, `reverse` becomes `alt-reverse`.
7. (define (topexpand top-level-form-stx)
8.   (parameterize ([current-namespace (make-base-namespace)]
9.                  [eval-jit-enabled  #f])
10.     (namespace-require 'racket/private/struct)
11.     (expand-syntax top-level-form-stx)))
12.  
13.  
14. (require syntax/kerncase)
15.  
16. (define (prettify x)
17.   (prettify-top-level-form x))
18.  
19. (define (prettify-top-level-form x)
20.   ; (displayln 'prettify-top-level-form)
21.   (kernel-syntax-case x #f
22.     [(#%expression expr)
23.      (with-syntax ([expr (prettify-top-level-form #'expr)])
24.        #'(#%expression expr))]
25.     [(module id module-path
26.        (#%module-begin module-level-form ...))
27.      (with-syntax ([(module-level-form ...)
28.                     (map prettify-top-level-form
29.                          (syntax->list #'(module-level-form ...)))])
30.        #'(module id module-path
31.            module-level-form ...))]
32.     [(begin top-level-form ...)
33.      (with-syntax ([(top-level-form ...)
34.                     (map prettify-top-level-form
35.                          (syntax->list #'(top-level-form ...)))])
36.        #'(begin top-level-form ...))]
37.     [(begin-for-syntax top-level-form ...)
38.      (with-syntax ([(top-level-form ...)
39.                     (map prettify-top-level-form
40.                          (syntax->list #'(top-level-form ...)))])
41.        #'(begin-for-syntax top-level-form ...))]
42.     [_
43.      (prettify-general-top-level-form x)]))
44.  
45. (define (prettify-module-level-form x)
46.   ; (displayln 'prettify-module-level-form)
47.   (kernel-syntax-case x #f
48.      [(#%provide raw-provide-spec ...)
49.       x]
50.      [(begin-for-syntax module-level-form ...)
51.       (with-syntax ([(module-level-form ...)
52.                      (map prettify-top-level-form
53.                           (syntax->list #'(module-level-form ...)))])
54.         #'(begin-for-syntax module-level-form ...))]
55.       [(module  . _) (prettify-submodule-form x)]
56.       [(module* . _) (prettify-submodule-form x)]
57.       [(#%declare declaration-keyword ...) x]
58.       [_
59.        (prettify-general-top-level-form x)]))
60.  
61. (define (prettify-submodule-form x)
62.   ; (displayln 'prettify-submodule-form)
63.   (kernel-syntax-case x #f
64.     [(module id module-path
65.        (#%plain-module-begin module-level-form ...))
66.      (with-syntax ([(module-level-form ...)
67.                     (map prettify-module-level-form
68.                          (syntax->list #'(module-level-form ...)))])
69.        #'(module id module-path
70.            (#%plain-module-begin module-level-form ...)))]
71.     [(module* id #f
72.        (#%plain-module-begin module-level-form ...))
73.      (with-syntax ([(module-level-form ...)
74.                     (map prettify-module-level-form
75.                          (syntax->list #'(module-level-form ...)))])
76.        #'(module* id #f
77.            (#%plain-module-begin module-level-form ...)))]
78.     [(module* id module-path
79.        (#%plain-module-begin module-level-form ...))
80.      (with-syntax ([(module-level-form ...)
81.                     (map prettify-module-level-form
82.                          (syntax->list #'(module-level-form ...)))])
83.        #'(module* id module-path
84.            (#%plain-module-begin module-level-form ...)))]
85.     [_ (error)]))
86.  
87. (define (prettify-general-top-level-form x)
88.   ; (displayln 'prettify-general-top-level-form)
89.   (kernel-syntax-case x #f
90.     [(define-values (id) expr)
91.      (with-syntax ([expr (prettify-expr #'expr)])
92.        #'(define id expr))]
93.     [(define-values (id ...) expr)
94.      (with-syntax ([expr (prettify-expr #'expr)])
95.        #'(define-values (id ...) expr))]
96.  
97.     [(define-syntaxes (id) expr)
98.      (with-syntax ([expr (prettify-expr #'expr)])
99.        #'(define-syntax id expr))]
100.     [(define-syntaxes (id ...) expr)
101.      (with-syntax ([expr (prettify-expr #'expr)])
102.        #'(define-syntaxes (id ...) expr))]
103.  
104.     [(#%require raw-require-spec ...)
105.      x]
106.  
107.     [_
108.      (prettify-expr x)]))
109.  
110. (define (prettify-expr* xs)
111.   (map prettify-expr
112.        (syntax->list xs)))
113.  
114. (define (prettify-expr** xss)
115.   (map prettify-expr*
116.        (syntax->list xss)))
117.  
118. (define (prettify-expr x)
119.   ; (displayln 'prettify-expr) (displayln x)
120.   (kernel-syntax-case* x #f ()
121.     [id (identifier? #'id) x]
122.     [(#%plain-lambda formals expr ...)
123.      (with-syntax ([(expr ...) (prettify-expr* #'(expr ...))])
124.        #'(lambda formals expr ...))]
125.     [(case-lambda (formals expr ...) ...)
126.      (with-syntax ([((expr ...) ...) (prettify-expr** #'((expr ...) ...))])
127.        #'(case-lambda (formals expr ...) ...))]
128.     [(if expr0 expr1 expr2)
129.      (with-syntax ([expr0 (prettify-expr #'expr0)]
130.                    [expr1 (prettify-expr #'expr1)]
131.                    [expr2 (prettify-expr #'expr2)])
132.        #'(if expr0 expr1 expr2))]
133.     [(begin expr ...)
134.      (with-syntax ([(expr ...) (prettify-expr* #'(expr ...))])
135.        #'(begin expr ...))]
136.     [(begin0 expr0 expr ...)
137.      (with-syntax ([(expr0 expr ...) (prettify-expr* #'(expr0 expr ...))])
138.        #'(begin expr0 expr ...))]
139.     [(let-values ([(id) expr] ...) bexpr ...)
140.      (with-syntax ([(expr ...)  (prettify-expr* #'(expr ...))]
141.                    [(bexpr ...) (prettify-expr* #'(bexpr ...))])
142.        #'(let ([id expr] ...) bexpr ...))]
143.     [(let-values ([(id ...) expr] ...) bexpr ...)
144.      (with-syntax ([(expr ...) (prettify-expr* #'(expr ...))]
145.                    [(bexpr ...) (prettify-expr* #'(bexpr ...))])
146.        #'(let-values ([(id ...) expr] ...) bexpr ...))]
147.     [(letrec-values ([(id) expr] ...) bexpr ...)
148.      (with-syntax ([(expr ...) (prettify-expr* #'(expr ...))]
149.                    [(bexpr ...) (prettify-expr* #'(bexpr ...))])
150.        #'(letrec ([id expr] ...) bexpr ...))]
151.     [(letrec-values ([(id ...) expr] ...) bexpr ...)
152.      (with-syntax ([(expr ...) (prettify-expr* #'(expr ...))]
153.                    [(bexpr ...) (prettify-expr* #'(bexpr ...))])
154.        #'(letrec-values ([(id ...) expr] ...) bexpr ...))]
155.     [(set! id expr)
156.      (with-syntax ([expr (prettify-expr #'expr)])
157.        #'(set! id expr))]
158.     [(quote datum)                x]
159.     [(quote-syntax datum)         x]
160.     [(quote-syntax datum #:local) x]
161.     [(with-continuation-mark expr0 expr1 expr2)
162.      (with-syntax ([(expr ...) (prettify-expr* #'(expr0 expr1 expr2))])
163.        #'(with-continuation-mark expr ...))]
164.     [(#%plain-app expr ...)
165.      (with-syntax ([(expr ...) (#%plain-app prettify-expr* #'(expr ...))])
166.        #'(expr ...))]
167.     [(#%top . id) x]
168.     [(#%variable-reference id) x]
169.     [(#%variable-reference (#%top . id)) x]
170.     [(#%variable-reference) x]
171.     [(#%datum . _) x]
172.     [_ (error 'prettify "got x: ~a" x)]))
173.  
174.  
175. (pretty-print
176.  (syntax->datum
177.   (prettify
178.    (topexpand #'(module foo racket/base
179.                   (struct foo (bar) #:transparent)
180.                   (define-values (fact)
181.                     (lambda (n)
182.                       (if (zero? n)
183.                           1
184.                           (* n (fact (- n 1))))))
185.                   (foo (fact 5)))))))
186.  
187.  
188.  
189. #;(pretty-print
190.            (prettify
191.            (syntax->datum
192.             (topexpand #'(module foo racket/base
193.                            (define-values (fact)
194.                              (lambda (n)
195.                                (if (zero? n)
196.                                    1
197.                                    (* n (fact (- n 1))))))
198.                            (fact 5))))))
199.  
200.  
201.  
202.  
203.  
204.  
205. #;(pretty-print
206.  (syntax->datum
207.   (prettify
208.    (topexpand #'(module foo '#%kernel
209.                   (define-values (fact)
210.                     (lambda (n)
211.                       (if (zero? n)
212.                           1
213.                           (* n (fact (- n 1))))))
214.                   (fact 5))))))
215.  

=>

'(module foo racket/base    (module configure-runtime '#%kernel (#%require racket/runtime-config) (configure '#f))    (define-values     (struct:foo foo1 foo? foo-bar)     (let-values (((struct: make- ? -ref -set!)                   (let ()                     (let () (make-struct-type 'foo '#f '1 '0 '#f null '#f '#f '(0) '#f 'foo)))))       (values struct: make- ? (make-struct-field-accessor -ref '0 'bar))))    (define-syntax foo      (make-self-ctor-checked-struct-info       (lambda ()         (list          (quote-syntax struct:foo)          (quote-syntax foo)          (quote-syntax foo?)          (list (quote-syntax foo-bar))          (list '#f)          '#t))       '(bar)       (list (list) (list))       (lambda () (quote-syntax foo1))))    (define fact (lambda (n) (if (zero? n) '1 (* n (fact (- n '1))))))    (call-with-values (lambda () (foo1 (fact '5))) print-values))