From 532fb83e0a8ee688366a311b58ce5875a7d6112d Mon Sep 17 00:00:00 2001 From: Alex Shinn Date: Wed, 24 Jun 2020 12:25:36 +0900 Subject: [PATCH] don't use nested show in pretty (issue #518); use string-width for computing width (issue #517) --- lib/srfi/166.sld | 2 +- lib/srfi/166/pretty.scm | 112 +++++++++++++++++++++++----------------- lib/srfi/166/pretty.sld | 2 +- lib/srfi/166/test.sld | 4 ++ 4 files changed, 70 insertions(+), 50 deletions(-) diff --git a/lib/srfi/166.sld b/lib/srfi/166.sld index a9c9e1a6..1e6d205c 100644 --- a/lib/srfi/166.sld +++ b/lib/srfi/166.sld @@ -21,7 +21,7 @@ radix precision decimal-sep decimal-align sign-rule comma-sep comma-rule word-separator? ambiguous-is-wide? ;; pretty - pretty pretty-shared pretty-simply pretty-color + pretty pretty-shared pretty-simply pretty-with-color ;; columnar columnar tabular wrapped wrapped/list wrapped/char justified from-file line-numbers show-columns diff --git a/lib/srfi/166/pretty.scm b/lib/srfi/166/pretty.scm index 52c22f56..87b59034 100644 --- a/lib/srfi/166/pretty.scm +++ b/lib/srfi/166/pretty.scm @@ -53,7 +53,7 @@ (call-with-output-string (lambda (out) (write x out)))) (define (try-fitted2 proc fail) - (fn (width (orig-output output)) + (fn (width string-width (orig-output output)) (let ((out (open-output-string))) (call-with-current-continuation (lambda (abort) @@ -64,7 +64,7 @@ (fn (col) (let lp ((i 0) (col col)) (let ((nli (string-find/index str #\newline i)) - (len (string-length str))) + (len (string-width str))) (if (< nli len) (if (> (+ (- nli i) col) width) (abort fail) @@ -88,33 +88,40 @@ proc (try-fitted2 proc (lp (car ls) (cdr ls)))))) -(define (fits-in-width width proc) +(define (fits-in-width width proc set-failed!) (call-with-current-continuation (lambda (abort) - (show - #f - (fn ((orig-output output)) - (define (output* str) - (each (orig-output str) - (fn (col) - (if (>= col width) - (abort #f) - nothing)))) - (with ((output output*)) - proc)))))) + (fn ((orig-output output)) + (define (output* str) + (each (orig-output str) + (fn (col) + (if (>= col width) + (begin (set-failed! #t) (abort #f)) + nothing)))) + (with ((output output*)) + proc))))) -(define (fits-in-columns width ls writer) +(define (fits-in-columns width ls writer set-result!) (let ((max-w (quotient width 2))) - (let lp ((ls ls) (res '()) (widest 0)) - (cond - ((pair? ls) - (let ((str (fits-in-width max-w (writer (car ls))))) - (and str - (lp (cdr ls) - (cons str res) - (max (string-length str) widest))))) - ((null? ls) (cons widest (reverse res))) - (else #f))))) + (fn (string-width) + (let lp ((ls ls) (res '()) (widest 0)) + (cond + ((pair? ls) + (let ((failed? #f)) + (call-with-output + (fits-in-width max-w + (writer (car ls)) + (lambda (x) (set! failed? x))) + (lambda (str) + (if failed? + (begin + (set-result! #f) + nothing) + (lp (cdr ls) + (cons str res) + (max (string-width str) widest))))))) + ((null? ls) (set-result! (cons widest (reverse res))) nothing) + (else (set-result! #f) nothing)))))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; style @@ -258,28 +265,36 @@ (fn (col width string-width) (let ((avail (- width col))) (cond - ((and (pair? (cdr ls)) (pair? (cddr ls)) (pair? (cdr (cddr ls))) - (fits-in-columns width ls (lambda (x) (pp-flat x pp shares)))) - => (lambda (ls) - ;; at least four elements which can be broken into columns - (let* ((prefix (make-nl-space col)) - (widest (+ 1 (car ls))) - (columns (quotient width widest))) ; always >= 2 - (let lp ((ls (cdr ls)) (i 1)) - (cond - ((null? ls) - nothing) - ((null? (cdr ls)) - (displayed (car ls))) - ((>= i columns) - (each (car ls) - prefix - (fn () (lp (cdr ls) 1)))) - (else - (let ((pad (- widest (string-width (car ls))))) - (each (car ls) - (make-space pad) - (lp (cdr ls) (+ i 1)))))))))) + ((and (pair? (cdr ls)) (pair? (cddr ls)) (pair? (cdr (cddr ls)))) + (let ((out (open-output-string)) + (result #f)) + (call-with-output + (fits-in-columns width ls (lambda (x) (pp-flat x pp shares)) + (lambda (res) (set! result res))) + (lambda (str) + (fn () + (if (not result) + ;; no room, print one per line + (joined/shares pp ls shares (make-nl-space col)) + ;; at least four elements which can be broken into columns + (let* ((prefix (make-nl-space col)) + (widest (+ 1 (car result))) + (columns (quotient width widest))) ; always >= 2 + (let lp ((ls (cdr result)) (i 1)) + (cond + ((null? ls) + nothing) + ((null? (cdr ls)) + (displayed (car ls))) + ((>= i columns) + (each (car ls) + prefix + (fn () (lp (cdr ls) 1)))) + (else + (let ((pad (- widest (string-width (car ls))))) + (each (car ls) + (make-space pad) + (lp (cdr ls) (+ i 1)))))))))))))) (else ;; no room, print one per line (joined/shares pp ls shares (make-nl-space col)))))) @@ -380,4 +395,5 @@ (each (pp obj (extract-shared-objects #f #f)) fl))) -(define pretty-color pretty) +;; TODO: add colors +(define pretty-with-color pretty) diff --git a/lib/srfi/166/pretty.sld b/lib/srfi/166/pretty.sld index 23c8f53e..92f83bef 100644 --- a/lib/srfi/166/pretty.sld +++ b/lib/srfi/166/pretty.sld @@ -8,5 +8,5 @@ (srfi 69) (srfi 130) (srfi 166 base)) - (export pretty pretty-shared pretty-simply pretty-color) + (export pretty pretty-shared pretty-simply pretty-with-color) (include "pretty.scm")) diff --git a/lib/srfi/166/test.sld b/lib/srfi/166/test.sld index 98146e79..3f4352ff 100644 --- a/lib/srfi/166/test.sld +++ b/lib/srfi/166/test.sld @@ -495,6 +495,10 @@ "(#(0 1) #(2 3) #(4 5) #(6 7) #(8 9) #(10 11) #(12 13) #(14 15) #(16 17) #(18 19))\n") + (test-pretty + "#(#(0 1) #(2 3) #(4 5) #(6 7) #(8 9) #(10 11) #(12 13) #(14 15) + #(16 17) #(18 19))\n") + (test-pretty "(define (fold kons knil ls) (define (loop ls acc)