From c7ac770fc8b782ae1f4a2ef5be306fcdb5224aad Mon Sep 17 00:00:00 2001 From: Chris Hanson Date: Mon, 27 Feb 2017 23:14:32 -0800 Subject: [PATCH] Implement string-padder; promote grapheme clusters. * Rename count-grapheme-clusters to grapheme-cluster-length. * Implement grapheme-cluster-slice. * Update string-pad-X to use string-padder. --- src/runtime/runtime.pkg | 8 ++-- src/runtime/string.scm | 45 ---------------------- src/runtime/ustring.scm | 84 ++++++++++++++++++++++++++++++++++++++--- 3 files changed, 83 insertions(+), 54 deletions(-) diff --git a/src/runtime/runtime.pkg b/src/runtime/runtime.pkg index b4c23e955..83cceb90a 100644 --- a/src/runtime/runtime.pkg +++ b/src/runtime/runtime.pkg @@ -977,8 +977,6 @@ USA. guarantee-substring guarantee-substring-end-index guarantee-substring-start-index - string-pad-left - string-pad-right string-search-all string-search-backward string-search-forward @@ -1006,6 +1004,8 @@ USA. string-find-previous-char-ci string-find-previous-char-in-set string-move! + string-pad-left + string-pad-right string-trim string-trim-left string-trim-right @@ -1029,7 +1029,8 @@ USA. substring=?) (export () (substring string-copy) - count-grapheme-clusters + grapheme-cluster-length + grapheme-cluster-slice list->string make-string string @@ -1071,6 +1072,7 @@ USA. string-match-forward string-match-forward-ci string-null? + string-padder string-prefix-ci? string-prefix? string-ref diff --git a/src/runtime/string.scm b/src/runtime/string.scm index e732548c4..3b89c7b88 100644 --- a/src/runtime/string.scm +++ b/src/runtime/string.scm @@ -72,51 +72,6 @@ USA. ascii (integer->char ascii)))) -;;;; Pad - -(define (string-pad-right string n #!optional char) - (guarantee-string string 'STRING-PAD-RIGHT) - (guarantee-string-index n 'STRING-PAD-RIGHT) - (let ((length (string-length string))) - (if (fix:= length n) - string - (let ((result (string-allocate n))) - (if (fix:> length n) - (string-copy! result 0 string 0 n) - (begin - (string-copy! result 0 string 0 length) - (string-fill! result - (if (default-object? char) - #\space - (begin - (guarantee-char char 'STRING-PAD-RIGHT) - char)) - length - n))) - result)))) - -(define (string-pad-left string n #!optional char) - (guarantee-string string 'STRING-PAD-LEFT) - (guarantee-string-index n 'STRING-PAD-LEFT) - (let ((length (string-length string))) - (if (fix:= length n) - string - (let ((result (string-allocate n)) - (i (fix:- n length))) - (if (fix:< i 0) - (string-copy! result 0 string (fix:- 0 i) length) - (begin - (string-fill! result - (if (default-object? char) - #\space - (begin - (guarantee-char char 'STRING-PAD-RIGHT) - char)) - 0 - i) - (string-copy! result i string 0 length))) - result)))) - ;;;; String search (define (substring? pattern text) diff --git a/src/runtime/ustring.scm b/src/runtime/ustring.scm index fc4198a5d..f066bad34 100644 --- a/src/runtime/ustring.scm +++ b/src/runtime/ustring.scm @@ -566,7 +566,7 @@ USA. result)))) |# -(define (count-grapheme-clusters string) +(define (grapheme-cluster-length string) (let ((breaks (find-grapheme-cluster-breaks string 0 @@ -576,6 +576,29 @@ USA. (if (fix:> breaks 0) (fix:- breaks 1) breaks))) + +(define (grapheme-cluster-slice string start end) + ;; START and END refer to the cluster breaks, they must be <= the number of + ;; clusters in STRING. + (guarantee index-fixnum? start 'grapheme-cluster-slice) + (guarantee index-fixnum? end 'grapheme-cluster-slice) + (if (not (fix:<= start end)) + (error:bad-range-argument start 'grapheme-cluster-slice)) + (let ((start-index #f) + (end-index #f)) + (find-grapheme-cluster-breaks string + 0 + (lambda (index count) + (if (fix:= count start) + (set! start-index index)) + (if (fix:= count end) + (set! end-index index)) + (fix:+ count 1))) + (if (not start-index) + (error:bad-range-argument start 'grapheme-cluster-slice)) + (if (not end-index) + (error:bad-range-argument end 'grapheme-cluster-slice)) + (string-slice string start-index end-index))) ;;;; Grapheme-cluster breaks @@ -1210,14 +1233,52 @@ USA. (loop (fix:- index 1)) index))))))))) +(define (one-of values) + (lambda (object) + (memq object values))) + (define-deferred string-trimmer-options (keyword-option-parser - (list (list 'where where-value? 'both) + (list (list 'where (one-of '(leading trailing both)) 'both) (list 'copy? boolean? #t) (list 'trim-char? unary-procedure? char-whitespace?)))) -(define (where-value? object) - (memq object '(leading trailing both))) +(define (string-padder . options) + (receive (where fill-with clip?) + (string-padder-options options 'string-padder) + (lambda (string n) + (guarantee index-fixnum? n 'string-padder) + (let ((cluster-length (grapheme-cluster-length string))) + (cond ((fix:= n cluster-length) + string) + ((fix:< n cluster-length) + (if clip? + (if (eq? where 'leading) + (grapheme-cluster-slice string + (fix:- cluster-length n) + cluster-length) + (grapheme-cluster-slice string 0 n)) + string)) + (else + (let ((builder (string-builder))) + (if (eq? where 'trailing) + (builder string)) + (do ((i 0 (fix:+ i 1))) + ((not (fix:< i n))) + (builder fill-with)) + (if (eq? where 'leading) + (builder string)) + (builder)))))))) + +(define (grapheme-cluster-string? object) + (and (string? object) + (fix:= 1 (grapheme-cluster-length object)))) + +(define-deferred string-padder-options + (keyword-option-parser + (list (list 'where (one-of '(leading trailing)) 'leading) + (list 'fill-with grapheme-cluster-string? " ") + (list 'clip? boolean? #t)))) (define (string-8-bit? string) (receive (string start end) (translate-slice string 0 (string-length string)) @@ -1359,7 +1420,7 @@ USA. (full-string-allocate 1)))) (string-set! s 0 char) s)) - + (define (legacy-string-trimmer where) (lambda (string #!optional char-set) ((string-trimmer 'where where @@ -1372,4 +1433,15 @@ USA. (define string-trim-left (legacy-string-trimmer 'leading)) (define string-trim-right (legacy-string-trimmer 'trailing)) -(define string-trim (legacy-string-trimmer 'both)) \ No newline at end of file +(define string-trim (legacy-string-trimmer 'both)) + +(define (legacy-string-padder where) + (lambda (string n #!optional char) + ((string-padder 'where where + 'fill-with (if (default-object? char) + char + (char->string char))) + string n))) + +(define string-pad-left (legacy-string-padder 'leading)) +(define string-pad-right (legacy-string-padder 'trailing)) \ No newline at end of file -- 2.25.1