implementing substring/preserve

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

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))
   )
 
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

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")

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)))
+              (diff (- (+ str-width ell-len) width))
-         (each (if (negative? diff)
+              (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)))
+                   (substring/width str 0 end))
-               ell))))))
+               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))))
+         (each
+          (if substring/preserve
+              (substring/preserve (substring/width str 0 left))
+              nothing)
           (if (negative? diff)
               ell
-             (each ell (substring str left right) 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

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 "ｈｅｌｌｏ\nｗｏｒｌｄ"
+          (show #f (with ((width 16))
+                     (terminal-aware (wrapped "ｈｅｌｌｏ　ｗｏｒｌｄ")))))
 
       (test
           "The  quick
@@ -774,8 +783,14 @@ def | 6
           (show #f (with ((ambiguous-is-wide? #t))
                      (terminal-aware "日本語ΠΜΕ"
                                      (fn (col) (each " col: " col))))))
-      (test "ｆｏ" (substring-terminal-width "ｆｏｏ" 1 4))
+      (test "ａｂｃ" (substring-terminal-width "ａｂｃ" 0 6))
-      (test "ｏ" (substring-terminal-width "ｆｏｏ" 2 5))
+      (test "ａｂ" (substring-terminal-width "ａｂｃ" 0 4))
+      (test "ｂｃ" (substring-terminal-width "ａｂｃ" 2 6))
+      (test "ａｂ" (substring-terminal-width "ａｂｃ" 1 4))
+      (test "ａｂ" (substring-terminal-width "ａｂｃ" 1 5))
+      (test "ｂ" (substring-terminal-width "ａｂｃ" 2 4))
+      (test "" (substring-terminal-width "ａｂｃ" 2 3))
+      (test "ａ" (substring-terminal-width "ａｂｃ" -1 2))
 
       ;; from-file
       ;; for reference, filesystem-test relies on creating files under /tmp

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)
+              (from (and (negative? lo) start))
-              (width 0)
+              (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)))))))
       (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))
+                       (lp1 (string-cursor-next str sc2) from width))
-                              (escapes
-                               (if (not from)
-                                   (cons (substring/cursors str sc sc3)
-                                         escapes)
-                                  escapes)))
-                         (lp1 sc3 from width escapes)))
                       (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)
+                   (eqv? #\[ (string-ref/cursor str sc2)))
+              (let lp2 ((sc2 (string-cursor-next str sc2)))
+                (if (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))))
 
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

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"))