;;;; utf8-srfi-13.scm -- Unicode-aware SRFI-13 ;; ;; Copyright (c) 2004-2009 Alex Shinn. All rights reserved. ;; BSD-style license: http://synthcode.com/license.txt (declare (no-procedure-checks) (bound-to-procedure ##sys#substring ##sys#become!)) (require-library utf8-lolevel utf8-srfi-14 iset utf8-case-map) (module utf8-srfi-13 ( ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; srfi-13 ;; predicates string-null? string-every string-any ;; constructors string-tabulate ;; selection string-copy string-copy! substring/shared string-take string-take-right string-drop string-drop-right string-pad string-pad-right string-trim string-trim-right string-trim-both ;; comparison string-compare string-compare-ci string-hash string-ci-hash string= string<> string< string> string<= string>= string-ci= string-ci<> string-ci< string-ci> string-ci<= string-ci>= ;; prefixes & suffixes string-prefix? string-prefix-ci? string-prefix-length string-prefix-length-ci string-suffix? string-suffix-ci? string-suffix-length string-suffix-length-ci ;; searching string-index string-index-right string-skip string-skip-right string-count string-contains string-contains-ci ;; alphabetic case maping string-titlecase string-titlecase! string-upcase string-upcase! string-downcase string-downcase! ;; reverse & append string-join string-reverse string-reverse! string-concatenate string-concatenate/shared string-append/shared string-concatenate-reverse string-concatenate-reverse/shared ;; iteration string-map string-map! string-fold string-fold-right string-unfold string-unfold-right string-for-each string-for-each-index ;; replicate & rotate xsubstring string-xcopy! string-replace string-tokenize ;; filtering & deleting string-filter string-delete ) (import (except scheme string-copy) chicken data-structures ports (except srfi-69 string-hash string-ci-hash) utf8-lolevel utf8-srfi-14 iset utf8-case-map) (define (string-null? s) (equal? s "")) (define (string-fold kons knil s . opt) (let-optionals* opt ((start 0) (end (utf8-string-length s))) (let lp ((i start) (b (utf8-index->offset s start)) (acc knil)) (if (>= i end) acc (lp (+ i 1) (+ b (utf8-start-byte->length (string-int-ref s b))) (kons (sp-ref s b) acc)))))) (define (string-fold-right kons knil s . opt) (let-optionals* opt ((start 0) (end (utf8-string-length s))) (let lp ((i (- end 1)) (b (utf8-prev-char s (utf8-index->offset s end))) (acc knil)) (if (< i start) acc (lp (- i 1) (utf8-prev-char s b) (kons (sp-ref s b) acc)))))) (define (string-unfold p f g seed . opt) (let-optionals* opt ((base "") (make-final (lambda (x) ""))) (let ((out (open-output-string))) (display base out) ; base must be a string, so normal display is fine (let lp ((seed seed)) (if (p seed) (display (make-final seed) out) (begin (write-utf8-char (f seed) out) (lp (g seed))))) (get-output-string out)))) (define (string-unfold-right p f g seed . opt) (let-optionals* opt ((base "") (make-final (lambda (x) ""))) (let lp ((seed seed) (ans (list base))) (if (p seed) (string-intersperse (cons (make-final seed) ans) "") (lp (g seed) (cons (char->utf8-string (f seed)) ans)))))) (define (string-map proc s . opt) (string-intersperse (reverse (map char->utf8-string (apply string-fold (lambda (c acc) (cons (proc c) acc)) '() s opt))) "")) (define string-map! string-map) (define (string-for-each proc s . opt) (apply string-fold (lambda (c acc) (proc c)) #f s opt) (if #f #f)) (define (string-for-each-index proc s . opt) (let ((start (if (pair? opt) (car opt) 0)) (end (if (and (pair? opt) (pair? (cdr opt))) (cadr opt) (utf8-string-length s)))) (do ((i start (+ i 1))) ((= i end)) (proc i)))) (define (char-predicate x) (cond ((procedure? x) x) ((char? x) (lambda (c) (eqv? c x))) ((char-set? x) (lambda (c) (char-set-contains? x c))) (else (error "unknown predicate" x)))) (define (string-any x str . opt) (let ((pred (char-predicate x))) (call-with-current-continuation (lambda (return) (apply string-fold (lambda (c acc) (cond ((pred c) => return) (else #f))) #f str opt))))) (define (string-every x str . opt) (let ((pred (char-predicate x))) (call-with-current-continuation (lambda (return) (apply string-fold (lambda (c acc) (cond ((pred c) => identity) (else (return #f)))) #f str opt))))) (define (string-tabulate proc len) (let ((out (open-output-string))) (let lp ((i 0)) (cond ((< i len) (write-utf8-char (proc i) out) (lp (+ i 1))))) (get-output-string out))) (define (string-copy s . opt) (with-substring-offsets (lambda (s start end) (##sys#substring s start end)) s opt)) (define (substring/shared s . opt) (with-substring-offsets (lambda (s start end) (##sys#substring s start end)) s opt)) (define (byte-string-copy! target t-off str start end) (if (> start t-off) (do ((i start (+ i 1)) (j t-off (+ j 1))) ((>= i end)) (string-set! target j (string-ref str i))) (do ((i (- end 1) (- i 1)) (j (+ -1 t-off (- end start)) (- j 1))) ((< i start)) (string-set! target j (string-ref str i))))) (define (string-copy! target tstart str . opt) (let-optionals* opt ((start 0) (end (utf8-string-length str))) (let* ((str (utf8-substring str start end)) (len (- end start)) (s-size (string-length str)) (t-total-size (string-length target)) (t-off (utf8-index->offset target tstart)) (t-end-off (utf8-index->offset target (+ tstart len))) (t-size (- t-end-off t-off))) (if (= s-size t-size) (byte-string-copy! target t-off str 0 len) (let ((res (string-append (##sys#substring target 0 t-off) str (##sys#substring target t-end-off t-total-size)))) (##sys#become! (list (cons target res)))))))) (define (string-take s n) (utf8-substring s 0 n)) (define (string-drop s n) (utf8-substring s n)) (define (string-take-right s n) (utf8-substring s (- (utf8-string-length s) n))) (define (string-drop-right s n) (utf8-substring s 0 (- (utf8-string-length s) n))) (define (string-pad s len . opt) (let-optionals* opt ((ch #\space) (start 0) (end (utf8-string-length s))) (let ((diff (- end start))) (if (<= len diff) (utf8-substring s (- end len) end) (string-append (make-utf8-string (- len diff) ch) (utf8-substring s start end)))))) (define (string-pad-right s len . opt) (let-optionals* opt ((ch #\space) (start 0) (end (utf8-string-length s))) (let ((diff (- end start))) (if (<= len diff) (utf8-substring s start (+ start len)) (string-append (utf8-substring s start end) (make-utf8-string (- len diff) ch)))))) (define (string-trim s . opt) (let-optionals* opt ((trimmer char-set:whitespace) (start 0) (end #f)) (let* ((pred (char-predicate trimmer)) (end-off (if end (utf8-index->offset s end) (string-length s)))) (let lp ((i (utf8-index->offset s start))) (if (or (>= i end-off) (not (pred (sp-ref s i)))) (##sys#substring s i end-off) (lp (sp-next s i))))))) (define (string-trim-right s . opt) (let-optionals* opt ((trimmer char-set:whitespace) (start 0) (end #f)) (let ((pred (char-predicate trimmer)) (end-off (if end (utf8-index->offset s end) (string-length s)))) (let lp ((i (sp-prev s end-off)) (j end-off)) (if (or (negative? i) (not (pred (sp-ref s i)))) (##sys#substring s (utf8-index->offset s start) j) (lp (sp-prev s i) i)))))) (define (string-trim-both s . opt) (let-optionals* opt ((trimmer char-set:whitespace)) (string-trim (apply string-trim-right s opt) trimmer))) ;; alas, can't use string-compare3 because the predicates get the ;; index as an argument (define (string-compare s1 s2 proc< proc= proc> . opt) (with-two-substring-offsets (lambda (s1 s2 start1 end1 start2 end2) (let lp ((i start1) (j start2)) (cond ((>= i end1) ((if (>= j end2) proc= proc<) (utf8-offset->index s1 i))) ((>= j end2) (utf8-offset->index s1 i)) ((charindex s1 i))) ((char>? (string-ref s1 i) (string-ref s2 i)) (proc> (utf8-offset->index s1 i))) (else (lp (+ i 1) (+ j 1)))))) s1 s2 opt)) (define (string-compare-ci s1 s2 proc< proc= proc> . opt) (with-two-substring-offsets (lambda (s1 s2 start1 end1 start2 end2) (let lp ((i start1) (j start2)) (cond ((>= i end1) ((if (>= j end2) proc= proc<) (utf8-offset->index s1 i))) ((>= j end2) (utf8-offset->index s1 i)) ((char-ciindex s1 i))) ((char-ci>? (string-ref s1 i) (string-ref s2 i)) (proc> (utf8-offset->index s1 i))) (else (lp (+ i 1) (+ j 1)))))) s1 s2 opt)) (define (make-string-comparator proc pred) (lambda (s1 s2 . opt) (if (null? opt) (pred (proc s1 s2)) (pred (with-two-substring-offsets (lambda (s1 s2 start1 end1 start2 end2) (proc (##sys#substring s1 start1 end1) (##sys#substring s2 start2 end2))) s1 s2 opt))))) (define string= (make-string-comparator string-compare3 zero?)) (define string<> (make-string-comparator string-compare3 (complement zero?))) (define string< (make-string-comparator string-compare3 negative?)) (define string> (make-string-comparator string-compare3 positive?)) (define string<= (make-string-comparator string-compare3 (complement positive?))) (define string>= (make-string-comparator string-compare3 (complement negative?))) (define string-ci= (make-string-comparator string-compare3-ci zero?)) (define string-ci<> (make-string-comparator string-compare3-ci (complement zero?))) (define string-ci< (make-string-comparator string-compare3-ci negative?)) (define string-ci> (make-string-comparator string-compare3-ci positive?)) (define string-ci<= (make-string-comparator string-compare3-ci (complement positive?))) (define string-ci>= (make-string-comparator string-compare3-ci (complement negative?))) (define (utf8-substring-length s start . opt) (let ((end (if (pair? opt) (car opt) (string-length s)))) (let lp ((i start) (res 0)) (if (>= i end) res (lp (+ i (utf8-start-byte->length (string-int-ref s i))) (+ res 1)))))) (define (make-string-fix-length proc) (lambda (s1 s2 . opt) (with-two-substring-offsets (lambda (s1 s2 start1 end1 start2 end2) (let ((res (proc s1 s2 start1 start2 end1 end2))) (if (zero? res) res (utf8-substring-length s1 start1 (+ start1 res))))) s1 s2 opt))) (define (byte-string-prefix-length s1 s2 start1 start2 end1 end2) (let lp ((i start1) (j start2)) (cond ((>= i end1) (- i start1)) ((>= j end2) (- j start2)) ((char=? (string-ref s1 i) (string-ref s2 j)) (lp (+ i 1) (+ j 1))) (else (- i start1))))) (define (byte-string-prefix-length-ci s1 s2 start1 start2 end1 end2) (let lp ((i start1) (j start2)) (cond ((>= i end1) (- i start1)) ((>= j end2) (- j start2)) ((char-ci=? (string-ref s1 i) (string-ref s2 j)) (lp (+ i 1) (+ j 1))) (else (- i start1))))) (define (byte-string-suffix-length s1 s2 start1 start2 end1 end2) (let lp ((i (- end1 1)) (j (- end2 1))) (cond ((< i start1) (- end1 i 1)) ((< j start2) (- end2 j 1)) ((char=? (string-ref s1 i) (string-ref s2 j)) (lp (- i 1) (- j 1))) (else (- end1 i 1))))) (define (byte-string-suffix-length-ci s1 s2 start1 start2 end1 end2) (let lp ((i (- end1 1)) (j (- end2 1))) (cond ((< i start1) (- end1 i 1)) ((< j start2) (- end2 j 1)) ((char-ci=? (string-ref s1 i) (string-ref s2 j)) (lp (- i 1) (- j 1))) (else (- end1 i 1))))) (define string-prefix-length (make-string-fix-length byte-string-prefix-length)) (define string-prefix-length-ci (make-string-fix-length byte-string-prefix-length-ci)) (define string-suffix-length (make-string-fix-length byte-string-suffix-length)) (define string-suffix-length-ci (make-string-fix-length byte-string-suffix-length-ci)) (define (make-string-prefix-test proc) (lambda (s1 s2 . opt) (cond ((null? opt) (and (<= (string-length s1) (string-length s2)) (proc s1 s2))) (else (with-two-substring-offsets (lambda (s1 s2 start1 end1 start2 end2) (let ((s1-len (- end1 start1)) (s2-len (- end2 start2))) (and (<= s1-len s2-len) (proc s1 s2 start1 start2 s1-len)))) s1 s2 opt))))) (define string-prefix? (make-string-prefix-test substring=?)) (define string-prefix-ci? (make-string-prefix-test substring-ci=?)) (define (string-suffix? s1 s2 . opt) (with-two-substring-offsets (lambda (s1 s2 start1 end1 start2 end2) (and (>= (- end2 start2) (- end1 start1)) (let lp ((i (- end1 1)) (j (- end2 1))) (or (< i start1) (if (char=? (string-ref s1 i) (string-ref s2 j)) (lp (- i 1) (- j 1)) #f))))) s1 s2 opt)) (define (string-suffix-ci? s1 s2 . opt) (with-two-substring-offsets (lambda (s1 s2 start1 end1 start2 end2) (and (>= (- end2 start2) (- end1 start1)) (let lp ((i (- end1 1)) (j (- end2 1))) (or (< i start1) (if (char-ci=? (string-ref s1 i) (string-ref s2 j)) (lp (- i 1) (- j 1)) #f))))) s1 s2 opt)) (define (make-string-hasher proc) (lambda (s . opt) (cond ((null? opt) (proc s)) ((null? (cdr opt)) (proc s (car opt))) (else (with-substring-offsets (lambda (s start end) (proc (##sys#substring s start end) (car opt))) s (cdr opt)))))) (define string-hash (make-string-hasher hash)) (define string-ci-hash (make-string-hasher (lambda (s) (hash (string-downcase s))))) (define (with-string-index+offset proc s x . opt) (if (equal? s "") #f (let-optionals* opt ((start 0) (end -1)) (let ((size (string-length s)) (pred (char-predicate x))) (let lp ((i start) (off (utf8-index->offset s start))) (if (or (= i end) (= off size)) (proc #f #f) (let ((ch (sp-ref s off))) (if (pred ch) (proc i off) (lp (+ i 1) (+ off (ucs-integer->length (char->integer ch)))))))))))) (define (with-string-index+offset-right proc s x . opt) (if (equal? s "") #f (let-optionals* opt ((start 0) (end (utf8-string-length s))) (let* ((size (string-length s)) (pred (char-predicate x))) (let lp ((i (- end 1)) (off (utf8-index->offset s (- end 1)))) (if (< i start) (proc #f #f) (let ((ch (sp-ref s off))) (if (pred ch) (proc i off) (if (zero? i) (lp -1 -1) (lp (- i 1) (utf8-prev-char s off))))))))))) (define (arg1 a b) a) ;;(define (arg2 a b) b) (define (string-index s x . opt) (apply with-string-index+offset arg1 s x opt)) ;; (define (string-offset s x . opt) ;; (apply with-string-index+offset arg2 s x opt)) (define (string-index-right s x . opt) (apply with-string-index+offset-right arg1 s x opt)) ;; (define (string-offset-right s x . opt) ;; (apply with-string-index+offset-right arg2 s x opt)) (define (string-skip s x . opt) (apply string-index s (complement (char-predicate x)) opt)) (define (string-skip-right s x . opt) (apply string-index-right s (complement (char-predicate x)) opt)) (define (string-count s x . opt) (let ((pred (char-predicate x))) (apply string-fold (lambda (c sum) (if (pred c) (+ sum 1) sum)) 0 s opt))) ;; cleaner to loop ourselves, but the byte-oriented substring-index ;; uses memcmp directly, so we go out of our way to make use of that, ;; while avoiding substring if at all possible (define (string-contains s1 s2 . opt) (define (return offset index) (and offset (+ (utf8-offset->index s1 offset) index))) (if (null? opt) (return (substring-index s2 s1) 0) (let* ((start1-index (car opt)) (opt (cdr opt)) (start1 (utf8-index->offset s1 start1-index))) (if (null? opt) (return (substring-index s2 s1 start1) 0) (let* ((end1 (utf8-index->offset s1 (car opt))) (opt (cdr opt)) (s2 (if (null? opt) s2 (with-substring-offsets ##sys#substring s2 opt)))) (if (= end1 (string-length s1)) (return (substring-index s2 s1 start1) 0) (return (substring-index s2 (##sys#substring s1 start1 end1)) start1-index))))))) ;; XXXX consider using full unicode case mappings (define (string-contains-ci s1 s2 . opt) (define (return offset index) (and offset (+ (utf8-offset->index s1 offset) index))) (if (null? opt) (return (substring-index s2 s1) 0) (let* ((start1-index (car opt)) (opt (cdr opt)) (start1 (utf8-index->offset s1 start1-index))) (if (null? opt) (return (substring-index-ci s2 s1 start1) 0) (let* ((end1 (utf8-index->offset s1 (car opt))) (opt (cdr opt)) (s2 (if (null? opt) s2 (with-substring-offsets ##sys#substring s2 opt)))) (if (= end1 (string-length s1)) (return (substring-index-ci s2 s1 start1) 0) (return (substring-index-ci s2 (##sys#substring s1 start1 end1)) start1-index))))))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; case mapping (define string-titlecase utf8-string-titlecase) (define string-titlecase! utf8-string-titlecase) (define string-downcase utf8-string-downcase) (define string-downcase! utf8-string-downcase) (define string-upcase utf8-string-upcase) (define string-upcase! utf8-string-upcase) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; reverse & append (define (%string-reverse s start end) (let* ((len (- end start)) (res (make-string len))) (let lp ((i end) (j 0)) (let ((i2 (utf8-prev-char s i))) (if (not i2) res (let lp2 ((i3 i2) (j j)) (if (eqv? i3 i) (lp i2 j) (begin (string-set! res j (string-ref s i3)) (lp2 (+ i3 1) (+ j 1)))))))))) (define (string-reverse s . opt) (with-substring-offsets %string-reverse s opt)) (define (string-reverse! s . opt) (with-substring-offsets (lambda (s start end) (let ((s2 (%string-reverse s start end))) (byte-string-copy! s start s2 0 (string-length s2)))) s opt)) (define (string-join ls . opt) (let-optionals* opt ((delim " ") (grammar 'infix)) (case grammar ((infix strict-infix) (if (and (eq? grammar 'strict-infix) (null? ls)) (error "strict-infix grammar requires a non-empty list")) (string-intersperse ls delim)) ((prefix) (if (null? ls) "" (string-intersperse (cons delim (intersperse ls delim)) ""))) ((suffix) (if (null? ls) "" (string-intersperse (append (intersperse ls delim) (list delim)) ""))) (else (error "unknown string-join grammar" grammar))))) (define string-append/shared string-append) (define (string-concatenate ls) (string-intersperse ls "")) (define (string-concatenate-reverse ls) (string-intersperse (reverse ls) "")) (define string-concatenate-reverse/shared string-concatenate-reverse) (define string-concatenate/shared string-concatenate) (define (xsubstring s1 from . opt) (let-optionals* opt ((to1 #f) (start 0) (end (utf8-string-length s1))) (let* ((s (utf8-substring s1 start end)) (len (- end start)) (to (or to1 (+ from len))) (out (open-output-string))) (let lp ((i from)) (cond ((< i to) (write-utf8-char (utf8-string-ref s (modulo i len)) out) (lp (+ i 1))))) (get-output-string out)))) (define (string-xcopy target tstart s from . opt) (let-optionals* opt ((to1 #f) (start 0) (end (utf8-string-length s))) (let ((to (or to1 (+ from (- end start))))) (string-append (utf8-substring target 0 tstart) (xsubstring s from to start end) (utf8-substring target (+ tstart (- to from)) (utf8-string-length target)))))) (define (string-xcopy! target tstart s from . opt) (let ((res (apply string-xcopy target tstart s from opt))) (##sys#become! (list (cons target res))))) (define (string-filter filt s . opt) (let ((pred (char-predicate filt))) (with-output-to-string (lambda () (string-for-each (lambda (c) (if (pred c) (write-utf8-char c))) (if (pair? opt) (apply utf8-substring s opt) s)))))) (define (string-delete filt s . opt) (let ((pred (char-predicate filt))) (apply string-filter (lambda (c) (not (pred c))) s opt))) (define (string-replace s1 s2 start1 end1 . opt) (let ((start1 (utf8-index->offset s1 start1)) (end1 (utf8-index->offset s1 end1))) (with-substring-offsets (lambda (s2 start2 end2) (string-append (##sys#substring s1 0 start1) (##sys#substring s2 start2 end2) (##sys#substring s1 end1 (string-length s1)))) s2 opt))) (define (string-tokenize s . opt) (let-optionals* opt ((token-set char-set:graphic) o2) (with-substring-offsets (lambda (s start end) (letrec ((out (lambda (sp res) (cond ((>= sp end) (reverse res)) ((char-set-contains? token-set (sp-ref s sp)) (in (sp-next s sp) sp res)) (else (out (sp-next s sp) res))))) (in (lambda (sp from res) (cond ((>= sp end) (reverse (cons (sp-substring s from end) res))) ((char-set-contains? token-set (sp-ref s sp)) (in (sp-next s sp) from res)) (else (out (sp-next s sp) (cons (sp-substring s from sp) res))))))) (out start '()))) s o2))) )