source: project/release/3/srfi-29/trunk/srfi-29.scm @ 10024

Last change on this file since 10024 was 10024, checked in by Kon Lovett, 13 years ago

Register feature

File size: 10.1 KB
Line 
1;;;; srfi-29.scm
2;;;; Kon Lovett, Dec '05
3
4;; ISSUES
5;;
6;; - Bit of a dither about (disable-interrupts). Suspect not really necessary but
7;; w/o the binary grows by ~10%!
8;;
9;; - Locale component symbols must have lowercase printname, as
10;; such they do not truely reflect ISO 639-1 & ISO 3166-1.
11;;
12;; - The locale details component is ill-defined, which symbol means what?
13;;
14;; - Possible race condition creating a bundle file or directory
15
16;; Default Bundles Directory is '(repository-path) "srfi-29-bundles"'.
17
18;; Within the bundle directory the structure
19;; is [(language) [(country) [(details)]]] (module).
20
21(eval-when (compile)
22  (declare
23    (usual-integrations)
24    (disable-interrupts) ; We got shared data
25    (fixnum)
26    (inline)
27    (no-procedure-checks)
28    (no-bound-checks)
29    (bound-to-procedure
30      most-specific-bundle-specifier )
31    (export
32      ;; Extensions
33      most-specific-bundle-specifier
34      localized-template/default
35      localized-template-set!
36      remove-bundle!
37      undeclare-bundle!
38      reset-locale-parameters
39      remove-bundle-directory!
40      load-best-available-bundle!
41      current-locale-format-function
42      localized-format
43      ;; SRFI 29
44      current-language
45      current-country
46      current-locale-details
47      load-bundle!
48      store-bundle!
49      declare-bundle!
50      localized-template ) ) )
51
52(use srfi-1 srfi-12 srfi-13 posix extras utils
53     miscmacros lookup-table locale misc-extn-directory)
54
55(register-feature! 'srfi-29)
56
57;;;
58
59;;
60
61(define-inline (->symbol obj)
62  (string->symbol (->string obj)) )
63
64;; Constants
65
66(define-constant DEFAULT-BUNDLE-DIR "srfi-29-bundles")
67
68;; System bundles are here:
69
70(define SYSTEM-BUNDLES (make-pathname (repository-path) DEFAULT-BUNDLE-DIR))
71
72;; Um, the user really should set a locale
73
74(define LANGUAGE-DEFAULT 'en)
75(define COUNTRY-DEFAULT 'us)
76
77;;
78
79(define-inline (make-srfi-29-exception loc msg . args)
80  (make-composite-condition
81   (make-property-condition 'exn 'message msg 'location loc 'arguments args)
82   (make-property-condition 'srfi-29)) )
83
84(define-inline (signal-srfi-29-exception loc msg . args)
85  (abort (apply make-srfi-29-exception loc msg args)) )
86
87;;
88
89(define-inline (locale-item? x)
90  (or (not x) (symbol? x)) )
91
92(define-inline (locale-details? obj)
93  (and (list? obj)
94       (every locale-item? obj)) )
95
96;; bundle-specifier: (list-of symbol)
97;; i.e. package + locale, (package-name [language] [country] [details ...])
98
99(define (bundle-specification->pathname bundle-specifier)
100  (if (null? bundle-specifier)
101      (signal-srfi-29-exception 'load-bundle! "must specify package name" bundle-specifier)
102      (make-pathname (reverse! (fold (lambda (x l)
103                                       (if x
104                                           (cons (symbol->string x) l)
105                                           l ) )
106                                     '()
107                                     (cdr bundle-specifier)))
108                     (symbol->string (car bundle-specifier))) ) )
109
110(define-inline (bundle-specification->absolute-pathname bundle-specifier alternate-dir)
111  (make-pathname (optional alternate-dir SYSTEM-BUNDLES)
112                 (bundle-specification->pathname bundle-specifier)) )
113
114;; Package Bundle Cache
115
116(define *package-bundle-cache* (make-dict 1 eq?))
117
118(define (invalidate-package-bundle-cache . bundle-specifier)
119  (if (not (null? bundle-specifier))
120      (dict-delete! *package-bundle-cache* (caar bundle-specifier))
121      (set! *package-bundle-cache* (make-dict 1 eq?)) ) )
122
123;; Bundles Dictionary
124
125(define *localization-bundles* (make-dict 1 equal?))
126
127(define-inline (find-bundle bundle-specifier)
128  (dict-ref *localization-bundles* bundle-specifier) )
129
130(define-inline (set-bundle! bundle-specifier bundle-alist)
131  (dict-set! *localization-bundles* bundle-specifier (alist->dict bundle-alist equal?)) )
132
133(define-inline (reset-bundle! bundle-specifier)
134  (invalidate-package-bundle-cache bundle-specifier)
135  (dict-delete! *localization-bundles* bundle-specifier) )
136
137;;
138
139(define-inline (cached-package-bundle package-name)
140  (or (dict-ref *package-bundle-cache* package-name)
141      (let loop ([specifier (remove! not (most-specific-bundle-specifier package-name))])
142        (and (not (null? specifier))
143             (if* (find-bundle specifier)
144                  (begin
145                    (dict-set! *package-bundle-cache* package-name it)
146                    it )
147                  (loop (drop-right! specifier 1)) ) ) ) ) )
148
149;; Canonical current locale
150
151(define (locale-ref what)
152  (let ([locale
153          (current-locale-components)]
154        [as-sym
155          (lambda (v)
156            (cond [(locale-item? v)  v]
157                  [(string? v)       (string->symbol (string-downcase v))]
158                  [else              (->symbol v)]) ) ] )
159    (select what
160      [('language)
161        (as-sym (locale-component-ref locale 'language LANGUAGE-DEFAULT))]
162      [('country)
163        (as-sym (locale-component-ref locale 'region COUNTRY-DEFAULT))]
164      [else
165        `(,(as-sym (locale-component-ref locale  'script))
166          ,(as-sym (locale-component-ref locale  'codeset))
167          ,(as-sym (locale-component-ref locale  'modifier))) ] ) ) )
168
169;;; Locale Parameters
170
171(define-parameter current-locale-format-function
172  format
173  (lambda (x)
174    (if (procedure? x)
175        x
176        (begin
177          (warning 'current-locale-format-function "invalid procedure" x)
178          (current-locale-format-function) ) ) ) )
179
180(define-parameter current-language
181  (locale-ref 'language)
182  (lambda (x)
183    (cond [(locale-item? x)
184           (invalidate-package-bundle-cache)
185           x ]
186          [else
187           (warning 'current-language "invalid locale item" x)
188           (current-language) ] ) ) )
189
190(define-parameter current-country
191  (locale-ref 'country)
192  (lambda (x)
193    (cond [(locale-item? x)
194           (invalidate-package-bundle-cache)
195           x ]
196          [else
197           (warning 'current-country "invalid locale item" x)
198           (current-country) ] ) ) )
199
200(define-parameter current-locale-details
201  (locale-ref 'details)
202  (lambda (x)
203    (cond [(locale-details? x)
204           (invalidate-package-bundle-cache)
205           x ]
206          [else
207            (warning 'current-locale-details "invalid locale item" x)
208            (current-locale-details) ] ) ) )
209
210;; If you change (current-locale), you don't have to set current-*
211;; by hand, you can simply call this procedure, and it will update
212;; those parameters to the values in the new locale. (Reset as in
213;; set anew.)
214
215(define (reset-locale-parameters)
216  (current-language (locale-ref 'language))
217  (current-country (locale-ref 'country))
218  (current-locale-details (locale-ref 'details)) )
219
220;;; Bundle Operations
221
222;;
223
224(define (most-specific-bundle-specifier package-name)
225  `(,package-name ,(current-language) ,(current-country) ,@(current-locale-details)) )
226
227;; Retrieve the localized template from the most specific bundle given
228;; its' package name and a template name
229
230(define (localized-template package-name template-name #!optional default)
231  (if* (cached-package-bundle package-name)
232       (dict-ref it template-name)
233       default ) )
234
235;;
236
237(define (localized-template/default package-name template-name #!optional (default template-name))
238  (localized-template package-name template-name default) )
239
240;;
241
242(define (localized-format package-name template-name port . fmtargs)
243  (let ([fmtstr (localized-template package-name template-name)])
244    (if (or fmtstr (string? template-name))
245        (apply (current-locale-format-function) port fmtstr fmtargs)
246        (let ([str (apply conc template-name #\space (intersperse fmtargs #\space))])
247          (cond [(port? port)                     (display str port)]
248                [(or (string? port) (not port))   str]
249                [else                             (display str) ] ) ) ) ) )
250
251;;
252
253(define (localized-template-set! package-name template-name value)
254  (and-let* ([bundle (cached-package-bundle package-name)])
255    (dict-set! bundle template-name value)
256    #t ) )
257
258;; Declare a bundle of templates with a given bundle specifier
259
260(define (declare-bundle! bundle-specifier bundle-alist)
261  (set-bundle! bundle-specifier bundle-alist)
262  #t )
263
264;; Remove declared bundle, if any
265
266(define (undeclare-bundle! bundle-specifier)
267  (reset-bundle! bundle-specifier)
268  #t )
269
270;; Reads bundle file & declares.
271
272(define (load-bundle! bundle-specifier . alternate-dir)
273  (let ([path (bundle-specification->absolute-pathname bundle-specifier alternate-dir)])
274    (and (file-exists? path)
275         (declare-bundle! bundle-specifier (with-input-from-file path read)) ) ) )
276
277;; Write bundle to file
278
279(define (store-bundle! bundle-specifier . alternate-dir)
280  (let ([path (bundle-specification->absolute-pathname bundle-specifier alternate-dir)]
281        [bundle (find-bundle bundle-specifier)] )
282    (unless bundle
283      (signal-srfi-29-exception 'store-bundle! "no such declared bundle" bundle-specifier) )
284    (create-pathname-directory path)
285    (delete-file* path)
286    (with-output-to-file path (lambda () (write (dict->alist bundle))))
287    #t ) )
288
289;; Remove declared bundle and file, if any
290
291(define (remove-bundle! bundle-specifier . alternate-dir)
292  (let ([path (bundle-specification->absolute-pathname bundle-specifier alternate-dir)])
293    (reset-bundle! bundle-specifier)
294    (delete-file* path)
295    #t ) )
296
297;; Remove declared bundle and file, if any
298
299(define (remove-bundle-directory! bundle-specifier . alternate-dir)
300  (let ([pathname (bundle-specification->absolute-pathname bundle-specifier alternate-dir)])
301    (delete-file* pathname)
302    (let ([topdir (optional alternate-dir SYSTEM-BUNDLES)])
303      (let loop ([path pathname])
304        (let* ([dir (pathname-directory path)]
305               [fillst (directory dir)])
306          (cond [(string=? dir topdir)        #t]
307                [(positive? (length fillst))  #f]
308                [else
309                  (delete-directory dir)
310                  (loop dir)]) ) ) ) ) )
311
312;; Try loading from most to least specific, returns #f when failure.
313
314(define (load-best-available-bundle! bundle-specifier . alternate-dir)
315  (let loop ([specifier (remove not bundle-specifier)])
316    (and (not (null? specifier))
317         (or (apply load-bundle! specifier alternate-dir)
318             (loop (drop-right! specifier 1)))) ) )
Note: See TracBrowser for help on using the repository browser.