-;;;; -*-scheme-*-
+;;;; -*- coding: utf-8; mode: scheme -*-
;;;;
-;;;; Copyright (C) 2001, 2004, 2006 Free Software Foundation, Inc.
+;;;; Copyright (C) 2001, 2004, 2006, 2009, 2010 Free Software Foundation, Inc.
;;;;
;;;; This library is free software; you can redistribute it and/or
;;;; modify it under the terms of the GNU Lesser General Public
;;;; License as published by the Free Software Foundation; either
-;;;; version 2.1 of the License, or (at your option) any later version.
+;;;; version 3 of the License, or (at your option) any later version.
;;;;
;;;; This library is distributed in the hope that it will be useful,
;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
;;;;
(define-module (ice-9 pretty-print)
- :use-module (ice-9 optargs)
- :export (pretty-print))
+ #:export (pretty-print
+ truncated-print))
+
;; From SLIB.
(rev-string-append l 0))
-(define (pretty-print obj . opts)
+(define* (pretty-print obj #:optional port*
+ #:key
+ (port (or port* (current-output-port)))
+ (width 79)
+ (display? #f)
+ (per-line-prefix ""))
"Pretty-print OBJ on PORT, which is a keyword argument defaulting to
the current output port. Formatting can be controlled by a number of
keyword arguments: Each line in the output is preceded by the string
Instead of with a keyword argument, you can also specify the output
port directly after OBJ, like (pretty-print OBJ PORT)."
- (if (pair? opts)
- (if (keyword? (car opts))
- (apply pretty-print-with-keys obj opts)
- (apply pretty-print-with-keys obj #:port (car opts) (cdr opts)))
- (pretty-print-with-keys obj)))
-
-(define* (pretty-print-with-keys obj
- #:key
- (port (current-output-port))
- (width 79)
- (display? #f)
- (per-line-prefix ""))
(generic-write obj display?
(- width (string-length per-line-prefix))
per-line-prefix
(lambda (s) (display s port) #t)))
+
+\f
+;; `truncated-print' was written in 2009 by Andy Wingo, and is not from
+;; genwrite.scm.
+(define* (truncated-print x #:optional port*
+ #:key
+ (port (or port* (current-output-port)))
+ (width 79)
+ (display? #f)
+ (breadth-first? #f))
+ "Print @var{obj}, truncating the output, if necessary, to make it fit
+into @var{width} characters. By default, @var{x} will be printed using
+@code{write}, though that behavior can be overriden via the
+@var{display?} keyword argument.
+
+The default behaviour is to print depth-first, meaning that the entire
+remaining width will be available to each sub-expression of @var{x} --
+e.g., if @var{x} is a vector, each member of @var{x}. One can attempt to
+\"ration\" the available width, trying to allocate it equally to each
+sub-expression, via the @var{breadth-first?} keyword argument."
+
+ ;; Make sure string ports are created with the right encoding.
+ (with-fluids ((%default-port-encoding (port-encoding port)))
+
+ (define ellipsis
+ ;; Choose between `HORIZONTAL ELLIPSIS' (U+2026) and three dots, depending
+ ;; on the encoding of PORT.
+ (let ((e "…"))
+ (catch 'encoding-error
+ (lambda ()
+ (with-output-to-string
+ (lambda ()
+ (display e))))
+ (lambda (key . args)
+ "..."))))
+
+ (let ((ellipsis-width (string-length ellipsis)))
+
+ (define (print-sequence x width len ref next)
+ (let lp ((x x)
+ (width width)
+ (i 0))
+ (if (> i 0)
+ (display #\space))
+ (cond
+ ((= i len)) ; catches 0-length case
+ ((= i (1- len))
+ (print (ref x i) (if (zero? i) width (1- width))))
+ ((<= width (+ 1 ellipsis-width))
+ (display "..."))
+ (else
+ (let ((str
+ (with-fluids ((%default-port-encoding (port-encoding port)))
+ (with-output-to-string
+ (lambda ()
+ (print (ref x i)
+ (if breadth-first?
+ (max 1
+ (1- (floor (/ width (- len i)))))
+ (- width (+ 1 ellipsis-width)))))))))
+ (display str)
+ (lp (next x) (- width 1 (string-length str)) (1+ i)))))))
+
+ (define (print-tree x width)
+ ;; width is >= the width of # . #, which is 5
+ (let lp ((x x)
+ (width width))
+ (cond
+ ((or (not (pair? x)) (<= width 4))
+ (display ". ")
+ (print x (- width 2)))
+ (else
+ ;; width >= 5
+ (let ((str (with-output-to-string
+ (lambda ()
+ (print (car x)
+ (if breadth-first?
+ (floor (/ (- width 3) 2))
+ (- width 4)))))))
+ (display str)
+ (display " ")
+ (lp (cdr x) (- width 1 (string-length str))))))))
+
+ (define (truncate-string str width)
+ ;; width is < (string-length str)
+ (let lp ((fixes '(("#<" . ">")
+ ("#(" . ")")
+ ("(" . ")")
+ ("\"" . "\""))))
+ (cond
+ ((null? fixes)
+ "#")
+ ((and (string-prefix? (caar fixes) str)
+ (string-suffix? (cdar fixes) str)
+ (>= (string-length str)
+ width
+ (+ (string-length (caar fixes))
+ (string-length (cdar fixes))
+ ellipsis-width)))
+ (format #f "~a~a~a~a"
+ (caar fixes)
+ (substring str (string-length (caar fixes))
+ (- width (string-length (cdar fixes))
+ ellipsis-width))
+ ellipsis
+ (cdar fixes)))
+ (else
+ (lp (cdr fixes))))))
+
+ (define (print x width)
+ (cond
+ ((<= width 0)
+ (error "expected a positive width" width))
+ ((list? x)
+ (cond
+ ((>= width (+ 2 ellipsis-width))
+ (display "(")
+ (print-sequence x (- width 2) (length x)
+ (lambda (x i) (car x)) cdr)
+ (display ")"))
+ (else
+ (display "#"))))
+ ((vector? x)
+ (cond
+ ((>= width (+ 3 ellipsis-width))
+ (display "#(")
+ (print-sequence x (- width 3) (vector-length x)
+ vector-ref identity)
+ (display ")"))
+ (else
+ (display "#"))))
+ ((uniform-vector? x)
+ (cond
+ ((>= width 9)
+ (format #t "#~a(" (uniform-vector-element-type x))
+ (print-sequence x (- width 6) (uniform-vector-length x)
+ uniform-vector-ref identity)
+ (display ")"))
+ (else
+ (display "#"))))
+ ((pair? x)
+ (cond
+ ((>= width (+ 4 ellipsis-width))
+ (display "(")
+ (print-tree x (- width 2))
+ (display ")"))
+ (else
+ (display "#"))))
+ (else
+ (let* ((str (with-output-to-string
+ (lambda () (if display? (display x) (write x)))))
+ (len (string-length str)))
+ (display (if (<= (string-length str) width)
+ str
+ (truncate-string str width)))))))
+
+ (with-output-to-port port
+ (lambda ()
+ (print x width))))))
HCoop / bpt / guile.git / blobdiff