← Back to branch summary

~ubuntu-branches/ubuntu/hardy/texmacs/hardy

« back to all changes in this revision

Viewing changes to TeXmacs/progs/kernel/library/base.scm

  • Committer: Bazaar Package Importer
  • Author(s): Ralf Treinen
  • Date: 2004-04-19 20:34:00 UTC
  • Revision ID: james.westby@ubuntu.com-20040419203400-g4e34ih0315wcn8v
Tags: upstream-1.0.3-R2
Import upstream version 1.0.3-R2

Show diffs side-by-side

added added

removed removed

Lines of Context:
TeXmacs/progs/kernel/library/base.scm
 
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 and comes WITHOUT
 
9
;; ANY WARRANTY WHATSOEVER. See the file $TEXMACS_PATH/LICENSE for details.
 
10
;; If you don't have this file, write to the Free Software Foundation, Inc.,
 
11
;; 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
 
12
;;
 
13
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 
14
 
 
15
(texmacs-module (kernel library base)
 
16
  (:use (kernel texmacs tm-define))
 
17
  (:export ;; booleans
 
18
    xor-sub xor
 
19
    ;; strings
 
20
    char->string string-tail char-in-string?
 
21
    string-starts? string-ends? string-contains?
 
22
    force-string reverse-list->string string-join
 
23
    string-drop-right string-drop string-take
 
24
    string-trim string-trim-right string-trim-both
 
25
    string-concatenate string-map string-fold string-fold-right
 
26
    string-split-lines string-tokenize string-tokenize-n
 
27
    ;; functions
 
28
    compose negate
 
29
    ;; dictionaries
 
30
    fill-dictionary-entry fill-dictionary
 
31
    ;; objects
 
32
    string->object func? tuple?))
 
33
 
 
34
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 
35
;; Booleans
 
36
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 
37
 
 
38
(define (xor-sub l)
 
39
  (cond ((null? l) #f)
 
40
        ((car l) (not (xor-sub (cdr l))))
 
41
        (else (xor-sub (cdr l)))))
 
42
 
 
43
(tm-define (xor . l)
 
44
  (:type ((tuple bool) -> bool))
 
45
  (:synopsis "Exclusive or of all elements in @l.")
 
46
  (xor-sub l))
 
47
 
 
48
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 
49
;; Strings
 
50
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 
51
 
 
52
;; NOTE: guile-1.6.0 implements SRFI-13 (string library) in C.
 
53
 
 
54
(tm-define (char->string c)
 
55
  (:type (char -> string))
 
56
  (:synopsis "Convert @c to a string")
 
57
  (list->string (list c)))
 
58
 
 
59
(tm-define (string-tail s n)
 
60
  (:type (string int -> string))
 
61
  (:synopsis "Return all but the first @n chars of @s.")
 
62
  (substring s n (string-length s)))
 
63
 
 
64
(tm-define (char-in-string? c s)
 
65
  (:type (char string -> bool))
 
66
  (:synopsis "Test whether @c occurs in @s")
 
67
  (not (== (string-index s c) #f)))
 
68
 
 
69
(tm-define (string-starts? s what)
 
70
  (:type (string string -> bool))
 
71
  (:synopsis "Test whether @s starts with @what.")
 
72
  (let ((n (string-length s))
 
73
        (k (string-length what)))
 
74
    (and (>= n k) (== (substring s 0 k) what))))
 
75
 
 
76
(tm-define (string-ends? s what)
 
77
  (:type (string string -> bool))
 
78
  (:synopsis "Test whether @s ends with @what.")
 
79
  (let ((n (string-length s))
 
80
        (k (string-length what)))
 
81
    (and (>= n k) (== (substring s (- n k) n) what))))
 
82
 
 
83
(tm-define (string-contains? s what)
 
84
  (:type (string string -> bool))
 
85
  (:synopsis "Test whether @s contains @what as a substring.")
 
86
  (>= (string-search-forwards what 0 s) 0))
 
87
 
 
88
(tm-define (force-string s)
 
89
  (:type (object -> string))
 
90
  (:synopsis "Return @s if @s is a string and the empty string otherwise")
 
91
  (if (string? s) s ""))
 
92
 
 
93
(tm-define (reverse-list->string cs)    ; srfi-13
 
94
  (:type ((list char) -> string))
 
95
  (:synopsis "Efficient implementation of (compose list->string reverse).")
 
96
  ;; Not yet any more efficient, but this may be fixed in the future.
 
97
  (list->string (reverse cs)))
 
98
 
 
99
(tm-define string-join                  ; srfi-13 (subset)
 
100
  ;; (:type ... How to write that?
 
101
  (:synopsis "Concatenate elements of @ss inserting separators.")
 
102
  (case-lambda
 
103
    ((ss) (string-join ss " "))
 
104
    ((ss delim) (string-concatenate (list-intersperse ss delim)))))
 
105
 
 
106
(tm-define (string-drop-right s n)      ; srfi-13
 
107
  (:type (string int -> string))
 
108
  (:synopsis "Return all but the last @n chars of @s.")
 
109
  (substring s 0 (- (string-length s) n)))
 
110
 
 
111
(define string-drop string-tail)        ; srfi-13
 
112
 
 
113
(tm-define (string-take s n)            ; srfi-13
 
114
  (:type (string int -> string))
 
115
  (:synopsis "Return the first @n chars of @s.")
 
116
  (substring s 0 n))
 
117
 
 
118
(tm-define (string-trim s)              ; srfi-13 (subset)
 
119
  (:type (string -> string))
 
120
  (:synopsis "Remove whitespace at start of @s.")
 
121
  (list->string (list-drop-while (string->list s) char-whitespace?)))
 
122
 
 
123
(define (list-drop-right-while l pred)
 
124
  (reverse! (list-drop-while (reverse l) pred)))
 
125
 
 
126
(tm-define (string-trim-right s)        ; srfi-13 (subset)
 
127
  (:type (string -> string))
 
128
  (:synopsis "Remove whitespace at end of @s.")
 
129
  (list->string (list-drop-right-while (string->list s) char-whitespace?)))
 
130
 
 
131
(tm-define (string-trim-both s)         ; srfi-13 (subset)
 
132
  (:type (string -> string))
 
133
  (:synopsis "Remove whitespace at start and end of @s.")
 
134
  (list->string
 
135
   (list-drop-right-while
 
136
    (list-drop-while (string->list s) char-whitespace?)
 
137
    char-whitespace?)))
 
138
 
 
139
(tm-define (string-concatenate ss)      ; srfi-13
 
140
  (:type ((list string) -> string))
 
141
  (:synopsis "Append the elements of @ss toghether.")
 
142
  ;; WARNING: not portable for long lists
 
143
  (apply string-append ss))
 
144
 
 
145
(tm-define (string-map proc s)          ; srfi-13 (subset)
 
146
  (:type ((char -> char) string -> string))
 
147
  (:synopsis "Map @proc on every char of @s.")
 
148
  (list->string (map proc (string->list s))))
 
149
 
 
150
(tm-define (string-fold kons knil s)    ; srfi-13 (subset))
 
151
  (:type ((char T -> T) T string -> T))
 
152
  (:synopsis "Fundamental string iterator.")
 
153
  (list-fold kons knil (string->list s)))
 
154
 
 
155
(tm-define (string-fold-right kons knil s) ; srfi-13 (subset)
 
156
  (:type ((char T -> T) T string -> T))
 
157
  (:synopsis "Right to left fundamental string iterator.")
 
158
  (list-fold-right kons knil (string->list s)))
 
159
 
 
160
(tm-define (string-split-lines s)
 
161
  (:type (string -> (list string)))
 
162
  (:synopsis "List of substrings of @s separated by newlines.")
 
163
  (map list->string
 
164
       (list-fold-right string-split-lines/kons '(()) (string->list s))))
 
165
 
 
166
(define (string-split-lines/kons c cs+lines)
 
167
  (if (== c #\newline)
 
168
      (cons '() cs+lines)
 
169
      (cons (cons c (car cs+lines)) (cdr cs+lines))))
 
170
                
 
171
(tm-define (string-tokenize s c)
 
172
  (:type (string char -> (list string)))
 
173
  (:synopsis "Cut string @s into pieces using @c as a separator.")
 
174
  (with d (string-index s c)
 
175
    (if d
 
176
        (cons (substring s 0 d)
 
177
              (string-tokenize (substring s (+ 1 d) (string-length s)) c))
 
178
        (list s))))
 
179
 
 
180
(tm-define (string-tokenize-n s c n)
 
181
  (:type (string char int -> (list string)))
 
182
  (:synopsis "As @string-tokenize, but only cut first @n pieces")
 
183
  (with d (string-index s c)
 
184
    (if (or (= n 0) (not d))
 
185
        (list s)
 
186
        (cons (substring s 0 d)
 
187
              (string-tokenize-n (substring s (+ 1 d) (string-length s))
 
188
                                 c
 
189
                                 (- n 1))))))
 
190
 
 
191
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 
192
;; Functions
 
193
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 
194
 
 
195
(tm-define (compose g f)
 
196
  (:type ((B -> C) (A -> B) -> (A -> C)))
 
197
  (:synopsis "Compose the functions @f and @g")
 
198
  (lambda x (g (apply f x))))
 
199
 
 
200
(tm-define (negate pred?)
 
201
  (:type ((T -> bool) -> (T -> bool)))
 
202
  (:synopsis "Return the negation of @pred?.")
 
203
  (lambda args (not (apply pred? args))))
 
204
 
 
205
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 
206
;; Dictionaries
 
207
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 
208
 
 
209
(define (fill-dictionary-entry d key im)
 
210
  (if (not (null? key))
 
211
      (begin
 
212
        (ahash-set! d (car key) im)
 
213
        (fill-dictionary-entry d (cdr key) im))))
 
214
 
 
215
(tm-define (fill-dictionary d l)
 
216
  (:type (forall Key Im
 
217
           ((alias (ahash-table Key Im)) (list (cross Key Im)) ->)))
 
218
  (:synopsis "Fill hash table @d with list of entries @l")
 
219
  (:warning "Depreciated")
 
220
  (if (not (null? l))
 
221
      (begin
 
222
        (let* ((r (reverse (car l))))
 
223
          (fill-dictionary-entry d (cdr r) (car r)))
 
224
        (fill-dictionary d (cdr l)))))
 
225
 
 
226
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 
227
;; Objects
 
228
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 
229
 
 
230
(tm-define (string->object s)
 
231
  (:type (string -> object))
 
232
  (:synopsis "Parse @s and build scheme object")
 
233
  (call-with-input-string s read))
 
234
 
 
235
(tm-define (func? x f . opts)
 
236
  (:type (object symbol -> bool)
 
237
         (object symbol int -> bool))
 
238
  (:synopsis "Is @x a list with first object @f?"
 
239
             "Optionally test the length of @x.")
 
240
  (let ((n (length opts)))
 
241
    (cond ((= n 0) (and (list? x) (not (null? x)) (== (car x) f)))
 
242
          ((= n 1)
 
243
           (let ((nn (car opts)))
 
244
             (and (list? x) (not (null? x))
 
245
                  (== (car x) f) (= (length x) (+ nn 1)))))
 
246
          (else (error "Too many arguments.")))))
 
247
 
 
248
(tm-define (tuple? x . opts)
 
249
  (:type (object -> bool)
 
250
         (object symbol -> bool)
 
251
         (object symbol int -> bool))
 
252
  (:synopsis "Equivalent to @list? without options"
 
253
             "Equivalent to @func? otherwise")
 
254
  (if (null? opts)
 
255
      (list? x)
 
256
      (apply func? (cons x opts))))