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