mirror of
https://git.savannah.gnu.org/git/guile.git
synced 2025-06-10 05:50:26 +02:00
Use HORIZONTAL ELLIPSIS' when available in truncated-print'.
* module/ice-9/pretty-print.scm (truncated-print): Set
`%default-port-encoding' to the encoding of PORT. Choose either
U+2026 or "..." depending on PORT's encoding.
* test-suite/tests/print.test ("truncated-print")[tprint]: New ENCODING
argument. Update existing tests accordingly. Add UTF-8 tests.
* doc/ref/misc-modules.texi (Pretty Printing): Mention the possible use
of U+2026.
This commit is contained in:
Ludovic Courtès
parent
cc7005bc37
commit
c5e05a1c70
3 changed files with 175 additions and 141 deletions
|
|
@ -83,9 +83,11 @@ line in which to do so.
|
|||
@print{} #<directory (gui...>
|
||||
@end lisp
|
||||
|
||||
@code{truncated-print} will not output a trailing newline. If an
|
||||
expression does not fit in the given width, it will be truncated --
|
||||
possibly ellipsized, or in the worst case, displayed as @nicode{#}.
|
||||
@code{truncated-print} will not output a trailing newline. If an expression does
|
||||
not fit in the given width, it will be truncated -- possibly
|
||||
ellipsized@footnote{On Unicode-capable ports, the ellipsis is represented by
|
||||
character `HORIZONTAL ELLIPSIS' (U+2026), otherwise it is represented by three
|
||||
dots.}, or in the worst case, displayed as @nicode{#}.
|
||||
|
||||
@deffn {Scheme Procedure} truncated-print obj [port] [keyword-options]
|
||||
Print @var{obj}, truncating the output, if necessary, to make it fit
|
||||
|
|
|
|||
|
|
@ -1,6 +1,6 @@
|
|||
;;;; -*-scheme-*-
|
||||
;;;; -*- coding: utf-8; mode: scheme -*-
|
||||
;;;;
|
||||
;;;; Copyright (C) 2001, 2004, 2006, 2009 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
|
||||
|
|
@ -271,6 +271,7 @@ port directly after OBJ, like (pretty-print OBJ PORT)."
|
|||
per-line-prefix
|
||||
(lambda (s) (display s port) #t)))
|
||||
|
||||
|
||||
;; `truncated-print' was written in 2009 by Andy Wingo, and is not from
|
||||
;; genwrite.scm.
|
||||
(define* (truncated-print x #:optional port*
|
||||
|
|
@ -285,123 +286,146 @@ into @var{width} characters. By default, @var{x} will be printed using
|
|||
@var{display?} keyword argument.
|
||||
|
||||
The default behaviour is to print depth-first, meaning that the entire
|
||||
remaining width will be available to each sub-expressoin of @var{x} --
|
||||
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."
|
||||
|
||||
(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 4)
|
||||
(display "..."))
|
||||
(else
|
||||
(let ((str (with-output-to-string
|
||||
(lambda ()
|
||||
(print (ref x i)
|
||||
(if breadth-first?
|
||||
(max 1
|
||||
(1- (floor (/ width (- len i)))))
|
||||
(- width 4)))))))
|
||||
(display str)
|
||||
(lp (next x) (- width 1 (string-length str)) (1+ i)))))))
|
||||
;; Make sure string ports are created with the right encoding.
|
||||
(with-fluids ((%default-port-encoding (port-encoding port)))
|
||||
|
||||
(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 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)
|
||||
"..."))))
|
||||
|
||||
(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))
|
||||
3)))
|
||||
(format #f "~a~a...~a"
|
||||
(caar fixes)
|
||||
(substring str (string-length (caar fixes))
|
||||
(- width (string-length (cdar fixes)) 3))
|
||||
(cdar fixes)))
|
||||
(else
|
||||
(lp (cdr fixes))))))
|
||||
(let ((ellipsis-width (string-length ellipsis)))
|
||||
|
||||
(define (print x width)
|
||||
(cond
|
||||
((<= width 0)
|
||||
(error "expected a positive width" width))
|
||||
((list? x)
|
||||
(cond
|
||||
((>= width 5)
|
||||
(display "(")
|
||||
(print-sequence x (- width 2) (length x) (lambda (x i) (car x)) cdr)
|
||||
(display ")"))
|
||||
(else
|
||||
(display "#"))))
|
||||
((vector? x)
|
||||
(cond
|
||||
((>= width 6)
|
||||
(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 7)
|
||||
(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)))))))
|
||||
(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)))))))
|
||||
|
||||
(with-output-to-port port
|
||||
(lambda ()
|
||||
(print x width))))
|
||||
(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))))))
|
||||
|
|
|
|||
|
|
@ -1,4 +1,4 @@
|
|||
;;;; -*- scheme -*-
|
||||
;;;; -*- coding: utf-8; mode: scheme; -*-
|
||||
;;;;
|
||||
;;;; Copyright (C) 2010 Free Software Foundation, Inc.
|
||||
;;;;
|
||||
|
|
@ -6,12 +6,12 @@
|
|||
;;;; modify it under the terms of the GNU Lesser General Public
|
||||
;;;; License as published by the Free Software Foundation; either
|
||||
;;;; 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
|
||||
;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
|
||||
;;;; Lesser General Public License for more details.
|
||||
;;;;
|
||||
;;;;
|
||||
;;;; You should have received a copy of the GNU Lesser General Public
|
||||
;;;; License along with this library; if not, write to the Free Software
|
||||
;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
|
||||
|
|
@ -22,25 +22,33 @@
|
|||
|
||||
(with-test-prefix "truncated-print"
|
||||
(define exp '(a b #(c d e) f . g))
|
||||
(define (tprint x width)
|
||||
(with-output-to-string
|
||||
(lambda ()
|
||||
(truncated-print x #:width width))))
|
||||
|
||||
(pass-if (equal? (tprint exp 10)
|
||||
"(a b . #)"))
|
||||
|
||||
(pass-if (equal? (tprint exp 15)
|
||||
"(a b # f . g)"))
|
||||
|
||||
(pass-if (equal? (tprint exp 18)
|
||||
"(a b #(c ...) . #)"))
|
||||
|
||||
(pass-if (equal? (tprint exp 20)
|
||||
"(a b #(c d e) f . g)"))
|
||||
|
||||
(pass-if (equal? (tprint "The quick brown fox" 20)
|
||||
"\"The quick brown...\""))
|
||||
|
||||
(pass-if (equal? (tprint (current-module) 20)
|
||||
"#<directory (tes...>")))
|
||||
(define (tprint x width encoding)
|
||||
(with-fluids ((%default-port-encoding encoding))
|
||||
(with-output-to-string
|
||||
(lambda ()
|
||||
(truncated-print x #:width width)))))
|
||||
|
||||
(pass-if (equal? (tprint exp 10 "ISO-8859-1")
|
||||
"(a b . #)"))
|
||||
|
||||
(pass-if (equal? (tprint exp 15 "ISO-8859-1")
|
||||
"(a b # f . g)"))
|
||||
|
||||
(pass-if (equal? (tprint exp 18 "ISO-8859-1")
|
||||
"(a b #(c ...) . #)"))
|
||||
|
||||
(pass-if (equal? (tprint exp 20 "ISO-8859-1")
|
||||
"(a b #(c d e) f . g)"))
|
||||
|
||||
(pass-if (equal? (tprint "The quick brown fox" 20 "ISO-8859-1")
|
||||
"\"The quick brown...\""))
|
||||
|
||||
(pass-if (equal? (tprint "The quick brown fox" 20 "UTF-8")
|
||||
"\"The quick brown f…\""))
|
||||
|
||||
(pass-if (equal? (tprint (current-module) 20 "ISO-8859-1")
|
||||
"#<directory (tes...>"))
|
||||
|
||||
(pass-if (equal? (tprint (current-module) 20 "UTF-8")
|
||||
"#<directory (test-…>")))
|
||||
|
|
|
|||
Loading…
Add table
Add a link
Reference in a new issue