1;;; 2;;; srfi-135 Immutable Texts 3;;; 4;;; Copyright (c) 2020 Shiro Kawai <shiro@acm.org> 5;;; 6;;; Redistribution and use in source and binary forms, with or without 7;;; modification, are permitted provided that the following conditions 8;;; are met: 9;;; 10;;; 1. Redistributions of source code must retain the above copyright 11;;; notice, this list of conditions and the following disclaimer. 12;;; 13;;; 2. Redistributions in binary form must reproduce the above copyright 14;;; notice, this list of conditions and the following disclaimer in the 15;;; documentation and/or other materials provided with the distribution. 16;;; 17;;; 3. Neither the name of the authors nor the names of its contributors 18;;; may be used to endorse or promote products derived from this 19;;; software without specific prior written permission. 20;;; 21;;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS 22;;; "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT 23;;; LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR 24;;; A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT 25;;; OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, 26;;; SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED 27;;; TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR 28;;; PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF 29;;; LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING 30;;; NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS 31;;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 32;;; 33 34;; In Gauche, O(1)-access immutable texts is just an immutable string with 35;; index attached. 36 37(define-module srfi-135 38 (use gauche.unicode) 39 (use gauche.lazy) 40 (use srfi-152) 41 (export text? textual? textual-null? textual-every textual-any 42 make-text text text-tabulate text-unfold text-unfold-right 43 textual->text textual->string textual->vector textual->list 44 string->text vector->text list->text reverse-list->text 45 textual->utf8 textual->utf16be textual->utf16le textual->utf16 46 utf8->text utf16be->text utf16le->text utf16->text 47 48 text-length textual-length text-ref textual-ref 49 subtext subtextual textual-copy 50 textual-take textual-take-right textual-drop textual-drop-right 51 textual-pad textual-pad-right 52 textual-trim textual-trim-right textual-trim-both 53 54 textual-replace 55 56 textual=? textual-ci=? 57 textual<? textual-ci<? textual<=? textual-ci<=? 58 textual>? textual-ci>? textual>=? textual-ci>=? 59 60 textual-prefix-length textual-suffix-length 61 textual-prefix? textual-suffix? 62 63 textual-index textual-index-right 64 textual-skip textual-skip-right 65 textual-contains textual-contains-right 66 67 textual-upcase textual-downcase 68 textual-foldcase textual-titlecase 69 70 textual-append textual-concatenate textual-concatenate-reverse 71 textual-join 72 73 textual-fold textual-fold-right 74 textual-map textual-for-each 75 textual-map-index textual-for-each-index 76 textual-count textual-filter textual-remove 77 78 textual-replicate textual-split)) 79(select-module srfi-135) 80 81(define (text? obj) 82 (and (string-immutable? obj) (string-fast-indexable? obj))) 83(define textual? string?) 84(define textual-null? string-null?) 85(define textual-every string-every) 86(define textual-any string-any) 87 88(define-inline (%textize obj) 89 (string-build-index! (string-copy-immutable obj))) 90(define-inline (%stringify obj) 91 (cond [(char? obj) (string obj)] 92 [(string? obj) obj] 93 [else (error "procedure expected to return a character, a string \ 94 or a text, but returned:" obj)])) 95 96(define (make-text len char) 97 (%textize (make-string len char))) 98(define (text . chars) 99 (%textize (list->string chars))) 100(define (text-tabulate proc len) 101 (%textize (string-tabulate proc len))) 102(define (text-unfold p f g seed :optional (base "") (make-final (^_ ""))) 103 (%textize 104 (with-output-to-string 105 (^[] (display base) 106 (let loop ((seed seed)) 107 (if (p seed) 108 (display (make-final seed)) 109 (begin (display (f seed)) 110 (loop (g seed))))))))) 111(define (text-unfold-right p f g seed :optional (base "") (make-final (^_ ""))) 112 (let loop ((seed seed) (r '())) 113 (if (p seed) 114 (%textize (string-append (%stringify (make-final seed)) 115 (string-concatenate r) 116 (%stringify base))) 117 (loop (g seed) 118 (cons (%stringify (f seed)) r))))) 119 120(define (textual->text textual) 121 (assume (textual? textual)) 122 (%textize textual)) 123(define (textual->string textual . args) 124 (assume (textual? textual)) 125 (apply string-copy textual args)) 126(define (textual->list textual . args) 127 (assume (textual? textual)) 128 (apply string->list textual args)) 129(define (textual->vector textual . args) 130 (assume (textual? textual)) 131 (apply string->vector textual args)) 132 133(define (string->text string . args) 134 (%textize (apply (with-module gauche.internal %maybe-substring) string args))) 135(define (vector->text vec . args) 136 (%textize (apply vector->string vec args))) 137(define (list->text lis :optional start end) 138 (let* ([lis (cond [(and (integer? start) (>= start 0)) (drop lis start)] 139 [(undefined? start) lis] 140 [else (error "start argument must be an integer, but got:" 141 start)])] 142 [lis (cond [(integer? end) 143 (if (>= end start) 144 (take lis (- end start)) 145 (errorf "end argument ~s is less than start argument ~s" 146 end start))] 147 [(undefined? end) lis] 148 [else (error "end argument must be an integer, but got:" 149 end)])]) 150 (%textize (list->string lis)))) 151(define (reverse-list->text lis . args) 152 (%textize (apply reverse-list->string lis args))) 153 154(define textual->utf8 string->utf8) 155(define (textual->utf16 textual . args) 156 (apply string->utf16 textual (native-endian) #t args)) 157(define (textual->utf16be textual . args) 158 (apply string->utf16 textual 'big-endian #f args)) 159(define (textual->utf16le textual . args) 160 (apply string->utf16 textual 'little-endian #f args)) 161 162(define (utf8->text bv . args) 163 (%textize (apply utf8->string bv args))) 164(define (utf16->text bv . args) 165 (%textize (apply utf16->string bv (native-endian) #f args))) 166(define (utf16be->text bv . args) 167 (%textize (apply utf16->string bv 'big-endian #t args))) 168(define (utf16le->text bv . args) 169 (%textize (apply utf16->string bv 'little-endian #t args))) 170 171(define (text-length text) 172 (assume (text? text)) 173 (string-length text)) 174(define (text-ref text index) 175 (assume (text? text)) 176 (string-ref text index)) 177(define textual-length string-length) 178(define textual-ref string-ref) 179 180(define (subtext text start end) 181 (assume (text? text)) 182 (%textize (substring text start end))) 183(define (subtextual textual start end) 184 (%textize (substring textual start end))) 185(define (textual-copy textual . args) 186 ;; textual-copy should copy once. 187 (%textize (apply string-copy textual args))) 188 189(define (textual-take textual nchars) 190 (%textize (string-take textual nchars))) 191(define (textual-drop textual nchars) 192 (%textize (string-drop textual nchars))) 193(define (textual-take-right textual nchars) 194 (%textize (string-take-right textual nchars))) 195(define (textual-drop-right textual nchars) 196 (%textize (string-drop-right textual nchars))) 197 198(define (textual-pad textual len . args) 199 (%textize (apply string-pad textual len args))) 200(define (textual-pad-right textual len . args) 201 (%textize (apply string-pad-right textual len args))) 202(define (textual-trim textual . args) 203 (%textize (apply string-trim textual args))) 204(define (textual-trim-right textual . args) 205 (%textize (apply string-trim-right textual args))) 206(define (textual-trim-both textual . args) 207 (%textize (apply string-trim-both textual args))) 208 209(define (textual-replace t1 t2 start1 end1 . args) 210 (%textize (apply string-replace t1 t2 start1 end1 args))) 211 212(define textual=? string=?) 213(define textual<? string<?) 214(define textual<=? string<=?) 215(define textual>? string>?) 216(define textual>=? string>=?) 217 218(define textual-ci=? string-ci=?) 219(define textual-ci<? string-ci<?) 220(define textual-ci<=? string-ci<=?) 221(define textual-ci>? string-ci>?) 222(define textual-ci>=? string-ci>=?) 223 224(define textual-prefix-length string-prefix-length) 225(define textual-suffix-length string-suffix-length) 226(define textual-prefix? string-prefix?) 227(define textual-suffix? string-suffix?) 228 229(define textual-index string-index) 230(define textual-index-right string-index-right) 231(define textual-skip string-skip) 232(define textual-skip-right string-skip-right) 233(define textual-contains string-contains) 234(define textual-contains-right string-contains-right) 235 236(define (textual-upcase textual) (%textize (string-upcase textual))) 237(define (textual-downcase textual) (%textize (string-downcase textual))) 238(define (textual-foldcase textual) (%textize (string-foldcase textual))) 239(define (textual-titlecase textual) (%textize (string-titlecase textual))) 240 241(define (textual-append . args) 242 (%textize (string-concatenate args))) 243(define (textual-concatenate args) 244 (%textize (string-concatenate args))) 245(define (textual-concatenate-reverse args :optional (final-textual "") end) 246 (textual-concatenate (reverse args 247 (list 248 (if (undefined? end) 249 final-textual 250 (subtext final-textual 0 end)))))) 251(define (textual-join lis . args) 252 (%textize (apply string-join lis args))) 253 254(define textual-fold string-fold) 255(define textual-fold-right string-fold-right) 256 257(define (textual-map proc textual . rest) 258 (assume (textual? textual)) 259 (assume (every textual? rest)) 260 (%textize 261 (string-concatenate 262 (if (null? rest) 263 (map (^t (%stringify (proc t))) (x->lseq textual)) 264 (apply map (^ ts (%stringify (apply proc ts))) 265 (x->lseq textual) 266 (map x->lseq rest)))))) 267(define (textual-for-each proc textual . rest) 268 (assume (textual? textual)) 269 (assume (every textual? rest)) 270 (apply string-for-each proc textual rest)) 271 272(define (textual-map-index proc textual :optional (start 0) 273 (end (textual-length textual))) 274 (%textize 275 (string-concatenate 276 (map (^i (%stringify (proc i))) 277 (lrange start end))))) 278(define (textual-for-each-index proc textual :optional (start 0) 279 (end (textual-length textual))) 280 (for-each proc (lrange start end))) 281 282(define textual-count string-count) 283(define (textual-filter pred textual . args) 284 (%textize (apply string-filter pred textual args))) 285(define (textual-remove pred textual . args) 286 (%textize (apply string-remove pred textual args))) 287 288(define (textual-replicate textual from to . args) 289 (%textize (apply string-replicate textual from to args))) 290(define (textual-split textual delimiter . args) 291 (map %textize (apply string-split textual delimiter args))) 292 293 294 295 296