4e3ff7ef886291b1ff393321e56cf07b5fdf5bc0
[mes.git] / module / srfi / srfi-13.mes
1 ;;; -*-scheme-*-
2
3 ;;; Mes --- Maxwell Equations of Software
4 ;;; Copyright © 2016,2017,2018 Jan (janneke) Nieuwenhuizen <janneke@gnu.org>
5 ;;;
6 ;;; This file is part of Mes.
7 ;;;
8 ;;; Mes is free software; you can redistribute it and/or modify it
9 ;;; under the terms of the GNU General Public License as published by
10 ;;; the Free Software Foundation; either version 3 of the License, or (at
11 ;;; your option) any later version.
12 ;;;
13 ;;; Mes is distributed in the hope that it will be useful, but
14 ;;; WITHOUT ANY WARRANTY; without even the implied warranty of
15 ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
16 ;;; GNU General Public License for more details.
17 ;;;
18 ;;; You should have received a copy of the GNU General Public License
19 ;;; along with Mes.  If not, see <http://www.gnu.org/licenses/>.
20
21 ;;; Commentary:
22
23 ;;; srfi-13.mes is the minimal srfi-13
24
25 ;;; Code:
26
27 (mes-use-module (srfi srfi-1))
28 (mes-use-module (srfi srfi-14))
29
30 (define (string-copy s)
31   (list->string (string->list s)))
32
33 (define (string=? a b)
34     (eq? (string->symbol a)
35          (string->symbol b)))
36
37 (define (string= a b . rest)
38   (let* ((start1 (and (pair? rest) (car rest)))
39          (end1 (and start1 (pair? (cdr rest)) (cadr rest)))
40          (start2 (and end1 (pair? (cddr rest)) (caddr rest)))
41          (end2 (and start2 (pair? (cdddr rest)) (cadddr rest))))
42     (string=? (if start1 (if end1 (substring a start1 end1)
43                              (substring a start1))
44                   a)
45               (if start2 (if end2 (substring b start2 end2)
46                              (substring b start2))
47                   b))))
48
49 (define (string-split s c)
50   (let loop ((lst (string->list s)) (result '()))
51     (let ((rest (memq c lst)))
52       (if (not rest) (append result (list (list->string lst)))
53           (loop (cdr rest)
54                 (append result
55                         (list (list->string (list-head lst (- (length lst) (length rest)))))))))))
56
57 (define (string-take s n)
58   (cond ((zero? n) s)
59         ((> n 0) (list->string (list-head (string->list s) n)))
60         (else (error "string-take: not supported: n=" n))))
61
62 (define (string-drop s n)
63   (cond ((zero? n) s)
64         ((> n 0) (list->string (list-tail (string->list s) n)))
65         (else s (error "string-drop: not supported: (n s)=" (cons n s)))))
66
67 (define (string-drop-right s n)
68   (cond ((zero? n) s)
69         ((> n 0) (let ((length (string-length s)))
70                    (list->string (list-head (string->list s) (- length n)))))
71         (else (error "string-drop-right: not supported: n=" n))))
72
73 (define (string-delete pred s)
74   (let ((p (if (procedure? pred) pred
75                (lambda (c) (not (eq? pred c))))))
76     (list->string (filter p (string->list s)))))
77
78 (define (string-index s pred . rest)
79   (let* ((start (and (pair? rest) (car rest)))
80          (end (and start (pair? (cdr rest)) (cadr rest)))
81          (pred (if (char? pred) (lambda (c) (eq? c pred)) pred)))
82     (if start (error "string-index: not supported: start=" start))
83     (if end (error "string-index: not supported: end=" end))
84     (let loop ((lst (string->list s)) (i 0))
85       (if (null? lst) #f
86           (if (pred (car lst)) i
87               (loop (cdr lst) (1+ i)))))))
88
89 (define (string-rindex s pred . rest)
90   (let* ((start (and (pair? rest) (car rest)))
91          (end (and start (pair? (cdr rest)) (cadr rest)))
92          (pred (if (char? pred) (lambda (c) (eq? c pred)) pred)))
93     (if start (error "string-rindex: not supported: start=" start))
94     (if end (error "string-rindex: not supported: end=" end))
95     (let loop ((lst (reverse (string->list s))) (i (1- (string-length s))))
96       (if (null? lst) #f
97           (if (pred (car lst)) i
98               (loop (cdr lst) (1- i)))))))
99
100 (define reverse-list->string (compose list->string reverse))
101
102 (define substring/copy substring)
103 (define substring/shared substring)
104
105 (define string-null? (compose null? string->list))
106
107 (define (string-fold cons' nil' s . rest)
108   (let* ((start (and (pair? rest) (car rest)))
109          (end (and start (pair? (cdr rest)) (cadr rest))))
110     (if start (error "string-fold: not supported: start=" start))
111     (if end (error "string-fold: not supported: end=" end))
112     (let loop ((lst (string->list s)) (prev nil'))
113       (if (null? lst) prev
114           (loop (cdr lst) (cons' (car lst) prev))))))
115
116 (define (string-fold-right cons' nil' s . rest)
117   (let* ((start (and (pair? rest) (car rest)))
118          (end (and start (pair? (cdr rest)) (cadr rest))))
119     (if start (error "string-fold-right: not supported: start=" start))
120     (if end (error "string-fold-right: not supported: end=" end))
121     (let loop ((lst (reverse (string->list s))) (prev nil'))
122       (if (null? lst) prev
123           (loop (cdr lst) (cons' (car lst) prev))))))
124
125 (define (string-contains string needle)
126   (let ((needle (string->list needle)))
127     (let loop ((string (string->list string)) (i 0))
128       (and (pair? string)
129            (let match ((start string) (needle needle) (n i))
130              (if (null? needle) i
131                  (and (pair? start)
132                       (if (eq? (car start) (car needle))
133                           (or (match (cdr start) (cdr needle) (1+ n))
134                               (loop (cdr string) (1+ i)))
135                           (loop (cdr string) (1+ i))))))))))
136
137 (define (string-trim string . pred)
138   (list->string
139    (if (pair? pred) (error "string-trim: not supported: PRED=" pred)
140        (let loop ((lst (string->list string)))
141          (if (or (null? lst)
142                  (not (char-whitespace? (car lst)))) lst
143                  (loop (cdr lst)))))))
144
145 (define (string-trim-right string . pred)
146   (list->string
147    (reverse!
148     (if (pair? pred) (error "string-trim-right: not supported: PRED=" pred)
149         (let loop ((lst (reverse (string->list string))))
150           (if (or (null? lst)
151                   (not (char-whitespace? (car lst)))) lst
152                   (loop (cdr lst))))))))
153
154 (define (string-trim-both string . pred)
155   ((compose string-trim string-trim-right) string))
156
157 (define (string-map f string)
158   (list->string (map f (string->list string))))
159
160 (define (string-replace string replace . rest)
161   (let* ((start1 (and (pair? rest) (car rest)))
162          (end1 (and start1 (pair? (cdr rest)) (cadr rest)))
163          (start2 (and end1 (pair? (cddr rest)) (caddr rest)))
164          (end2 (and start2 (pair? (cdddr rest)) (cadddr rest))))
165     (if start2 (error "string-replace: not supported: START2=" start2))
166     (if end2 (error "string-replace: not supported: END2=" end2))
167     (list->string
168      (append
169       (string->list (string-take string (or start1 0)))
170       (string->list replace)
171       (string->list (string-drop string (or end1 (string-length string))))))))