Commit | Line | Data |
---|---|---|
c5e05a1c | 1 | ;;;; -*- coding: utf-8; mode: scheme -*- |
a482f2cc | 2 | ;;;; |
8c43b28a | 3 | ;;;; Copyright (C) 2001, 2004, 2006, 2009, 2010, |
5fc051ba | 4 | ;;;; 2012, 2013, 2014 Free Software Foundation, Inc. |
a482f2cc | 5 | ;;;; |
73be1d9e MV |
6 | ;;;; This library is free software; you can redistribute it and/or |
7 | ;;;; modify it under the terms of the GNU Lesser General Public | |
8 | ;;;; License as published by the Free Software Foundation; either | |
53befeb7 | 9 | ;;;; version 3 of the License, or (at your option) any later version. |
a482f2cc | 10 | ;;;; |
73be1d9e | 11 | ;;;; This library is distributed in the hope that it will be useful, |
a482f2cc | 12 | ;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of |
73be1d9e MV |
13 | ;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU |
14 | ;;;; Lesser General Public License for more details. | |
a482f2cc | 15 | ;;;; |
73be1d9e MV |
16 | ;;;; You should have received a copy of the GNU Lesser General Public |
17 | ;;;; License along with this library; if not, write to the Free Software | |
92205699 | 18 | ;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA |
a482f2cc | 19 | ;;;; |
1a179b03 | 20 | (define-module (ice-9 pretty-print) |
5bae880e LC |
21 | #:use-module (ice-9 match) |
22 | #:use-module (srfi srfi-1) | |
2f3b7e9a | 23 | #:use-module (rnrs bytevectors) |
8c6eea2f AW |
24 | #:export (pretty-print |
25 | truncated-print)) | |
c1ff4aa7 | 26 | |
b337528f MV |
27 | |
28 | ;; From SLIB. | |
29 | ||
30 | ;;"genwrite.scm" generic write used by pretty-print and truncated-print. | |
31 | ;; Copyright (c) 1991, Marc Feeley | |
32 | ;; Author: Marc Feeley (feeley@iro.umontreal.ca) | |
33 | ;; Distribution restrictions: none | |
34 | ||
35 | (define genwrite:newline-str (make-string 1 #\newline)) | |
36 | ||
8c43b28a MW |
37 | (define (generic-write |
38 | obj display? width max-expr-width per-line-prefix output) | |
b337528f MV |
39 | |
40 | (define (read-macro? l) | |
41 | (define (length1? l) (and (pair? l) (null? (cdr l)))) | |
42 | (let ((head (car l)) (tail (cdr l))) | |
43 | (case head | |
44 | ((quote quasiquote unquote unquote-splicing) (length1? tail)) | |
45 | (else #f)))) | |
46 | ||
47 | (define (read-macro-body l) | |
48 | (cadr l)) | |
49 | ||
50 | (define (read-macro-prefix l) | |
5bc8bc69 | 51 | (let ((head (car l))) |
b337528f MV |
52 | (case head |
53 | ((quote) "'") | |
54 | ((quasiquote) "`") | |
55 | ((unquote) ",") | |
56 | ((unquote-splicing) ",@")))) | |
57 | ||
58 | (define (out str col) | |
59 | (and col (output str) (+ col (string-length str)))) | |
60 | ||
61 | (define (wr obj col) | |
5bae880e LC |
62 | (let loop ((obj obj) |
63 | (col col)) | |
64 | (match obj | |
65 | (((or 'quote 'quasiquote 'unquote 'unquote-splicing) body) | |
66 | (wr body (out (read-macro-prefix obj) col))) | |
67 | ((head . (rest ...)) | |
68 | ;; A proper list: do our own list printing so as to catch read | |
69 | ;; macros that appear in the middle of the list. | |
70 | (let ((col (loop head (out "(" col)))) | |
71 | (out ")" | |
72 | (fold (lambda (i col) | |
73 | (loop i (out " " col))) | |
74 | col rest)))) | |
75 | (_ | |
76 | (out (object->string obj (if display? display write)) col))))) | |
b337528f MV |
77 | |
78 | (define (pp obj col) | |
79 | ||
80 | (define (spaces n col) | |
81 | (if (> n 0) | |
82 | (if (> n 7) | |
83 | (spaces (- n 8) (out " " col)) | |
84 | (out (substring " " 0 n) col)) | |
85 | col)) | |
86 | ||
87 | (define (indent to col) | |
88 | (and col | |
89 | (if (< to col) | |
f5259dd3 MV |
90 | (and (out genwrite:newline-str col) |
91 | (out per-line-prefix 0) | |
92 | (spaces to 0)) | |
b337528f MV |
93 | (spaces (- to col) col)))) |
94 | ||
95 | (define (pr obj col extra pp-pair) | |
96 | (if (or (pair? obj) (vector? obj)) ; may have to split on multiple lines | |
97 | (let ((result '()) | |
98 | (left (min (+ (- (- width col) extra) 1) max-expr-width))) | |
8c43b28a | 99 | (generic-write obj display? #f max-expr-width "" |
b337528f MV |
100 | (lambda (str) |
101 | (set! result (cons str result)) | |
102 | (set! left (- left (string-length str))) | |
103 | (> left 0))) | |
104 | (if (> left 0) ; all can be printed on one line | |
105 | (out (reverse-string-append result) col) | |
106 | (if (pair? obj) | |
107 | (pp-pair obj col extra) | |
108 | (pp-list (vector->list obj) (out "#" col) extra pp-expr)))) | |
109 | (wr obj col))) | |
110 | ||
111 | (define (pp-expr expr col extra) | |
112 | (if (read-macro? expr) | |
113 | (pr (read-macro-body expr) | |
114 | (out (read-macro-prefix expr) col) | |
115 | extra | |
116 | pp-expr) | |
117 | (let ((head (car expr))) | |
118 | (if (symbol? head) | |
119 | (let ((proc (style head))) | |
120 | (if proc | |
121 | (proc expr col extra) | |
122 | (if (> (string-length (symbol->string head)) | |
123 | max-call-head-width) | |
124 | (pp-general expr col extra #f #f #f pp-expr) | |
125 | (pp-call expr col extra pp-expr)))) | |
126 | (pp-list expr col extra pp-expr))))) | |
127 | ||
128 | ; (head item1 | |
129 | ; item2 | |
130 | ; item3) | |
131 | (define (pp-call expr col extra pp-item) | |
132 | (let ((col* (wr (car expr) (out "(" col)))) | |
133 | (and col | |
134 | (pp-down (cdr expr) col* (+ col* 1) extra pp-item)))) | |
135 | ||
136 | ; (item1 | |
137 | ; item2 | |
138 | ; item3) | |
139 | (define (pp-list l col extra pp-item) | |
140 | (let ((col (out "(" col))) | |
141 | (pp-down l col col extra pp-item))) | |
142 | ||
143 | (define (pp-down l col1 col2 extra pp-item) | |
144 | (let loop ((l l) (col col1)) | |
145 | (and col | |
146 | (cond ((pair? l) | |
147 | (let ((rest (cdr l))) | |
148 | (let ((extra (if (null? rest) (+ extra 1) 0))) | |
149 | (loop rest | |
150 | (pr (car l) (indent col2 col) extra pp-item))))) | |
151 | ((null? l) | |
152 | (out ")" col)) | |
153 | (else | |
154 | (out ")" | |
155 | (pr l | |
156 | (indent col2 (out "." (indent col2 col))) | |
157 | (+ extra 1) | |
158 | pp-item))))))) | |
159 | ||
160 | (define (pp-general expr col extra named? pp-1 pp-2 pp-3) | |
161 | ||
162 | (define (tail1 rest col1 col2 col3) | |
163 | (if (and pp-1 (pair? rest)) | |
164 | (let* ((val1 (car rest)) | |
165 | (rest (cdr rest)) | |
166 | (extra (if (null? rest) (+ extra 1) 0))) | |
167 | (tail2 rest col1 (pr val1 (indent col3 col2) extra pp-1) col3)) | |
168 | (tail2 rest col1 col2 col3))) | |
169 | ||
170 | (define (tail2 rest col1 col2 col3) | |
171 | (if (and pp-2 (pair? rest)) | |
172 | (let* ((val1 (car rest)) | |
173 | (rest (cdr rest)) | |
174 | (extra (if (null? rest) (+ extra 1) 0))) | |
175 | (tail3 rest col1 (pr val1 (indent col3 col2) extra pp-2))) | |
176 | (tail3 rest col1 col2))) | |
177 | ||
178 | (define (tail3 rest col1 col2) | |
179 | (pp-down rest col2 col1 extra pp-3)) | |
180 | ||
181 | (let* ((head (car expr)) | |
182 | (rest (cdr expr)) | |
183 | (col* (wr head (out "(" col)))) | |
184 | (if (and named? (pair? rest)) | |
185 | (let* ((name (car rest)) | |
186 | (rest (cdr rest)) | |
187 | (col** (wr name (out " " col*)))) | |
188 | (tail1 rest (+ col indent-general) col** (+ col** 1))) | |
189 | (tail1 rest (+ col indent-general) col* (+ col* 1))))) | |
190 | ||
191 | (define (pp-expr-list l col extra) | |
192 | (pp-list l col extra pp-expr)) | |
193 | ||
194 | (define (pp-LAMBDA expr col extra) | |
195 | (pp-general expr col extra #f pp-expr-list #f pp-expr)) | |
196 | ||
197 | (define (pp-IF expr col extra) | |
198 | (pp-general expr col extra #f pp-expr #f pp-expr)) | |
199 | ||
200 | (define (pp-COND expr col extra) | |
201 | (pp-call expr col extra pp-expr-list)) | |
202 | ||
203 | (define (pp-CASE expr col extra) | |
204 | (pp-general expr col extra #f pp-expr #f pp-expr-list)) | |
205 | ||
206 | (define (pp-AND expr col extra) | |
207 | (pp-call expr col extra pp-expr)) | |
208 | ||
209 | (define (pp-LET expr col extra) | |
210 | (let* ((rest (cdr expr)) | |
211 | (named? (and (pair? rest) (symbol? (car rest))))) | |
212 | (pp-general expr col extra named? pp-expr-list #f pp-expr))) | |
213 | ||
214 | (define (pp-BEGIN expr col extra) | |
215 | (pp-general expr col extra #f #f #f pp-expr)) | |
216 | ||
217 | (define (pp-DO expr col extra) | |
218 | (pp-general expr col extra #f pp-expr-list pp-expr-list pp-expr)) | |
219 | ||
253f2608 LC |
220 | (define (pp-SYNTAX-CASE expr col extra) |
221 | (pp-general expr col extra #t pp-expr-list #f pp-expr)) | |
222 | ||
b337528f MV |
223 | ; define formatting style (change these to suit your style) |
224 | ||
225 | (define indent-general 2) | |
226 | ||
227 | (define max-call-head-width 5) | |
228 | ||
b337528f MV |
229 | (define (style head) |
230 | (case head | |
8c43b28a MW |
231 | ((lambda lambda* let* letrec define define* define-public |
232 | define-syntax let-syntax letrec-syntax with-syntax) | |
253f2608 | 233 | pp-LAMBDA) |
b337528f MV |
234 | ((if set!) pp-IF) |
235 | ((cond) pp-COND) | |
236 | ((case) pp-CASE) | |
237 | ((and or) pp-AND) | |
238 | ((let) pp-LET) | |
239 | ((begin) pp-BEGIN) | |
240 | ((do) pp-DO) | |
253f2608 LC |
241 | ((syntax-rules) pp-LAMBDA) |
242 | ((syntax-case) pp-SYNTAX-CASE) | |
b337528f MV |
243 | (else #f))) |
244 | ||
245 | (pr obj col 0 pp-expr)) | |
246 | ||
f5259dd3 | 247 | (out per-line-prefix 0) |
b337528f MV |
248 | (if width |
249 | (out genwrite:newline-str (pp obj 0)) | |
21a10205 MV |
250 | (wr obj 0)) |
251 | ;; Return `unspecified' | |
252 | (if #f #f)) | |
b337528f MV |
253 | |
254 | ; (reverse-string-append l) = (apply string-append (reverse l)) | |
255 | ||
256 | (define (reverse-string-append l) | |
257 | ||
258 | (define (rev-string-append l i) | |
259 | (if (pair? l) | |
260 | (let* ((str (car l)) | |
261 | (len (string-length str)) | |
262 | (result (rev-string-append (cdr l) (+ i len)))) | |
263 | (let loop ((j 0) (k (- (- (string-length result) i) len))) | |
264 | (if (< j len) | |
265 | (begin | |
266 | (string-set! result k (string-ref str j)) | |
267 | (loop (+ j 1) (+ k 1))) | |
268 | result))) | |
269 | (make-string i))) | |
270 | ||
271 | (rev-string-append l 0)) | |
272 | ||
8c6eea2f | 273 | (define* (pretty-print obj #:optional port* |
c1ff4aa7 | 274 | #:key |
8c6eea2f | 275 | (port (or port* (current-output-port))) |
c1ff4aa7 | 276 | (width 79) |
8c43b28a | 277 | (max-expr-width 50) |
c1ff4aa7 AW |
278 | (display? #f) |
279 | (per-line-prefix "")) | |
f5259dd3 MV |
280 | "Pretty-print OBJ on PORT, which is a keyword argument defaulting to |
281 | the current output port. Formatting can be controlled by a number of | |
282 | keyword arguments: Each line in the output is preceded by the string | |
283 | PER-LINE-PREFIX, which is empty by default. The output lines will be | |
284 | at most WIDTH characters wide; the default is 79. If DISPLAY? is | |
285 | true, display rather than write representation will be used. | |
286 | ||
287 | Instead of with a keyword argument, you can also specify the output | |
288 | port directly after OBJ, like (pretty-print OBJ PORT)." | |
f5259dd3 MV |
289 | (generic-write obj display? |
290 | (- width (string-length per-line-prefix)) | |
8c43b28a | 291 | max-expr-width |
f5259dd3 | 292 | per-line-prefix |
8c6eea2f AW |
293 | (lambda (s) (display s port) #t))) |
294 | ||
c5e05a1c | 295 | \f |
8c6eea2f AW |
296 | ;; `truncated-print' was written in 2009 by Andy Wingo, and is not from |
297 | ;; genwrite.scm. | |
298 | (define* (truncated-print x #:optional port* | |
299 | #:key | |
300 | (port (or port* (current-output-port))) | |
301 | (width 79) | |
302 | (display? #f) | |
303 | (breadth-first? #f)) | |
91a214eb | 304 | "Print @var{x}, truncating the output, if necessary, to make it fit |
8c6eea2f AW |
305 | into @var{width} characters. By default, @var{x} will be printed using |
306 | @code{write}, though that behavior can be overriden via the | |
307 | @var{display?} keyword argument. | |
308 | ||
309 | The default behaviour is to print depth-first, meaning that the entire | |
c5e05a1c | 310 | remaining width will be available to each sub-expression of @var{x} -- |
8c6eea2f AW |
311 | e.g., if @var{x} is a vector, each member of @var{x}. One can attempt to |
312 | \"ration\" the available width, trying to allocate it equally to each | |
313 | sub-expression, via the @var{breadth-first?} keyword argument." | |
314 | ||
6dce942c MW |
315 | (define ellipsis |
316 | ;; Choose between `HORIZONTAL ELLIPSIS' (U+2026) and three dots, depending | |
317 | ;; on the encoding of PORT. | |
318 | (let ((e "…")) | |
319 | (catch 'encoding-error | |
320 | (lambda () | |
321 | (with-fluids ((%default-port-conversion-strategy 'error)) | |
322 | (call-with-output-string | |
323 | (lambda (p) | |
324 | (set-port-encoding! p (port-encoding port)) | |
325 | (display e p))))) | |
326 | (lambda (key . args) | |
327 | "...")))) | |
328 | ||
329 | (let ((ellipsis-width (string-length ellipsis))) | |
330 | ||
331 | (define (print-sequence x width len ref next) | |
332 | (let lp ((x x) | |
333 | (width width) | |
334 | (i 0)) | |
335 | (if (> i 0) | |
336 | (display #\space)) | |
c5e05a1c | 337 | (cond |
6dce942c MW |
338 | ((= i len)) ; catches 0-length case |
339 | ((and (= i (1- len)) (or (zero? i) (> width 1))) | |
340 | (print (ref x i) (if (zero? i) width (1- width)))) | |
341 | ((<= width (+ 1 ellipsis-width)) | |
342 | (display ellipsis)) | |
c5e05a1c | 343 | (else |
6dce942c MW |
344 | (let ((str (with-output-to-string |
345 | (lambda () | |
346 | (print (ref x i) | |
347 | (if breadth-first? | |
348 | (max 1 | |
349 | (1- (floor (/ width (- len i))))) | |
350 | (- width (+ 1 ellipsis-width)))))))) | |
351 | (display str) | |
352 | (lp (next x) (- width 1 (string-length str)) (1+ i))))))) | |
353 | ||
354 | (define (print-tree x width) | |
355 | ;; width is >= the width of # . #, which is 5 | |
356 | (let lp ((x x) | |
357 | (width width)) | |
358 | (cond | |
359 | ((or (not (pair? x)) (<= width 4)) | |
360 | (display ". ") | |
361 | (print x (- width 2))) | |
362 | (else | |
363 | ;; width >= 5 | |
364 | (let ((str (with-output-to-string | |
365 | (lambda () | |
366 | (print (car x) | |
367 | (if breadth-first? | |
368 | (floor (/ (- width 3) 2)) | |
369 | (- width 4))))))) | |
370 | (display str) | |
371 | (display " ") | |
372 | (lp (cdr x) (- width 1 (string-length str)))))))) | |
373 | ||
374 | (define (truncate-string str width) | |
375 | ;; width is < (string-length str) | |
376 | (let lp ((fixes '(("#<" . ">") | |
377 | ("#(" . ")") | |
378 | ("(" . ")") | |
379 | ("\"" . "\"")))) | |
380 | (cond | |
381 | ((null? fixes) | |
382 | "#") | |
383 | ((and (string-prefix? (caar fixes) str) | |
384 | (string-suffix? (cdar fixes) str) | |
385 | (>= (string-length str) | |
386 | width | |
387 | (+ (string-length (caar fixes)) | |
388 | (string-length (cdar fixes)) | |
389 | ellipsis-width))) | |
390 | (format #f "~a~a~a~a" | |
391 | (caar fixes) | |
392 | (substring str (string-length (caar fixes)) | |
393 | (- width (string-length (cdar fixes)) | |
394 | ellipsis-width)) | |
395 | ellipsis | |
396 | (cdar fixes))) | |
397 | (else | |
398 | (lp (cdr fixes)))))) | |
399 | ||
400 | (define (print x width) | |
401 | (cond | |
402 | ((<= width 0) | |
403 | (error "expected a positive width" width)) | |
404 | ((list? x) | |
405 | (cond | |
406 | ((>= width (+ 2 ellipsis-width)) | |
407 | (display "(") | |
408 | (print-sequence x (- width 2) (length x) | |
409 | (lambda (x i) (car x)) cdr) | |
410 | (display ")")) | |
411 | (else | |
412 | (display "#")))) | |
413 | ((vector? x) | |
414 | (cond | |
415 | ((>= width (+ 3 ellipsis-width)) | |
416 | (display "#(") | |
417 | (print-sequence x (- width 3) (vector-length x) | |
418 | vector-ref identity) | |
419 | (display ")")) | |
420 | (else | |
421 | (display "#")))) | |
5fc051ba | 422 | ((bytevector? x) |
6dce942c MW |
423 | (cond |
424 | ((>= width 9) | |
5fc051ba AW |
425 | (format #t "#~a(" (array-type x)) |
426 | (print-sequence x (- width 6) (array-length x) | |
427 | array-ref identity) | |
6dce942c MW |
428 | (display ")")) |
429 | (else | |
430 | (display "#")))) | |
431 | ((pair? x) | |
432 | (cond | |
433 | ((>= width (+ 4 ellipsis-width)) | |
434 | (display "(") | |
435 | (print-tree x (- width 2)) | |
436 | (display ")")) | |
437 | (else | |
438 | (display "#")))) | |
439 | (else | |
440 | (let* ((str (with-output-to-string | |
441 | (lambda () (if display? (display x) (write x))))) | |
442 | (len (string-length str))) | |
443 | (display (if (<= (string-length str) width) | |
444 | str | |
445 | (truncate-string str width))))))) | |
446 | ||
447 | (with-output-to-port port | |
448 | (lambda () | |
449 | (print x width))))) |