module/ice-9/pretty-print.scm

   1 ;;;; -*- coding: utf-8; mode: scheme -*-
   2 ;;;;
   3 ;;;;    Copyright (C) 2001, 2004, 2006, 2009, 2010,
   4 ;;;;      2012, 2013, 2014 Free Software Foundation, Inc.
   5 ;;;;
   6 ;;;; This library is free software; you can redistribute it and/or
   7 ;;;; modify it under the terms of the GNU Lesser General Public
   8 ;;;; License as published by the Free Software Foundation; either
   9 ;;;; version 3 of the License, or (at your option) any later version.
  10 ;;;;
  11 ;;;; This library is distributed in the hope that it will be useful,
  12 ;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  13 ;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
  14 ;;;; Lesser General Public License for more details.
  15 ;;;;
  16 ;;;; You should have received a copy of the GNU Lesser General Public
  17 ;;;; License along with this library; if not, write to the Free Software
  18 ;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
  19 ;;;;
  20 (define-module (ice-9 pretty-print)
  21   #:use-module (ice-9 match)
  22   #:use-module (srfi srfi-1)
  23   #:use-module (rnrs bytevectors)
  24   #:export (pretty-print
  25             truncated-print))
  26
  27
  28 ;; From SLIB.
  29
  30 ;;"genwrite.scm" generic write used by pretty-print and truncated-print.
  31 ;; Copyright (c) 1991, Marc Feeley
  32 ;; Author: Marc Feeley (feeley@iro.umontreal.ca)
  33 ;; Distribution restrictions: none
  34
  35 (define genwrite:newline-str (make-string 1 #\newline))
  36
  37 (define (generic-write
  38          obj display? width max-expr-width per-line-prefix output)
  39
  40   (define (read-macro? l)
  41     (define (length1? l) (and (pair? l) (null? (cdr l))))
  42     (let ((head (car l)) (tail (cdr l)))
  43       (case head
  44         ((quote quasiquote unquote unquote-splicing) (length1? tail))
  45         (else                                        #f))))
  46
  47   (define (read-macro-body l)
  48     (cadr l))
  49
  50   (define (read-macro-prefix l)
  51     (let ((head (car l)))
  52       (case head
  53         ((quote)            "'")
  54         ((quasiquote)       "`")
  55         ((unquote)          ",")
  56         ((unquote-splicing) ",@"))))
  57
  58   (define (out str col)
  59     (and col (output str) (+ col (string-length str))))
  60
  61   (define (wr obj col)
  62     (let loop ((obj obj)
  63                (col col))
  64       (match obj
  65         (((or 'quote 'quasiquote 'unquote 'unquote-splicing) body)
  66          (wr body (out (read-macro-prefix obj) col)))
  67         ((head . (rest ...))
  68          ;; A proper list: do our own list printing so as to catch read
  69          ;; macros that appear in the middle of the list.
  70          (let ((col (loop head (out "(" col))))
  71            (out ")"
  72                 (fold (lambda (i col)
  73                         (loop i (out " " col)))
  74                       col rest))))
  75         (_
  76          (out (object->string obj (if display? display write)) col)))))
  77
  78   (define (pp obj col)
  79
  80     (define (spaces n col)
  81       (if (> n 0)
  82         (if (> n 7)
  83           (spaces (- n 8) (out "        " col))
  84           (out (substring "        " 0 n) col))
  85         col))
  86
  87     (define (indent to col)
  88       (and col
  89            (if (< to col)
  90              (and (out genwrite:newline-str col)
  91                   (out per-line-prefix 0)
  92                   (spaces to 0))
  93              (spaces (- to col) col))))
  94
  95     (define (pr obj col extra pp-pair)
  96       (if (or (pair? obj) (vector? obj)) ; may have to split on multiple lines
  97         (let ((result '())
  98               (left (min (+ (- (- width col) extra) 1) max-expr-width)))
  99           (generic-write obj display? #f max-expr-width ""
 100             (lambda (str)
 101               (set! result (cons str result))
 102               (set! left (- left (string-length str)))
 103               (> left 0)))
 104           (if (> left 0) ; all can be printed on one line
 105             (out (reverse-string-append result) col)
 106             (if (pair? obj)
 107               (pp-pair obj col extra)
 108               (pp-list (vector->list obj) (out "#" col) extra pp-expr))))
 109         (wr obj col)))
 110
 111     (define (pp-expr expr col extra)
 112       (if (read-macro? expr)
 113         (pr (read-macro-body expr)
 114             (out (read-macro-prefix expr) col)
 115             extra
 116             pp-expr)
 117         (let ((head (car expr)))
 118           (if (symbol? head)
 119             (let ((proc (style head)))
 120               (if proc
 121                 (proc expr col extra)
 122                 (if (> (string-length (symbol->string head))
 123                        max-call-head-width)
 124                   (pp-general expr col extra #f #f #f pp-expr)
 125                   (pp-call expr col extra pp-expr))))
 126             (pp-list expr col extra pp-expr)))))
 127
 128     ; (head item1
 129     ;       item2
 130     ;       item3)
 131     (define (pp-call expr col extra pp-item)
 132       (let ((col* (wr (car expr) (out "(" col))))
 133         (and col
 134              (pp-down (cdr expr) col* (+ col* 1) extra pp-item))))
 135
 136     ; (item1
 137     ;  item2
 138     ;  item3)
 139     (define (pp-list l col extra pp-item)
 140       (let ((col (out "(" col)))
 141         (pp-down l col col extra pp-item)))
 142
 143     (define (pp-down l col1 col2 extra pp-item)
 144       (let loop ((l l) (col col1))
 145         (and col
 146              (cond ((pair? l)
 147                     (let ((rest (cdr l)))
 148                       (let ((extra (if (null? rest) (+ extra 1) 0)))
 149                         (loop rest
 150                               (pr (car l) (indent col2 col) extra pp-item)))))
 151                    ((null? l)
 152                     (out ")" col))
 153                    (else
 154                     (out ")"
 155                          (pr l
 156                              (indent col2 (out "." (indent col2 col)))
 157                              (+ extra 1)
 158                              pp-item)))))))
 159
 160     (define (pp-general expr col extra named? pp-1 pp-2 pp-3)
 161
 162       (define (tail1 rest col1 col2 col3)
 163         (if (and pp-1 (pair? rest))
 164           (let* ((val1 (car rest))
 165                  (rest (cdr rest))
 166                  (extra (if (null? rest) (+ extra 1) 0)))
 167             (tail2 rest col1 (pr val1 (indent col3 col2) extra pp-1) col3))
 168           (tail2 rest col1 col2 col3)))
 169
 170       (define (tail2 rest col1 col2 col3)
 171         (if (and pp-2 (pair? rest))
 172           (let* ((val1 (car rest))
 173                  (rest (cdr rest))
 174                  (extra (if (null? rest) (+ extra 1) 0)))
 175             (tail3 rest col1 (pr val1 (indent col3 col2) extra pp-2)))
 176           (tail3 rest col1 col2)))
 177
 178       (define (tail3 rest col1 col2)
 179         (pp-down rest col2 col1 extra pp-3))
 180
 181       (let* ((head (car expr))
 182              (rest (cdr expr))
 183              (col* (wr head (out "(" col))))
 184         (if (and named? (pair? rest))
 185           (let* ((name (car rest))
 186                  (rest (cdr rest))
 187                  (col** (wr name (out " " col*))))
 188             (tail1 rest (+ col indent-general) col** (+ col** 1)))
 189           (tail1 rest (+ col indent-general) col* (+ col* 1)))))
 190
 191     (define (pp-expr-list l col extra)
 192       (pp-list l col extra pp-expr))
 193
 194     (define (pp-LAMBDA expr col extra)
 195       (pp-general expr col extra #f pp-expr-list #f pp-expr))
 196
 197     (define (pp-IF expr col extra)
 198       (pp-general expr col extra #f pp-expr #f pp-expr))
 199
 200     (define (pp-COND expr col extra)
 201       (pp-call expr col extra pp-expr-list))
 202
 203     (define (pp-CASE expr col extra)
 204       (pp-general expr col extra #f pp-expr #f pp-expr-list))
 205
 206     (define (pp-AND expr col extra)
 207       (pp-call expr col extra pp-expr))
 208
 209     (define (pp-LET expr col extra)
 210       (let* ((rest (cdr expr))
 211              (named? (and (pair? rest) (symbol? (car rest)))))
 212         (pp-general expr col extra named? pp-expr-list #f pp-expr)))
 213
 214     (define (pp-BEGIN expr col extra)
 215       (pp-general expr col extra #f #f #f pp-expr))
 216
 217     (define (pp-DO expr col extra)
 218       (pp-general expr col extra #f pp-expr-list pp-expr-list pp-expr))
 219
 220     (define (pp-SYNTAX-CASE expr col extra)
 221       (pp-general expr col extra #t pp-expr-list #f pp-expr))
 222
 223     ; define formatting style (change these to suit your style)
 224
 225     (define indent-general 2)
 226
 227     (define max-call-head-width 5)
 228
 229     (define (style head)
 230       (case head
 231         ((lambda lambda* let* letrec define define* define-public
 232                  define-syntax let-syntax letrec-syntax with-syntax)
 233                                      pp-LAMBDA)
 234         ((if set!)                   pp-IF)
 235         ((cond)                      pp-COND)
 236         ((case)                      pp-CASE)
 237         ((and or)                    pp-AND)
 238         ((let)                       pp-LET)
 239         ((begin)                     pp-BEGIN)
 240         ((do)                        pp-DO)
 241         ((syntax-rules)              pp-LAMBDA)
 242         ((syntax-case)               pp-SYNTAX-CASE)
 243         (else                        #f)))
 244
 245     (pr obj col 0 pp-expr))
 246
 247   (out per-line-prefix 0)
 248   (if width
 249     (out genwrite:newline-str (pp obj 0))
 250     (wr obj 0))
 251   ;; Return `unspecified'
 252   (if #f #f))
 253
 254 ; (reverse-string-append l) = (apply string-append (reverse l))
 255
 256 (define (reverse-string-append l)
 257
 258   (define (rev-string-append l i)
 259     (if (pair? l)
 260       (let* ((str (car l))
 261              (len (string-length str))
 262              (result (rev-string-append (cdr l) (+ i len))))
 263         (let loop ((j 0) (k (- (- (string-length result) i) len)))
 264           (if (< j len)
 265             (begin
 266               (string-set! result k (string-ref str j))
 267               (loop (+ j 1) (+ k 1)))
 268             result)))
 269       (make-string i)))
 270
 271   (rev-string-append l 0))
 272
 273 (define* (pretty-print obj #:optional port*
 274                        #:key
 275                        (port (or port* (current-output-port)))
 276                        (width 79)
 277                        (max-expr-width 50)
 278                        (display? #f)
 279                        (per-line-prefix ""))
 280   "Pretty-print OBJ on PORT, which is a keyword argument defaulting to
 281 the current output port.  Formatting can be controlled by a number of
 282 keyword arguments: Each line in the output is preceded by the string
 283 PER-LINE-PREFIX, which is empty by default.  The output lines will be
 284 at most WIDTH characters wide; the default is 79.  If DISPLAY? is
 285 true, display rather than write representation will be used.
 286
 287 Instead of with a keyword argument, you can also specify the output
 288 port directly after OBJ, like (pretty-print OBJ PORT)."
 289   (generic-write obj display?
 290                  (- width (string-length per-line-prefix))
 291                  max-expr-width
 292                  per-line-prefix
 293                  (lambda (s) (display s port) #t)))
 294
 295 \f
 296 ;; `truncated-print' was written in 2009 by Andy Wingo, and is not from
 297 ;; genwrite.scm.
 298 (define* (truncated-print x #:optional port*
 299                           #:key
 300                           (port (or port* (current-output-port)))
 301                           (width 79)
 302                           (display? #f)
 303                           (breadth-first? #f))
 304   "Print @var{x}, truncating the output, if necessary, to make it fit
 305 into @var{width} characters. By default, @var{x} will be printed using
 306 @code{write}, though that behavior can be overriden via the
 307 @var{display?} keyword argument.
 308
 309 The default behaviour is to print depth-first, meaning that the entire
 310 remaining width will be available to each sub-expression of @var{x} --
 311 e.g., if @var{x} is a vector, each member of @var{x}. One can attempt to
 312 \"ration\" the available width, trying to allocate it equally to each
 313 sub-expression, via the @var{breadth-first?} keyword argument."
 314
 315   (define ellipsis
 316     ;; Choose between `HORIZONTAL ELLIPSIS' (U+2026) and three dots, depending
 317     ;; on the encoding of PORT.
 318     (let ((e "…"))
 319       (catch 'encoding-error
 320         (lambda ()
 321           (with-fluids ((%default-port-conversion-strategy 'error))
 322             (call-with-output-string
 323              (lambda (p)
 324                (set-port-encoding! p (port-encoding port))
 325                (display e p)))))
 326         (lambda (key . args)
 327           "..."))))
 328
 329   (let ((ellipsis-width (string-length ellipsis)))
 330
 331     (define (print-sequence x width len ref next)
 332       (let lp ((x x)
 333                (width width)
 334                (i 0))
 335         (if (> i 0)
 336             (display #\space))
 337         (cond
 338          ((= i len)) ; catches 0-length case
 339          ((and (= i (1- len)) (or (zero? i) (> width 1)))
 340           (print (ref x i) (if (zero? i) width (1- width))))
 341          ((<= width (+ 1 ellipsis-width))
 342           (display ellipsis))
 343          (else
 344           (let ((str (with-output-to-string
 345                        (lambda ()
 346                          (print (ref x i)
 347                                 (if breadth-first?
 348                                     (max 1
 349                                          (1- (floor (/ width (- len i)))))
 350                                     (- width (+ 1 ellipsis-width))))))))
 351             (display str)
 352             (lp (next x) (- width 1 (string-length str)) (1+ i)))))))
 353
 354     (define (print-tree x width)
 355       ;; width is >= the width of # . #, which is 5
 356       (let lp ((x x)
 357                (width width))
 358         (cond
 359          ((or (not (pair? x)) (<= width 4))
 360           (display ". ")
 361           (print x (- width 2)))
 362          (else
 363           ;; width >= 5
 364           (let ((str (with-output-to-string
 365                        (lambda ()
 366                          (print (car x)
 367                                 (if breadth-first?
 368                                     (floor (/ (- width 3) 2))
 369                                     (- width 4)))))))
 370             (display str)
 371             (display " ")
 372             (lp (cdr x) (- width 1 (string-length str))))))))
 373
 374     (define (truncate-string str width)
 375       ;; width is < (string-length str)
 376       (let lp ((fixes '(("#<" . ">")
 377                         ("#(" . ")")
 378                         ("(" . ")")
 379                         ("\"" . "\""))))
 380         (cond
 381          ((null? fixes)
 382           "#")
 383          ((and (string-prefix? (caar fixes) str)
 384                (string-suffix? (cdar fixes) str)
 385                (>= (string-length str)
 386                    width
 387                    (+ (string-length (caar fixes))
 388                       (string-length (cdar fixes))
 389                       ellipsis-width)))
 390           (format #f "~a~a~a~a"
 391                   (caar fixes)
 392                   (substring str (string-length (caar fixes))
 393                              (- width (string-length (cdar fixes))
 394                                 ellipsis-width))
 395                   ellipsis
 396                   (cdar fixes)))
 397          (else
 398           (lp (cdr fixes))))))
 399
 400     (define (print x width)
 401       (cond
 402        ((<= width 0)
 403         (error "expected a positive width" width))
 404        ((list? x)
 405         (cond
 406          ((>= width (+ 2 ellipsis-width))
 407           (display "(")
 408           (print-sequence x (- width 2) (length x)
 409                           (lambda (x i) (car x)) cdr)
 410           (display ")"))
 411          (else
 412           (display "#"))))
 413        ((vector? x)
 414         (cond
 415          ((>= width (+ 3 ellipsis-width))
 416           (display "#(")
 417           (print-sequence x (- width 3) (vector-length x)
 418                           vector-ref identity)
 419           (display ")"))
 420          (else
 421           (display "#"))))
 422        ((bytevector? x)
 423         (cond
 424          ((>= width 9)
 425           (format #t  "#~a(" (array-type x))
 426           (print-sequence x (- width 6) (array-length x)
 427                           array-ref identity)
 428           (display ")"))
 429          (else
 430           (display "#"))))
 431        ((pair? x)
 432         (cond
 433          ((>= width (+ 4 ellipsis-width))
 434           (display "(")
 435           (print-tree x (- width 2))
 436           (display ")"))
 437          (else
 438           (display "#"))))
 439        (else
 440         (let* ((str (with-output-to-string
 441                       (lambda () (if display? (display x) (write x)))))
 442                (len (string-length str)))
 443           (display (if (<= (string-length str) width)
 444                        str
 445                        (truncate-string str width)))))))
 446
 447     (with-output-to-port port
 448       (lambda ()
 449         (print x width)))))