diff --git a/lib/srfi/166.sld b/lib/srfi/166.sld index 43930621..7a1e8e3b 100644 --- a/lib/srfi/166.sld +++ b/lib/srfi/166.sld @@ -18,9 +18,10 @@ fn with with! forked call-with-output ;; state variables port row col width output writer pad-char ellipsis - string-width substring/width + string-width substring/width substring/preserve radix precision decimal-sep decimal-align sign-rule comma-sep comma-rule word-separator? ambiguous-is-wide? + pretty-environment ;; pretty pretty pretty-shared pretty-simply pretty-with-color ;; columnar @@ -31,6 +32,7 @@ string-terminal-width string-terminal-width/wide substring-terminal-width substring-terminal-width/wide substring-terminal-width substring-terminal-width/wide + substring-terminal-preserve upcased downcased ;; color as-red as-blue as-green as-cyan as-yellow diff --git a/lib/srfi/166/base.scm b/lib/srfi/166/base.scm index 3db2307a..eb341635 100644 --- a/lib/srfi/166/base.scm +++ b/lib/srfi/166/base.scm @@ -44,8 +44,8 @@ (pad-char #\space) (output output-default) (string-width substring-length) - (string-take-width string-take) (substring/width substring) + (substring/preserve #f) (word-separator? char-whitespace?) (ambiguous-is-wide? #f) (ellipsis "") @@ -56,6 +56,7 @@ (sign-rule #f) (precision #f) (writer #f) + (pretty-environment (interaction-environment)) ) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; diff --git a/lib/srfi/166/base.sld b/lib/srfi/166/base.sld index b3293e8b..c27fa593 100644 --- a/lib/srfi/166/base.sld +++ b/lib/srfi/166/base.sld @@ -2,9 +2,10 @@ (define-library (srfi 166 base) (import (scheme base) (scheme char) - (scheme write) (scheme complex) (scheme inexact) + (scheme repl) + (scheme write) (srfi 1) (srfi 69) (srfi 130) @@ -45,9 +46,10 @@ fn with with! forked call-with-output ;; state variables port row col width output writer pad-char ellipsis - string-width substring/width + string-width substring/width substring/preserve radix precision decimal-sep decimal-align sign-rule comma-sep comma-rule word-separator? ambiguous-is-wide? + pretty-environment ) (include "base.scm") (include "write.scm") diff --git a/lib/srfi/166/show.scm b/lib/srfi/166/show.scm index 479ad35b..f06c2e68 100644 --- a/lib/srfi/166/show.scm +++ b/lib/srfi/166/show.scm @@ -146,14 +146,21 @@ width (each-in-list ls) (lambda (str str-width diff) - (fn (ellipsis string-width substring/width) + (fn (ellipsis string-width substring/width substring/preserve) (let* ((ell (if (char? ellipsis) (string ellipsis) (or ellipsis ""))) (ell-len (string-width ell)) - (diff (- (+ str-width ell-len) width))) - (each (if (negative? diff) + (diff (- (+ str-width ell-len) width)) + (end (- width ell-len))) + (each (if substring/preserve + (substring/preserve (substring/width str -1 0)) + nothing) + (if (negative? diff) nothing - (substring/width str 0 (- width ell-len))) - ell)))))) + (substring/width str 0 end)) + ell + (if (and substring/preserve (< end str-width)) + (substring/preserve (substring/width str end str-width)) + nothing))))))) ;;> As \scheme{trimmed/right} but removes from the left. (define (trimmed/left width . ls) @@ -161,11 +168,14 @@ width (each-in-list ls) (lambda (str str-width diff) - (fn (ellipsis string-width substring/width) + (fn (ellipsis string-width substring/width substring/preserve) (let* ((ell (if (char? ellipsis) (string ellipsis) (or ellipsis ""))) (ell-len (string-width ell)) (diff (- (+ str-width ell-len) width))) - (each ell + (each (if (and substring/preserve (positive? diff)) + (substring/preserve (substring/width str 0 diff)) + nothing) + ell (if (negative? diff) nothing (substring/width str diff str-width)))))))) @@ -181,15 +191,22 @@ width (each-in-list ls) (lambda (str str-width diff) - (fn (ellipsis string-width) + (fn (ellipsis string-width substring/width substring/preserve) (let* ((ell (if (char? ellipsis) (string ellipsis) (or ellipsis ""))) (ell-len (string-width ell)) (diff (- (+ str-width ell-len ell-len) width)) (left (quotient diff 2)) (right (- str-width (quotient (+ diff 1) 2)))) - (if (negative? diff) - ell - (each ell (substring str left right) ell))))))) + (each + (if substring/preserve + (substring/preserve (substring/width str 0 left)) + nothing) + (if (negative? diff) + ell + (each ell (substring/width str left right) ell)) + (if substring/preserve + (substring/preserve (substring/width str right str-width)) + nothing))))))) ;;> A \scheme{trimmed}, but truncates and terminates immediately if ;;> more than \var{width} characters are generated by \var{ls}. Thus diff --git a/lib/srfi/166/test.sld b/lib/srfi/166/test.sld index d1719edf..c76b6739 100644 --- a/lib/srfi/166/test.sld +++ b/lib/srfi/166/test.sld @@ -304,8 +304,14 @@ (test "abc" (show #f (trimmed/right 3 "abc"))) (test "ab" (show #f (trimmed/right 3 "ab"))) (test "a" (show #f (trimmed/right 3 "a"))) + (test "abcde" (show #f (trimmed/right 5 "abcdef"))) + (test "abcde" (show #f (trimmed 5 "abcde"))) (test "cde" (show #f (trimmed 3 "abcde"))) + (test "bcdef" (show #f (trimmed 5 "abcdef"))) (test "bcd" (show #f (trimmed/both 3 "abcde"))) + (test "abcd" (show #f (trimmed/both 4 "abcde"))) + (test "abcde" (show #f (trimmed/both 5 "abcdef"))) + (test "bcde" (show #f (trimmed/both 4 "abcdef"))) (test "bcdef" (show #f (trimmed/both 5 "abcdefgh"))) (test "abc" (show #f (trimmed/lazy 3 "abcde"))) (test "abc" (show #f (trimmed/lazy 3 "abc\nde"))) @@ -608,9 +614,12 @@ "abc\ndef\n") (list displayed "123\n456\n")))) + (test "" (show #f (wrapped " "))) (test "hello\nworld" (show #f (with ((width 8)) (wrapped "hello world")))) - (test "" (show #f (wrapped " "))) + (test "hello\nworld" + (show #f (with ((width 16)) + (terminal-aware (wrapped "hello world"))))) (test "The quick @@ -774,8 +783,14 @@ def | 6 (show #f (with ((ambiguous-is-wide? #t)) (terminal-aware "日本語ΠΜΕ" (fn (col) (each " col: " col)))))) - (test "fo" (substring-terminal-width "foo" 1 4)) - (test "o" (substring-terminal-width "foo" 2 5)) + (test "abc" (substring-terminal-width "abc" 0 6)) + (test "ab" (substring-terminal-width "abc" 0 4)) + (test "bc" (substring-terminal-width "abc" 2 6)) + (test "ab" (substring-terminal-width "abc" 1 4)) + (test "ab" (substring-terminal-width "abc" 1 5)) + (test "b" (substring-terminal-width "abc" 2 4)) + (test "" (substring-terminal-width "abc" 2 3)) + (test "a" (substring-terminal-width "abc" -1 2)) ;; from-file ;; for reference, filesystem-test relies on creating files under /tmp diff --git a/lib/srfi/166/unicode.scm b/lib/srfi/166/unicode.scm index 43db2335..dcdc43ba 100644 --- a/lib/srfi/166/unicode.scm +++ b/lib/srfi/166/unicode.scm @@ -68,39 +68,8 @@ (let ((start (string-cursor-start str)) (end (string-cursor-end str))) (let lp1 ((sc start) - (from #f) - (width 0) - (escapes '())) - ;; need to pick up trailing ansi escapes - (define (finish res sc) - (let ((res (if (pair? escapes) - (string-concatenate-reverse (cons res escapes)) - res)) - (end-1 (string-cursor-prev str end))) - (let lp ((sc sc) (right-escapes '())) - (define (finish2 right-escapes) - (if (pair? right-escapes) - (string-append res - (string-concatenate-reverse - right-escapes)) - res)) - (if (string-cursor>=? sc end-1) - (finish2 right-escapes) - (let ((c (string-ref/cursor str sc)) - (sc2 (string-cursor-next str sc))) - (if (and (= 27 (char->integer c)) - (eqv? #\[ (string-ref/cursor str sc2))) - (let lp2 ((sc2 (string-cursor-next str sc2))) - (if (string-cursor>=? sc2 end) - (finish2 right-escapes) - (let ((c2 (string-ref/cursor str sc2)) - (sc3 (string-cursor-next str sc2))) - (if (eqv? #\m c2) - (lp sc3 - (cons (substring/cursors str sc sc3) - right-escapes)) - (lp2 sc3))))) - (lp sc2 right-escapes))))))) + (from (and (negative? lo) start)) + (width 0)) (if (string-cursor>=? sc end) (if from (substring/cursors str from end) str) (let ((c (string-ref/cursor str sc))) @@ -112,26 +81,22 @@ (string-cursor-next str sc)))) (let lp2 ((sc2 (string-cursor-forward str sc 2))) (cond ((string-cursor>=? sc2 end) - (lp1 sc2 from width escapes)) + (lp1 sc2 from width)) ((memv (string-ref/cursor str sc2) '(#\m #\newline)) - (let* ((sc3 (string-cursor-next str sc2)) - (escapes - (if (not from) - (cons (substring/cursors str sc sc3) - escapes) - escapes))) - (lp1 sc3 from width escapes))) + (lp1 (string-cursor-next str sc2) from width)) (else (lp2 (string-cursor-next str sc2)))))) (else (let ((width2 (+ width (unicode-char-width c ambiguous-is-wide?)))) (cond ((> width2 hi) - (finish (substring/cursors str (or from start) sc) sc)) + (if from + (substring/cursors str from sc) + "")) ((and (not from) (> width2 lo)) - (lp1 (string-cursor-next str sc) sc width2 escapes)) + (lp1 (string-cursor-next str sc) sc width2)) (else - (lp1 (string-cursor-next str sc) from width2 escapes) + (lp1 (string-cursor-next str sc) from width2) )))))))))) (define (substring-terminal-width str lo hi) @@ -140,6 +105,44 @@ (define (substring-terminal-width/wide str lo hi) (substring-terminal-width/aux str lo hi #t)) +;; The BiDi control characters - trimming these would result in the +;; remaining text rendered in the wrong direction. +;; Other characters for consideration would be language tags or +;; interlinear annotation, but use of these is discouraged. +;; Similarly, we might want to preserve the BOM only at the start of +;; text, but this is a file-level encoding mechanism and not likely +;; appropriate to formatting in-memory strings. +(define non-local-controls + '(#\x061C #\x200E #\x200F #\x202A #\x202B #\x202C + #\x202D #\x202E #\x2066 #\x2067 #\x2068 #\x2069)) + +(define (substring-terminal-preserve str) + (let ((start (string-cursor-start str)) + (end (string-cursor-end str))) + (let lp1 ((sc start) (escapes '())) + (if (string-cursor>=? sc end) + (string-concatenate-reverse escapes) + (let ((c (string-ref/cursor str sc)) + (sc2 (string-cursor-next str sc))) + (cond + ((and (= 27 (char->integer c)) + (string-cursor=? sc2 end) + (string-concatenate-reverse escapes) + (let ((c2 (string-ref/cursor str sc2)) + (sc3 (string-cursor-next str sc2))) + (if (eqv? #\m c2) + (lp1 sc3 + (cons (substring/cursors str sc sc3) + escapes)) + (lp2 sc3)))))) + ((and (memv c non-local-controls)) + (lp1 sc2 (cons (string c) escapes))) + (else + (lp1 sc2 escapes)))))))) + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (define (terminal-aware . args) @@ -149,7 +152,8 @@ string-terminal-width)) (substring/width (if ambiguous-is-wide? substring-terminal-width/wide - substring-terminal-width))) + substring-terminal-width)) + (substring/preserve substring-terminal-preserve)) (each-in-list args)))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; diff --git a/lib/srfi/166/unicode.sld b/lib/srfi/166/unicode.sld index f1506a11..8c88906c 100644 --- a/lib/srfi/166/unicode.sld +++ b/lib/srfi/166/unicode.sld @@ -8,6 +8,7 @@ (export terminal-aware string-terminal-width string-terminal-width/wide substring-terminal-width substring-terminal-width/wide + substring-terminal-preserve upcased downcased) (include "width.scm" "unicode.scm"))