1
2;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
3;;
4;; MODULE      : base.scm
5;; DESCRIPTION : frequently used Scheme subroutines
6;; COPYRIGHT   : (C) 2002  Joris van der Hoeven
7;;
8;; This software falls under the GNU general public license version 3 or later.
9;; It comes WITHOUT ANY WARRANTY WHATSOEVER. For details, see the file LICENSE
10;; in the root directory or <http://www.gnu.org/licenses/gpl-3.0.html>.
11;;
12;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
13
14(texmacs-module (kernel library base))
15
16;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
17;; Booleans
18;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
19
20(define (xor-sub l)
21  (cond ((null? l) #f)
22	((car l) (not (xor-sub (cdr l))))
23	(else (xor-sub (cdr l)))))
24
25(define-public (xor . l)
26  "Exclusive or of all elements in @l."
27  (xor-sub l))
28
29;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
30;; Numbers
31;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
32
33(define-public (float->string s)
34  (number->string s))
35
36(define-public (string->float s)
37  (exact->inexact (string->number s)))
38
39;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
40;; Strings
41;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
42
43;; NOTE: guile-1.6.0 implements SRFI-13 (string library) in C.
44
45(define-public (char->string c)
46  "Convert @c to a string"
47  (list->string (list c)))
48
49(define-public (string-tail s n)
50  "Return all but the first @n chars of @s."
51  (substring s n (string-length s)))
52
53(define-public (char-in-string? c s)
54  "Test whether @c occurs in @s"
55  (!= (string-index s c) #f))
56
57(define-public (string-starts? s what)
58  "Test whether @s starts with @what."
59  (let ((n (string-length s))
60	(k (string-length what)))
61    (and (>= n k) (== (substring s 0 k) what))))
62
63(define-public (string-ends? s what)
64  "Test whether @s ends with @what."
65  (let ((n (string-length s))
66	(k (string-length what)))
67    (and (>= n k) (== (substring s (- n k) n) what))))
68
69(define-public (string-contains? s what)
70  "Test whether @s contains @what as a substring."
71  (>= (string-search-forwards what 0 s) 0))
72
73(define-public (force-string s)
74  "Return @s if @s is a string and the empty string otherwise"
75  (if (string? s) s ""))
76
77(provide-public (reverse-list->string cs)	; srfi-13
78  "Efficient implementation of (compose list->string reverse)."
79  ;; Not yet any more efficient, but this may be fixed in the future.
80  (list->string (reverse cs)))
81
82(provide-public (string-join	ss . opt)	; srfi-13 (subset)
83  "Concatenate elements of @ss inserting separators."
84  (if (null? opt) (string-join ss " ")
85      (string-concatenate (list-intersperse ss (car opt)))))
86
87(provide-public (string-drop-right s n)	; srfi-13
88  "Return all but the last @n chars of @s."
89  (substring s 0 (- (string-length s) n)))
90
91(provide-public string-drop string-tail)	; srfi-13
92
93(provide-public (string-take s n)		; srfi-13
94  "Return the first @n chars of @s."
95  (substring s 0 n))
96
97(provide-public (string-trim s)		; srfi-13 (subset)
98  "Remove whitespace at start of @s."
99  (list->string (list-drop-while (string->list s) char-whitespace?)))
100
101(define-public (list-drop-right-while l pred)
102  (reverse! (list-drop-while (reverse l) pred)))
103
104(provide-public (string-trim-right s)	; srfi-13 (subset)
105  "Remove whitespace at end of @s."
106  (list->string (list-drop-right-while (string->list s) char-whitespace?)))
107
108(provide-public (string-trim-both s)		; srfi-13 (subset)
109  "Remove whitespace at start and end of @s."
110  (list->string
111   (list-drop-right-while
112    (list-drop-while (string->list s) char-whitespace?)
113    char-whitespace?)))
114
115(provide-public (string-concatenate ss)	; srfi-13
116  "Append the elements of @ss toghether."
117  ;; WARNING: not portable for long lists
118  (apply string-append ss))
119
120(provide-public (string-map proc s) 		; srfi-13 (subset)
121  "Map @proc on every char of @s."
122  (list->string (map proc (string->list s))))
123
124(provide-public (string-fold kons knil s) 	; srfi-13 (subset))
125  "Fundamental string iterator."
126  (list-fold kons knil (string->list s)))
127
128(provide-public (string-fold-right kons knil s) ; srfi-13 (subset)
129  "Right to left fundamental string iterator."
130  (list-fold-right kons knil (string->list s)))
131
132(define (string-split-lines/kons c cs+lines)
133  (if (== c #\newline)
134      (cons '() cs+lines)
135      (cons (cons c (car cs+lines)) (cdr cs+lines))))
136
137(define-public (string-split-lines s)
138  "List of substrings of @s separated by newlines."
139  (map list->string
140       (list-fold-right string-split-lines/kons '(()) (string->list s))))
141
142(provide-public (string-tokenize-by-char s sep)
143  "Cut string @s into pieces using @sep as a separator."
144  (with d (string-index s sep)
145    (if d
146	(cons (substring s 0 d)
147	      (string-tokenize-by-char (substring s (+ 1 d) (string-length s)) sep))
148	(list s))))
149
150(define-public (string-tokenize-by-char-n s sep n)
151  "As @string-tokenize-by-char, but only cut first @n pieces"
152  (with d (string-index s sep)
153    (if (or (= n 0) (not d))
154	(list s)
155	(cons (substring s 0 d)
156	      (string-tokenize-by-char-n (substring s (+ 1 d) (string-length s))
157				 sep
158				 (- n 1))))))
159
160(define-public (string-decompose s sep)
161  (with d (string-search-forwards sep 0 s)
162    (if (< d 0)
163        (list s)
164        (cons (substring s 0 d)
165              (string-decompose (substring s (+ d (string-length sep))
166                                           (string-length s)) sep)))))
167
168(define-public (string-recompose l sep)
169  "Turn list @l of strings into one string using @sep as separator."
170  (if (char? sep) (set! sep (list->string (list sep))))
171  (cond ((null? l) "")
172	((null? (cdr l)) (car l))
173	(else (string-append (car l) sep (string-recompose (cdr l) sep)))))
174
175(define-public (string-tokenize-comma s)
176  "Cut string @s into pieces using comma as a separator and remove whitespace."
177  (map string-trim-both (string-tokenize-by-char s #\,)))
178
179(define-public (string-recompose-comma l)
180  "Turn list @l of strings into comma separated string."
181  (string-recompose l ", "))
182
183(define (property-pair->string p)
184  (string-append (car p) "=" (cdr p)))
185
186(define (string->property-pair s)
187  (with pos (string-index s #\=)
188    (if pos
189	(cons (string-take s pos) (string-drop s (+ pos 1)))
190	(cons s "true"))))
191
192(define-public (string->alist s)
193  "Parse @s of the form \"var1=val1/.../varn=valn\" as an association list."
194  (map string->property-pair (string-tokenize-by-char s #\/)))
195
196(define-public (alist->string l)
197  "Pretty print the association list @l as a string."
198  (string-recompose (map property-pair->string l) "/"))
199
200;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
201;; Some string-like functions on symbols
202;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
203
204(define-public (symbol<=? x y)
205  (string<=? (symbol->string x) (symbol->string y)))
206
207(define-public (symbol-starts? s1 s2)
208  (string-starts? (symbol->string s1) (symbol->string s2)))
209
210(define-public (symbol-ends? s1 s2)
211  (string-ends? (symbol->string s1) (symbol->string s2)))
212
213(define-public (symbol-drop s n)
214  (string->symbol (string-drop (symbol->string s) n)))
215
216(define-public (symbol-drop-right s n)
217  (string->symbol (string-drop-right (symbol->string s) n)))
218
219;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
220;; Functions
221;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
222
223(define-public (compose g f)
224  "Compose the functions @f and @g"
225  (lambda x (g (apply f x))))
226
227(define-public (non pred?)
228  "Return the negation of @pred?."
229  (lambda args (not (apply pred? args))))
230
231;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
232;; Objects
233;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
234
235(define-public (string->object s)
236  "Parse @s and build scheme object"
237  (call-with-input-string s read))
238
239(define-public (object->string* obj)
240  (cond ((null? obj) (object->string obj))
241	((pair? obj) (object->string obj))
242	((number? obj) (object->string obj))
243	((string? obj) (object->string obj))
244	((symbol? obj) (object->string obj))
245	((tree? obj) (object->string (tree->stree obj)))
246	(else (object->string #f))))
247
248(define-public (func? x f . opts)
249  "Is @x a list with first stree @f? Optionally test the length of @x."
250  (let ((n (length opts)))
251    (cond ((= n 0) (and (list? x) (nnull? x) (== (car x) f)))
252	  ((= n 1)
253	   (let ((nn (car opts)))
254             (and (list? x) (nnull? x)
255                  (== (car x) f) (= (length x) (+ nn 1)))))
256	  (else (error "Too many arguments.")))))
257
258(define-public (tuple? x . opts)
259  "Equivalent to @list? without options or to @func? otherwise"
260  (if (null? opts)
261      (list? x)
262      (apply func? (cons x opts))))
263
264;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
265;; Positions
266;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
267
268(define-public (position-new . opts)
269  (position-new-path (if (null? opts) (cursor-path) (car opts))))
270
271;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
272;; Urls
273;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
274
275(define-public (url->list u)
276  (cond ((url-none? u) '())
277	((url-or? u) (append (url->list (url-ref u 1))
278			     (url->list (url-ref u 2))))
279	(else (list u))))
280
281(define-public (list->url l)
282  (cond ((null? l) (url-none))
283	((null? (cdr l)) (car l))
284	(else (url-or (car l) (list->url (cdr l))))))
285
286(define-public (url-read-directory u wc)
287  (with d (url-expand (url-complete (url-append u (url-wildcard wc)) "r"))
288    (url->list d)))
289
290;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
291;; Buffers
292;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
293
294(define-public (current-buffer)
295  (with u (current-buffer-url)
296    (and (not (url-none? u)) u)))
297
298(define-public (path->buffer p)
299  (with u (path-to-buffer p)
300    (and (not (url-none? u)) u)))
301
302(define-public (buffer->tree u)
303  (with t (buffer-get-body u)
304    (and (tree-active? t) t)))
305
306(define-public (tree->buffer t)
307  (and-with p (tree->path t)
308    (path->buffer p)))
309
310(define-public (buffer->path u)
311  (with t (buffer->tree u)
312    (and t (tree->path t))))
313
314(define-public (buffer-exists? name)
315  (in? (url->url name) (buffer-list)))
316
317(define-public (buffer-master)
318  (buffer-get-master (current-buffer)))
319
320(define-public (buffer-in-recent-menu? u)
321  (or (not (url-rooted-tmfs? u))
322      (string-starts? (url->unix u) "tmfs://part/")))
323
324(define-public (buffer-in-menu? u)
325  (or (buffer-in-recent-menu? u)
326      (string-starts? (url->unix u) "tmfs://help/")
327      (string-starts? (url->unix u) "tmfs://remote-file/")
328      (string-starts? (url->unix u) "tmfs://apidoc/")))
329
330(define-public (window->buffer win)
331  (with u (window-to-buffer win)
332    (and (not (url-none? u)) u)))
333
334(define-public (current-view)
335  (with u (current-view-url)
336    (and (not (url-none? u)) u)))
337
338(define-public (view->window vw)
339  (with win (view->window-url vw)
340    (and (not (url-none? win)) win)))
341
342;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
343;; Redirections
344;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
345
346(define-public (tm-with-output-to-string p)
347  (cout-buffer)
348  (p)
349  (cout-unbuffer))
350