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

;;;; -*-scheme-*-
;;;;
;;;; 	Copyright (C) 2001 Free Software Foundation, Inc.
;;;; 
;;;; This program is free software; you can redistribute it and/or modify
;;;; it under the terms of the GNU General Public License as published by
;;;; the Free Software Foundation; either version 2, or (at your option)
;;;; any later version.
;;;; 
;;;; This program 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 General Public License for more details.
;;;; 
;;;; You should have received a copy of the GNU General Public License
;;;; along with this software; see the file COPYING.  If not, write to
;;;; the Free Software Foundation, Inc., 59 Temple Place, Suite 330,
;;;; Boston, MA 02111-1307 USA
;;;;
;;;; As a special exception, the Free Software Foundation gives permission
;;;; for additional uses of the text contained in its release of GUILE.
;;;;
;;;; The exception is that, if you link the GUILE library with other files
;;;; to produce an executable, this does not by itself cause the
;;;; resulting executable to be covered by the GNU General Public License.
;;;; Your use of that executable is in no way restricted on account of
;;;; linking the GUILE library code into it.
;;;;
;;;; This exception does not however invalidate any other reasons why
;;;; the executable file might be covered by the GNU General Public License.
;;;;
;;;; This exception applies only to the code released by the
;;;; Free Software Foundation under the name GUILE.  If you copy
;;;; code from other Free Software Foundation releases into a copy of
;;;; GUILE, as the General Public License permits, the exception does
;;;; not apply to the code that you add in this way.  To avoid misleading
;;;; anyone as to the status of such modified files, you must delete
;;;; this exception notice from them.
;;;;
;;;; If you write modifications of your own for GUILE, it is your choice
;;;; whether to permit this exception to apply to your modifications.
;;;; If you do not wish that, delete this exception notice.
;;;; 
(define-module (ice-9 pretty-print)
  :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 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) (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))

  (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))

;"pp.scm" Pretty-Print
(define (pretty-print obj . opt)
  (let ((port (if (pair? opt) (car opt) (current-output-port))))
    (generic-write obj #f 79
		   (lambda (s) (display s port) #t))))
Commit	Line	Data
a482f2cc MV	1	;;;; --scheme--
	2	;;;;
	3	;;;; Copyright (C) 2001 Free Software Foundation, Inc.
	4	;;;;
	5	;;;; This program is free software; you can redistribute it and/or modify
	6	;;;; it under the terms of the GNU General Public License as published by
	7	;;;; the Free Software Foundation; either version 2, or (at your option)
	8	;;;; any later version.
	9	;;;;
	10	;;;; This program is distributed in the hope that it will be useful,
	11	;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
	12	;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
	13	;;;; GNU General Public License for more details.
	14	;;;;
	15	;;;; You should have received a copy of the GNU General Public License
	16	;;;; along with this software; see the file COPYING. If not, write to
	17	;;;; the Free Software Foundation, Inc., 59 Temple Place, Suite 330,
	18	;;;; Boston, MA 02111-1307 USA
	19	;;;;
	20	;;;; As a special exception, the Free Software Foundation gives permission
	21	;;;; for additional uses of the text contained in its release of GUILE.
	22	;;;;
	23	;;;; The exception is that, if you link the GUILE library with other files
	24	;;;; to produce an executable, this does not by itself cause the
	25	;;;; resulting executable to be covered by the GNU General Public License.
	26	;;;; Your use of that executable is in no way restricted on account of
	27	;;;; linking the GUILE library code into it.
	28	;;;;
	29	;;;; This exception does not however invalidate any other reasons why
	30	;;;; the executable file might be covered by the GNU General Public License.
	31	;;;;
	32	;;;; This exception applies only to the code released by the
	33	;;;; Free Software Foundation under the name GUILE. If you copy
	34	;;;; code from other Free Software Foundation releases into a copy of
	35	;;;; GUILE, as the General Public License permits, the exception does
	36	;;;; not apply to the code that you add in this way. To avoid misleading
	37	;;;; anyone as to the status of such modified files, you must delete
	38	;;;; this exception notice from them.
	39	;;;;
	40	;;;; If you write modifications of your own for GUILE, it is your choice
	41	;;;; whether to permit this exception to apply to your modifications.
	42	;;;; If you do not wish that, delete this exception notice.
	43	;;;;
1a179b03 MD	44	(define-module (ice-9 pretty-print)
1a179b03 MD	45	:export (pretty-print))
b337528f MV	46
	47	;; From SLIB.
	48
	49	;;"genwrite.scm" generic write used by pretty-print and truncated-print.
	50	;; Copyright (c) 1991, Marc Feeley
	51	;; Author: Marc Feeley (feeley@iro.umontreal.ca)
	52	;; Distribution restrictions: none
	53
	54	(define genwrite:newline-str (make-string 1 #\newline))
	55
	56	(define (generic-write obj display? width output)
	57
	58	(define (read-macro? l)
	59	(define (length1? l) (and (pair? l) (null? (cdr l))))
	60	(let ((head (car l)) (tail (cdr l)))
	61	(case head
	62	((quote quasiquote unquote unquote-splicing) (length1? tail))
	63	(else #f))))
	64
	65	(define (read-macro-body l)
	66	(cadr l))
	67
	68	(define (read-macro-prefix l)
	69	(let ((head (car l)) (tail (cdr l)))
	70	(case head
	71	((quote) "'")
	72	((quasiquote) "`")
	73	((unquote) ",")
	74	((unquote-splicing) ",@"))))
	75
	76	(define (out str col)
	77	(and col (output str) (+ col (string-length str))))
	78
	79	(define (wr obj col)
	80
	81	(define (wr-expr expr col)
	82	(if (read-macro? expr)
	83	(wr (read-macro-body expr) (out (read-macro-prefix expr) col))
	84	(wr-lst expr col)))
	85
	86	(define (wr-lst l col)
	87	(if (pair? l)
	88	(let loop ((l (cdr l))
	89	(col (and col (wr (car l) (out "(" col)))))
	90	(cond ((not col) col)
	91	((pair? l)
	92	(loop (cdr l) (wr (car l) (out " " col))))
	93	((null? l) (out ")" col))
	94	(else (out ")" (wr l (out " . " col))))))
	95	(out "()" col)))
	96
	97	(cond ((pair? obj) (wr-expr obj col))
	98	((null? obj) (wr-lst obj col))
	99	((vector? obj) (wr-lst (vector->list obj) (out "#" col)))
	100	((boolean? obj) (out (if obj "#t" "#f") col))
	101	((number? obj) (out (number->string obj) col))
	102	((symbol? obj) (out (symbol->string obj) col))
	103	((procedure? obj) (out "#[procedure]" col))
	104	((string? obj) (if display?
	105	(out obj col)
	106	(let loop ((i 0) (j 0) (col (out "\"" col)))
	107	(if (and col (< j (string-length obj)))
	108	(let ((c (string-ref obj j)))
	109	(if (or (char=? c #\\)
110	(char=? c #\"))
111	(loop j
112	(+ j 1)
113	(out "\\"
114	(out (substring obj i j)
115	col)))
116	(loop i (+ j 1) col)))
117	(out "\""
118	(out (substring obj i j) col))))))
119	((char? obj) (if display?
120	(out (make-string 1 obj) col)
121	(out (case obj
122	((#\space) "space")
123	((#\newline) "newline")
124	(else (make-string 1 obj)))
125	(out "#\\" col))))
269ce439	126	(else (out (object->string obj) col))))
b337528f MV	127
	128	(define (pp obj col)
	129
	130	(define (spaces n col)
	131	(if (> n 0)
	132	(if (> n 7)
	133	(spaces (- n 8) (out " " col))
	134	(out (substring " " 0 n) col))
	135	col))
	136
	137	(define (indent to col)
	138	(and col
	139	(if (< to col)
	140	(and (out genwrite:newline-str col) (spaces to 0))
	141	(spaces (- to col) col))))
	142
	143	(define (pr obj col extra pp-pair)
	144	(if (or (pair? obj) (vector? obj)) ; may have to split on multiple lines
	145	(let ((result '())
	146	(left (min (+ (- (- width col) extra) 1) max-expr-width)))
	147	(generic-write obj display? #f
	148	(lambda (str)
	149	(set! result (cons str result))
	150	(set! left (- left (string-length str)))
	151	(> left 0)))
	152	(if (> left 0) ; all can be printed on one line
	153	(out (reverse-string-append result) col)
	154	(if (pair? obj)
	155	(pp-pair obj col extra)
	156	(pp-list (vector->list obj) (out "#" col) extra pp-expr))))
	157	(wr obj col)))
	158
	159	(define (pp-expr expr col extra)
	160	(if (read-macro? expr)
	161	(pr (read-macro-body expr)
	162	(out (read-macro-prefix expr) col)
	163	extra
	164	pp-expr)
	165	(let ((head (car expr)))
	166	(if (symbol? head)
	167	(let ((proc (style head)))
	168	(if proc
	169	(proc expr col extra)
	170	(if (> (string-length (symbol->string head))
	171	max-call-head-width)
	172	(pp-general expr col extra #f #f #f pp-expr)
	173	(pp-call expr col extra pp-expr))))
	174	(pp-list expr col extra pp-expr)))))
	175
	176	; (head item1
	177	; item2
	178	; item3)
	179	(define (pp-call expr col extra pp-item)
	180	(let ((col* (wr (car expr) (out "(" col))))
	181	(and col
	182	(pp-down (cdr expr) col* (+ col* 1) extra pp-item))))
	183
	184	; (item1
	185	; item2
	186	; item3)
	187	(define (pp-list l col extra pp-item)
	188	(let ((col (out "(" col)))
	189	(pp-down l col col extra pp-item)))
	190
191	(define (pp-down l col1 col2 extra pp-item)
192	(let loop ((l l) (col col1))
193	(and col
194	(cond ((pair? l)
195	(let ((rest (cdr l)))
196	(let ((extra (if (null? rest) (+ extra 1) 0)))
197	(loop rest
198	(pr (car l) (indent col2 col) extra pp-item)))))
199	((null? l)
200	(out ")" col))
201	(else
202	(out ")"
203	(pr l
204	(indent col2 (out "." (indent col2 col)))
205	(+ extra 1)
206	pp-item)))))))
207
208	(define (pp-general expr col extra named? pp-1 pp-2 pp-3)
209
210	(define (tail1 rest col1 col2 col3)
211	(if (and pp-1 (pair? rest))
212	(let* ((val1 (car rest))
213	(rest (cdr rest))
214	(extra (if (null? rest) (+ extra 1) 0)))
215	(tail2 rest col1 (pr val1 (indent col3 col2) extra pp-1) col3))
216	(tail2 rest col1 col2 col3)))
217
218	(define (tail2 rest col1 col2 col3)
219	(if (and pp-2 (pair? rest))
220	(let* ((val1 (car rest))
221	(rest (cdr rest))
222	(extra (if (null? rest) (+ extra 1) 0)))
223	(tail3 rest col1 (pr val1 (indent col3 col2) extra pp-2)))
224	(tail3 rest col1 col2)))
225
226	(define (tail3 rest col1 col2)
227	(pp-down rest col2 col1 extra pp-3))
228
229	(let* ((head (car expr))
230	(rest (cdr expr))
231	(col* (wr head (out "(" col))))
232	(if (and named? (pair? rest))
233	(let* ((name (car rest))
234	(rest (cdr rest))
235	(col** (wr name (out " " col*))))
236	(tail1 rest (+ col indent-general) col (+ col 1)))
237	(tail1 rest (+ col indent-general) col* (+ col* 1)))))
238
239	(define (pp-expr-list l col extra)
240	(pp-list l col extra pp-expr))
241
242	(define (pp-LAMBDA expr col extra)
243	(pp-general expr col extra #f pp-expr-list #f pp-expr))
244
245	(define (pp-IF expr col extra)
246	(pp-general expr col extra #f pp-expr #f pp-expr))
247
248	(define (pp-COND expr col extra)
249	(pp-call expr col extra pp-expr-list))
250
251	(define (pp-CASE expr col extra)
252	(pp-general expr col extra #f pp-expr #f pp-expr-list))
253
254	(define (pp-AND expr col extra)
255	(pp-call expr col extra pp-expr))
256
257	(define (pp-LET expr col extra)
258	(let* ((rest (cdr expr))
259	(named? (and (pair? rest) (symbol? (car rest)))))
260	(pp-general expr col extra named? pp-expr-list #f pp-expr)))
261
262	(define (pp-BEGIN expr col extra)
263	(pp-general expr col extra #f #f #f pp-expr))
264
265	(define (pp-DO expr col extra)
266	(pp-general expr col extra #f pp-expr-list pp-expr-list pp-expr))
267
268	; define formatting style (change these to suit your style)
269
270	(define indent-general 2)
271
272	(define max-call-head-width 5)
273
274	(define max-expr-width 50)
275
276	(define (style head)
277	(case head
278	((lambda let* letrec define) pp-LAMBDA)
279	((if set!) pp-IF)
280	((cond) pp-COND)
281	((case) pp-CASE)
282	((and or) pp-AND)
283	((let) pp-LET)
284	((begin) pp-BEGIN)
285	((do) pp-DO)
286	(else #f)))
287
288	(pr obj col 0 pp-expr))
289
290	(if width
291	(out genwrite:newline-str (pp obj 0))
21a10205 MV	292	(wr obj 0))
	293	;; Return `unspecified'
	294	(if #f #f))
b337528f MV	295
	296	; (reverse-string-append l) = (apply string-append (reverse l))
	297
	298	(define (reverse-string-append l)
	299
	300	(define (rev-string-append l i)
	301	(if (pair? l)
	302	(let* ((str (car l))
	303	(len (string-length str))
	304	(result (rev-string-append (cdr l) (+ i len))))
	305	(let loop ((j 0) (k (- (- (string-length result) i) len)))
	306	(if (< j len)
	307	(begin
	308	(string-set! result k (string-ref str j))
	309	(loop (+ j 1) (+ k 1)))
	310	result)))
	311	(make-string i)))
	312
	313	(rev-string-append l 0))
	314
	315	;"pp.scm" Pretty-Print
	316	(define (pretty-print obj . opt)
	317	(let ((port (if (pair? opt) (car opt) (current-output-port))))
	318	(generic-write obj #f 79
	319	(lambda (s) (display s port) #t))))
	320