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...>
|
@print{} #<directory (gui...>
|
||||||
@end lisp
|
@end lisp
|
||||||
|
|
||||||
@code{truncated-print} will not output a trailing newline. If an
|
@code{truncated-print} will not output a trailing newline. If an expression does
|
||||||
expression does not fit in the given width, it will be truncated --
|
not fit in the given width, it will be truncated -- possibly
|
||||||
possibly ellipsized, or in the worst case, displayed as @nicode{#}.
|
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]
|
@deffn {Scheme Procedure} truncated-print obj [port] [keyword-options]
|
||||||
Print @var{obj}, truncating the output, if necessary, to make it fit
|
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
|
;;;; This library is free software; you can redistribute it and/or
|
||||||
;;;; modify it under the terms of the GNU Lesser General Public
|
;;;; 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
|
per-line-prefix
|
||||||
(lambda (s) (display s port) #t)))
|
(lambda (s) (display s port) #t)))
|
||||||
|
|
||||||
|
|
||||||
;; `truncated-print' was written in 2009 by Andy Wingo, and is not from
|
;; `truncated-print' was written in 2009 by Andy Wingo, and is not from
|
||||||
;; genwrite.scm.
|
;; genwrite.scm.
|
||||||
(define* (truncated-print x #:optional port*
|
(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.
|
@var{display?} keyword argument.
|
||||||
|
|
||||||
The default behaviour is to print depth-first, meaning that the entire
|
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
|
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
|
\"ration\" the available width, trying to allocate it equally to each
|
||||||
sub-expression, via the @var{breadth-first?} keyword argument."
|
sub-expression, via the @var{breadth-first?} keyword argument."
|
||||||
|
|
||||||
(define (print-sequence x width len ref next)
|
;; Make sure string ports are created with the right encoding.
|
||||||
(let lp ((x x)
|
(with-fluids ((%default-port-encoding (port-encoding port)))
|
||||||
(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)))))))
|
|
||||||
|
|
||||||
(define (print-tree x width)
|
(define ellipsis
|
||||||
;; width is >= the width of # . #, which is 5
|
;; Choose between `HORIZONTAL ELLIPSIS' (U+2026) and three dots, depending
|
||||||
(let lp ((x x)
|
;; on the encoding of PORT.
|
||||||
(width width))
|
(let ((e "…"))
|
||||||
(cond
|
(catch 'encoding-error
|
||||||
((or (not (pair? x)) (<= width 4))
|
(lambda ()
|
||||||
(display ". ")
|
(with-output-to-string
|
||||||
(print x (- width 2)))
|
(lambda ()
|
||||||
(else
|
(display e))))
|
||||||
;; width >= 5
|
(lambda (key . args)
|
||||||
(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)
|
(let ((ellipsis-width (string-length ellipsis)))
|
||||||
;; 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))))))
|
|
||||||
|
|
||||||
(define (print x width)
|
(define (print-sequence x width len ref next)
|
||||||
(cond
|
(let lp ((x x)
|
||||||
((<= width 0)
|
(width width)
|
||||||
(error "expected a positive width" width))
|
(i 0))
|
||||||
((list? x)
|
(if (> i 0)
|
||||||
(cond
|
(display #\space))
|
||||||
((>= width 5)
|
(cond
|
||||||
(display "(")
|
((= i len)) ; catches 0-length case
|
||||||
(print-sequence x (- width 2) (length x) (lambda (x i) (car x)) cdr)
|
((= i (1- len))
|
||||||
(display ")"))
|
(print (ref x i) (if (zero? i) width (1- width))))
|
||||||
(else
|
((<= width (+ 1 ellipsis-width))
|
||||||
(display "#"))))
|
(display "..."))
|
||||||
((vector? x)
|
(else
|
||||||
(cond
|
(let ((str
|
||||||
((>= width 6)
|
(with-fluids ((%default-port-encoding (port-encoding port)))
|
||||||
(display "#(")
|
(with-output-to-string
|
||||||
(print-sequence x (- width 3) (vector-length x) vector-ref identity)
|
(lambda ()
|
||||||
(display ")"))
|
(print (ref x i)
|
||||||
(else
|
(if breadth-first?
|
||||||
(display "#"))))
|
(max 1
|
||||||
((uniform-vector? x)
|
(1- (floor (/ width (- len i)))))
|
||||||
(cond
|
(- width (+ 1 ellipsis-width)))))))))
|
||||||
((>= width 9)
|
(display str)
|
||||||
(format #t "#~a(" (uniform-vector-element-type x))
|
(lp (next x) (- width 1 (string-length str)) (1+ i)))))))
|
||||||
(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)))))))
|
|
||||||
|
|
||||||
(with-output-to-port port
|
(define (print-tree x width)
|
||||||
(lambda ()
|
;; width is >= the width of # . #, which is 5
|
||||||
(print x width))))
|
(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.
|
;;;; Copyright (C) 2010 Free Software Foundation, Inc.
|
||||||
;;;;
|
;;;;
|
||||||
|
|
@ -22,25 +22,33 @@
|
||||||
|
|
||||||
(with-test-prefix "truncated-print"
|
(with-test-prefix "truncated-print"
|
||||||
(define exp '(a b #(c d e) f . g))
|
(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)
|
(define (tprint x width encoding)
|
||||||
"(a b . #)"))
|
(with-fluids ((%default-port-encoding encoding))
|
||||||
|
(with-output-to-string
|
||||||
|
(lambda ()
|
||||||
|
(truncated-print x #:width width)))))
|
||||||
|
|
||||||
(pass-if (equal? (tprint exp 15)
|
(pass-if (equal? (tprint exp 10 "ISO-8859-1")
|
||||||
"(a b # f . g)"))
|
"(a b . #)"))
|
||||||
|
|
||||||
(pass-if (equal? (tprint exp 18)
|
(pass-if (equal? (tprint exp 15 "ISO-8859-1")
|
||||||
"(a b #(c ...) . #)"))
|
"(a b # f . g)"))
|
||||||
|
|
||||||
(pass-if (equal? (tprint exp 20)
|
(pass-if (equal? (tprint exp 18 "ISO-8859-1")
|
||||||
"(a b #(c d e) f . g)"))
|
"(a b #(c ...) . #)"))
|
||||||
|
|
||||||
(pass-if (equal? (tprint "The quick brown fox" 20)
|
(pass-if (equal? (tprint exp 20 "ISO-8859-1")
|
||||||
"\"The quick brown...\""))
|
"(a b #(c d e) f . g)"))
|
||||||
|
|
||||||
(pass-if (equal? (tprint (current-module) 20)
|
(pass-if (equal? (tprint "The quick brown fox" 20 "ISO-8859-1")
|
||||||
"#<directory (tes...>")))
|
"\"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