42 |
;;;; If you do not wish that, delete this exception notice. |
;;;; If you do not wish that, delete this exception notice. |
43 |
;;;; |
;;;; |
44 |
(define-module (ice-9 pretty-print) |
(define-module (ice-9 pretty-print) |
45 |
|
:use-module (ice-9 optargs) |
46 |
:export (pretty-print)) |
:export (pretty-print)) |
47 |
|
|
48 |
;; From SLIB. |
;; From SLIB. |
54 |
|
|
55 |
(define genwrite:newline-str (make-string 1 #\newline)) |
(define genwrite:newline-str (make-string 1 #\newline)) |
56 |
|
|
57 |
(define (generic-write obj display? width output) |
(define (generic-write obj display? width per-line-prefix output) |
58 |
|
|
59 |
(define (read-macro? l) |
(define (read-macro? l) |
60 |
(define (length1? l) (and (pair? l) (null? (cdr l)))) |
(define (length1? l) (and (pair? l) (null? (cdr l)))) |
138 |
(define (indent to col) |
(define (indent to col) |
139 |
(and col |
(and col |
140 |
(if (< to col) |
(if (< to col) |
141 |
(and (out genwrite:newline-str col) (spaces to 0)) |
(and (out genwrite:newline-str col) |
142 |
|
(out per-line-prefix 0) |
143 |
|
(spaces to 0)) |
144 |
(spaces (- to col) col)))) |
(spaces (- to col) col)))) |
145 |
|
|
146 |
(define (pr obj col extra pp-pair) |
(define (pr obj col extra pp-pair) |
147 |
(if (or (pair? obj) (vector? obj)) ; may have to split on multiple lines |
(if (or (pair? obj) (vector? obj)) ; may have to split on multiple lines |
148 |
(let ((result '()) |
(let ((result '()) |
149 |
(left (min (+ (- (- width col) extra) 1) max-expr-width))) |
(left (min (+ (- (- width col) extra) 1) max-expr-width))) |
150 |
(generic-write obj display? #f |
(generic-write obj display? #f "" |
151 |
(lambda (str) |
(lambda (str) |
152 |
(set! result (cons str result)) |
(set! result (cons str result)) |
153 |
(set! left (- left (string-length str))) |
(set! left (- left (string-length str))) |
290 |
|
|
291 |
(pr obj col 0 pp-expr)) |
(pr obj col 0 pp-expr)) |
292 |
|
|
293 |
|
(out per-line-prefix 0) |
294 |
(if width |
(if width |
295 |
(out genwrite:newline-str (pp obj 0)) |
(out genwrite:newline-str (pp obj 0)) |
296 |
(wr obj 0)) |
(wr obj 0)) |
316 |
|
|
317 |
(rev-string-append l 0)) |
(rev-string-append l 0)) |
318 |
|
|
319 |
;"pp.scm" Pretty-Print |
(define (pretty-print obj . opts) |
320 |
(define (pretty-print obj . opt) |
"Pretty-print OBJ on PORT, which is a keyword argument defaulting to |
321 |
(let ((port (if (pair? opt) (car opt) (current-output-port)))) |
the current output port. Formatting can be controlled by a number of |
322 |
(generic-write obj #f 79 |
keyword arguments: Each line in the output is preceded by the string |
323 |
(lambda (s) (display s port) #t)))) |
PER-LINE-PREFIX, which is empty by default. The output lines will be |
324 |
|
at most WIDTH characters wide; the default is 79. If DISPLAY? is |
325 |
|
true, display rather than write representation will be used. |
326 |
|
|
327 |
|
Instead of with a keyword argument, you can also specify the output |
328 |
|
port directly after OBJ, like (pretty-print OBJ PORT)." |
329 |
|
(if (pair? opts) |
330 |
|
(if (keyword? (car opts)) |
331 |
|
(apply pretty-print-with-keys obj opts) |
332 |
|
(apply pretty-print-with-keys obj #:port (car opts) (cdr opts))) |
333 |
|
(pretty-print-with-keys obj))) |
334 |
|
|
335 |
|
(define* (pretty-print-with-keys obj |
336 |
|
#:key |
337 |
|
(port (current-output-port)) |
338 |
|
(width 79) |
339 |
|
(display? #f) |
340 |
|
(per-line-prefix "")) |
341 |
|
(generic-write obj display? |
342 |
|
(- width (string-length per-line-prefix)) |
343 |
|
per-line-prefix |
344 |
|
(lambda (s) (display s port) #t))) |