1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
|
(module to-string racket/base
(require racket/contract/base
syntax/stx)
(require racket/list)
(define (syntax->string c)
(let* ([s (open-output-string)]
[l (syntax->list c)]
[init-col (or (syntax-column (first l)) 0)]
[col init-col]
[line (or (syntax-line (first l)) 0)])
(define (advance c init-line!)
(let ([c (syntax-column c)]
[l (syntax-line c)])
(when (and l (l . > . line))
(for-each (λ (_) (newline)) (range (- l line)))
(set! line l)
(init-line!))
(when c
(display (make-string (max 0 (- c col)) #\space))
(set! col c))))
(define quotes-table
#hasheq((quote . "'")
(quasiquote . "`")
(unquote . ",")
(unquote-splicing . ",@")
(syntax . "#'")
(quasisyntax . "#`")
(unsyntax . "#,")
(unsyntax-splicing . "#,@")))
(define (get-quote c)
(hash-ref quotes-table (syntax-e (car (syntax-e c)))))
(parameterize ([current-output-port s]
[read-case-sensitive #t])
(define (loop init-line!)
(lambda (c)
(cond
[(eq? 'code:blank (syntax-e c))
(advance c init-line!)]
[(eq? '_ (syntax-e c))
(advance c init-line!)
(printf "_")
(set! col (+ col 1))]
[(eq? '... (syntax-e c))
(void)]
[(and (pair? (syntax-e c))
(eq? (syntax-e (car (syntax-e c))) 'code:comment))
(advance c init-line!)
(printf "; ")
(display (syntax-e (cadr (syntax->list c))))]
[(and (pair? (syntax-e c))
(eq? (syntax-e (car (syntax-e c))) 'code:contract))
(advance c init-line!)
(printf "; ")
(let* ([l (cdr (syntax->list c))]
[s-col (or (syntax-column (first l)) col)])
(set! col s-col)
(for-each (loop (lambda ()
(set! col s-col)
(printf "; ")))
l))]
[(and (pair? (syntax-e c))
(hash-has-key? quotes-table (syntax-e (car (syntax-e c))))
(eq? (syntax-span (car (syntax-e c)))
(string-length (get-quote c))))
;; The above conditions detect the shorthand form of quote and friends
;; The shorthand form will read, for instance, '<form>
;; as (quote <form>), so the result is guaranteed to be a syntax list
;; with exactly two elements in it.
(advance c init-line!)
(printf (get-quote c))
(set! col (+ col (string-length (get-quote c))))
(let ([i (cadr (syntax->list c))])
((loop init-line!) i))]
[(pair? (syntax-e c))
(advance c init-line!)
(define c-paren-shape (syntax-property c 'paren-shape))
(printf "~a" (or c-paren-shape #\())
(set! col (+ col 1))
(define se (syntax-e c))
(define (build-string-from-pair sp)
(cond
[(syntax? sp)
(printf " . ")
(set! col (+ col 3))
((loop init-line!) sp)]
[else
((loop init-line!) (car sp))
(build-string-from-pair (cdr sp))]))
(if (list? se)
(map (loop init-line!) se)
(build-string-from-pair se))
(printf (case c-paren-shape
[(#\[) "]"]
[(#\{) "}"]
[else ")"]))
(set! col (+ col 1))]
[(vector? (syntax-e c))
(advance c init-line!)
(printf "#(")
(set! col (+ col 2))
(map (loop init-line!) (vector->list (syntax-e c)))
(printf ")")
(set! col (+ col 1))]
[else
(advance c init-line!)
(let ([s (format "~s" (syntax-e c))])
(set! col (+ col (string-length s)))
(display s))])))
(for-each (loop (lambda () (set! col init-col))) l))
(get-output-string s)))
(provide/contract [syntax->string (-> (and/c syntax? stx-list?)
string?)]))
|
