From 192f8b7bfaef46e1351bee0959d0c82cdf0398bd Mon Sep 17 00:00:00 2001 From: Chris Hanson Date: Wed, 1 Mar 2017 21:12:50 -0800 Subject: [PATCH] Change string-joiner and string-splitter to use keyword options. Also enhance keyword-option-parser. --- doc/ref-manual/strings.texi | 8 ++- src/edwin/edwin.pkg | 3 - src/edwin/string.scm | 96 ++++++++++---------------- src/etc/ucd-converter.scm | 4 +- src/runtime/list.scm | 35 ++++++++-- src/runtime/runtime.pkg | 34 +++++----- src/runtime/ustring.scm | 131 +++++++++++++++++++++--------------- 7 files changed, 164 insertions(+), 147 deletions(-) diff --git a/doc/ref-manual/strings.texi b/doc/ref-manual/strings.texi index d4b442d6a..9c25efa05 100644 --- a/doc/ref-manual/strings.texi +++ b/doc/ref-manual/strings.texi @@ -361,9 +361,11 @@ foo @result{} "abyde" @deffn string->vector string [start [end]] @deffn vector->string vector [start [end]] -@deffn string-joiner infix [prefix [suffix]] -@deffn string-joiner* infix [prefix [suffix]] -@deffn string-splitter delimiter [allow-runs?] +@deffn string-joiner [keyword object] @dots{} +@deffn string-joiner* [keyword object] @dots{} +@deffn string-splitter [keyword object] @dots{} +@deffn string-trimmer [keyword object] @dots{} +@deffn string-padder [keyword object] @dots{} @deffn string-any proc string1 string @dots{} @deffn string-count proc string1 string @dots{} diff --git a/src/edwin/edwin.pkg b/src/edwin/edwin.pkg index 92d17a05e..528cf2ed3 100644 --- a/src/edwin/edwin.pkg +++ b/src/edwin/edwin.pkg @@ -197,8 +197,6 @@ USA. string-hash string-head string-head! - string-joiner - string-joiner* string-length string-lower-case? string-map @@ -220,7 +218,6 @@ USA. string-search-backward string-search-forward string-set! - string-splitter string-suffix-ci? string-suffix? string-tail diff --git a/src/edwin/string.scm b/src/edwin/string.scm index 7b52e5fda..133a7dcc8 100644 --- a/src/edwin/string.scm +++ b/src/edwin/string.scm @@ -520,73 +520,49 @@ USA. (string-set! string i char))))) (define (decorated-string-append prefix infix suffix strings) - ((string-joiner* infix prefix suffix) strings)) - -(define (string-joiner infix #!optional prefix suffix) - (let ((joiner (string-joiner* prefix infix suffix))) - (lambda strings - (joiner strings)))) - -(define (string-joiner* infix #!optional prefix suffix) - (let ((prefix (if (default-object? prefix) "" prefix)) - (suffix (if (default-object? suffix) "" suffix))) - (let ((infix (string-append suffix infix prefix))) - - (lambda (strings) - (string-append* - (if (pair? strings) - (cons* prefix - (car strings) - (let loop ((strings (cdr strings))) - (if (pair? strings) - (cons* infix - (car strings) - (loop (cdr strings))) - (list suffix)))) - '())))))) + (let ((infix (string-append suffix infix prefix))) + (string-append* + (if (pair? strings) + (cons* prefix + (car strings) + (let loop ((strings (cdr strings))) + (if (pair? strings) + (cons* infix + (car strings) + (loop (cdr strings))) + (list suffix)))) + '())))) (define (burst-string string delimiter allow-runs?) - ((string-splitter delimiter allow-runs?) string)) - -(define (string-splitter delimiter #!optional allow-runs?) - (let ((predicate (splitter-delimiter->predicate delimiter)) - (allow-runs? (if (default-object? allow-runs?) #t allow-runs?))) - - (lambda (string #!optional start end) - (let* ((end (fix:end-index end (string-length string) 'string-splitter)) - (start (fix:start-index start end 'string-splitter))) - - (define (find-start start) - (if allow-runs? - (let loop ((index start)) - (if (fix:< index end) - (if (predicate (string-ref string index)) - (loop (fix:+ index 1)) - (find-end index (fix:+ index 1))) - '())) - (find-end start start))) - - (define (find-end start index) - (let loop ((index index)) + (let ((end (string-length string)) + (predicate (delimiter->predicate delimiter))) + + (define (find-start start) + (if allow-runs? + (let loop ((index start)) (if (fix:< index end) (if (predicate (string-ref string index)) - (cons (string-copy string start index) - (find-start (fix:+ index 1))) - (loop (fix:+ index 1))) - (list (string-copy string start end))))) - - (find-start start))))) - -(define (splitter-delimiter->predicate delimiter) + (loop (fix:+ index 1)) + (find-end index (fix:+ index 1))) + '())) + (find-end start start))) + + (define (find-end start index) + (let loop ((index index)) + (if (fix:< index end) + (if (predicate (string-ref string index)) + (cons (string-copy string start index) + (find-start (fix:+ index 1))) + (loop (fix:+ index 1))) + (list (string-copy string start end))))) + + (find-start 0))) + +(define (delimiter->predicate delimiter) (cond ((char? delimiter) (char=-predicate delimiter)) ((char-set? delimiter) (char-set-predicate delimiter)) ((unary-procedure? delimiter) delimiter) - (else (error:not-a splitter-delimiter? delimiter 'string-splitter)))) - -(define (splitter-delimiter? object) - (or (char? object) - (char-set? object) - (unary-procedure? object))) + (else (error:wrong-type-argument delimiter "delimiter" 'burst-string)))) (define (random-byte-vector n #!optional state) (let ((bv (random-bytevector n state)) diff --git a/src/etc/ucd-converter.scm b/src/etc/ucd-converter.scm index f7c6d6fa3..009bc7a79 100644 --- a/src/etc/ucd-converter.scm +++ b/src/etc/ucd-converter.scm @@ -570,7 +570,9 @@ USA. (define value-manager:code-points (value-manager "#" - (let ((splitter (string-splitter #\space #f))) + (let ((splitter + (string-splitter 'delimiter #\space + 'allow-runs? #f))) (lambda (value) (if (string=? "" value) '() diff --git a/src/runtime/list.scm b/src/runtime/list.scm index 8a8c75b71..5d35b4493 100644 --- a/src/runtime/list.scm +++ b/src/runtime/list.scm @@ -1428,7 +1428,7 @@ USA. (cons (cdr (car alist)) (loop (cdr alist)))) '()))) - + (define (keyword-option-parser keyword-option-specs) (guarantee-list-of keyword-option-spec? keyword-option-specs 'keyword-option-parser) @@ -1436,17 +1436,38 @@ USA. (guarantee keyword-list? options caller) (apply values (map (lambda (spec) - (let ((value (get-keyword-value options (car spec)))) - (if (default-object? value) - (caddr spec) - (guarantee (cadr spec) value caller)))) + (receive (name predicate default-value) + (keyword-option-spec-parts spec) + (let ((value (get-keyword-value options name))) + (if (default-object? value) + (begin + (if (default-object? default-value) + (error (string "Missing required option '" + name + "':") + options)) + default-value) + (guarantee predicate value caller))))) keyword-option-specs)))) (define (keyword-option-spec? object) (and (list? object) - (fix:= 3 (length object)) + (memv (length object) '(2 3)) (interned-symbol? (car object)) - (unary-procedure? (cadr object)))) + (or (unary-procedure? (cadr object)) + (and (pair? (cadr object)) + (list-of-type? (cadr object) interned-symbol?) + (or (null? (cddr object)) + (memq (caddr object) (cadr object))))))) + +(define (keyword-option-spec-parts spec) + (values (car spec) + (if (pair? (cadr spec)) + (lambda (object) (memq object (cadr spec))) + (cadr spec)) + (if (null? (cddr spec)) + (default-object) + (caddr spec)))) ;;;; Last pair diff --git a/src/runtime/runtime.pkg b/src/runtime/runtime.pkg index 1f49ebc59..043e464ba 100644 --- a/src/runtime/runtime.pkg +++ b/src/runtime/runtime.pkg @@ -971,27 +971,10 @@ USA. (parent (runtime)) (export () deprecated:ustring (string-hash-mod string-hash) - (string-search-all string-find-all-matches) - (string-search-forward string-find-first-match) (substring->list string->list) (substring-move-left! substring-move!) (substring-move-right! substring-move!) - burst-string - char->string - decorated-string-append - string-find-next-char - string-find-next-char-ci - string-find-next-char-in-set - string-find-previous-char - string-find-previous-char-ci - string-find-previous-char-in-set string-move! - string-pad-left - string-pad-right - string-search-backward - string-trim - string-trim-left - string-trim-right substring-cistring + decorated-string-append grapheme-cluster-length grapheme-cluster-slice list->string @@ -1047,6 +1035,12 @@ USA. string-find-first-match string-find-last-index string-find-last-match + string-find-next-char + string-find-next-char-ci + string-find-next-char-in-set + string-find-previous-char + string-find-previous-char-ci + string-find-previous-char-in-set string-foldcase string-for-each string-for-primitive ;export to (runtime) after 9.3 @@ -1062,11 +1056,14 @@ USA. string-match-forward string-match-forward-ci string-null? + string-pad-left + string-pad-right string-padder string-prefix-ci? string-prefix? string-ref string-replace + string-search-backward string-set! string-slice string-splitter @@ -1074,6 +1071,9 @@ USA. string-suffix? string-tail string-titlecase + string-trim + string-trim-left + string-trim-right string-trimmer string-upcase string-upper-case? diff --git a/src/runtime/ustring.scm b/src/runtime/ustring.scm index 1c2cfbae9..978656060 100644 --- a/src/runtime/ustring.scm +++ b/src/runtime/ustring.scm @@ -1183,18 +1183,19 @@ USA. i (loop (fix:- i 1))))))) -;;;; Joiner/splitter +;;;; Joiner -(define (string-joiner infix #!optional prefix suffix) - (let ((joiner (string-joiner* prefix infix suffix))) +(define (string-joiner . options) + (let ((joiner (%string-joiner options 'string-joiner))) (lambda strings (joiner strings)))) -(define (string-joiner* infix #!optional prefix suffix) - (let ((prefix (if (default-object? prefix) "" prefix)) - (suffix (if (default-object? suffix) "" suffix))) - (let ((infix (string-append suffix infix prefix))) +(define (string-joiner* . options) + (%string-joiner options 'string-joiner*)) +(define (%string-joiner options caller) + (receive (infix prefix suffix) (string-joiner-options options caller) + (let ((infix (string-append suffix infix prefix))) (lambda (strings) (string-append* (if (pair? strings) @@ -1208,34 +1209,50 @@ USA. (list suffix)))) '())))))) -(define (string-splitter delimiter #!optional allow-runs?) - (let ((predicate (splitter-delimiter->predicate delimiter)) - (allow-runs? (if (default-object? allow-runs?) #t allow-runs?))) - - (lambda (string #!optional start end) - (let* ((end (fix:end-index end (string-length string) 'string-splitter)) - (start (fix:start-index start end 'string-splitter))) - - (define (find-start start) - (if allow-runs? - (let loop ((index start)) - (if (fix:< index end) - (if (predicate (string-ref string index)) - (loop (fix:+ index 1)) - (find-end index (fix:+ index 1))) - '())) - (find-end start start))) - - (define (find-end start index) - (let loop ((index index)) - (if (fix:< index end) - (if (predicate (string-ref string index)) - (cons (string-copy string start index) - (find-start (fix:+ index 1))) - (loop (fix:+ index 1))) - (list (string-copy string start end))))) - - (find-start start))))) +(define-deferred string-joiner-options + (keyword-option-parser + (list (list 'infix string? "") + (list 'prefix string? "") + (list 'suffix string? "")))) + +;;;; Splitter + +(define (string-splitter . options) + (receive (delimiter allow-runs? copy?) + (string-splitter-options options 'string-splitter) + (let ((predicate (splitter-delimiter->predicate delimiter)) + (get-part (if copy? string-copy string-slice))) + + (lambda (string #!optional start end) + (let* ((end (fix:end-index end (string-length string) 'string-splitter)) + (start (fix:start-index start end 'string-splitter))) + + (define (find-start start) + (if allow-runs? + (let loop ((index start)) + (if (fix:< index end) + (if (predicate (string-ref string index)) + (loop (fix:+ index 1)) + (find-end index (fix:+ index 1))) + '())) + (find-end start start))) + + (define (find-end start index) + (let loop ((index index)) + (if (fix:< index end) + (if (predicate (string-ref string index)) + (cons (get-part string start index) + (find-start (fix:+ index 1))) + (loop (fix:+ index 1))) + (list (get-part string start end))))) + + (find-start start)))))) + +(define-deferred string-splitter-options + (keyword-option-parser + (list (list 'delimiter splitter-delimiter? char-whitespace?) + (list 'allow-runs? boolean? #t) + (list 'copy? boolean? #f)))) (define (splitter-delimiter->predicate delimiter) (cond ((char? delimiter) (char=-predicate delimiter)) @@ -1247,21 +1264,8 @@ USA. (or (char? object) (char-set? object) (unary-procedure? object))) - -(define (decorated-string-append prefix infix suffix strings) - ((string-joiner* infix prefix suffix) strings)) - -(define (burst-string string delimiter allow-runs?) - ((string-splitter delimiter allow-runs?) string)) - -(define (string-replace string char1 char2) - (guarantee bitless-char? char1 'string-replace) - (guarantee bitless-char? char2 'string-replace) - (string-map (lambda (char) - (if (char=? char char1) char2 char)) - string)) -;;;; Trimmer/padder +;;;; Trimmer/Padder (define (string-trimmer . options) (receive (where copy? trim-char?) @@ -1286,13 +1290,9 @@ 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 (one-of '(leading trailing both)) 'both) + (list (list 'where '(leading trailing both) 'both) (list 'copy? boolean? #t) (list 'trim-char? unary-procedure? char-whitespace?)))) @@ -1329,7 +1329,7 @@ USA. (define-deferred string-padder-options (keyword-option-parser - (list (list 'where (one-of '(leading trailing)) 'leading) + (list (list 'where '(leading trailing) 'leading) (list 'fill-with grapheme-cluster-string? " ") (list 'clip? boolean? #t)))) @@ -1350,6 +1350,13 @@ USA. ((not (fix:< i end))) (cp-vector-set! bytes i cp))))))) +(define (string-replace string char1 char2) + (guarantee bitless-char? char1 'string-replace) + (guarantee bitless-char? char2 'string-replace) + (string-map (lambda (char) + (if (char=? char char1) char2 char)) + string)) + (define (string-hash string #!optional modulus) (let ((string* (string-for-primitive string))) (if (default-object? modulus) @@ -1558,4 +1565,16 @@ USA. string n))) (define string-pad-left (legacy-string-padder 'leading)) -(define string-pad-right (legacy-string-padder 'trailing)) \ No newline at end of file +(define string-pad-right (legacy-string-padder 'trailing)) + +(define (decorated-string-append prefix infix suffix strings) + ((string-joiner* 'prefix prefix + 'infix infix + 'suffix suffix) + strings)) + +(define (burst-string string delimiter allow-runs?) + ((string-splitter 'delimiter delimiter + 'allow-runs? allow-runs? + 'copy? #t) + string)) \ No newline at end of file -- 2.25.1