1;;; -*- mode:scheme; coding:utf-8; -*- 2;;; 3;;; srfi/%3a130/strings.scm - Cursor-based string library 4;;; 5;;; Copyright (c) 2016 Takashi Kato <ktakashi@ymail.com> 6;;; 7;;; Redistribution and use in source and binary forms, with or without 8;;; modification, are permitted provided that the following conditions 9;;; are met: 10;;; 11;;; 1. Redistributions of source code must retain the above copyright 12;;; notice, this list of conditions and the following disclaimer. 13;;; 14;;; 2. Redistributions in binary form must reproduce the above copyright 15;;; notice, this list of conditions and the following disclaimer in the 16;;; documentation and/or other materials provided with the distribution. 17;;; 18;;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS 19;;; "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT 20;;; LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR 21;;; A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT 22;;; OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, 23;;; SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED 24;;; TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR 25;;; PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF 26;;; LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING 27;;; NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS 28;;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 29;;; 30 31(library (srfi :130 strings) 32 (export string-cursor? 33 string-cursor-start string-cursor-end 34 string-cursor-next string-cursor-prev 35 string-cursor-forward string-cursor-back 36 string-cursor=? 37 string-cursor<? string-cursor>? 38 string-cursor<=? string-cursor>=? 39 string-cursor-diff 40 string-cursor->index string-index->cursor 41 42 string-null? 43 string-every string-any 44 45 string-tabulate 46 string-unfold string-unfold-right 47 48 string->list/cursors string->vector/cursors 49 reverse-list->string string-join 50 51 string-ref/cursor 52 substring/cursors string-copy/cursors 53 string-take string-take-right 54 string-drop string-drop-right 55 string-pad string-pad-right 56 string-trim string-trim-right string-trim-both 57 58 string-prefix-length string-suffix-length 59 string-prefix? string-suffix? 60 61 string-index string-index-right 62 string-skip string-skip-right 63 string-contains string-contains-right 64 65 string-reverse 66 string-concatenate string-concatenate-reverse 67 string-fold string-fold-right 68 string-for-each-cursor 69 string-replicate string-count 70 string-replace string-split 71 string-filter string-remove) 72 ;; TODO don't import all bindings from (rnrs) 73 (import (rnrs) 74 ;; To make fully R6RS implementaion then remove this 75 ;; and implement string->vector 76 (only (scheme base) string->vector) 77 (only (srfi :1) last-pair) 78 (except (srfi :13) 79 string-index 80 string-index-right 81 string-skip 82 string-skip-right 83 string-map 84 string-for-each) 85 (prefix (only (srfi :13) 86 string-index 87 string-index-right 88 string-skip 89 string-skip-right) 90 srfi-13:)) 91 92(define (errmsg ignore) "illegal argument(s)") 93(define (exact-integer? o) (and (integer? o) (exact? o))) 94 95;; From sample implementation 96 97;;; Copyright (C) William D Clinger (2016). 98;;; 99;;; Permission is hereby granted, free of charge, to any person 100;;; obtaining a copy of this software and associated documentation 101;;; files (the "Software"), to deal in the Software without 102;;; restriction, including without limitation the rights to use, 103;;; copy, modify, merge, publish, distribute, sublicense, and/or 104;;; sell copies of the Software, and to permit persons to whom the 105;;; Software is furnished to do so, subject to the following 106;;; conditions: 107;;; 108;;; The above copyright notice and this permission notice shall be 109;;; included in all copies or substantial portions of the Software. 110;;; 111;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, 112;;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES 113;;; OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND 114;;; NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT 115;;; HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, 116;;; WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING 117;;; FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR 118;;; OTHER DEALINGS IN THE SOFTWARE. 119 120;;; For convenient interoperation with SRFI 13, 121;;; cursors ought to be the same as indexes. 122 123;;; Some of the FIXME comments mark procedures that really ought 124;;; to do more checking for "is an error" situations. 125 126(define (string-cursor? x) 127 (and (exact-integer? x) 128 (>= x 0))) 129 130(define (string-cursor-start s) 0) 131(define (string-cursor-end s) (string-length s)) 132(define (string-cursor-next s curs) (+ curs 1)) ; FIXME 133(define (string-cursor-prev s curs) (- curs 1)) ; FIXME 134(define (string-cursor-forward s curs n) (+ curs n)) ; FIXME 135(define (string-cursor-back s curs n) (- curs n)) ; FIXME 136(define (string-cursor=? curs1 curs2) (= curs1 curs2)) 137(define (string-cursor<? curs1 curs2) (< curs1 curs2)) 138(define (string-cursor>? curs1 curs2) (> curs1 curs2)) 139(define (string-cursor<=? curs1 curs2) (<= curs1 curs2)) 140(define (string-cursor>=? curs1 curs2) (>= curs1 curs2)) 141(define (string-cursor-diff s start end) (- end start)) ; FIXME 142(define (string-cursor->index s curs) curs) 143(define (string-index->cursor s idx) idx) 144 145(define string->list/cursors string->list) 146(define string->vector/cursors string->vector) 147 148(define string-ref/cursor string-ref) 149(define substring/cursors substring) 150(define string-copy/cursors string-copy) 151 152;;; The SRFI 13 procedures return #f sometimes, so they can't be the same 153;;; even if cursors are the same as indexes. 154;;; Furthermore string-index-right and string-skip-right return the 155;;; successor of the cursor for the character found. 156 157(define string-index 158 (case-lambda 159 ((s pred) 160 (string-index s pred 0 (string-length s))) 161 ((s pred start) 162 (string-index s pred start (string-length s))) 163 ((s pred start end) 164 (or (srfi-13:string-index s pred start end) 165 end)))) 166 167(define string-index-right 168 (case-lambda 169 ((s pred) 170 (string-index-right s pred 0 (string-length s))) 171 ((s pred start) 172 (string-index-right s pred start (string-length s))) 173 ((s pred start end) 174 (let ((i (srfi-13:string-index-right s pred start end))) 175 (if i (+ i 1) start))))) 176 177(define (string-skip s pred . rest) 178 (apply string-index s (lambda (x) (not (pred x))) rest)) 179 180(define (string-skip-right s pred . rest) 181 (apply string-index-right s (lambda (x) (not (pred x))) rest)) 182 183;;; FIXME: inefficient 184 185(define string-contains-right 186 (case-lambda 187 ((s1 s2) 188 (string-contains-right s1 s2 0 (string-length s1) 0 (string-length s2))) 189 ((s1 s2 start1) 190 (string-contains-right s1 s2 191 start1 (string-length s1) 0 (string-length s2))) 192 ((s1 s2 start1 end1) 193 (string-contains-right s1 s2 start1 end1 0 (string-length s2))) 194 ((s1 s2 start1 end1 start2) 195 (string-contains-right s1 s2 start1 end1 start2 (string-length s2))) 196 ((s1 s2 start1 end1 start2 end2) 197 (if (= start2 end2) 198 end1 199 (let loop ((i #f) 200 (j (string-contains s1 s2 start1 end1 start2 end2))) 201 (if (and j (< j end1)) 202 (loop j (string-contains s1 s2 (+ j 1) end1 start2 end2)) 203 i)))))) 204 205(define string-for-each-cursor 206 (case-lambda 207 ((proc s) 208 (string-for-each-cursor proc s 0 (string-length s))) 209 ((proc s start) 210 (string-for-each-cursor proc s start (string-length s))) 211 ((proc s start end) 212 (do ((i start (+ i 1))) 213 ((>= i end)) 214 (proc i))))) 215 216(define string-replicate 217 (case-lambda 218 ((s from to start end) 219 (string-replicate (substring s start end) from to)) 220 ((s from to start) 221 (string-replicate (substring s start (string-length s)) from to)) 222 ((s from to) 223 (let* ((n (- to from)) 224 (len (string-length s))) 225 (cond ((= n 0) 226 "") 227 ((or (< n 0) 228 (= len 0)) 229 (assertion-violation 'string-replicate 230 (errmsg 'msg:illegalargs) 231 s from to)) 232 (else 233 (let* ((from (mod from len)) ; make from non-negative 234 (to (+ from n))) 235 (do ((replicates '() (cons s replicates)) 236 (replicates-length 0 (+ replicates-length len))) 237 ((>= replicates-length to) 238 (substring (apply string-append replicates) 239 from to)))))))))) 240 241(define string-split 242 (case-lambda 243 ((s delimiter grammar limit start end) 244 (string-split (substring s start end) delimiter grammar limit)) 245 ((s delimiter grammar limit start) 246 (string-split (substring s start (string-length s)) 247 delimiter grammar limit)) 248 ((s delimiter) 249 (string-split s delimiter 'infix #f)) 250 ((s delimiter grammar) 251 (string-split s delimiter grammar #f)) 252 ((s delimiter grammar limit) 253 (define (complain) 254 (assertion-violation 'string-split 255 (errmsg 'msg:illegalargs) 256 s delimiter grammar limit)) 257 (let* ((limit (or limit (string-length s))) 258 (splits 259 (cond ((= 0 (string-length delimiter)) 260 (string-split-into-characters s limit)) 261 (else 262 (string-split-using-word s delimiter limit))))) 263 (case grammar 264 ((infix strict-infix) 265 (if (= 0 (string-length s)) 266 (if (eq? grammar 'infix) 267 '() 268 (complain)) 269 splits)) 270 ((prefix) 271 (if (and (pair? splits) 272 (= 0 (string-length (car splits)))) 273 (cdr splits) 274 splits)) 275 ((suffix) 276 (if (and (pair? splits) 277 (= 0 (string-length (car (last-pair splits))))) 278 (reverse (cdr (reverse splits))) 279 splits)) 280 (else 281 (complain))))))) 282 283(define (string-split-into-characters s limit) 284 (let ((n (string-length s))) 285 (cond ((> n (+ limit 1)) 286 (append (string-split-into-characters (substring s 0 limit) limit) 287 (substring s limit n))) 288 (else 289 (map string (string->list s)))))) 290 291;;; FIXME: inefficient 292 293(define (string-split-using-word s sep limit) 294 (cond ((= 0 limit) 295 (list s)) 296 (else 297 (let ((i (string-contains s sep))) 298 (if i 299 (cons (substring s 0 i) 300 (string-split-using-word 301 (substring s (+ i (string-length sep)) (string-length s)) 302 sep 303 (- limit 1))) 304 (list s)))))) 305 306(define (string-remove pred s . args) 307 (apply string-filter 308 (lambda (c) (not (pred c))) 309 s 310 args)) 311 312 ) 313