[bpt/guile.git] / ice-9 / pretty-print.scm

;;;; -*-scheme-*-
;;;;
;;;; 	Copyright (C) 2001 Free Software Foundation, Inc.
;;;; 
;;;; This library is free software; you can redistribute it and/or
;;;; modify it under the terms of the GNU Lesser General Public
;;;; License as published by the Free Software Foundation; either
;;;; version 2.1 of the License, or (at your option) any later version.
;;;; 
;;;; This library is distributed in the hope that it will be useful,
;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
;;;; Lesser General Public License for more details.
;;;; 
;;;; You should have received a copy of the GNU Lesser General Public
;;;; License along with this library; if not, write to the Free Software
;;;; Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
;;;; 
(define-module (ice-9 pretty-print)
  :use-module (ice-9 optargs)
  :export (pretty-print))

;; From SLIB.

;;"genwrite.scm" generic write used by pretty-print and truncated-print.
;; Copyright (c) 1991, Marc Feeley
;; Author: Marc Feeley (feeley@iro.umontreal.ca)
;; Distribution restrictions: none

(define genwrite:newline-str (make-string 1 #\newline))

(define (generic-write obj display? width per-line-prefix output)

  (define (read-macro? l)
    (define (length1? l) (and (pair? l) (null? (cdr l))))
    (let ((head (car l)) (tail (cdr l)))
      (case head
        ((quote quasiquote unquote unquote-splicing) (length1? tail))
        (else                                        #f))))

  (define (read-macro-body l)
    (cadr l))

  (define (read-macro-prefix l)
    (let ((head (car l)) (tail (cdr l)))
      (case head
        ((quote)            "'")
        ((quasiquote)       "`")
        ((unquote)          ",")
        ((unquote-splicing) ",@"))))

  (define (out str col)
    (and col (output str) (+ col (string-length str))))

  (define (wr obj col)

    (define (wr-expr expr col)
      (if (read-macro? expr)
        (wr (read-macro-body expr) (out (read-macro-prefix expr) col))
        (wr-lst expr col)))

    (define (wr-lst l col)
      (if (pair? l)
	  (let loop ((l (cdr l))
		     (col (and col (wr (car l) (out "(" col)))))
	    (cond ((not col) col)
		  ((pair? l)
		   (loop (cdr l) (wr (car l) (out " " col))))
		  ((null? l) (out ")" col))
		  (else      (out ")" (wr l (out " . " col))))))
	  (out "()" col)))

    (cond ((pair? obj)        (wr-expr obj col))
          ((null? obj)        (wr-lst obj col))
          ((vector? obj)      (wr-lst (vector->list obj) (out "#" col)))
          ((boolean? obj)     (out (if obj "#t" "#f") col))
          ((number? obj)      (out (number->string obj) col))
          ((symbol? obj)      (out (symbol->string obj) col))
          ((procedure? obj)   (out "#[procedure]" col))
          ((string? obj)      (if display?
                                (out obj col)
                                (let loop ((i 0) (j 0) (col (out "\"" col)))
                                  (if (and col (< j (string-length obj)))
                                    (let ((c (string-ref obj j)))
                                      (if (or (char=? c #\\)
                                              (char=? c #\"))
                                        (loop j
                                              (+ j 1)
                                              (out "\\"
                                                   (out (substring obj i j)
                                                        col)))
                                        (loop i (+ j 1) col)))
                                    (out "\""
                                         (out (substring obj i j) col))))))
          ((char? obj)        (if display?
                                (out (make-string 1 obj) col)
                                (out (case obj
                                       ((#\space)   "space")
                                       ((#\newline) "newline")
                                       (else        (make-string 1 obj)))
                                     (out "#\\" col))))
	  (else               (out (object->string obj) col))))

  (define (pp obj col)

    (define (spaces n col)
      (if (> n 0)
        (if (> n 7)
          (spaces (- n 8) (out "        " col))
          (out (substring "        " 0 n) col))
        col))

    (define (indent to col)
      (and col
           (if (< to col)
             (and (out genwrite:newline-str col)
		  (out per-line-prefix 0)
		  (spaces to 0))
             (spaces (- to col) col))))

    (define (pr obj col extra pp-pair)
      (if (or (pair? obj) (vector? obj)) ; may have to split on multiple lines
        (let ((result '())
              (left (min (+ (- (- width col) extra) 1) max-expr-width)))
          (generic-write obj display? #f ""
            (lambda (str)
              (set! result (cons str result))
              (set! left (- left (string-length str)))
              (> left 0)))
          (if (> left 0) ; all can be printed on one line
            (out (reverse-string-append result) col)
            (if (pair? obj)
              (pp-pair obj col extra)
              (pp-list (vector->list obj) (out "#" col) extra pp-expr))))
        (wr obj col)))

    (define (pp-expr expr col extra)
      (if (read-macro? expr)
        (pr (read-macro-body expr)
            (out (read-macro-prefix expr) col)
            extra
            pp-expr)
        (let ((head (car expr)))
          (if (symbol? head)
            (let ((proc (style head)))
              (if proc
                (proc expr col extra)
                (if (> (string-length (symbol->string head))
                       max-call-head-width)
                  (pp-general expr col extra #f #f #f pp-expr)
                  (pp-call expr col extra pp-expr))))
            (pp-list expr col extra pp-expr)))))

    ; (head item1
    ;       item2
    ;       item3)
    (define (pp-call expr col extra pp-item)
      (let ((col* (wr (car expr) (out "(" col))))
        (and col
             (pp-down (cdr expr) col* (+ col* 1) extra pp-item))))

    ; (item1
    ;  item2
    ;  item3)
    (define (pp-list l col extra pp-item)
      (let ((col (out "(" col)))
        (pp-down l col col extra pp-item)))

    (define (pp-down l col1 col2 extra pp-item)
      (let loop ((l l) (col col1))
        (and col
             (cond ((pair? l)
                    (let ((rest (cdr l)))
                      (let ((extra (if (null? rest) (+ extra 1) 0)))
                        (loop rest
                              (pr (car l) (indent col2 col) extra pp-item)))))
                   ((null? l)
                    (out ")" col))
                   (else
                    (out ")"
                         (pr l
                             (indent col2 (out "." (indent col2 col)))
                             (+ extra 1)
                             pp-item)))))))

    (define (pp-general expr col extra named? pp-1 pp-2 pp-3)

      (define (tail1 rest col1 col2 col3)
        (if (and pp-1 (pair? rest))
          (let* ((val1 (car rest))
                 (rest (cdr rest))
                 (extra (if (null? rest) (+ extra 1) 0)))
            (tail2 rest col1 (pr val1 (indent col3 col2) extra pp-1) col3))
          (tail2 rest col1 col2 col3)))

      (define (tail2 rest col1 col2 col3)
        (if (and pp-2 (pair? rest))
          (let* ((val1 (car rest))
                 (rest (cdr rest))
                 (extra (if (null? rest) (+ extra 1) 0)))
            (tail3 rest col1 (pr val1 (indent col3 col2) extra pp-2)))
          (tail3 rest col1 col2)))

      (define (tail3 rest col1 col2)
        (pp-down rest col2 col1 extra pp-3))

      (let* ((head (car expr))
             (rest (cdr expr))
             (col* (wr head (out "(" col))))
        (if (and named? (pair? rest))
          (let* ((name (car rest))
                 (rest (cdr rest))
                 (col** (wr name (out " " col*))))
            (tail1 rest (+ col indent-general) col** (+ col** 1)))
          (tail1 rest (+ col indent-general) col* (+ col* 1)))))

    (define (pp-expr-list l col extra)
      (pp-list l col extra pp-expr))

    (define (pp-LAMBDA expr col extra)
      (pp-general expr col extra #f pp-expr-list #f pp-expr))

    (define (pp-IF expr col extra)
      (pp-general expr col extra #f pp-expr #f pp-expr))

    (define (pp-COND expr col extra)
      (pp-call expr col extra pp-expr-list))

    (define (pp-CASE expr col extra)
      (pp-general expr col extra #f pp-expr #f pp-expr-list))

    (define (pp-AND expr col extra)
      (pp-call expr col extra pp-expr))

    (define (pp-LET expr col extra)
      (let* ((rest (cdr expr))
             (named? (and (pair? rest) (symbol? (car rest)))))
        (pp-general expr col extra named? pp-expr-list #f pp-expr)))

    (define (pp-BEGIN expr col extra)
      (pp-general expr col extra #f #f #f pp-expr))

    (define (pp-DO expr col extra)
      (pp-general expr col extra #f pp-expr-list pp-expr-list pp-expr))

    ; define formatting style (change these to suit your style)

    (define indent-general 2)

    (define max-call-head-width 5)

    (define max-expr-width 50)

    (define (style head)
      (case head
        ((lambda let* letrec define) pp-LAMBDA)
        ((if set!)                   pp-IF)
        ((cond)                      pp-COND)
        ((case)                      pp-CASE)
        ((and or)                    pp-AND)
        ((let)                       pp-LET)
        ((begin)                     pp-BEGIN)
        ((do)                        pp-DO)
        (else                        #f)))

    (pr obj col 0 pp-expr))

  (out per-line-prefix 0)
  (if width
    (out genwrite:newline-str (pp obj 0))
    (wr obj 0))
  ;; Return `unspecified'
  (if #f #f))

; (reverse-string-append l) = (apply string-append (reverse l))

(define (reverse-string-append l)

  (define (rev-string-append l i)
    (if (pair? l)
      (let* ((str (car l))
             (len (string-length str))
             (result (rev-string-append (cdr l) (+ i len))))
        (let loop ((j 0) (k (- (- (string-length result) i) len)))
          (if (< j len)
            (begin
              (string-set! result k (string-ref str j))
              (loop (+ j 1) (+ k 1)))
            result)))
      (make-string i)))

  (rev-string-append l 0))

(define (pretty-print obj . opts)
  "Pretty-print OBJ on PORT, which is a keyword argument defaulting to
the current output port.  Formatting can be controlled by a number of
keyword arguments: Each line in the output is preceded by the string
PER-LINE-PREFIX, which is empty by default.  The output lines will be
at most WIDTH characters wide; the default is 79.  If DISPLAY? is
true, display rather than write representation will be used.

Instead of with a keyword argument, you can also specify the output
port directly after OBJ, like (pretty-print OBJ PORT)."
  (if (pair? opts)
      (if (keyword? (car opts))
	  (apply pretty-print-with-keys obj opts)
	  (apply pretty-print-with-keys obj #:port (car opts) (cdr opts)))
      (pretty-print-with-keys obj)))

(define* (pretty-print-with-keys obj
				 #:key 
				 (port (current-output-port))
				 (width 79)
				 (display? #f)
				 (per-line-prefix ""))
  (generic-write obj display?
		 (- width (string-length per-line-prefix))
		 per-line-prefix
		 (lambda (s) (display s port) #t)))
Commit	Line	Data
a482f2cc MV	1	;;;; --scheme--
	2	;;;;
	3	;;;; Copyright (C) 2001 Free Software Foundation, Inc.
	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
73be1d9e MV	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
	17	;;;; Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 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)
	45	(let ((head (car l)) (tail (cdr l)))
	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)
	56
	57	(define (wr-expr expr col)
	58	(if (read-macro? expr)
	59	(wr (read-macro-body expr) (out (read-macro-prefix expr) col))
	60	(wr-lst expr col)))
	61
	62	(define (wr-lst l col)
	63	(if (pair? l)
	64	(let loop ((l (cdr l))
	65	(col (and col (wr (car l) (out "(" col)))))
	66	(cond ((not col) col)
	67	((pair? l)
	68	(loop (cdr l) (wr (car l) (out " " col))))
	69	((null? l) (out ")" col))
	70	(else (out ")" (wr l (out " . " col))))))
	71	(out "()" col)))
	72
	73	(cond ((pair? obj) (wr-expr obj col))
	74	((null? obj) (wr-lst obj col))
	75	((vector? obj) (wr-lst (vector->list obj) (out "#" col)))
	76	((boolean? obj) (out (if obj "#t" "#f") col))
	77	((number? obj) (out (number->string obj) col))
	78	((symbol? obj) (out (symbol->string obj) col))
	79	((procedure? obj) (out "#[procedure]" col))
	80	((string? obj) (if display?
	81	(out obj col)
	82	(let loop ((i 0) (j 0) (col (out "\"" col)))
	83	(if (and col (< j (string-length obj)))
	84	(let ((c (string-ref obj j)))
	85	(if (or (char=? c #\\)
	86	(char=? c #\"))
	87	(loop j
	88	(+ j 1)
	89	(out "\\"
	90	(out (substring obj i j)
	91	col)))
	92	(loop i (+ j 1) col)))
	93	(out "\""
	94	(out (substring obj i j) col))))))
	95	((char? obj) (if display?
	96	(out (make-string 1 obj) col)
97	(out (case obj
98	((#\space) "space")
99	((#\newline) "newline")
100	(else (make-string 1 obj)))
101	(out "#\\" col))))
269ce439	102	(else (out (object->string obj) col))))
b337528f MV	103
	104	(define (pp obj col)
	105
	106	(define (spaces n col)
	107	(if (> n 0)
	108	(if (> n 7)
	109	(spaces (- n 8) (out " " col))
	110	(out (substring " " 0 n) col))
	111	col))
	112
	113	(define (indent to col)
	114	(and col
	115	(if (< to col)
f5259dd3 MV	116	(and (out genwrite:newline-str col)
	117	(out per-line-prefix 0)
	118	(spaces to 0))
b337528f MV	119	(spaces (- to col) col))))
	120
	121	(define (pr obj col extra pp-pair)
	122	(if (or (pair? obj) (vector? obj)) ; may have to split on multiple lines
	123	(let ((result '())
	124	(left (min (+ (- (- width col) extra) 1) max-expr-width)))
f5259dd3	125	(generic-write obj display? #f ""
b337528f MV	126	(lambda (str)
	127	(set! result (cons str result))
	128	(set! left (- left (string-length str)))
	129	(> left 0)))
	130	(if (> left 0) ; all can be printed on one line
	131	(out (reverse-string-append result) col)
	132	(if (pair? obj)
	133	(pp-pair obj col extra)
	134	(pp-list (vector->list obj) (out "#" col) extra pp-expr))))
	135	(wr obj col)))
	136
	137	(define (pp-expr expr col extra)
	138	(if (read-macro? expr)
	139	(pr (read-macro-body expr)
	140	(out (read-macro-prefix expr) col)
	141	extra
	142	pp-expr)
	143	(let ((head (car expr)))
	144	(if (symbol? head)
	145	(let ((proc (style head)))
	146	(if proc
	147	(proc expr col extra)
	148	(if (> (string-length (symbol->string head))
	149	max-call-head-width)
	150	(pp-general expr col extra #f #f #f pp-expr)
	151	(pp-call expr col extra pp-expr))))
	152	(pp-list expr col extra pp-expr)))))
	153
	154	; (head item1
	155	; item2
	156	; item3)
	157	(define (pp-call expr col extra pp-item)
	158	(let ((col* (wr (car expr) (out "(" col))))
	159	(and col
	160	(pp-down (cdr expr) col* (+ col* 1) extra pp-item))))
	161
	162	; (item1
	163	; item2
	164	; item3)
	165	(define (pp-list l col extra pp-item)
	166	(let ((col (out "(" col)))
	167	(pp-down l col col extra pp-item)))
	168
	169	(define (pp-down l col1 col2 extra pp-item)
	170	(let loop ((l l) (col col1))
	171	(and col
	172	(cond ((pair? l)
	173	(let ((rest (cdr l)))
	174	(let ((extra (if (null? rest) (+ extra 1) 0)))
	175	(loop rest
	176	(pr (car l) (indent col2 col) extra pp-item)))))
	177	((null? l)
	178	(out ")" col))
	179	(else
	180	(out ")"
	181	(pr l
	182	(indent col2 (out "." (indent col2 col)))
	183	(+ extra 1)
	184	pp-item)))))))
	185
	186	(define (pp-general expr col extra named? pp-1 pp-2 pp-3)
	187
	188	(define (tail1 rest col1 col2 col3)
	189	(if (and pp-1 (pair? rest))
190	(let* ((val1 (car rest))
191	(rest (cdr rest))
192	(extra (if (null? rest) (+ extra 1) 0)))
193	(tail2 rest col1 (pr val1 (indent col3 col2) extra pp-1) col3))
194	(tail2 rest col1 col2 col3)))
195
196	(define (tail2 rest col1 col2 col3)
197	(if (and pp-2 (pair? rest))
198	(let* ((val1 (car rest))
199	(rest (cdr rest))
200	(extra (if (null? rest) (+ extra 1) 0)))
201	(tail3 rest col1 (pr val1 (indent col3 col2) extra pp-2)))
202	(tail3 rest col1 col2)))
203
204	(define (tail3 rest col1 col2)
205	(pp-down rest col2 col1 extra pp-3))
206
207	(let* ((head (car expr))
208	(rest (cdr expr))
209	(col* (wr head (out "(" col))))
210	(if (and named? (pair? rest))
211	(let* ((name (car rest))
212	(rest (cdr rest))
213	(col** (wr name (out " " col*))))
214	(tail1 rest (+ col indent-general) col (+ col 1)))
215	(tail1 rest (+ col indent-general) col* (+ col* 1)))))
216
217	(define (pp-expr-list l col extra)
218	(pp-list l col extra pp-expr))
219
220	(define (pp-LAMBDA expr col extra)
221	(pp-general expr col extra #f pp-expr-list #f pp-expr))
222
223	(define (pp-IF expr col extra)
224	(pp-general expr col extra #f pp-expr #f pp-expr))
225
226	(define (pp-COND expr col extra)
227	(pp-call expr col extra pp-expr-list))
228
229	(define (pp-CASE expr col extra)
230	(pp-general expr col extra #f pp-expr #f pp-expr-list))
231
232	(define (pp-AND expr col extra)
233	(pp-call expr col extra pp-expr))
234
235	(define (pp-LET expr col extra)
236	(let* ((rest (cdr expr))
237	(named? (and (pair? rest) (symbol? (car rest)))))
238	(pp-general expr col extra named? pp-expr-list #f pp-expr)))
239
240	(define (pp-BEGIN expr col extra)
241	(pp-general expr col extra #f #f #f pp-expr))
242
243	(define (pp-DO expr col extra)
244	(pp-general expr col extra #f pp-expr-list pp-expr-list pp-expr))
245
246	; define formatting style (change these to suit your style)
247
248	(define indent-general 2)
249
250	(define max-call-head-width 5)
251
252	(define max-expr-width 50)
253
254	(define (style head)
255	(case head
256	((lambda let* letrec define) pp-LAMBDA)
257	((if set!) pp-IF)
258	((cond) pp-COND)
259	((case) pp-CASE)
260	((and or) pp-AND)
261	((let) pp-LET)
262	((begin) pp-BEGIN)
263	((do) pp-DO)
264	(else #f)))
265
266	(pr obj col 0 pp-expr))
267
f5259dd3	268	(out per-line-prefix 0)
b337528f MV	269	(if width
b337528f MV	270	(out genwrite:newline-str (pp obj 0))
21a10205 MV	271	(wr obj 0))
	272	;; Return `unspecified'
	273	(if #f #f))
b337528f MV	274
	275	; (reverse-string-append l) = (apply string-append (reverse l))
	276
	277	(define (reverse-string-append l)
	278
	279	(define (rev-string-append l i)
	280	(if (pair? l)
	281	(let* ((str (car l))
	282	(len (string-length str))
	283	(result (rev-string-append (cdr l) (+ i len))))
	284	(let loop ((j 0) (k (- (- (string-length result) i) len)))
	285	(if (< j len)
	286	(begin
	287	(string-set! result k (string-ref str j))
	288	(loop (+ j 1) (+ k 1)))
	289	result)))
	290	(make-string i)))
	291
	292	(rev-string-append l 0))
	293
f5259dd3 MV	294	(define (pretty-print obj . opts)
	295	"Pretty-print OBJ on PORT, which is a keyword argument defaulting to
	296	the current output port. Formatting can be controlled by a number of
	297	keyword arguments: Each line in the output is preceded by the string
	298	PER-LINE-PREFIX, which is empty by default. The output lines will be
	299	at most WIDTH characters wide; the default is 79. If DISPLAY? is
	300	true, display rather than write representation will be used.
	301
	302	Instead of with a keyword argument, you can also specify the output
	303	port directly after OBJ, like (pretty-print OBJ PORT)."
	304	(if (pair? opts)
	305	(if (keyword? (car opts))
	306	(apply pretty-print-with-keys obj opts)
	307	(apply pretty-print-with-keys obj #:port (car opts) (cdr opts)))
	308	(pretty-print-with-keys obj)))
	309
	310	(define* (pretty-print-with-keys obj
	311	#:key
	312	(port (current-output-port))
	313	(width 79)
	314	(display? #f)
	315	(per-line-prefix ""))
	316	(generic-write obj display?
	317	(- width (string-length per-line-prefix))
	318	per-line-prefix
	319	(lambda (s) (display s port) #t)))