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   :use-module (ice-9 optargs)
  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 per-line-prefix 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)
 142                   (out per-line-prefix 0)
 143                   (spaces to 0))
 144              (spaces (- to col) col))))
 145
 146     (define (pr obj col extra pp-pair)
 147       (if (or (pair? obj) (vector? obj)) ; may have to split on multiple lines
 148         (let ((result '())
 149               (left (min (+ (- (- width col) extra) 1) max-expr-width)))
 150           (generic-write obj display? #f ""
 151             (lambda (str)
 152               (set! result (cons str result))
 153               (set! left (- left (string-length str)))
 154               (> left 0)))
 155           (if (> left 0) ; all can be printed on one line
 156             (out (reverse-string-append result) col)
 157             (if (pair? obj)
 158               (pp-pair obj col extra)
 159               (pp-list (vector->list obj) (out "#" col) extra pp-expr))))
 160         (wr obj col)))
 161
 162     (define (pp-expr expr col extra)
 163       (if (read-macro? expr)
 164         (pr (read-macro-body expr)
 165             (out (read-macro-prefix expr) col)
 166             extra
 167             pp-expr)
 168         (let ((head (car expr)))
 169           (if (symbol? head)
 170             (let ((proc (style head)))
 171               (if proc
 172                 (proc expr col extra)
 173                 (if (> (string-length (symbol->string head))
 174                        max-call-head-width)
 175                   (pp-general expr col extra #f #f #f pp-expr)
 176                   (pp-call expr col extra pp-expr))))
 177             (pp-list expr col extra pp-expr)))))
 178
 179     ; (head item1
 180     ;       item2
 181     ;       item3)
 182     (define (pp-call expr col extra pp-item)
 183       (let ((col* (wr (car expr) (out "(" col))))
 184         (and col
 185              (pp-down (cdr expr) col* (+ col* 1) extra pp-item))))
 186
 187     ; (item1
 188     ;  item2
 189     ;  item3)
 190     (define (pp-list l col extra pp-item)
 191       (let ((col (out "(" col)))
 192         (pp-down l col col extra pp-item)))
 193
 194     (define (pp-down l col1 col2 extra pp-item)
 195       (let loop ((l l) (col col1))
 196         (and col
 197              (cond ((pair? l)
 198                     (let ((rest (cdr l)))
 199                       (let ((extra (if (null? rest) (+ extra 1) 0)))
 200                         (loop rest
 201                               (pr (car l) (indent col2 col) extra pp-item)))))
 202                    ((null? l)
 203                     (out ")" col))
 204                    (else
 205                     (out ")"
 206                          (pr l
 207                              (indent col2 (out "." (indent col2 col)))
 208                              (+ extra 1)
 209                              pp-item)))))))
 210
 211     (define (pp-general expr col extra named? pp-1 pp-2 pp-3)
 212
 213       (define (tail1 rest col1 col2 col3)
 214         (if (and pp-1 (pair? rest))
 215           (let* ((val1 (car rest))
 216                  (rest (cdr rest))
 217                  (extra (if (null? rest) (+ extra 1) 0)))
 218             (tail2 rest col1 (pr val1 (indent col3 col2) extra pp-1) col3))
 219           (tail2 rest col1 col2 col3)))
 220
 221       (define (tail2 rest col1 col2 col3)
 222         (if (and pp-2 (pair? rest))
 223           (let* ((val1 (car rest))
 224                  (rest (cdr rest))
 225                  (extra (if (null? rest) (+ extra 1) 0)))
 226             (tail3 rest col1 (pr val1 (indent col3 col2) extra pp-2)))
 227           (tail3 rest col1 col2)))
 228
 229       (define (tail3 rest col1 col2)
 230         (pp-down rest col2 col1 extra pp-3))
 231
 232       (let* ((head (car expr))
 233              (rest (cdr expr))
 234              (col* (wr head (out "(" col))))
 235         (if (and named? (pair? rest))
 236           (let* ((name (car rest))
 237                  (rest (cdr rest))
 238                  (col** (wr name (out " " col*))))
 239             (tail1 rest (+ col indent-general) col** (+ col** 1)))
 240           (tail1 rest (+ col indent-general) col* (+ col* 1)))))
 241
 242     (define (pp-expr-list l col extra)
 243       (pp-list l col extra pp-expr))
 244
 245     (define (pp-LAMBDA expr col extra)
 246       (pp-general expr col extra #f pp-expr-list #f pp-expr))
 247
 248     (define (pp-IF expr col extra)
 249       (pp-general expr col extra #f pp-expr #f pp-expr))
 250
 251     (define (pp-COND expr col extra)
 252       (pp-call expr col extra pp-expr-list))
 253
 254     (define (pp-CASE expr col extra)
 255       (pp-general expr col extra #f pp-expr #f pp-expr-list))
 256
 257     (define (pp-AND expr col extra)
 258       (pp-call expr col extra pp-expr))
 259
 260     (define (pp-LET expr col extra)
 261       (let* ((rest (cdr expr))
 262              (named? (and (pair? rest) (symbol? (car rest)))))
 263         (pp-general expr col extra named? pp-expr-list #f pp-expr)))
 264
 265     (define (pp-BEGIN expr col extra)
 266       (pp-general expr col extra #f #f #f pp-expr))
 267
 268     (define (pp-DO expr col extra)
 269       (pp-general expr col extra #f pp-expr-list pp-expr-list pp-expr))
 270
 271     ; define formatting style (change these to suit your style)
 272
 273     (define indent-general 2)
 274
 275     (define max-call-head-width 5)
 276
 277     (define max-expr-width 50)
 278
 279     (define (style head)
 280       (case head
 281         ((lambda let* letrec define) pp-LAMBDA)
 282         ((if set!)                   pp-IF)
 283         ((cond)                      pp-COND)
 284         ((case)                      pp-CASE)
 285         ((and or)                    pp-AND)
 286         ((let)                       pp-LET)
 287         ((begin)                     pp-BEGIN)
 288         ((do)                        pp-DO)
 289         (else                        #f)))
 290
 291     (pr obj col 0 pp-expr))
 292
 293   (out per-line-prefix 0)
 294   (if width
 295     (out genwrite:newline-str (pp obj 0))
 296     (wr obj 0))
 297   ;; Return `unspecified'
 298   (if #f #f))
 299
 300 ; (reverse-string-append l) = (apply string-append (reverse l))
 301
 302 (define (reverse-string-append l)
 303
 304   (define (rev-string-append l i)
 305     (if (pair? l)
 306       (let* ((str (car l))
 307              (len (string-length str))
 308              (result (rev-string-append (cdr l) (+ i len))))
 309         (let loop ((j 0) (k (- (- (string-length result) i) len)))
 310           (if (< j len)
 311             (begin
 312               (string-set! result k (string-ref str j))
 313               (loop (+ j 1) (+ k 1)))
 314             result)))
 315       (make-string i)))
 316
 317   (rev-string-append l 0))
 318
 319 (define (pretty-print obj . opts)
 320   "Pretty-print OBJ on PORT, which is a keyword argument defaulting to
 321 the current output port.  Formatting can be controlled by a number of
 322 keyword arguments: Each line in the output is preceded by the string
 323 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)))