1#!/usr/local/bin/sketchy -f
2
3; PP.SCM -- A pretty-printer for SketchyLISP.
4; Copyright (C) 2006,2007 Nils M Holm <nmh@t3x.org>
5; See the file LICENSE for conditions of use.
6
7; ---name---
8; pp
9
10; ---purpose---
11; Pretty-print SketchyLISP (and some Scheme) programs.
12; .P
13; .E Because PP uses
14; .C read
15; .E to parse expressions, it strips all comments
16; .E from its input programs.
17
18; ---language---
19; R5RS Scheme
20
21; ---keywords---
22; Pretty-printing, code, formatting, reformatting.
23
24; ---example---
25; (pp '(let ((a 1) (b 2)) (lambda (x) (list x a b)))) => #<void>
26; ; Output:
27; ; (let ((a 1)
28; ;       (b 2))
29; ;   (lambda (x)
30; ;     (list x a b)))
31
32; (require "lib/not.scm")
33; (require "lib/s-length.scm") ; string-length
34; (require "lib/numtostr.scm") ; number->string
35; (require "lib/ceqp.scm") ; char=?
36; (require "lib/ceqp.scm") ; char=?
37; (require "lib/booleanp.scm") ; boolean?
38; (require "lib/zerop.scm") ; zero?
39; (require "lib/list.scm")
40; (require "lib/minus.scm") ; -
41; (require "lib/plus.scm") ; +
42; (require "lib/gteq.scm") ; >=
43; (require "lib/greater.scm") ; >
44; (require "lib/newline.scm")
45; (require "lib/less.scm") ; <
46; (require "lib/letstar.scm") ; let*
47; (require "lib/if.scm")
48; (require "lib/caar.scm") ; caar cadr cddr
49; (require "lib/caaar.scm") ; caddr cadar
50; (require "lib/caaaar.scm") ; cadddr
51; (require "lib/length.scm")
52
53; ---code---
54(define Right-margin 72)
55
56(define LP #\()
57(define RP #\))
58
59(define (atom? x)
60  (and (not (pair? x))
61       (not (null? x))
62       (not (vector? x))))
63
64(define (pp-atom-length x)
65  (cond ((null? x) 2)
66    ((number? x)
67      (string-length (number->string x)))
68    ((string? x)
69      (+ 2 (string-length x)))
70    ((char? x)
71      (cond ((char=? x #\newline) 9)
72        ((char=? x #\space) 7)
73        (else 3)))
74    ((boolean? x) 2)
75    ((symbol? x)
76      (string-length (symbol->string x)))
77    (else (bottom (list 'unknown 'atom: x)))))
78
79(define (pp-list-length x)
80  (cond ((vector? x)
81      (+ 1 (pp-list-length (vector->list x))))
82    ((not (pair? x))
83      (pp-atom-length x))
84    ((eq? (car x) 'quote)
85      (+ 1 (pp-list-length (cadr x))))
86    (else (+ 1 (pp-list-length (car x))
87               (let ((k (pp-list-length (cdr x))))
88                 (if (atom? (cdr x)) (+ 4 k) k))))))
89
90(define (pp-length x)
91  (cond ((atom? x) (pp-atom-length x))
92    (else (pp-list-length x))))
93
94(define (spaces n)
95  (or (zero? n)
96      (begin (display #\space)
97             (spaces (- n 1)))))
98
99(define (pp-atom x)
100  (begin (write x)
101         (pp-atom-length x)))
102
103(define (exceeds-margin k x)
104  (>= (+ k (pp-length x))
105      Right-margin))
106
107(define (linewrap k x)
108  (cond ((zero? k) k)
109    ((exceeds-margin k x)
110      (begin (newline) 0))
111    (else k)))
112
113(define (indent k n)
114  (cond ((not (zero? k)) k)
115    ((< k n) (begin (spaces (- n k)) n))
116    (else k)))
117
118(define (pp-members x n k)
119  (cond ((null? x) k)
120    ((not (pair? x))
121      (begin (display ". ")
122             (+ 2 k (pp-atom x))))
123    (else (let* ((k (pp-expr (car x) (+ 2 n) k #f))
124                 (k (cond ((null? (cdr x)) k)
125                      ((> k 0) (begin (display #\space)
126                                      (+ 1 k)))
127                      (else 0))))
128          (pp-members (cdr x) n k)))))
129
130(define (pp-list x n k glue)
131  (let* ((k (if glue k (linewrap k x)))
132         (k (indent k n)))
133      (cond ((not (pair? x))
134          (+ k (pp-atom x)))
135        (else (begin (display LP)
136                     (let ((k (pp-members x k (+ 1 k))))
137                       (begin (display RP)
138                              (+ 1 k))))))))
139
140(define (pp-quote x n k)
141  (begin (display #\')
142         (pp-expr (cadr x) n (+ 1 k) #t)))
143
144(define (pp-lambda x n k)
145  (begin (display LP)
146         (display "lambda ")
147         (pp-expr (cadr x) (+ 2 k) (+ 8 k) #t)
148         (newline)
149         (let ((k (pp-expr (caddr x) (+ 2 k) 0 #f)))
150           (begin (display RP)
151                  (+ 1 k)))))
152
153(define (pp-cond x n k)
154  (letrec
155    ((pp-indented-clause
156       (lambda (x n k)
157         (begin (display LP)
158                (pp-expr (caar x) n (+ 1 k) #t)
159                (newline)
160                (let ((k (pp-expr (cadar x) (+ 2 n) 0 #f)))
161                  (begin (display RP)
162                         (+ 1 k))))))
163     (pp-inline-clause
164       (lambda (x n k)
165         (begin (display LP)
166                (let ((k (pp-expr (caar x) n (+ 1 k) #t)))
167                  (begin (display #\space)
168                         (let ((k (pp-expr (cadar x)
169                                    (+ 1 k) (+ 1 k) #t)))
170                           (begin (display RP)
171                                  (+ 1 k))))))))
172     (pp-clause
173       (lambda (x n k)
174         (let ((k (indent k n)))
175           (cond ((and (exceeds-margin k (car x))
176                       (not (eq? (caar x) #t))
177                       (not (eq? (caar x) 'else)))
178               (pp-indented-clause x n k))
179             (else (pp-inline-clause x n k))))))
180     (indent-clauses
181       (lambda (x n k)
182         (let ((k (pp-clause x n k)))
183           (cond ((null? (cdr x))
184               (begin (display RP)
185                      (+ 1 k)))
186             (else (begin (newline)
187                          (indent-clauses (cdr x) n 0))))))))
188    (begin (display LP)
189           (display "cond ")
190           (indent-clauses (cdr x) (+ k 2) (+ k 6)))))
191
192(define (pp-if x n k)
193  (cond ((exceeds-margin k x)
194      (begin (display LP)
195             (display "if ")
196             (pp-expr (cadr x) (+ 4 n) (+ 4 k) #t)
197             (newline)
198             (pp-expr (caddr x) (+ 4 n) 0 #f)
199             (newline)
200             (let ((k (pp-expr (cadddr x) (+ 4 n) 0 #f)))
201               (begin (display RP)
202                      (+ 1 k)))))
203    (else (pp-list x n k #t))))
204
205(define (pp-indented x n k prefix always-split)
206  (let ((pl (+ 1 (string-length prefix))))
207    (letrec
208      ((indent-args
209         (lambda (x n k glue)
210           (let ((k (pp-expr (car x) n k glue)))
211             (cond ((null? (cdr x))
212                 (begin (display RP)
213                        (+ 1 k)))
214               (else (begin (newline)
215                            (indent-args (cdr x) n 0 #f))))))))
216      (cond ((or (and (> (length x) 1) (exceeds-margin k x))
217                 always-split)
218          (begin (display LP)
219                 (display prefix)
220                 (indent-args (cdr x) (+ k pl) (+ k pl) #t)))
221        (else (pp-list x (+ k pl) k #f))))))
222
223(define (pp-and x n k)
224  (pp-indented x n k "and " #f))
225
226(define (pp-or x n k)
227  (pp-indented x n k "or " #f))
228
229(define (pp-begin x n k)
230  (pp-indented x n k "begin " #t))
231
232(define (pp-let-body x n k ind)
233  (letrec
234    ((lambda?
235       (lambda (x)
236         (and (pair? x) (eq? 'lambda (car x)))))
237     (pp-let-procedure
238       (lambda (x n k)
239         (begin (pp-expr (caar x) n (+ 1 k) #t)
240                (newline)
241                (let ((k (pp-expr (cadar x) (+ 2 n) 0 #t)))
242                  (begin (display RP)
243                         (+ 2 k))))))
244     (pp-let-data
245       (lambda (x n k)
246         (let ((k (pp-expr (caar x) n (+ 1 k) #t)))
247           (begin (display #\space)
248                  (let ((k (pp-expr (cadar x) (+ 2 n) (+ 1 k) #t)))
249                    (begin (display RP)
250                           (+ 2 k)))))))
251     (pp-assoc
252       (lambda (x n k)
253         (let ((k (indent k n)))
254           (begin (display LP)
255                  (cond ((lambda? (cadar x))
256                      (pp-let-procedure x n k))
257                    (else (pp-let-data x n k)))))))
258     (indent-bindings
259       (lambda (x n k)
260         (let ((k (pp-assoc x n k)))
261           (cond ((null? (cdr x))
262               (begin (display RP)
263                      (+ 1 k)))
264             (else (begin (newline)
265                          (indent-bindings (cdr x) n 0))))))))
266    (let ((k (indent-bindings (cadr x) (+ n ind) k)))
267      (begin (newline)
268             (let ((k (pp-expr (caddr x) (+ 2 n) 0 #f)))
269               (begin (display RP)
270                      (+ 2 k)))))))
271
272(define (pp-let x n k)
273  (begin (display LP)
274         (display "let ")
275         (display LP)
276         (pp-let-body x k (+ 6 k) 6)))
277
278(define (pp-let* x n k)
279  (begin (display LP)
280         (display "let* ")
281         (display LP)
282         (pp-let-body x k (+ 7 k) 7)))
283
284(define (pp-letrec x n k)
285  (begin (display LP)
286         (display "letrec ")
287         (newline)
288         (let ((k (indent 0 (+ k 2))))
289           (begin (display LP)
290                  (pp-let-body x n (+ 1 k) 3)))))
291
292(define (pp-define x n k)
293  (cond ((pair? (cadr x))
294      (begin (display LP)
295             (display "define ")
296             (pp-list (cadr x) n k #t)
297             (newline)
298             (let ((k (pp-expr (caddr x) (+ 2 n) 0 #f)))
299               (begin (display RP)
300                      (+ 1 k)))))
301    (else (pp-list x n k #f))))
302
303(define (pp-define-syntax x n k)
304  (begin (display LP)
305         (display "define-syntax ")
306         (pp-list (cadr x) n k #t)
307         (newline)
308         (let ((k (pp-expr (caddr x) (+ 2 k) 0 #f)))
309           (begin (display RP)
310                  (+ 1 k)))))
311
312(define (pp-syntax-rules x n k)
313  (letrec
314    ((pp-rules
315       (lambda (x n k)
316         (cond ((null? x) k)
317           (else (begin (indent 0 n)
318                        (display LP)
319                        (pp-list (caar x) n (+ 1 k) #t)
320                        (newline)
321                        (let* ((k (pp-list (cadar x) (+ 2 n) 0 #f)))
322                          (cond ((null? (cdr x))
323                              (begin (display RP)
324                                     (pp-rules (cdr x) n k)))
325                            (else (begin (newline)
326                                         (pp-rules (cdr x) n 0)))))))))))
327    (begin (display LP)
328           (display "syntax-rules ")
329           (pp-list (cadr x) (+ 16 k) (+ 14 k) #t)
330           (newline)
331           (let ((k (pp-rules (cddr x) (+ 2 k) (+ 2 n k))))
332             (begin (display RP)
333                    (+ 2 k))))))
334
335(define (pp-expr x n k glue)
336  (let* ((k (if glue k (linewrap k x)))
337         (k (indent k n)))
338    (cond ((vector? x)
339        (begin (display "#")
340               (display LP)
341               (let ((k (pp-members (vector->list x) n (+ 2 k))))
342                 (begin (display RP)
343                        (+ 2 k)))))
344      ((not (pair? x)) (+ k (pp-atom x)))
345      ((eq? (car x) 'quote) (pp-quote x n k))
346      ((eq? (car x) 'lambda) (pp-lambda x n k))
347      ((eq? (car x) 'cond) (pp-cond x n k))
348      ((eq? (car x) 'if) (pp-if x n k))
349      ((eq? (car x) 'and) (pp-and x n k))
350      ((eq? (car x) 'or) (pp-or x n k))
351      ((eq? (car x) 'let) (pp-let x n k))
352      ((eq? (car x) 'let*) (pp-let* x n k))
353      ((eq? (car x) 'letrec) (pp-letrec x n k))
354      ((eq? (car x) 'begin) (pp-begin x n k))
355      ((eq? (car x) 'define) (pp-define x n k))
356      ((eq? (car x) 'define-syntax) (pp-define-syntax x n k))
357      ((eq? (car x) 'syntax-rules) (pp-syntax-rules x n k))
358      (else (begin (display LP)
359                   (let ((k (pp-members x n (+ 1 k))))
360                     (begin (display RP)
361                            (+ 1 k))))))))
362
363(define (pp x)
364  (begin (pp-expr x 0 0 #f)
365         (newline)))
366
367(define (main)
368  (letrec
369    ((pp*
370       (lambda (x)
371         (and (not (eof-object? x))
372              (begin (pp x)
373                     (let ((next (read)))
374                       (begin (cond ((not (eof-object? next))
375                                  (newline))
376                                (else #f))
377                              (pp* next))))))))
378    (pp* (read))))
379