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

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

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 (
97    (cell (assq what lc)) )
98    (if cell
99      (cdr cell)
100      def ) ) )
101
102; Components argument cannot be null to effect in-place modification.
103
104(define (*set-locale-component! loc lc what value checker)
105  (checker loc what value)
106  (if (null? lc)
107    (alist-cons what value lc)
108    (let (
109      (cell (assq what lc)) )
110      (cond
111        (cell
112          (set-cdr! cell value))
113        (else
114          (set-cdr! (last-pair lc) (list (cons what value)))) )
115      lc ) ) )
116
117#;
118(define (*delete-locale-component! loc lc what)
119  (check-symbol loc what 'key)
120  (if (null? lc)
121    lc
122    () ) )
123
124(define (*update-locale-components! loc lc kvs checker)
125  (let loop ((kvs kvs))
126    (cond
127      ((null? kvs)
128        lc )
129      (else
130        (set! lc (*set-locale-component! loc lc (car kvs) (cadr kvs) checker))
131        (loop (cddr kvs)) ) ) ) )
132
133(define (*locale-components=? a b)
134  (or
135    (eq? a b)
136    (and
137      (fx= (length a) (length b))
138      (foldl
139        (lambda (flg elma)
140          (and
141            flg
142            (and-let* (
143              (elmb (assq (car elma) b)) )
144              (equal? (cdr elma) (cdr elmb)) ) ) )
145        #t
146        a) ) ) )
147
148;;; Locale Components
149
150(define (check-locale-component loc what value)
151  (case (check-symbol loc what 'key)
152    ((tag)
153      (*check-component loc symbol? what value) )
154    ((name)
155      ;Because anything can be a "name" need to protect against "unspecified"
156      (*check-component loc (lambda (x) (not (eq? (void) x))) what value) )
157    ((source)
158      (*check-component loc
159        (lambda (x) (or (string? x) (and (pair? x) (string? (car x)))))
160        what value) )
161    ((locales)
162      (*check-component loc
163        (lambda (x) (and (list? x) (every locale-components? x)))
164        what value) )
165    ((language)
166      (*check-component loc string? what value) )
167    ((script)
168      (*check-component loc string? what value) )
169    ((region)
170      (*check-component loc string? what value) )
171    ((country)
172      (*check-component loc string? what value) )
173    ((subdivision)
174      (*check-component loc string? what value) )
175    ((codeset)
176      (*check-component loc string? what value) )
177    ((modifier)
178      (*check-component loc string? what value) )
179    ; accept everything else
180    (else ) ) )
181
182(define (make-empty-locale-components loc tag)
183  (*set-locale-component! loc '() 'tag tag check-locale-component))
184
185(define (*make-locale-components loc nam src tag)
186  (let ((lc (make-empty-locale-components loc tag)))
187    (*set-locale-component! loc lc 'name nam check-locale-component)
188    (*set-locale-component! loc lc 'source src check-locale-component)
189    lc ) )
190
191(define (make-locale-components nam . args)
192  (let-optionals args (
193    (src #f)
194    (tag 'locale))
195    (*make-locale-components 'make-locale-components nam src tag) ) )
196
197(define (locale-components? obj)
198  (and
199    (pair? obj)
200    (*locale-component-exists? 'locale-components? obj 'tag)
201    (*locale-component-exists? 'locale-components? obj 'name)
202    (*locale-component-exists? 'locale-components? obj 'source)) )
203
204(define-check+error-type locale-components)
205
206(define (locale-components=? a b)
207  (*locale-components=?
208    (check-locale-components 'locale-components=? a)
209    (check-locale-components 'locale-components=? b)) )
210
211(define (locale-component-exists? lc what)
212  (*locale-component-exists? 'locale-component-exists?
213    (check-locale-components 'locale-component-exists? lc)
214    what) )
215
216(define (locale-component-ref lc what . def)
217  (*locale-component-ref 'locale-component-ref
218    (check-locale-components 'locale-component-ref lc)
219    what (optional def #f)) )
220
221(define (set-locale-component! lc what value)
222  (*set-locale-component! 'set-locale-component!
223    (check-locale-components 'set-locale-component! lc)
224    what value check-locale-component) )
225
226#;
227(define (delete-locale-component! lc what)
228  (*delete-locale-component! 'delete-locale-component!
229    (check-locale-components 'delete-locale-component! lc)
230    what check-locale-component) )
231
232(define (update-locale-components! lc . args)
233  (*update-locale-components! 'update-locale-components!
234    (check-locale-components 'update-locale-components! lc)
235    args check-locale-component) )
236
237;;; Timezone Daylight Saving Time Rule
238
239;; Offset
240
241(define-constant SEC/DY 86400)
242(define (timezone-offset? obj)
243  (and
244    (fixnum? obj)
245    (let (
246      (atzo (fxabs obj)) )
247      (and (fx<= 0 atzo) (fx< atzo SEC/DY)))) )
248
249(define-check+error-type timezone-offset)
250
251;;
252
253;The Julian day n (1 <= n <= 365).  Leap days are not counted; that is, in all
254;years -- including leap years -- February 28 is day 59 and March 1 is day 60.
255;It is impossible to explicitly refer to the occasional February 29.
256
257(define-record-type timezone-dst-rule-julian-noleap
258  (%make-timezone-dst-rule-julian-noleap j o)
259  timezone-dst-rule-julian-noleap?
260  (j timezone-dst-rule-julian-noleap-day)
261  (o timezone-dst-rule-julian-noleap-offset) )
262
263(define (timezone-dst-rule-julian-noleap-day? obj)
264  (and (fixnum? obj) (<= 1 obj 365)) )
265
266(define-check+error-type timezone-dst-rule-julian-noleap-day)
267
268(define (make-timezone-dst-rule-julian-noleap j o)
269  (%make-timezone-dst-rule-julian-noleap
270    (check-timezone-dst-rule-julian-noleap-day 'make-timezone-dst-rule-julian-noleap j)
271    (check-timezone-offset 'make-timezone-dst-rule-julian-noleap o)) )
272
273;;
274
275;The zero-based Julian day (0 <= n <= 365 ). Leap days are counted, and it is
276;possible to refer to February 29.
277
278(define-record-type timezone-dst-rule-julian-leap
279  (%make-timezone-dst-rule-julian-leap j o)
280  timezone-dst-rule-julian-leap?
281  (j timezone-dst-rule-julian-leap-day)
282  (o timezone-dst-rule-julian-leap-offset) )
283
284(define (timezone-dst-rule-julian-leap-day? obj)
285  (and (fixnum? obj) (<= 0 obj 365)) )
286
287(define-check+error-type timezone-dst-rule-julian-leap-day)
288
289(define (make-timezone-dst-rule-julian-leap j o)
290  (%make-timezone-dst-rule-julian-leap
291    (check-timezone-dst-rule-julian-leap-day 'make-timezone-dst-rule-julian-leap j)
292    (check-timezone-offset 'make-timezone-dst-rule-julian-leap o)) )
293
294;;
295
296(define (timezone-dst-rule-julian? r)
297  (or (timezone-dst-rule-julian-noleap? r) (timezone-dst-rule-julian-leap? r)) )
298
299(define-error-type timezone-dst-rule-julian)
300
301(define (timezone-dst-rule-julian r)
302  (cond
303    ((timezone-dst-rule-julian-noleap? r)
304      (timezone-dst-rule-julian-noleap-day r))
305    ((timezone-dst-rule-julian-leap? r)
306      (timezone-dst-rule-julian-leap-day r))
307    (else
308      (error-timezone-dst-rule-julian 'timezone-dst-rule-julian r) ) ) )
309
310;;
311
312;The d'th day (0 <= d <= 6) of week n of month m of the year (1 <= n <= 5), (1
313;<= m <= 12), where week 5 means ``the last d day in month m'' which may occur
314;in either the fourth or the fifth week).  Week 1 is the first week in which the
315;d'th day occurs.  Day zero is Sunday.
316
317(define-record-type timezone-dst-rule-mwd
318  (%make-timezone-dst-rule-mwd m w d o)
319  timezone-dst-rule-mwd?
320  (m timezone-dst-rule-mwd-month)
321  (w timezone-dst-rule-mwd-week)
322  (d timezone-dst-rule-mwd-day)
323  (o timezone-dst-rule-mwd-offset) )
324
325(define (timezone-dst-rule-mwd-day? obj)
326  (and (fixnum? obj) (<= 0 obj 6)) )
327
328(define (timezone-dst-rule-mwd-week? obj)
329  (and (fixnum? obj) (<= 1 obj 5)) )
330
331(define (timezone-dst-rule-mwd-month? obj)
332  (and (fixnum? obj) (<= 1 obj 12)) )
333
334(define-check+error-type timezone-dst-rule-mwd-day)
335(define-check+error-type timezone-dst-rule-mwd-week)
336(define-check+error-type timezone-dst-rule-mwd-month)
337
338(define-check+error-type timezone-dst-rule-mwd)
339
340(define (make-timezone-dst-rule-mwd m w d o)
341  (%make-timezone-dst-rule-mwd
342    (check-timezone-dst-rule-mwd-month 'make-timezone-dst-rule-mwd m)
343    (check-timezone-dst-rule-mwd-week 'make-timezone-dst-rule-mwd w)
344    (check-timezone-dst-rule-mwd-day 'make-timezone-dst-rule-mwd d)
345    (check-timezone-offset 'make-timezone-dst-rule-mwd o)) )
346
347(define (timezone-dst-rule-month r)
348  (timezone-dst-rule-mwd-month
349    (check-timezone-dst-rule-mwd 'timezone-dst-rule-month r)) )
350
351(define (timezone-dst-rule-week r)
352  (timezone-dst-rule-mwd-week
353    (check-timezone-dst-rule-mwd 'timezone-dst-rule-week r)) )
354
355(define (timezone-dst-rule-day r)
356  (timezone-dst-rule-mwd-day
357    (check-timezone-dst-rule-mwd 'timezone-dst-rule-day r)) )
358
359;;
360
361(define (timezone-dst-rule? obj)
362  (or
363    (timezone-dst-rule-julian-noleap? obj)
364    (timezone-dst-rule-julian-leap? obj)
365    (timezone-dst-rule-mwd? obj) ) )
366
367(define-error-type timezone-dst-rule)
368
369(define (timezone-dst-rule-offset r)
370  (cond
371    ((timezone-dst-rule-julian-noleap? r)
372      (timezone-dst-rule-julian-noleap-offset r))
373    ((timezone-dst-rule-julian-leap? r)
374      (timezone-dst-rule-julian-leap-offset r))
375    ((timezone-dst-rule-mwd? r)
376      (timezone-dst-rule-mwd-offset r))
377    (else
378      (error-timezone-dst-rule 'timezone-dst-rule-offset r) ) ) )
379
380;;; Timezone Components
381
382(define (check-timezone-component loc what value)
383  (case (check-symbol loc what 'key)
384    ((std-name)
385      (*check-component loc string? what value) )
386    ((std-offset)
387      (*check-component loc timezone-offset? what value) )
388    ((dst-name)
389      (*check-component loc string? what value) )
390    ((dst-offset)
391      (*check-component loc timezone-offset? what value) )
392    ((dst-start)
393      (*check-component loc timezone-dst-rule? what value) )
394    ((dst-end)
395      (*check-component loc timezone-dst-rule? what value) )
396    ; accept everything else
397    (else ) ) )
398
399(define (make-timezone-components nam . src)
400  (*make-locale-components 'make-timezone-components nam (optional src #f) 'timezone) )
401
402(define (timezone-components? obj)
403  (and
404    (locale-components? obj)
405    (eq? 'timezone (*locale-component-ref 'timezone-components? obj 'tag #f))) )
406
407(define-check+error-type timezone-components)
408
409(define (timezone-components=? a b)
410  (*locale-components=?
411    (check-timezone-components 'timezone-components=? a)
412    (check-timezone-components 'timezone-components=? b)) )
413
414(define (timezone-component-ref tz what . def)
415  (*locale-component-ref 'timezone-component-ref
416    (check-timezone-components 'timezone-component-ref tz)
417    what (optional def #f)) )
418
419(define (set-timezone-component! tz what value)
420  (*set-locale-component! 'set-timezone-component!
421    (check-timezone-components 'set-timezone-component! tz)
422    what value check-timezone-component) )
423
424(define (update-timezone-components! tz . args)
425  (*update-locale-components! 'update-timezone-components!
426    (check-timezone-components 'update-timezone-components! tz)
427    args check-timezone-component) )
428
429) ;module locale-components
Note: See TracBrowser for help on using the repository browser.