[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]
[Guile-commits] 11/18: Rewrite pretty-print to rely on port-column, abor
From: |
Andy Wingo |
Subject: |
[Guile-commits] 11/18: Rewrite pretty-print to rely on port-column, abort early |
Date: |
Thu, 8 Jun 2023 04:26:42 -0400 (EDT) |
wingo pushed a commit to branch main
in repository guile.
commit 29a9f26a36035d5425b173d101628ecc62f5a46b
Author: Andy Wingo <wingo@pobox.com>
AuthorDate: Fri Jun 2 13:25:01 2023 +0200
Rewrite pretty-print to rely on port-column, abort early
* module/ice-9/pretty-print.scm (call-with-truncating-output-string):
New function.
* module/ice-9/pretty-print.scm (generic-write): Rewrite so that instead
of keeping track of the column, we just use port-column on the port.
Also, when checking if a possibly-improper list can print on one line,
use new call-with-truncating-output-string so as to always abort early,
even for long bytevectors.
---
module/ice-9/pretty-print.scm | 431 ++++++++++++++++++++++++------------------
1 file changed, 246 insertions(+), 185 deletions(-)
diff --git a/module/ice-9/pretty-print.scm b/module/ice-9/pretty-print.scm
index 136869062..5ad25ca5f 100644
--- a/module/ice-9/pretty-print.scm
+++ b/module/ice-9/pretty-print.scm
@@ -21,10 +21,36 @@
#:use-module (ice-9 match)
#:use-module (srfi srfi-1)
#:use-module (rnrs bytevectors)
+ #:use-module (ice-9 soft-ports)
+ #:use-module (ice-9 textual-ports)
#:export (pretty-print
truncated-print))
+(define* (call-with-truncating-output-string proc success failure #:key
+ (initial-column 0)
+ (max-column 79)
+ (allow-newline? #f))
+ (define length 0)
+ (define strs '())
+ (define tag (make-prompt-tag))
+ (define (write-string str)
+ (set! length (+ length (string-length str)))
+ (set! strs (cons str strs))
+ (when (< (- max-column initial-column) length)
+ (abort-to-prompt tag)))
+ (define port
+ (make-soft-port #:id "truncating-output-port"
+ #:write-string write-string))
+ (call-with-prompt
+ tag
+ (lambda ()
+ (proc port)
+ (close port)
+ (success (string-concatenate-reverse strs)))
+ (lambda (_)
+ (failure (string-concatenate-reverse strs)))))
+
;; From SLIB.
;;"genwrite.scm" generic write used by pretty-print and truncated-print.
@@ -33,205 +59,240 @@
;; Distribution restrictions: none
(define (generic-write
- obj display? width max-expr-width per-line-prefix output)
+ obj display? width max-expr-width per-line-prefix port)
+ (define (wr obj port)
+ (define (wr-read-macro prefix x)
+ (put-string port prefix)
+ (wr x port))
+ (match obj
+ (('quote x) (wr-read-macro "'" x))
+ (('quasiquote x) (wr-read-macro "`" x))
+ (('unquote x) (wr-read-macro "," x))
+ (('unquote-splicing x) (wr-read-macro ",@" x))
+ ((head . (rest ...))
+ ;; A proper list: do our own list printing so as to catch read
+ ;; macros that appear in the middle of the list.
+ (put-string port "(")
+ (wr head port)
+ (for-each (lambda (x)
+ (put-string port " ")
+ (wr x port))
+ rest)
+ (put-string port ")"))
+ (_
+ ((if display? display write) obj port))))
+
+ (define (pp obj)
+ ; define formatting style (change these to suit your style)
+ (define indent-general 2)
+ (define max-call-head-width 5)
- (define (out str col)
- (and col (output str) (+ col (string-length str))))
+ (define (spaces n)
+ (when (< 0 n)
+ (put-string port " " 0 (min 8 n))
+ (when (< 8 n)
+ (spaces (- 8 n)))))
- (define (wr obj col)
- (let loop ((obj obj)
- (col col))
- (define (wr-read-macro prefix x) (wr x (out prefix col)))
+ (define (indent to)
+ (let ((col (port-column port)))
+ (cond
+ ((< to col)
+ (put-string port "\n")
+ (put-string port per-line-prefix)
+ (spaces to))
+ (else
+ (spaces (- to col))))))
+
+ (define (pr obj pp-pair)
(match obj
- (('quote x) (wr-read-macro "'" x))
- (('quasiquote x) (wr-read-macro "`" x))
- (('unquote x) (wr-read-macro "," x))
- (('unquote-splicing x) (wr-read-macro ",@" x))
- ((head . (rest ...))
- ;; A proper list: do our own list printing so as to catch read
- ;; macros that appear in the middle of the list.
- (let ((col (loop head (out "(" col))))
- (out ")"
- (fold (lambda (i col)
- (loop i (out " " col)))
- col rest))))
+ ((? vector?)
+ (put-string port "#")
+ (pr (vector->list obj) pp-pair))
+ ((not (? pair?))
+ (wr obj port))
+ (('quote x) (put-string port "'") (pr x pp-pair))
+ (('quasiquote x) (put-string port "`") (pr x pp-pair))
+ (('unquote x) (put-string port ",") (pr x pp-pair))
+ (('unquote-splicing x) (put-string port ",@") (pr x pp-pair))
(_
- (out (object->string obj (if display? display write)) col)))))
-
- (define (pp obj col)
-
- (define (spaces n col)
- (if (> n 0)
- (if (> n 7)
- (spaces (- n 8) (out " " col))
- (out (substring " " 0 n) col))
- col))
-
- (define (indent to col)
- (and col
- (if (< to col)
- (and (out "\n" col)
- (out per-line-prefix 0)
- (spaces to 0))
- (spaces (- to col) col))))
-
- (define (pr obj col extra pp-pair)
- (if (or (pair? obj) (vector? obj)) ; may have to split on multiple lines
- (let ((result '())
- (left (min (+ (- (- width col) extra) 1) max-expr-width)))
- (generic-write obj display? #f max-expr-width ""
- (lambda (str)
- (set! result (cons str result))
- (set! left (- left (string-length str)))
- (> left 0)))
- (if (> left 0) ; all can be printed on one line
- (out (string-concatenate-reverse result) col)
- (if (pair? obj)
- (pp-pair obj col extra)
- (pp-list (vector->list obj) (out "#" col) extra pp-expr))))
- (wr obj col)))
-
- (define (pp-expr expr col extra)
- (define (pp-read-macro prefix x)
- (pr x (out prefix col) extra pp-expr))
+ ;; A pair (and possibly a list). May have to split on multiple
+ ;; lines.
+ (call-with-truncating-output-string
+ (lambda (port) (wr obj port))
+ (lambda (full-str) (put-string port full-str))
+ (lambda (partial-str) (pp-pair obj))
+ #:initial-column (port-column port)
+ #:max-column width
+ #:allow-newline? #f))))
+
+ (define (pp-expr expr)
(match expr
- (('quote x) (pp-read-macro "'" x))
- (('quasiquote x) (pp-read-macro "`" x))
- (('unquote x) (pp-read-macro "," x))
- (('unquote-splicing x) (pp-read-macro ",@" x))
+ (((or 'quote 'quasiquote 'unquote 'unquote-splicing) _)
+ (pp-quote expr))
+ (('lambda _ _ . _) (pp-lambda expr))
+ (('lambda* _ _ . _) (pp-lambda expr))
+ (('let (? symbol?) _ _ . _) (pp-named-let expr))
+ (('let _ _ . _) (pp-let expr))
+ (('let* _ _ . _) (pp-let expr))
+ (('letrec _ _ . _) (pp-let expr))
+ (('letrec* _ _ . _) (pp-let expr))
+ (('let-syntax _ _ . _) (pp-let expr))
+ (('letrec-syntax _ _ . _) (pp-let expr))
+ (('define _ _ . _) (pp-define expr))
+ (('define* _ _ . _) (pp-define expr))
+ (('define-public _ _ . _) (pp-define expr))
+ (('define-syntax _ _ . _) (pp-define expr))
+ (('if _ _ . (or () (_))) (pp-if expr))
+ (('cond . _) (pp-cond expr))
+ (('case _ . _) (pp-case expr))
+ (('begin . _) (pp-begin expr))
+ (('do _ _ . _) (pp-do expr))
+ (('syntax-rules _ . _) (pp-syntax-rules expr))
+ (('syntax-case _ _ . _) (pp-syntax-case expr))
(((? symbol? head) . _)
- (let ((proc (style head)))
- (if proc
- (proc expr col extra)
- (if (> (string-length (symbol->string head))
- max-call-head-width)
- (pp-general expr col extra #f #f #f pp-expr)
- (pp-call expr col extra pp-expr)))))
- (_ (pp-list expr col extra pp-expr))))
+ (if (< max-call-head-width (string-length (symbol->string head)))
+ (pp-list expr pp-expr)
+ (pp-call expr pp-expr)))
+ (_ (pp-list expr pp-expr))))
+
+ (define (pp0 head body)
+ (let ((body-col (+ (port-column port) indent-general)))
+ (put-string port "(")
+ (wr head port)
+ (pp-down body body-col pp-expr)))
+
+ (define (pp1 head param0 body pp-param0)
+ (let ((body-col (+ (port-column port) indent-general)))
+ (put-string port "(")
+ (wr head port)
+ (put-string port " ")
+ (pr param0 pp-param0)
+ (pp-down body body-col pp-expr)))
+
+ (define (pp2 head param0 param1 body pp-param0 pp-param1)
+ (let ((body-col (+ (port-column port) indent-general)))
+ (put-string port "(")
+ (wr head port)
+ (put-string port " ")
+ (pr param0 pp-param0)
+ (put-string port " ")
+ (pr param1 pp-param1)
+ (pp-down body body-col pp-expr)))
+
+ (define (pp-quote expr)
+ (match obj
+ ((head x)
+ (put-string port
+ (match x
+ ('quote "'")
+ ('quasiquote "`")
+ ('unquote ",")
+ ('unquote-splicing ",@")))
+ (pr x pp-expr))))
+
+ (define (pp-lambda expr)
+ (match expr
+ ((head args . body)
+ (pp1 head args body pp-expr-list))))
+
+ (define (pp-let expr)
+ (match expr
+ ((head bindings . body)
+ (pp1 head bindings body pp-expr-list))))
+
+ (define (pp-named-let expr)
+ (match expr
+ ((head name bindings . body)
+ (pp2 head name bindings body pp-expr pp-expr-list))))
+
+ (define (pp-define expr)
+ (match expr
+ ((head args . body)
+ (pp1 head args body pp-expr-list))))
+
+ (define (pp-if expr)
+ (match expr
+ ((head test . body)
+ ;; "if" indent is 4.
+ (put-string port "(")
+ (wr head port)
+ (put-string port " ")
+ (let ((body-col (port-column port)))
+ (pr test pp-expr)
+ (pp-down body body-col pp-expr)))))
+
+ (define (pp-cond expr)
+ (match expr
+ ((head . clauses)
+ (pp0 head clauses))))
+
+ (define (pp-case expr)
+ (match expr
+ ((head x . clauses)
+ (pp1 head x clauses pp-expr))))
+
+ (define (pp-begin expr)
+ (match expr
+ ((head . body) (pp0 head body))))
+
+ (define (pp-do expr)
+ (match expr
+ ((head bindings exit . body)
+ (pp2 head bindings exit body pp-expr-list pp-expr-list))))
+
+ (define (pp-syntax-rules expr)
+ (match expr
+ ((head literals . clauses)
+ (pp1 head literals clauses pp-expr-list))))
+
+ (define (pp-syntax-case expr)
+ (match expr
+ ((head stx literals . clauses)
+ (pp2 head stx literals clauses pp-expr pp-expr-list))))
; (head item1
; item2
; item3)
- (define (pp-call expr col extra pp-item)
- (let ((col* (wr (car expr) (out "(" col))))
- (and col
- (pp-down (cdr expr) col* (+ col* 1) extra pp-item))))
+ (define (pp-call expr pp-item)
+ (match expr
+ ((head . tail)
+ (put-string port "(")
+ (wr head port)
+ (pp-down tail (+ (port-column port) 1) pp-item))))
; (item1
; item2
; item3)
- (define (pp-list l col extra pp-item)
- (let ((col (out "(" col)))
- (pp-down l col col extra pp-item)))
-
- (define (pp-down l col1 col2 extra pp-item)
- (let loop ((l l) (col col1))
- (and col
- (cond ((pair? l)
- (let ((rest (cdr l)))
- (let ((extra (if (null? rest) (+ extra 1) 0)))
- (loop rest
- (pr (car l) (indent col2 col) extra pp-item)))))
- ((null? l)
- (out ")" col))
- (else
- (out ")"
- (pr l
- (indent col2 (out "." (indent col2 col)))
- (+ extra 1)
- pp-item)))))))
-
- (define (pp-general expr col extra named? pp-1 pp-2 pp-3)
-
- (define (tail1 rest col1 col2 col3)
- (if (and pp-1 (pair? rest))
- (let* ((val1 (car rest))
- (rest (cdr rest))
- (extra (if (null? rest) (+ extra 1) 0)))
- (tail2 rest col1 (pr val1 (indent col3 col2) extra pp-1) col3))
- (tail2 rest col1 col2 col3)))
-
- (define (tail2 rest col1 col2 col3)
- (if (and pp-2 (pair? rest))
- (let* ((val1 (car rest))
- (rest (cdr rest))
- (extra (if (null? rest) (+ extra 1) 0)))
- (tail3 rest col1 (pr val1 (indent col3 col2) extra pp-2)))
- (tail3 rest col1 col2)))
-
- (define (tail3 rest col1 col2)
- (pp-down rest col2 col1 extra pp-3))
-
- (let* ((head (car expr))
- (rest (cdr expr))
- (col* (wr head (out "(" col))))
- (if (and named? (pair? rest))
- (let* ((name (car rest))
- (rest (cdr rest))
- (col** (wr name (out " " col*))))
- (tail1 rest (+ col indent-general) col** (+ col** 1)))
- (tail1 rest (+ col indent-general) col* (+ col* 1)))))
-
- (define (pp-expr-list l col extra)
- (pp-list l col extra pp-expr))
-
- (define (pp-LAMBDA expr col extra)
- (pp-general expr col extra #f pp-expr-list #f pp-expr))
-
- (define (pp-IF expr col extra)
- (pp-general expr col extra #f pp-expr #f pp-expr))
-
- (define (pp-COND expr col extra)
- (pp-call expr col extra pp-expr-list))
-
- (define (pp-CASE expr col extra)
- (pp-general expr col extra #f pp-expr #f pp-expr-list))
-
- (define (pp-AND expr col extra)
- (pp-call expr col extra pp-expr))
-
- (define (pp-LET expr col extra)
- (let* ((rest (cdr expr))
- (named? (and (pair? rest) (symbol? (car rest)))))
- (pp-general expr col extra named? pp-expr-list #f pp-expr)))
-
- (define (pp-BEGIN expr col extra)
- (pp-general expr col extra #f #f #f pp-expr))
-
- (define (pp-DO expr col extra)
- (pp-general expr col extra #f pp-expr-list pp-expr-list pp-expr))
-
- (define (pp-SYNTAX-CASE expr col extra)
- (pp-general expr col extra #t pp-expr-list #f pp-expr))
-
- ; define formatting style (change these to suit your style)
-
- (define indent-general 2)
-
- (define max-call-head-width 5)
-
- (define (style head)
- (case head
- ((lambda lambda* let* letrec define define* define-public
- define-syntax let-syntax letrec-syntax with-syntax)
- pp-LAMBDA)
- ((if set!) pp-IF)
- ((cond) pp-COND)
- ((case) pp-CASE)
- ((and or) pp-AND)
- ((let) pp-LET)
- ((begin) pp-BEGIN)
- ((do) pp-DO)
- ((syntax-rules) pp-LAMBDA)
- ((syntax-case) pp-SYNTAX-CASE)
- (else #f)))
-
- (pr obj col 0 pp-expr))
-
- (out per-line-prefix 0)
+ (define (pp-list l pp-item)
+ (put-string port "(")
+ (pp-down l (port-column port) pp-item))
+
+ (define (pp-down l item-indent pp-item)
+ (let loop ((l l))
+ (match l
+ (() (put-string port ")"))
+ ((head . tail)
+ (indent item-indent)
+ (pr head pp-item)
+ (loop tail))
+ (improper-tail
+ (indent item-indent)
+ (put-string port ".")
+ (indent item-indent)
+ (pr improper-tail pp-item)
+ (put-string port ")")))))
+
+ (define (pp-expr-list l)
+ (pp-list l pp-expr))
+
+ (pr obj pp-expr))
+
+ (put-string port per-line-prefix)
(if width
- (out "\n" (pp obj 0))
- (wr obj 0))
+ (begin
+ (pp obj)
+ (newline))
+ (wr obj port))
;; Return `unspecified'
(if #f #f))
@@ -255,7 +316,7 @@ port directly after OBJ, like (pretty-print OBJ PORT)."
(- width (string-length per-line-prefix))
max-expr-width
per-line-prefix
- (lambda (s) (display s port) #t)))
+ port))
;; `truncated-print' was written in 2009 by Andy Wingo, and is not from
- [Guile-commits] 08/18: Rewrite soft ports in Scheme, (continued)
- [Guile-commits] 08/18: Rewrite soft ports in Scheme, Andy Wingo, 2023/06/08
- [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 <=
- [Guile-commits] 14/18: truncated-print: use call-with-truncating-output-string, Andy Wingo, 2023/06/08
- [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