Also enhance keyword-option-parser.
@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{}
string-hash
string-head
string-head!
- string-joiner
- string-joiner*
string-length
string-lower-case?
string-map
string-search-backward
string-search-forward
string-set!
- string-splitter
string-suffix-ci?
string-suffix?
string-tail
(string-set! string i char)))))
\f
(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))
(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)
'()
(cons (cdr (car alist))
(loop (cdr alist))))
'())))
-
+\f
(define (keyword-option-parser keyword-option-specs)
(guarantee-list-of keyword-option-spec? keyword-option-specs
'keyword-option-parser)
(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))))
\f
;;;; Last pair
(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-ci<?
substring-ci=?
substring-fill!
substring<?
substring=?)
(export ()
+ (string-search-all string-find-all-matches)
+ (string-search-forward string-find-first-match)
(substring string-copy)
8-bit-string?
+ burst-string
+ char->string
+ decorated-string-append
grapheme-cluster-length
grapheme-cluster-slice
list->string
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
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
string-suffix?
string-tail
string-titlecase
+ string-trim
+ string-trim-left
+ string-trim-right
string-trimmer
string-upcase
string-upper-case?
i
(loop (fix:- i 1)))))))
\f
-;;;; 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)
(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? ""))))
+\f
+;;;; 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))
(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))
\f
-;;;; Trimmer/padder
+;;;; Trimmer/Padder
(define (string-trimmer . options)
(receive (where copy? trim-char?)
(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?))))
(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))))
\f
((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)
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
projects / mit-scheme.git / commitdiff