mirror/guile
mirror/guile
1
Fork 0
mirror of https://git.savannah.gnu.org/git/guile.git synced 2025-06-10 05:50:26 +02:00
Code Activity

truncated-print: use call-with-truncating-output-string

Browse source 
* module/ice-9/pretty-print.scm (truncated-print): Use new
call-with-truncating-output-string, to allow for early bailout when
printing large records.
This commit is contained in:
Andy Wingo 2023-06-02 22:15:38 +02:00
parent 379a9a64c6
commit 0e4334406a
1 changed files with 31 additions and 32 deletions
Download patch file Download diff file Expand all files Collapse all files

63
module/ice-9/pretty-print.scm
View file

@ -385,30 +385,26 @@ sub-expression, via the @var{breadth-first?} keyword argument."
(lp (cdr x) (- width 1 (string-length str)))))))) (lp (cdr x) (- width 1 (string-length str))))))))
(define (truncate-string str width) (define (truncate-string str width)
;; width is < (string-length str) (unless (< width (string-length str))
(let lp ((fixes '(("#<" . ">") (error "precondition failed"))
("#(" . ")") (or (or-map (match-lambda
("(" . ")") ((prefix . suffix)
("\"" . "\"")))) (and (string-prefix? prefix str)
(cond (<= (+ (string-length prefix)
((null? fixes) (string-length suffix)
"#") ellipsis-width)
((and (string-prefix? (caar fixes) str) width)
(string-suffix? (cdar fixes) str) (format #f "~a~a~a"
(>= (string-length str) (substring str 0
width (- width (string-length suffix)
(+ (string-length (caar fixes)) ellipsis-width))
(string-length (cdar fixes)) ellipsis
ellipsis-width))) suffix))))
(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 #:key inner?) (define* (print x width #:key inner?)
(cond (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. ;; the truncated bitvector would print as #1b(...), so we print by hand.
((>= width (+ 2 ellipsis-width)) ((>= width (+ 2 ellipsis-width))
(format #t "#*") (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))) (make-shared-array x list (- width 2 ellipsis-width)))
(format #t ellipsis)) (display ellipsis))
(else (else
(display "#")))) (display "#"))))
((and (array? x) (not (string? x))) ((and (array? x) (not (string? x)))
@ -483,12 +479,15 @@ sub-expression, via the @var{breadth-first?} keyword argument."
(else (else
(display "#")))) (display "#"))))
(else (else
(let* ((str (with-output-to-string (call-with-truncating-output-string
(lambda () (if display? (display x) (write x))))) (lambda (port)
(len (string-length str))) (if display? (display x port) (write x port)))
(display (if (<= (string-length str) width) (lambda (full-str)
str (display full-str))
(truncate-string str width))))))) (lambda (partial-str)
(display (truncate-string partial-str width)))
#:max-column width
#:allow-newline? #f))))
(with-output-to-port port (with-output-to-port port
(lambda () (lambda ()