From c9d753f5ce9eaf8d66cdf61da1a4ddd0aeaca812 Mon Sep 17 00:00:00 2001 From: Shiro Kawai Date: Tue, 24 Dec 2024 23:01:13 -1000 Subject: [PATCH] Fix pprint column rounding issue https://github.com/shirok/Gauche/issues/941 --- ChangeLog | 5 +++++ lib/gauche/pputil.scm | 24 +++++++++++++++--------- test/io2.scm | 37 +++++++++++++++++++++++++++++++++++-- 3 files changed, 55 insertions(+), 11 deletions(-) diff --git a/ChangeLog b/ChangeLog index 5b387f44e..dcc55479a 100644 --- a/ChangeLog +++ b/ChangeLog @@ -1,3 +1,8 @@ +2024-12-24 Shiro Kawai + + * lib/gauche/pputil.scm (do-layout-elements): Fix column rounding + issue https://github.com/shirok/Gauche/issues/941 + 2024-12-20 Shiro Kawai * lib/gauche/numioutil.scm: Move print-exact-decimal-point-number diff --git a/lib/gauche/pputil.scm b/lib/gauche/pputil.scm index 53d16431f..839c4f362 100644 --- a/lib/gauche/pputil.scm +++ b/lib/gauche/pputil.scm @@ -94,6 +94,8 @@ (define-inline (>=* a b) (and a b (>= a b))) (define-inline (-* a b . args) (and a b (if (null? args) (- a b) (apply -* (- a b) args)))) +(define-inline (+* a b . args) + (and a b (if (null? args) (+ a b) (apply +* (+ a b) args)))) (define-inline (min* a b) (if a (if b (min a b) a) b)) ;; Render OBJ into a string. The resulting string is then used with @@ -297,31 +299,35 @@ ;; find out best fit. Each layouter may be invoked more than once, ;; when retry happens. (define (do-layout-elements room memo elts) - (define (do-oneline r es strs) + (define (do-oneline r es strs first?) (match es [() (cons strs (-* room r))] - [(e . es) (match-let1 (s . w) (e room memo) + [(e . es) (match-let1 (s . w) (e r memo) (cond [(not w) (do-linear room elts)] ;giveup [(>* w room) ;too big (do-fill room es (list* 'b s 'b strs))] - [(>* w r) + [(and first? (>* r w)) + (do-oneline (-* r w) es (list* s 's strs) #f)] + [(>* w (-* r 1)) (do-fill (-* room w) es (list* s 'b strs))] [else - (do-oneline (-* r w 1) es (list* s 's strs))]))])) + (do-oneline (-* r w 1) es (list* s 's strs) #f)]))])) (define (do-fill r es strs) (match es [() (cons strs #f)] - [(e . es) (match-let1 (s . w) (e room memo) + [(e . es) (match-let1 (s . w) (e r memo) (cond [(not w) (do-linear room elts)] [(>* w (-* r 1)) - (do-fill (-* room w 1) es (list* s 'b strs))] - [else (do-fill (-* r w 1) es (list* s 's strs))]))])) + (do-fill (-* room w) es (list* s 'b strs))] + [else + (do-fill (-* r w 1) es (list* s 's strs))]))])) (define (do-linear r es) (cons (fold (^[e strs] (match-let1 (s . w) (e room memo) (list* s 'b strs))) '() es) #f)) - (match-let1 (s . w) (do-oneline room elts '()) - (cons (cons ")" s) w))) + + (match-let1 (s . w) (do-oneline room elts '() #t) + (cons (cons ")" s) (+* w 1)))) ;; Render the nested list of strings. Some trick: S's and b's right ;; after open paren are ignored. S's right after b's are also ignored. diff --git a/test/io2.scm b/test/io2.scm index 5fbafe842..03103e1c1 100644 --- a/test/io2.scm +++ b/test/io2.scm @@ -707,8 +707,8 @@ [data2 '(Lorem (ipsum #(dolor (sit (amet . consectetur)))))] ) (define (t name expect data . args) - (test* #"~|name| ~|args|" expect - (with-output-to-string (^[] (apply pprint data args))))) + (test*/diff #"~|name| ~|args|" expect + (with-output-to-string (^[] (apply pprint data args))))) (define elli (with-module gauche.internal (string-ellipsis))) (let-syntax ([t* (syntax-rules () @@ -763,6 +763,39 @@ \n (ipsum #(dolor (sit #))))\n") )) +;; Rounding error +;; https://github.com/shirok/Gauche/issues/941 +(test*/diff "rounding" + "(abc abc abc abc abc abc abc abc abc abc + abc abc abc abc abc abc abc abc abc abc + abc abc abc abc abc abc abc abc abc abc + abc abc abc abc abc abc abc abc abc abc + abc abc abc abc abc abc abc abc abc abc + abc abc abc abc abc abc abc abc abc abc + abc abc abc abc abc abc abc abc abc abc + abc abc abc abc abc abc abc abc abc abc + abc abc abc abc abc abc abc abc abc abc + abc abc abc abc abc abc abc abc abc abc) +" + (with-output-to-string (cut pprint (make-list 100 'abc) + :indent 20 :width 60))) + +;; some more rounding tests +(let ((expected '("(abc)\n" + "(abc abc)\n" + "(abc abc\n abc)\n" + "(abc abc\n abc abc)\n" + "(abc abc\n abc abc\n abc)\n" + "(abc abc\n abc abc\n abc abc)\n" + "(abc abc\n abc abc\n abc abc\n abc)\n" + "(abc abc\n abc abc\n abc abc\n abc abc)\n"))) + (dotimes [i (length expected)] + (test*/diff #"rounding ~i" + (~ expected i) + (with-output-to-string + (cut pprint (make-list (+ i 1) 'abc) :width 8)))) + ) + (test* "no newline" "(a\n a)" (call-with-output-string (cut pprint '(a a) :width 3 :newline #f :port <>)))