Fcalva/chibi-scheme
1
0
Fork 0
mirror of https://github.com/ashinn/chibi-scheme.git synced 2025-07-03 11:16:36 +02:00
Code Issues Projects Releases Packages Wiki Activity Actions 1

implementing substring/preserve

Browse source
This commit is contained in:
Alex Shinn 2020-07-21 14:05:30 +09:00
parent bde8a618ec
commit 97ea47686e
7 changed files with 105 additions and 63 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

4
lib/srfi/166.sld
View file

@ -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

3
lib/srfi/166/base.scm
View file

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

6
lib/srfi/166/base.sld
View file

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

39
lib/srfi/166/show.scm
View file

@ -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

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

@ -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 "ｆｏｏ" 2 5))
(test "ａｂｃ" (substring-terminal-width "ａｂｃ" 0 6))
(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

94
lib/srfi/166/unicode.scm
View file

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

1
lib/srfi/166/unicode.sld
View file

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