[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]
[Guile-commits] 14/18: truncated-print: use call-with-truncating-output-
From: |
Andy Wingo |
Subject: |
[Guile-commits] 14/18: truncated-print: use call-with-truncating-output-string |
Date: |
Thu, 8 Jun 2023 04:26:43 -0400 (EDT) |
wingo pushed a commit to branch main
in repository guile.
commit 0e4334406a791dc904eb6acc3c1a0ecdda8f9066
Author: Andy Wingo <wingo@pobox.com>
AuthorDate: Fri Jun 2 22:15:38 2023 +0200
truncated-print: use call-with-truncating-output-string
* module/ice-9/pretty-print.scm (truncated-print): Use new
call-with-truncating-output-string, to allow for early bailout when
printing large records.
---
module/ice-9/pretty-print.scm | 63 +++++++++++++++++++++----------------------
1 file changed, 31 insertions(+), 32 deletions(-)
diff --git a/module/ice-9/pretty-print.scm b/module/ice-9/pretty-print.scm
index 35a47088c..21a80e9a5 100644
--- a/module/ice-9/pretty-print.scm
+++ b/module/ice-9/pretty-print.scm
@@ -385,30 +385,26 @@ sub-expression, via the @var{breadth-first?} keyword
argument."
(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))))))
+ (unless (< width (string-length str))
+ (error "precondition failed"))
+ (or (or-map (match-lambda
+ ((prefix . suffix)
+ (and (string-prefix? prefix str)
+ (<= (+ (string-length prefix)
+ (string-length suffix)
+ ellipsis-width)
+ width)
+ (format #f "~a~a~a"
+ (substring str 0
+ (- width (string-length suffix)
+ ellipsis-width))
+ ellipsis
+ suffix))))
+ '(("#<" . ">")
+ ("#(" . ")")
+ ("(" . ")")
+ ("\"" . "\"")))
+ "#"))
(define* (print x width #:key inner?)
(cond
@@ -448,9 +444,9 @@ sub-expression, via the @var{breadth-first?} keyword
argument."
;; the truncated bitvector would print as #1b(...), so we print by
hand.
((>= width (+ 2 ellipsis-width))
(format #t "#*")
- (array-for-each (lambda (xi) (format #t (if xi "1" "0")))
+ (array-for-each (lambda (xi) (display (if xi "1" "0")))
(make-shared-array x list (- width 2
ellipsis-width)))
- (format #t ellipsis))
+ (display ellipsis))
(else
(display "#"))))
((and (array? x) (not (string? x)))
@@ -483,12 +479,15 @@ sub-expression, via the @var{breadth-first?} keyword
argument."
(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)))))))
+ (call-with-truncating-output-string
+ (lambda (port)
+ (if display? (display x port) (write x port)))
+ (lambda (full-str)
+ (display full-str))
+ (lambda (partial-str)
+ (display (truncate-string partial-str width)))
+ #:max-column width
+ #:allow-newline? #f))))
(with-output-to-port port
(lambda ()
- [Guile-commits] 04/18: bytevector-slice: optimize trivial case, (continued)
- [Guile-commits] 04/18: bytevector-slice: optimize trivial case, Andy Wingo, 2023/06/08
- [Guile-commits] 16/18: Load (ice-9 binary-ports) from C in thread-safe way, Andy Wingo, 2023/06/08
- [Guile-commits] 07/18: Use custom binary output ports for make-chunked-output-port, Andy Wingo, 2023/06/08
- [Guile-commits] 13/18: Inline generic-write into pretty-print, Andy Wingo, 2023/06/08
- [Guile-commits] 10/18: Modernize soft ports, Andy Wingo, 2023/06/08
- [Guile-commits] 01/18: pretty-print: Use string-concatenate-reverse, Andy Wingo, 2023/06/08
- [Guile-commits] 17/18: Deprecate (ice-9 lineio), Andy Wingo, 2023/06/08
- [Guile-commits] 18/18: Fix exn dispatch for exns within pre-unwind handlers, Andy Wingo, 2023/06/08
- [Guile-commits] 09/18: Implement R6RS custom textual ports, Andy Wingo, 2023/06/08
- [Guile-commits] 11/18: Rewrite pretty-print to rely on port-column, abort early, Andy Wingo, 2023/06/08
- [Guile-commits] 14/18: truncated-print: use call-with-truncating-output-string,
Andy Wingo <=
- [Guile-commits] 12/18: pretty-print: width arg is never false, Andy Wingo, 2023/06/08
- [Guile-commits] 15/18: Fix allow-newline? in call-with-truncating-output-string, Andy Wingo, 2023/06/08
- [Guile-commits] 02/18: pretty-print: inline genwrite:newline-str, Andy Wingo, 2023/06/08