ice-9/pretty-print.scm

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