Commit | Line | Data |
---|---|---|
a482f2cc MV |
1 | ;;;; -*-scheme-*- |
2 | ;;;; | |
cd5fea8d | 3 | ;;;; Copyright (C) 2001, 2004, 2006 Free Software Foundation, Inc. |
a482f2cc | 4 | ;;;; |
73be1d9e MV |
5 | ;;;; This library is free software; you can redistribute it and/or |
6 | ;;;; modify it under the terms of the GNU Lesser General Public | |
7 | ;;;; License as published by the Free Software Foundation; either | |
8 | ;;;; version 2.1 of the License, or (at your option) any later version. | |
a482f2cc | 9 | ;;;; |
73be1d9e | 10 | ;;;; This library is distributed in the hope that it will be useful, |
a482f2cc | 11 | ;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of |
73be1d9e MV |
12 | ;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU |
13 | ;;;; Lesser General Public License for more details. | |
a482f2cc | 14 | ;;;; |
73be1d9e MV |
15 | ;;;; You should have received a copy of the GNU Lesser General Public |
16 | ;;;; License along with this library; if not, write to the Free Software | |
92205699 | 17 | ;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA |
a482f2cc | 18 | ;;;; |
1a179b03 | 19 | (define-module (ice-9 pretty-print) |
f5259dd3 | 20 | :use-module (ice-9 optargs) |
1a179b03 | 21 | :export (pretty-print)) |
b337528f MV |
22 | |
23 | ;; From SLIB. | |
24 | ||
25 | ;;"genwrite.scm" generic write used by pretty-print and truncated-print. | |
26 | ;; Copyright (c) 1991, Marc Feeley | |
27 | ;; Author: Marc Feeley (feeley@iro.umontreal.ca) | |
28 | ;; Distribution restrictions: none | |
29 | ||
30 | (define genwrite:newline-str (make-string 1 #\newline)) | |
31 | ||
f5259dd3 | 32 | (define (generic-write obj display? width per-line-prefix output) |
b337528f MV |
33 | |
34 | (define (read-macro? l) | |
35 | (define (length1? l) (and (pair? l) (null? (cdr l)))) | |
36 | (let ((head (car l)) (tail (cdr l))) | |
37 | (case head | |
38 | ((quote quasiquote unquote unquote-splicing) (length1? tail)) | |
39 | (else #f)))) | |
40 | ||
41 | (define (read-macro-body l) | |
42 | (cadr l)) | |
43 | ||
44 | (define (read-macro-prefix l) | |
5bc8bc69 | 45 | (let ((head (car l))) |
b337528f MV |
46 | (case head |
47 | ((quote) "'") | |
48 | ((quasiquote) "`") | |
49 | ((unquote) ",") | |
50 | ((unquote-splicing) ",@")))) | |
51 | ||
52 | (define (out str col) | |
53 | (and col (output str) (+ col (string-length str)))) | |
54 | ||
55 | (define (wr obj col) | |
2d51a8a1 MV |
56 | (cond ((and (pair? obj) |
57 | (read-macro? obj)) | |
58 | (wr (read-macro-body obj) | |
59 | (out (read-macro-prefix obj) col))) | |
60 | (else | |
61 | (out (object->string obj (if display? display write)) col)))) | |
b337528f MV |
62 | |
63 | (define (pp obj col) | |
64 | ||
65 | (define (spaces n col) | |
66 | (if (> n 0) | |
67 | (if (> n 7) | |
68 | (spaces (- n 8) (out " " col)) | |
69 | (out (substring " " 0 n) col)) | |
70 | col)) | |
71 | ||
72 | (define (indent to col) | |
73 | (and col | |
74 | (if (< to col) | |
f5259dd3 MV |
75 | (and (out genwrite:newline-str col) |
76 | (out per-line-prefix 0) | |
77 | (spaces to 0)) | |
b337528f MV |
78 | (spaces (- to col) col)))) |
79 | ||
80 | (define (pr obj col extra pp-pair) | |
81 | (if (or (pair? obj) (vector? obj)) ; may have to split on multiple lines | |
82 | (let ((result '()) | |
83 | (left (min (+ (- (- width col) extra) 1) max-expr-width))) | |
f5259dd3 | 84 | (generic-write obj display? #f "" |
b337528f MV |
85 | (lambda (str) |
86 | (set! result (cons str result)) | |
87 | (set! left (- left (string-length str))) | |
88 | (> left 0))) | |
89 | (if (> left 0) ; all can be printed on one line | |
90 | (out (reverse-string-append result) col) | |
91 | (if (pair? obj) | |
92 | (pp-pair obj col extra) | |
93 | (pp-list (vector->list obj) (out "#" col) extra pp-expr)))) | |
94 | (wr obj col))) | |
95 | ||
96 | (define (pp-expr expr col extra) | |
97 | (if (read-macro? expr) | |
98 | (pr (read-macro-body expr) | |
99 | (out (read-macro-prefix expr) col) | |
100 | extra | |
101 | pp-expr) | |
102 | (let ((head (car expr))) | |
103 | (if (symbol? head) | |
104 | (let ((proc (style head))) | |
105 | (if proc | |
106 | (proc expr col extra) | |
107 | (if (> (string-length (symbol->string head)) | |
108 | max-call-head-width) | |
109 | (pp-general expr col extra #f #f #f pp-expr) | |
110 | (pp-call expr col extra pp-expr)))) | |
111 | (pp-list expr col extra pp-expr))))) | |
112 | ||
113 | ; (head item1 | |
114 | ; item2 | |
115 | ; item3) | |
116 | (define (pp-call expr col extra pp-item) | |
117 | (let ((col* (wr (car expr) (out "(" col)))) | |
118 | (and col | |
119 | (pp-down (cdr expr) col* (+ col* 1) extra pp-item)))) | |
120 | ||
121 | ; (item1 | |
122 | ; item2 | |
123 | ; item3) | |
124 | (define (pp-list l col extra pp-item) | |
125 | (let ((col (out "(" col))) | |
126 | (pp-down l col col extra pp-item))) | |
127 | ||
128 | (define (pp-down l col1 col2 extra pp-item) | |
129 | (let loop ((l l) (col col1)) | |
130 | (and col | |
131 | (cond ((pair? l) | |
132 | (let ((rest (cdr l))) | |
133 | (let ((extra (if (null? rest) (+ extra 1) 0))) | |
134 | (loop rest | |
135 | (pr (car l) (indent col2 col) extra pp-item))))) | |
136 | ((null? l) | |
137 | (out ")" col)) | |
138 | (else | |
139 | (out ")" | |
140 | (pr l | |
141 | (indent col2 (out "." (indent col2 col))) | |
142 | (+ extra 1) | |
143 | pp-item))))))) | |
144 | ||
145 | (define (pp-general expr col extra named? pp-1 pp-2 pp-3) | |
146 | ||
147 | (define (tail1 rest col1 col2 col3) | |
148 | (if (and pp-1 (pair? rest)) | |
149 | (let* ((val1 (car rest)) | |
150 | (rest (cdr rest)) | |
151 | (extra (if (null? rest) (+ extra 1) 0))) | |
152 | (tail2 rest col1 (pr val1 (indent col3 col2) extra pp-1) col3)) | |
153 | (tail2 rest col1 col2 col3))) | |
154 | ||
155 | (define (tail2 rest col1 col2 col3) | |
156 | (if (and pp-2 (pair? rest)) | |
157 | (let* ((val1 (car rest)) | |
158 | (rest (cdr rest)) | |
159 | (extra (if (null? rest) (+ extra 1) 0))) | |
160 | (tail3 rest col1 (pr val1 (indent col3 col2) extra pp-2))) | |
161 | (tail3 rest col1 col2))) | |
162 | ||
163 | (define (tail3 rest col1 col2) | |
164 | (pp-down rest col2 col1 extra pp-3)) | |
165 | ||
166 | (let* ((head (car expr)) | |
167 | (rest (cdr expr)) | |
168 | (col* (wr head (out "(" col)))) | |
169 | (if (and named? (pair? rest)) | |
170 | (let* ((name (car rest)) | |
171 | (rest (cdr rest)) | |
172 | (col** (wr name (out " " col*)))) | |
173 | (tail1 rest (+ col indent-general) col** (+ col** 1))) | |
174 | (tail1 rest (+ col indent-general) col* (+ col* 1))))) | |
175 | ||
176 | (define (pp-expr-list l col extra) | |
177 | (pp-list l col extra pp-expr)) | |
178 | ||
179 | (define (pp-LAMBDA expr col extra) | |
180 | (pp-general expr col extra #f pp-expr-list #f pp-expr)) | |
181 | ||
182 | (define (pp-IF expr col extra) | |
183 | (pp-general expr col extra #f pp-expr #f pp-expr)) | |
184 | ||
185 | (define (pp-COND expr col extra) | |
186 | (pp-call expr col extra pp-expr-list)) | |
187 | ||
188 | (define (pp-CASE expr col extra) | |
189 | (pp-general expr col extra #f pp-expr #f pp-expr-list)) | |
190 | ||
191 | (define (pp-AND expr col extra) | |
192 | (pp-call expr col extra pp-expr)) | |
193 | ||
194 | (define (pp-LET expr col extra) | |
195 | (let* ((rest (cdr expr)) | |
196 | (named? (and (pair? rest) (symbol? (car rest))))) | |
197 | (pp-general expr col extra named? pp-expr-list #f pp-expr))) | |
198 | ||
199 | (define (pp-BEGIN expr col extra) | |
200 | (pp-general expr col extra #f #f #f pp-expr)) | |
201 | ||
202 | (define (pp-DO expr col extra) | |
203 | (pp-general expr col extra #f pp-expr-list pp-expr-list pp-expr)) | |
204 | ||
205 | ; define formatting style (change these to suit your style) | |
206 | ||
207 | (define indent-general 2) | |
208 | ||
209 | (define max-call-head-width 5) | |
210 | ||
211 | (define max-expr-width 50) | |
212 | ||
213 | (define (style head) | |
214 | (case head | |
215 | ((lambda let* letrec define) pp-LAMBDA) | |
216 | ((if set!) pp-IF) | |
217 | ((cond) pp-COND) | |
218 | ((case) pp-CASE) | |
219 | ((and or) pp-AND) | |
220 | ((let) pp-LET) | |
221 | ((begin) pp-BEGIN) | |
222 | ((do) pp-DO) | |
223 | (else #f))) | |
224 | ||
225 | (pr obj col 0 pp-expr)) | |
226 | ||
f5259dd3 | 227 | (out per-line-prefix 0) |
b337528f MV |
228 | (if width |
229 | (out genwrite:newline-str (pp obj 0)) | |
21a10205 MV |
230 | (wr obj 0)) |
231 | ;; Return `unspecified' | |
232 | (if #f #f)) | |
b337528f MV |
233 | |
234 | ; (reverse-string-append l) = (apply string-append (reverse l)) | |
235 | ||
236 | (define (reverse-string-append l) | |
237 | ||
238 | (define (rev-string-append l i) | |
239 | (if (pair? l) | |
240 | (let* ((str (car l)) | |
241 | (len (string-length str)) | |
242 | (result (rev-string-append (cdr l) (+ i len)))) | |
243 | (let loop ((j 0) (k (- (- (string-length result) i) len))) | |
244 | (if (< j len) | |
245 | (begin | |
246 | (string-set! result k (string-ref str j)) | |
247 | (loop (+ j 1) (+ k 1))) | |
248 | result))) | |
249 | (make-string i))) | |
250 | ||
251 | (rev-string-append l 0)) | |
252 | ||
f5259dd3 MV |
253 | (define (pretty-print obj . opts) |
254 | "Pretty-print OBJ on PORT, which is a keyword argument defaulting to | |
255 | the current output port. Formatting can be controlled by a number of | |
256 | keyword arguments: Each line in the output is preceded by the string | |
257 | PER-LINE-PREFIX, which is empty by default. The output lines will be | |
258 | at most WIDTH characters wide; the default is 79. If DISPLAY? is | |
259 | true, display rather than write representation will be used. | |
260 | ||
261 | Instead of with a keyword argument, you can also specify the output | |
262 | port directly after OBJ, like (pretty-print OBJ PORT)." | |
263 | (if (pair? opts) | |
264 | (if (keyword? (car opts)) | |
265 | (apply pretty-print-with-keys obj opts) | |
266 | (apply pretty-print-with-keys obj #:port (car opts) (cdr opts))) | |
267 | (pretty-print-with-keys obj))) | |
268 | ||
269 | (define* (pretty-print-with-keys obj | |
270 | #:key | |
271 | (port (current-output-port)) | |
272 | (width 79) | |
273 | (display? #f) | |
274 | (per-line-prefix "")) | |
275 | (generic-write obj display? | |
276 | (- width (string-length per-line-prefix)) | |
277 | per-line-prefix | |
278 | (lambda (s) (display s port) #t))) |