ice-9/pretty-print.scm

   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 ;;;;
  44 (define-module (ice-9 pretty-print))
  45
  46 (export pretty-print)
  47
  48 ;; From SLIB.
  49
  50 ;;"genwrite.scm" generic write used by pretty-print and truncated-print.
  51 ;; Copyright (c) 1991, Marc Feeley
  52 ;; Author: Marc Feeley (feeley@iro.umontreal.ca)
  53 ;; Distribution restrictions: none
  54
  55 (define genwrite:newline-str (make-string 1 #\newline))
  56
  57 (define (generic-write obj display? width output)
  58
  59   (define (read-macro? l)
  60     (define (length1? l) (and (pair? l) (null? (cdr l))))
  61     (let ((head (car l)) (tail (cdr l)))
  62       (case head
  63         ((quote quasiquote unquote unquote-splicing) (length1? tail))
  64         (else                                        #f))))
  65
  66   (define (read-macro-body l)
  67     (cadr l))
  68
  69   (define (read-macro-prefix l)
  70     (let ((head (car l)) (tail (cdr l)))
  71       (case head
  72         ((quote)            "'")
  73         ((quasiquote)       "`")
  74         ((unquote)          ",")
  75         ((unquote-splicing) ",@"))))
  76
  77   (define (out str col)
  78     (and col (output str) (+ col (string-length str))))
  79
  80   (define (wr obj col)
  81
  82     (define (wr-expr expr col)
  83       (if (read-macro? expr)
  84         (wr (read-macro-body expr) (out (read-macro-prefix expr) col))
  85         (wr-lst expr col)))
  86
  87     (define (wr-lst l col)
  88       (if (pair? l)
  89           (let loop ((l (cdr l))
  90                      (col (and col (wr (car l) (out "(" col)))))
  91             (cond ((not col) col)
  92                   ((pair? l)
  93                    (loop (cdr l) (wr (car l) (out " " col))))
  94                   ((null? l) (out ")" col))
  95                   (else      (out ")" (wr l (out " . " col))))))
  96           (out "()" col)))
  97
  98     (cond ((pair? obj)        (wr-expr obj col))
  99           ((null? obj)        (wr-lst obj col))
 100           ((vector? obj)      (wr-lst (vector->list obj) (out "#" col)))
 101           ((boolean? obj)     (out (if obj "#t" "#f") col))
 102           ((number? obj)      (out (number->string obj) col))
 103           ((symbol? obj)      (out (symbol->string obj) col))
 104           ((procedure? obj)   (out "#[procedure]" col))
 105           ((string? obj)      (if display?
 106                                 (out obj col)
 107                                 (let loop ((i 0) (j 0) (col (out "\"" col)))
 108                                   (if (and col (< j (string-length obj)))
 109                                     (let ((c (string-ref obj j)))
 110                                       (if (or (char=? c #\\)
 111                                               (char=? c #\"))
 112                                         (loop j
 113                                               (+ j 1)
 114                                               (out "\\"
 115                                                    (out (substring obj i j)
 116                                                         col)))
 117                                         (loop i (+ j 1) col)))
 118                                     (out "\""
 119                                          (out (substring obj i j) col))))))
 120           ((char? obj)        (if display?
 121                                 (out (make-string 1 obj) col)
 122                                 (out (case obj
 123                                        ((#\space)   "space")
 124                                        ((#\newline) "newline")
 125                                        (else        (make-string 1 obj)))
 126                                      (out "#\\" col))))
 127           (else               (out (object->string obj) col))))
 128
 129   (define (pp obj col)
 130
 131     (define (spaces n col)
 132       (if (> n 0)
 133         (if (> n 7)
 134           (spaces (- n 8) (out "        " col))
 135           (out (substring "        " 0 n) col))
 136         col))
 137
 138     (define (indent to col)
 139       (and col
 140            (if (< to col)
 141              (and (out genwrite:newline-str col) (spaces to 0))
 142              (spaces (- to col) col))))
 143
 144     (define (pr obj col extra pp-pair)
 145       (if (or (pair? obj) (vector? obj)) ; may have to split on multiple lines
 146         (let ((result '())
 147               (left (min (+ (- (- width col) extra) 1) max-expr-width)))
 148           (generic-write obj display? #f
 149             (lambda (str)
 150               (set! result (cons str result))
 151               (set! left (- left (string-length str)))
 152               (> left 0)))
 153           (if (> left 0) ; all can be printed on one line
 154             (out (reverse-string-append result) col)
 155             (if (pair? obj)
 156               (pp-pair obj col extra)
 157               (pp-list (vector->list obj) (out "#" col) extra pp-expr))))
 158         (wr obj col)))
 159
 160     (define (pp-expr expr col extra)
 161       (if (read-macro? expr)
 162         (pr (read-macro-body expr)
 163             (out (read-macro-prefix expr) col)
 164             extra
 165             pp-expr)
 166         (let ((head (car expr)))
 167           (if (symbol? head)
 168             (let ((proc (style head)))
 169               (if proc
 170                 (proc expr col extra)
 171                 (if (> (string-length (symbol->string head))
 172                        max-call-head-width)
 173                   (pp-general expr col extra #f #f #f pp-expr)
 174                   (pp-call expr col extra pp-expr))))
 175             (pp-list expr col extra pp-expr)))))
 176
 177     ; (head item1
 178     ;       item2
 179     ;       item3)
 180     (define (pp-call expr col extra pp-item)
 181       (let ((col* (wr (car expr) (out "(" col))))
 182         (and col
 183              (pp-down (cdr expr) col* (+ col* 1) extra pp-item))))
 184
 185     ; (item1
 186     ;  item2
 187     ;  item3)
 188     (define (pp-list l col extra pp-item)
 189       (let ((col (out "(" col)))
 190         (pp-down l col col extra pp-item)))
 191
 192     (define (pp-down l col1 col2 extra pp-item)
 193       (let loop ((l l) (col col1))
 194         (and col
 195              (cond ((pair? l)
 196                     (let ((rest (cdr l)))
 197                       (let ((extra (if (null? rest) (+ extra 1) 0)))
 198                         (loop rest
 199                               (pr (car l) (indent col2 col) extra pp-item)))))
 200                    ((null? l)
 201                     (out ")" col))
 202                    (else
 203                     (out ")"
 204                          (pr l
 205                              (indent col2 (out "." (indent col2 col)))
 206                              (+ extra 1)
 207                              pp-item)))))))
 208
 209     (define (pp-general expr col extra named? pp-1 pp-2 pp-3)
 210
 211       (define (tail1 rest col1 col2 col3)
 212         (if (and pp-1 (pair? rest))
 213           (let* ((val1 (car rest))
 214                  (rest (cdr rest))
 215                  (extra (if (null? rest) (+ extra 1) 0)))
 216             (tail2 rest col1 (pr val1 (indent col3 col2) extra pp-1) col3))
 217           (tail2 rest col1 col2 col3)))
 218
 219       (define (tail2 rest col1 col2 col3)
 220         (if (and pp-2 (pair? rest))
 221           (let* ((val1 (car rest))
 222                  (rest (cdr rest))
 223                  (extra (if (null? rest) (+ extra 1) 0)))
 224             (tail3 rest col1 (pr val1 (indent col3 col2) extra pp-2)))
 225           (tail3 rest col1 col2)))
 226
 227       (define (tail3 rest col1 col2)
 228         (pp-down rest col2 col1 extra pp-3))
 229
 230       (let* ((head (car expr))
 231              (rest (cdr expr))
 232              (col* (wr head (out "(" col))))
 233         (if (and named? (pair? rest))
 234           (let* ((name (car rest))
 235                  (rest (cdr rest))
 236                  (col** (wr name (out " " col*))))
 237             (tail1 rest (+ col indent-general) col** (+ col** 1)))
 238           (tail1 rest (+ col indent-general) col* (+ col* 1)))))
 239
 240     (define (pp-expr-list l col extra)
 241       (pp-list l col extra pp-expr))
 242
 243     (define (pp-LAMBDA expr col extra)
 244       (pp-general expr col extra #f pp-expr-list #f pp-expr))
 245
 246     (define (pp-IF expr col extra)
 247       (pp-general expr col extra #f pp-expr #f pp-expr))
 248
 249     (define (pp-COND expr col extra)
 250       (pp-call expr col extra pp-expr-list))
 251
 252     (define (pp-CASE expr col extra)
 253       (pp-general expr col extra #f pp-expr #f pp-expr-list))
 254
 255     (define (pp-AND expr col extra)
 256       (pp-call expr col extra pp-expr))
 257
 258     (define (pp-LET expr col extra)
 259       (let* ((rest (cdr expr))
 260              (named? (and (pair? rest) (symbol? (car rest)))))
 261         (pp-general expr col extra named? pp-expr-list #f pp-expr)))
 262
 263     (define (pp-BEGIN expr col extra)
 264       (pp-general expr col extra #f #f #f pp-expr))
 265
 266     (define (pp-DO expr col extra)
 267       (pp-general expr col extra #f pp-expr-list pp-expr-list pp-expr))
 268
 269     ; define formatting style (change these to suit your style)
 270
 271     (define indent-general 2)
 272
 273     (define max-call-head-width 5)
 274
 275     (define max-expr-width 50)
 276
 277     (define (style head)
 278       (case head
 279         ((lambda let* letrec define) pp-LAMBDA)
 280         ((if set!)                   pp-IF)
 281         ((cond)                      pp-COND)
 282         ((case)                      pp-CASE)
 283         ((and or)                    pp-AND)
 284         ((let)                       pp-LET)
 285         ((begin)                     pp-BEGIN)
 286         ((do)                        pp-DO)
 287         (else                        #f)))
 288
 289     (pr obj col 0 pp-expr))
 290
 291   (if width
 292     (out genwrite:newline-str (pp obj 0))
 293     (wr obj 0))
 294   ;; Return `unspecified'
 295   (if #f #f))
 296
 297 ; (reverse-string-append l) = (apply string-append (reverse l))
 298
 299 (define (reverse-string-append l)
 300
 301   (define (rev-string-append l i)
 302     (if (pair? l)
 303       (let* ((str (car l))
 304              (len (string-length str))
 305              (result (rev-string-append (cdr l) (+ i len))))
 306         (let loop ((j 0) (k (- (- (string-length result) i) len)))
 307           (if (< j len)
 308             (begin
 309               (string-set! result k (string-ref str j))
 310               (loop (+ j 1) (+ k 1)))
 311             result)))
 312       (make-string i)))
 313
 314   (rev-string-append l 0))
 315
 316 ;"pp.scm" Pretty-Print
 317 (define (pretty-print obj . opt)
 318   (let ((port (if (pair? opt) (car opt) (current-output-port))))
 319     (generic-write obj #f 79
 320                    (lambda (s) (display s port) #t))))
 321