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

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

Parse errors are now failures. Added type checking for components. Made posix tz name be almost anything.

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