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

Rewrite pretty-print to rely on port-column, abort early

Browse source 
* 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.
This commit is contained in:
Andy Wingo 2023-06-02 13:25:01 +02:00
parent f320ce8979
commit 29a9f26a36
1 changed files with 241 additions and 180 deletions
Download patch file Download diff file Expand all files Collapse all files

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

@ -21,10 +21,36 @@
#:use-module (ice-9 match) #:use-module (ice-9 match)
#:use-module (srfi srfi-1) #:use-module (srfi srfi-1)
#:use-module (rnrs bytevectors) #:use-module (rnrs bytevectors)
#:use-module (ice-9 soft-ports)
#:use-module (ice-9 textual-ports)
#:export (pretty-print #:export (pretty-print
truncated-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. ;; From SLIB.
;;"genwrite.scm" generic write used by pretty-print and truncated-print. ;;"genwrite.scm" generic write used by pretty-print and truncated-print.
@ -33,15 +59,11 @@
;; Distribution restrictions: none ;; Distribution restrictions: none
(define (generic-write (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 (out str col) (define (wr-read-macro prefix x)
(and col (output str) (+ col (string-length str)))) (put-string port prefix)
(wr x port))
(define (wr obj col)
(let loop ((obj obj)
(col col))
(define (wr-read-macro prefix x) (wr x (out prefix col)))
(match obj (match obj
(('quote x) (wr-read-macro "'" x)) (('quote x) (wr-read-macro "'" x))
(('quasiquote x) (wr-read-macro "`" x)) (('quasiquote x) (wr-read-macro "`" x))
@ -50,188 +72,227 @@
((head . (rest ...)) ((head . (rest ...))
;; A proper list: do our own list printing so as to catch read ;; A proper list: do our own list printing so as to catch read
;; macros that appear in the middle of the list. ;; macros that appear in the middle of the list.
(let ((col (loop head (out "(" col)))) (put-string port "(")
(out ")" (wr head port)
(fold (lambda (i col) (for-each (lambda (x)
(loop i (out " " col))) (put-string port " ")
col rest)))) (wr x port))
rest)
(put-string port ")"))
(_ (_
(out (object->string obj (if display? display write)) col))))) ((if display? display write) obj port))))
(define (pp obj col) (define (pp obj)
; define formatting style (change these to suit your style)
(define indent-general 2)
(define max-call-head-width 5)
(define (spaces n col) (define (spaces n)
(if (> n 0) (when (< 0 n)
(if (> n 7) (put-string port " " 0 (min 8 n))
(spaces (- n 8) (out " " col)) (when (< 8 n)
(out (substring " " 0 n) col)) (spaces (- 8 n)))))
col))
(define (indent to col) (define (indent to)
(and col (let ((col (port-column port)))
(if (< to col) (cond
(and (out "\n" col) ((< to col)
(out per-line-prefix 0) (put-string port "\n")
(spaces to 0)) (put-string port per-line-prefix)
(spaces (- to col) col)))) (spaces to))
(else
(spaces (- to col))))))
(define (pr obj col extra pp-pair) (define (pr obj pp-pair)
(if (or (pair? obj) (vector? obj)) ; may have to split on multiple lines (match obj
(let ((result '()) ((? vector?)
(left (min (+ (- (- width col) extra) 1) max-expr-width))) (put-string port "#")
(generic-write obj display? #f max-expr-width "" (pr (vector->list obj) pp-pair))
(lambda (str) ((not (? pair?))
(set! result (cons str result)) (wr obj port))
(set! left (- left (string-length str))) (('quote x) (put-string port "'") (pr x pp-pair))
(> left 0))) (('quasiquote x) (put-string port "`") (pr x pp-pair))
(if (> left 0) ; all can be printed on one line (('unquote x) (put-string port ",") (pr x pp-pair))
(out (string-concatenate-reverse result) col) (('unquote-splicing x) (put-string port ",@") (pr x pp-pair))
(if (pair? obj) (_
(pp-pair obj col extra) ;; A pair (and possibly a list). May have to split on multiple
(pp-list (vector->list obj) (out "#" col) extra pp-expr)))) ;; lines.
(wr obj col))) (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 col extra) (define (pp-expr expr)
(define (pp-read-macro prefix x)
(pr x (out prefix col) extra pp-expr))
(match expr (match expr
(('quote x) (pp-read-macro "'" x)) (((or 'quote 'quasiquote 'unquote 'unquote-splicing) _)
(('quasiquote x) (pp-read-macro "`" x)) (pp-quote expr))
(('unquote x) (pp-read-macro "," x)) (('lambda _ _ . _) (pp-lambda expr))
(('unquote-splicing x) (pp-read-macro ",@" x)) (('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) . _) (((? symbol? head) . _)
(let ((proc (style head))) (if (< max-call-head-width (string-length (symbol->string head)))
(if proc (pp-list expr pp-expr)
(proc expr col extra) (pp-call expr pp-expr)))
(if (> (string-length (symbol->string head)) (_ (pp-list expr pp-expr))))
max-call-head-width)
(pp-general expr col extra #f #f #f pp-expr) (define (pp0 head body)
(pp-call expr col extra pp-expr))))) (let ((body-col (+ (port-column port) indent-general)))
(_ (pp-list expr col extra pp-expr)))) (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 ; (head item1
; item2 ; item2
; item3) ; item3)
(define (pp-call expr col extra pp-item) (define (pp-call expr pp-item)
(let ((col* (wr (car expr) (out "(" col)))) (match expr
(and col ((head . tail)
(pp-down (cdr expr) col* (+ col* 1) extra pp-item)))) (put-string port "(")
(wr head port)
(pp-down tail (+ (port-column port) 1) pp-item))))
; (item1 ; (item1
; item2 ; item2
; item3) ; item3)
(define (pp-list l col extra pp-item) (define (pp-list l pp-item)
(let ((col (out "(" col))) (put-string port "(")
(pp-down l col col extra pp-item))) (pp-down l (port-column port) pp-item))
(define (pp-down l col1 col2 extra pp-item) (define (pp-down l item-indent pp-item)
(let loop ((l l) (col col1)) (let loop ((l l))
(and col (match l
(cond ((pair? l) (() (put-string port ")"))
(let ((rest (cdr l))) ((head . tail)
(let ((extra (if (null? rest) (+ extra 1) 0))) (indent item-indent)
(loop rest (pr head pp-item)
(pr (car l) (indent col2 col) extra pp-item))))) (loop tail))
((null? l) (improper-tail
(out ")" col)) (indent item-indent)
(else (put-string port ".")
(out ")" (indent item-indent)
(pr l (pr improper-tail pp-item)
(indent col2 (out "." (indent col2 col))) (put-string port ")")))))
(+ extra 1)
pp-item)))))))
(define (pp-general expr col extra named? pp-1 pp-2 pp-3) (define (pp-expr-list l)
(pp-list l pp-expr))
(define (tail1 rest col1 col2 col3) (pr obj pp-expr))
(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) (put-string port per-line-prefix)
(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)
(if width (if width
(out "\n" (pp obj 0)) (begin
(wr obj 0)) (pp obj)
(newline))
(wr obj port))
;; Return `unspecified' ;; Return `unspecified'
(if #f #f)) (if #f #f))
@ -255,7 +316,7 @@ port directly after OBJ, like (pretty-print OBJ PORT)."
(- width (string-length per-line-prefix)) (- width (string-length per-line-prefix))
max-expr-width max-expr-width
per-line-prefix per-line-prefix
(lambda (s) (display s port) #t))) port))
;; `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