Fcalva/chibi-scheme
1
0
Fork 0
mirror of https://github.com/ashinn/chibi-scheme.git synced 2025-05-21 22:59:16 +02:00
Code Issues Projects Releases Packages Wiki Activity Actions

don't use nested show in pretty (issue #518); use string-width for computing width (issue #517)

Browse source
This commit is contained in:
Alex Shinn 2020-06-24 12:25:36 +09:00
parent cd7480ce45
commit 532fb83e0a
4 changed files with 70 additions and 50 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

2
lib/srfi/166.sld
View file

@ -21,7 +21,7 @@
radix precision decimal-sep decimal-align sign-rule radix precision decimal-sep decimal-align sign-rule
comma-sep comma-rule word-separator? ambiguous-is-wide? comma-sep comma-rule word-separator? ambiguous-is-wide?
;; pretty ;; pretty
pretty pretty-shared pretty-simply pretty-color pretty pretty-shared pretty-simply pretty-with-color
;; columnar ;; columnar
columnar tabular wrapped wrapped/list wrapped/char columnar tabular wrapped wrapped/list wrapped/char
justified from-file line-numbers show-columns justified from-file line-numbers show-columns

112
lib/srfi/166/pretty.scm
View file

@ -53,7 +53,7 @@
(call-with-output-string (lambda (out) (write x out)))) (call-with-output-string (lambda (out) (write x out))))
(define (try-fitted2 proc fail) (define (try-fitted2 proc fail)
(fn (width (orig-output output)) (fn (width string-width (orig-output output))
(let ((out (open-output-string))) (let ((out (open-output-string)))
(call-with-current-continuation (call-with-current-continuation
(lambda (abort) (lambda (abort)
@ -64,7 +64,7 @@
(fn (col) (fn (col)
(let lp ((i 0) (col col)) (let lp ((i 0) (col col))
(let ((nli (string-find/index str #\newline i)) (let ((nli (string-find/index str #\newline i))
(len (string-length str))) (len (string-width str)))
(if (< nli len) (if (< nli len)
(if (> (+ (- nli i) col) width) (if (> (+ (- nli i) col) width)
(abort fail) (abort fail)
@ -88,33 +88,40 @@
proc proc
(try-fitted2 proc (lp (car ls) (cdr ls)))))) (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 (call-with-current-continuation
(lambda (abort) (lambda (abort)
(show (fn ((orig-output output))
#f (define (output* str)
(fn ((orig-output output)) (each (orig-output str)
(define (output* str) (fn (col)
(each (orig-output str) (if (>= col width)
(fn (col) (begin (set-failed! #t) (abort #f))
(if (>= col width) nothing))))
(abort #f) (with ((output output*))
nothing)))) proc)))))
(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 ((max-w (quotient width 2)))
(let lp ((ls ls) (res '()) (widest 0)) (fn (string-width)
(cond (let lp ((ls ls) (res '()) (widest 0))
((pair? ls) (cond
(let ((str (fits-in-width max-w (writer (car ls))))) ((pair? ls)
(and str (let ((failed? #f))
(lp (cdr ls) (call-with-output
(cons str res) (fits-in-width max-w
(max (string-length str) widest))))) (writer (car ls))
((null? ls) (cons widest (reverse res))) (lambda (x) (set! failed? x)))
(else #f))))) (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 ;; style
@ -258,28 +265,36 @@
(fn (col width string-width) (fn (col width string-width)
(let ((avail (- width col))) (let ((avail (- width col)))
(cond (cond
((and (pair? (cdr ls)) (pair? (cddr ls)) (pair? (cdr (cddr ls))) ((and (pair? (cdr ls)) (pair? (cddr ls)) (pair? (cdr (cddr ls))))
(fits-in-columns width ls (lambda (x) (pp-flat x pp shares)))) (let ((out (open-output-string))
=> (lambda (ls) (result #f))
;; at least four elements which can be broken into columns (call-with-output
(let* ((prefix (make-nl-space col)) (fits-in-columns width ls (lambda (x) (pp-flat x pp shares))
(widest (+ 1 (car ls))) (lambda (res) (set! result res)))
(columns (quotient width widest))) ; always >= 2 (lambda (str)
(let lp ((ls (cdr ls)) (i 1)) (fn ()
(cond (if (not result)
((null? ls) ;; no room, print one per line
nothing) (joined/shares pp ls shares (make-nl-space col))
((null? (cdr ls)) ;; at least four elements which can be broken into columns
(displayed (car ls))) (let* ((prefix (make-nl-space col))
((>= i columns) (widest (+ 1 (car result)))
(each (car ls) (columns (quotient width widest))) ; always >= 2
prefix (let lp ((ls (cdr result)) (i 1))
(fn () (lp (cdr ls) 1)))) (cond
(else ((null? ls)
(let ((pad (- widest (string-width (car ls))))) nothing)
(each (car ls) ((null? (cdr ls))
(make-space pad) (displayed (car ls)))
(lp (cdr ls) (+ i 1)))))))))) ((>= 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 (else
;; no room, print one per line ;; no room, print one per line
(joined/shares pp ls shares (make-nl-space col)))))) (joined/shares pp ls shares (make-nl-space col))))))
@ -380,4 +395,5 @@
(each (pp obj (extract-shared-objects #f #f)) (each (pp obj (extract-shared-objects #f #f))
fl))) fl)))
(define pretty-color pretty) ;; TODO: add colors
(define pretty-with-color pretty)

2
lib/srfi/166/pretty.sld
View file

@ -8,5 +8,5 @@
(srfi 69) (srfi 69)
(srfi 130) (srfi 130)
(srfi 166 base)) (srfi 166 base))
(export pretty pretty-shared pretty-simply pretty-color) (export pretty pretty-shared pretty-simply pretty-with-color)
(include "pretty.scm")) (include "pretty.scm"))

4
lib/srfi/166/test.sld
View file

@ -495,6 +495,10 @@
"(#(0 1) #(2 3) #(4 5) #(6 7) #(8 9) #(10 11) #(12 13) #(14 15) "(#(0 1) #(2 3) #(4 5) #(6 7) #(8 9) #(10 11) #(12 13) #(14 15)
#(16 17) #(18 19))\n") #(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 (test-pretty
"(define (fold kons knil ls) "(define (fold kons knil ls)
(define (loop ls acc) (define (loop ls acc)