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