source: project/release/4/locale/tags/0.6.3/locale-components.scm @ 15916

Last change on this file since 15916 was 15916, checked in by Kon Lovett, 11 years ago

Rel 0.6.3 - David Murray's patch for TZ envvar parsing.

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