source: project/release/4/locale/trunk/locale-components.scm @ 35426

Last change on this file since 35426 was 35426, checked in by kon, 5 months ago

add ±[0-9]+ as std-time name (but not dst-name), any name pattern match is name, add test, reflow

File size: 12.5 KB
Line 
1;;;; locale-components.scm
2;;;; Kon Lovett, May '06
3
4;; ISSUES
5;;
6;; - Components predicates are not fool-proof.
7;;
8;; - Used selectors for *-components since it is assumed extra elements
9;; will be needed by platform specific code. May switch to records later &
10;; deprecate the existing interface.
11
12(module locale-components
13
14(;export
15  ;
16  make-locale-components
17  locale-components?
18  check-locale-components error-locale-components
19  locale-components=?
20  locale-component-ref
21  locale-component-exists?
22  set-locale-component!
23  update-locale-components!
24  ;
25  make-timezone-components
26  timezone-components?
27  check-timezone-components error-timezone-components
28  set-timezone-component!
29  timezone-component-ref
30  update-timezone-components!
31  ;
32  timezone-offset?
33  check-timezone-offset error-timezone-offset
34  ;
35  make-timezone-dst-rule-julian-leap
36  timezone-dst-rule-julian-leap?
37  check-timezone-dst-rule-julian-leap-day error-timezone-dst-rule-julian-leap-day
38  ;
39  make-timezone-dst-rule-julian-noleap
40  timezone-dst-rule-julian-noleap?
41  check-timezone-dst-rule-julian-noleap-day error-timezone-dst-rule-julian-noleap-day
42  ;
43  timezone-dst-rule-julian?
44  timezone-dst-rule-julian
45  ;
46  make-timezone-dst-rule-mwd
47  timezone-dst-rule-mwd?
48  check-timezone-dst-rule-mwd error-timezone-dst-rule-mwd
49  check-timezone-dst-rule-mwd-day error-timezone-dst-rule-mwd-day
50  check-timezone-dst-rule-mwd-week error-timezone-dst-rule-mwd-week
51  check-timezone-dst-rule-mwd-month error-timezone-dst-rule-mwd-month
52  timezone-components=?
53  timezone-dst-rule-day
54  timezone-dst-rule-month
55  timezone-dst-rule-week
56  ;
57  timezone-dst-rule-offset)
58
59(import scheme chicken)
60(use
61  (only srfi-1 last-pair every alist-cons)
62  type-checks type-errors)
63
64;;;
65
66;;fx-utils
67
68(: fxnegative? (fixnum --> boolean))
69;
70(define (fxnegative? n)
71  (fx> 0 n) )
72
73(: fxabs (fixnum --> fixnum))
74;
75(define (fxabs n)
76  (if (fxnegative? n) (fxneg n) n) )
77
78;;
79
80(define-inline (->boolean obj)
81  (and obj #t))
82
83;;
84
85(define (*check-component loc pred what value)
86  (unless (pred value)
87    (error loc (make-error-type-message what) value)) )
88
89
90;;; Locale Components Operations
91
92(define-inline (*locale-component-exists? loc lc what)
93  (->boolean (assq what lc)) )
94
95(define-inline (*locale-component-ref loc lc what def)
96  (let ((cell (assq what lc)))
97    (if cell
98      (cdr cell)
99      def ) ) )
100
101; Components argument cannot be null to effect in-place modification.
102
103(define (*set-locale-component! loc lc what value checker)
104  (checker loc what value)
105  (if (null? lc)
106    (alist-cons what value lc)
107    (let ((cell (assq what lc)))
108      (cond
109        (cell
110          (set-cdr! cell value))
111        (else
112          (set-cdr! (last-pair lc) (list (cons what value)))))
113      lc ) ) )
114
115#;
116(define (*delete-locale-component! loc lc what)
117  (check-symbol loc what 'key)
118  (if (null? lc)
119    lc
120    () ) )
121
122(define (*update-locale-components! loc lc kvs checker)
123  (let loop ((kvs kvs))
124    (cond
125      ((null? kvs)
126        lc )
127      (else
128        (set! lc (*set-locale-component! loc lc (car kvs) (cadr kvs) checker))
129        (loop (cddr kvs)) ) ) ) )
130
131(define (*locale-components=? a b)
132  (or
133    (eq? a b)
134    (and
135      (fx= (length a) (length b))
136      (foldl
137        (lambda (flg elma)
138          (and
139            flg
140            (and-let* (
141              (elmb (assq (car elma) b)) )
142              (equal? (cdr elma) (cdr elmb)) ) ) )
143        #t
144        a) ) ) )
145
146;;; Locale Components
147
148(define (check-locale-component loc what value)
149  (case (check-symbol loc what 'key)
150    ((tag)
151      (*check-component loc symbol? what value) )
152    ((name)
153      ;Because anything can be a "name" need to protect against "unspecified"
154      (*check-component loc (lambda (x) (not (eq? (void) x))) what value) )
155    ((source)
156      (*check-component loc
157        (lambda (x) (or (string? x) (and (pair? x) (string? (car x)))))
158        what value) )
159    ((locales)
160      (*check-component loc
161        (lambda (x) (and (list? x) (every locale-components? x)))
162        what value) )
163    ((language)
164      (*check-component loc string? what value) )
165    ((script)
166      (*check-component loc string? what value) )
167    ((region)
168      (*check-component loc string? what value) )
169    ((country)
170      (*check-component loc string? what value) )
171    ((subdivision)
172      (*check-component loc string? what value) )
173    ((codeset)
174      (*check-component loc string? what value) )
175    ((modifier)
176      (*check-component loc string? what value) )
177    ; accept everything else
178    (else ) ) )
179
180(define (make-empty-locale-components loc tag)
181  (*set-locale-component! loc '() 'tag tag check-locale-component))
182
183(define (*make-locale-components loc nam src tag)
184  (let ((lc (make-empty-locale-components loc tag)))
185    (*set-locale-component! loc lc 'name nam check-locale-component)
186    (*set-locale-component! loc lc 'source src check-locale-component)
187    lc ) )
188
189(define (make-locale-components nam . args)
190  (let-optionals args (
191    (src #f)
192    (tag 'locale))
193    (*make-locale-components 'make-locale-components nam src tag) ) )
194
195(define (locale-components? obj)
196  (and
197    (pair? obj)
198    (*locale-component-exists? 'locale-components? obj 'tag)
199    (*locale-component-exists? 'locale-components? obj 'name)
200    (*locale-component-exists? 'locale-components? obj 'source)) )
201
202(define-check+error-type locale-components)
203
204(define (locale-components=? a b)
205  (*locale-components=?
206    (check-locale-components 'locale-components=? a)
207    (check-locale-components 'locale-components=? b)) )
208
209(define (locale-component-exists? lc what)
210  (*locale-component-exists? 'locale-component-exists?
211    (check-locale-components 'locale-component-exists? lc)
212    what) )
213
214(define (locale-component-ref lc what . def)
215  (*locale-component-ref 'locale-component-ref
216    (check-locale-components 'locale-component-ref lc)
217    what (optional def #f)) )
218
219(define (set-locale-component! lc what value)
220  (*set-locale-component! 'set-locale-component!
221    (check-locale-components 'set-locale-component! lc)
222    what value check-locale-component) )
223
224#;
225(define (delete-locale-component! lc what)
226  (*delete-locale-component! 'delete-locale-component!
227    (check-locale-components 'delete-locale-component! lc)
228    what check-locale-component) )
229
230(define (update-locale-components! lc . args)
231  (*update-locale-components! 'update-locale-components!
232    (check-locale-components 'update-locale-components! lc)
233    args check-locale-component) )
234
235;;; Timezone Daylight Saving Time Rule
236
237;; Offset
238
239(define-constant SEC/DY 86400)
240(define (timezone-offset? obj)
241  (and
242    (fixnum? obj)
243    (let (
244      (atzo (fxabs obj)) )
245      (and (fx<= 0 atzo) (fx< atzo SEC/DY)))) )
246
247(define-check+error-type timezone-offset)
248
249;;
250
251;The Julian day n (1 <= n <= 365).  Leap days are not counted; that is, in all
252;years -- including leap years -- February 28 is day 59 and March 1 is day 60.
253;It is impossible to explicitly refer to the occasional February 29.
254
255(define-record-type timezone-dst-rule-julian-noleap
256  (%make-timezone-dst-rule-julian-noleap j o)
257  timezone-dst-rule-julian-noleap?
258  (j timezone-dst-rule-julian-noleap-day)
259  (o timezone-dst-rule-julian-noleap-offset) )
260
261(define (timezone-dst-rule-julian-noleap-day? obj)
262  (and (fixnum? obj) (<= 1 obj 365)) )
263
264(define-check+error-type timezone-dst-rule-julian-noleap-day)
265
266(define (make-timezone-dst-rule-julian-noleap j o)
267  (%make-timezone-dst-rule-julian-noleap
268  (check-timezone-dst-rule-julian-noleap-day 'make-timezone-dst-rule-julian-noleap j)
269  (check-timezone-offset 'make-timezone-dst-rule-julian-noleap o)) )
270
271;;
272
273;The zero-based Julian day (0 <= n <= 365 ). Leap days are counted, and it is
274;possible to refer to February 29.
275
276(define-record-type timezone-dst-rule-julian-leap
277  (%make-timezone-dst-rule-julian-leap j o)
278  timezone-dst-rule-julian-leap?
279  (j timezone-dst-rule-julian-leap-day)
280  (o timezone-dst-rule-julian-leap-offset) )
281
282(define (timezone-dst-rule-julian-leap-day? obj)
283  (and (fixnum? obj) (<= 0 obj 365)) )
284
285(define-check+error-type timezone-dst-rule-julian-leap-day)
286
287(define (make-timezone-dst-rule-julian-leap j o)
288  (%make-timezone-dst-rule-julian-leap
289  (check-timezone-dst-rule-julian-leap-day 'make-timezone-dst-rule-julian-leap j)
290  (check-timezone-offset 'make-timezone-dst-rule-julian-leap o)) )
291
292;;
293
294(define (timezone-dst-rule-julian? r)
295  (or (timezone-dst-rule-julian-noleap? r) (timezone-dst-rule-julian-leap? r)) )
296
297(define-error-type timezone-dst-rule-julian)
298
299(define (timezone-dst-rule-julian r)
300  (cond
301    ((timezone-dst-rule-julian-noleap? r)
302      (timezone-dst-rule-julian-noleap-day r))
303    ((timezone-dst-rule-julian-leap? r)
304      (timezone-dst-rule-julian-leap-day r))
305    (else
306      (error-timezone-dst-rule-julian 'timezone-dst-rule-julian r) ) ) )
307
308;;
309
310;The d'th day (0 <= d <= 6) of week n of month m of the year (1 <= n <= 5), (1
311;<= m <= 12), where week 5 means ``the last d day in month m'' which may occur
312;in either the fourth or the fifth week).  Week 1 is the first week in which the
313;d'th day occurs.  Day zero is Sunday.
314
315(define-record-type timezone-dst-rule-mwd
316  (%make-timezone-dst-rule-mwd m w d o)
317  timezone-dst-rule-mwd?
318  (m timezone-dst-rule-mwd-month)
319  (w timezone-dst-rule-mwd-week)
320  (d timezone-dst-rule-mwd-day)
321  (o timezone-dst-rule-mwd-offset) )
322
323(define (timezone-dst-rule-mwd-day? obj)
324  (and (fixnum? obj) (<= 0 obj 6)) )
325
326(define (timezone-dst-rule-mwd-week? obj)
327  (and (fixnum? obj) (<= 1 obj 5)) )
328
329(define (timezone-dst-rule-mwd-month? obj)
330  (and (fixnum? obj) (<= 1 obj 12)) )
331
332(define-check+error-type timezone-dst-rule-mwd-day)
333(define-check+error-type timezone-dst-rule-mwd-week)
334(define-check+error-type timezone-dst-rule-mwd-month)
335
336(define-check+error-type timezone-dst-rule-mwd)
337
338(define (make-timezone-dst-rule-mwd m w d o)
339  (%make-timezone-dst-rule-mwd
340    (check-timezone-dst-rule-mwd-month 'make-timezone-dst-rule-mwd m)
341    (check-timezone-dst-rule-mwd-week 'make-timezone-dst-rule-mwd w)
342    (check-timezone-dst-rule-mwd-day 'make-timezone-dst-rule-mwd d)
343    (check-timezone-offset 'make-timezone-dst-rule-mwd o)) )
344
345(define (timezone-dst-rule-month r)
346  (timezone-dst-rule-mwd-month
347    (check-timezone-dst-rule-mwd 'timezone-dst-rule-month r)) )
348
349(define (timezone-dst-rule-week r)
350  (timezone-dst-rule-mwd-week
351    (check-timezone-dst-rule-mwd 'timezone-dst-rule-week r)) )
352
353(define (timezone-dst-rule-day r)
354  (timezone-dst-rule-mwd-day
355    (check-timezone-dst-rule-mwd 'timezone-dst-rule-day r)) )
356
357;;
358
359(define (timezone-dst-rule? obj)
360  (or
361    (timezone-dst-rule-julian-noleap? obj)
362    (timezone-dst-rule-julian-leap? obj)
363    (timezone-dst-rule-mwd? obj) ) )
364
365(define-error-type timezone-dst-rule)
366
367(define (timezone-dst-rule-offset r)
368  (cond
369    ((timezone-dst-rule-julian-noleap? r)
370      (timezone-dst-rule-julian-noleap-offset r))
371    ((timezone-dst-rule-julian-leap? r)
372      (timezone-dst-rule-julian-leap-offset r))
373    ((timezone-dst-rule-mwd? r)
374      (timezone-dst-rule-mwd-offset r))
375    (else
376      (error-timezone-dst-rule 'timezone-dst-rule-offset r) ) ) )
377
378;;; Timezone Components
379
380(define (check-timezone-component loc what value)
381  (case (check-symbol loc what 'key)
382    ((std-name)
383      (*check-component loc string? what value) )
384    ((std-offset)
385      (*check-component loc timezone-offset? what value) )
386    ((dst-name)
387      (*check-component loc string? what value) )
388    ((dst-offset)
389      (*check-component loc timezone-offset? what value) )
390    ((dst-start)
391      (*check-component loc timezone-dst-rule? what value) )
392    ((dst-end)
393      (*check-component loc timezone-dst-rule? what value) )
394    ; accept everything else
395    (else ) ) )
396
397(define (make-timezone-components nam . src)
398  (*make-locale-components 'make-timezone-components nam (optional src #f) 'timezone) )
399
400(define (timezone-components? obj)
401  (and (locale-components? obj)
402       (eq? 'timezone (*locale-component-ref 'timezone-components? obj 'tag #f))) )
403
404(define-check+error-type timezone-components)
405
406(define (timezone-components=? a b)
407  (check-timezone-components 'timezone-components=? a)
408  (check-timezone-components 'timezone-components=? b)
409  (*locale-components=? a b) )
410
411(define (timezone-component-ref tz what . def)
412  (check-timezone-components 'timezone-component-ref tz)
413  (*locale-component-ref 'timezone-component-ref tz what (optional def #f)) )
414
415(define (set-timezone-component! tz what value)
416  (check-timezone-components 'set-timezone-component! tz)
417  (*set-locale-component! 'set-timezone-component! tz what value check-timezone-component) )
418
419(define (update-timezone-components! tz . args)
420  (check-timezone-components 'update-timezone-components! tz)
421  (*update-locale-components! 'update-timezone-components! tz args check-timezone-component) )
422
423) ;module locale-components
Note: See TracBrowser for help on using the repository browser.