source: project/release/3/srfi-29/tags/1.14.0/srfi-29.scm @ 13898

Last change on this file since 13898 was 13898, checked in by Kon Lovett, 12 years ago

Release.

File size: 12.0 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
7;; necessary but 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 of the SRFI is ill-defined, which
13;; symbol means what?
14;;
15;; - Possible race condition creating a bundle file or directory
16
17;; Default Bundles Directory is '(repository-path) "srfi-29-bundles"'.
18
19;; Within the bundle directory the structure
20;; is [(language) [(country) [(details)]] (module).
21
22(eval-when (compile)
23  (declare
24    (usual-integrations)
25    (disable-interrupts) ; We got shared data
26    (fixnum)
27    (inline)
28    (no-procedure-checks)
29    (bound-to-procedure ; Forward references
30      most-specific-bundle-specifier
31      invalidate-package-bundle-cache )
32    (export
33      ; SRFI 29
34      current-language
35      current-country
36      current-locale-details
37      load-bundle!
38      store-bundle!
39      declare-bundle!
40      localized-template
41      ; Extensions
42      most-specific-bundle-specifier
43      localized-template/default
44      localized-template-set!
45      remove-bundle!
46      undeclare-bundle!
47      reset-locale-parameters
48      remove-bundle-directory!
49      load-best-available-bundle!
50      current-locale-format-function
51      localized-format ) ) )
52
53(require-extension srfi-1 srfi-12 srfi-13 posix files miscmacros lookup-table locale misc-extn-directory)
54
55(register-feature! 'srfi-29)
56
57;;;
58
59;;
60
61(define (display/port obj port)
62  (cond ((port? port)                     (display obj port))
63        ((or (string? port) (not port))   (->string obj))
64        (else                             (display obj) ) ) )
65
66;;
67
68(define-inline (%->symbol obj) (string->symbol (->string obj)))
69
70;; Constants
71
72(define-constant DEFAULT-BUNDLE-DIR "srfi-29-bundles")
73
74;; System bundles are here:
75
76(define SYSTEM-BUNDLES (make-pathname (repository-path) DEFAULT-BUNDLE-DIR))
77
78;;
79
80(define (make-exn-condition loc msg args)
81  (make-property-condition 'exn 'message msg 'location loc 'arguments args) )
82
83(define (make-srfi-29-condition) (make-property-condition 'srfi-29))
84
85(define (make-insufficient-condition) (make-property-condition 'insufficient))
86
87(define (make-undefined-condition) (make-property-condition 'undefined))
88
89(define (make-exn-srfi-29-condition loc msg . args)
90  (make-composite-condition
91   (make-exn-condition loc msg args)
92   (make-srfi-29-condition)) )
93
94(define (error-insufficient loc msg . args)
95  (abort
96   (make-composite-condition
97    (apply make-exn-srfi-29-condition loc msg args)
98    (make-insufficient-condition))) )
99
100(define (error-undefined loc msg . args)
101  (abort
102   (make-composite-condition
103    (apply make-exn-srfi-29-condition loc msg args)
104    (make-undefined-condition))) )
105
106;;
107
108(define-inline (%locale-item? x) (or (not x) (symbol? x)))
109
110(define-inline (%locale-details? obj) (and (list? obj) (every %locale-item? obj)))
111
112(define (coerce-locale-item obj)
113  (cond ((%locale-item? obj) obj)
114        ((string? obj)      (string->symbol (string-downcase obj)))
115        (else               (%->symbol obj) ) ) )
116
117(define (cons-locale-item lci lst)
118  (if lci (cons (symbol->string lci) lst)
119      lst ) )
120
121;; bundle-specifier: (list-of symbol)
122;; i.e. package + locale: (package-name [language] [country] [details ...])
123
124(define (bundle-specification-directory bundle-specifier)
125  (reverse! (fold cons-locale-item '() (cdr bundle-specifier))) )
126
127(define (bundle-specification-filename bundle-specifier)
128  (symbol->string (car bundle-specifier)) )
129
130(define (bundle-specification->pathname bundle-specifier)
131  (make-pathname (bundle-specification-directory bundle-specifier)
132                 (bundle-specification-filename bundle-specifier)) )
133
134(define-inline (%bundle-specification->absolute-pathname bundle-specifier alternate-dir)
135  (make-pathname
136   (optional alternate-dir SYSTEM-BUNDLES)
137   (bundle-specification->pathname bundle-specifier)) )
138
139;; Bundles Dictionary
140
141(define *localization-bundles* (make-dict equal?))
142
143(define-inline (%find-bundle bundle-specifier)
144  (dict-ref *localization-bundles* bundle-specifier) )
145
146(define-inline (%set-bundle! bundle-specifier bundle-alist)
147  (dict-set! *localization-bundles* bundle-specifier (alist->dict bundle-alist equal?)) )
148
149(define-inline (%reset-bundle! bundle-specifier)
150  (invalidate-package-bundle-cache bundle-specifier)
151  (dict-delete! *localization-bundles* bundle-specifier) )
152
153;; Package Bundle Cache
154
155(define *package-bundle-cache* (make-dict eq?))
156
157(define (invalidate-package-bundle-cache . bundle-specifier)
158  (if (null? bundle-specifier) (set! *package-bundle-cache* (make-dict eq?))
159      (dict-delete! *package-bundle-cache* (caar bundle-specifier)) ) )
160
161(define (cached-package-bundle package-name)
162  (or (dict-ref *package-bundle-cache* package-name)
163      (let loop ((specifier (remove! not (most-specific-bundle-specifier package-name))))
164        (and (not (null? specifier))
165             (if* (%find-bundle specifier)
166                  (begin
167                    (dict-set! *package-bundle-cache* package-name it)
168                    it )
169                  (loop (drop-right! specifier 1)) ) ) ) ) )
170
171;; Canonical current locale
172
173(define (locale-ref what)
174  (let ((lc (current-locale-components)))
175    (case what
176      ((details)
177        (list (locale-ref 'script) (locale-ref 'codeset) (locale-ref 'modifier)))
178      (else
179        (coerce-locale-item (locale-component-ref lc what)) ) ) ) )
180
181;;; Locale Parameters
182
183;; The default 'format' procedure
184;; Any supplied procedure MUST have the same signature as SRFI 28 'format'
185;; The initial procedure is the builtin
186
187(define-parameter current-locale-format-function format
188  (lambda (x)
189    (if (procedure? x) x
190        (begin
191          (warning 'current-locale-format-function "invalid procedure" x)
192          (current-locale-format-function) ) ) ) )
193
194;; The default language
195
196(define-parameter current-language (locale-ref 'language)
197  (lambda (x)
198    (cond ((%locale-item? x)
199           (invalidate-package-bundle-cache)
200           x )
201          (else
202           (warning 'current-language "invalid locale item" x)
203           (current-language) ) ) ) )
204
205;; The default country
206
207(define-parameter current-country (locale-ref 'region)
208  (lambda (x)
209    (cond ((%locale-item? x)
210           (invalidate-package-bundle-cache)
211           x )
212          (else
213           (warning 'current-country "invalid locale item" x)
214           (current-country) ) ) ) )
215
216;; The default locale-details
217
218(define-parameter current-locale-details (locale-ref 'details)
219  (lambda (x)
220    (cond ((%locale-details? x)
221           (invalidate-package-bundle-cache)
222           x )
223          (else
224           (warning 'current-locale-details "invalid locale item" x)
225           (current-locale-details) ) ) ) )
226
227;; If you change (current-locale), you don't have to set current-*
228;; by hand, you can simply call this procedure, and it will update
229;; those parameters to the values in the new locale. (Reset as in
230;; set anew.)
231
232(define (reset-locale-parameters)
233  (current-language (locale-ref 'language))
234  (current-country (locale-ref 'region))
235  (current-locale-details (locale-ref 'details)) )
236
237;;; Bundle Operations
238
239;; Returns the full bundle specifier for the specified package using the default locale
240
241(define (most-specific-bundle-specifier package-name)
242  `(,package-name ,(current-language) ,(current-country) ,@(current-locale-details)) )
243
244;; Returns the localized template from the most specific bundle given
245;; its' package name and a template name, if the package exists. Otherwise
246;; returns the default argument, default #f.
247
248(define (localized-template package-name template-name #!optional default)
249  (if* (cached-package-bundle package-name) (dict-ref it template-name)
250       default ) )
251
252;; Returns the localized template from the most specific bundle given
253;; its' package name and a template name, if the package exists. Otherwise
254;; returns the default argument, default is the template-name.
255
256(define (localized-template/default package-name template-name #!optional (default template-name))
257  (localized-template package-name template-name default) )
258
259;; Returns the application of the default 'format' procedure to the
260;; supplied arguments, using the package template as the format-string.
261;;
262;; When a format-string is unavailable an emergency display of the
263;; relevant details is made to proper destination.
264
265(define (localized-format package-name template-name port . fmtargs)
266
267  (define (format-info-string package-name template-name fmtargs)
268    (conc #\[ package-name #\/ template-name
269              #\space
270              (apply conc (intersperse fmtargs #\space))
271          #\]) )
272
273  (let ((fmtstr (or (localized-template package-name template-name)
274                    (and (string? template-name)
275                         template-name))))
276    (if fmtstr (apply (current-locale-format-function) port fmtstr fmtargs)
277        (display/port (format-info-string package-name template-name fmtargs) port) ) ) )
278
279;; Create or update the value for a template in an existing package.
280;; Returns #t for success & #f when no such package.
281
282(define (localized-template-set! package-name template-name value)
283  (and-let* ((bundle (cached-package-bundle package-name)))
284    (dict-set! bundle template-name value)
285    #t ) )
286
287;; Declare a bundle of templates with a given bundle specifier
288
289(define (declare-bundle! bundle-specifier bundle-alist)
290  (%set-bundle! bundle-specifier bundle-alist)
291  #t )
292
293;; Remove declared bundle, if any
294
295(define (undeclare-bundle! bundle-specifier)
296  (%reset-bundle! bundle-specifier)
297  #t )
298
299;; Error checking versions
300
301(define (need-bundle loc bundle-specifier)
302  (or (%find-bundle bundle-specifier)
303      (error-undefined loc "undeclared bundle specification" bundle-specifier)) )
304
305(define (check-bundle-specifier loc obj)
306  (unless (and (list? obj) (not (null? obj)))
307    (error-insufficient loc "null bundle specification" obj) ) )
308
309(define (need-bundle-absolute-pathname loc bundle-specifier alternate-dir)
310  (check-bundle-specifier loc bundle-specifier)
311  (%bundle-specification->absolute-pathname bundle-specifier alternate-dir) )
312
313;; Reads bundle file & declares.
314
315(define (load-bundle! bundle-specifier . alternate-dir)
316  (let ((path (need-bundle-absolute-pathname 'load-bundle! bundle-specifier alternate-dir)))
317    (and (file-exists? path)
318         (declare-bundle! bundle-specifier (with-input-from-file path read)) ) ) )
319
320;; Write bundle to file
321
322(define (store-bundle! bundle-specifier . alternate-dir)
323  (let ((path (need-bundle-absolute-pathname 'store-bundle! bundle-specifier alternate-dir))
324        (bundle (need-bundle 'store-bundle! bundle-specifier)) )
325    (create-pathname-directory path)
326    (delete-file* path)
327    (with-output-to-file path (lambda () (write (dict->alist bundle))))
328    #t ) )
329
330;; Remove declared bundle and file, if any
331
332(define (remove-bundle! bundle-specifier . alternate-dir)
333  (let ((path (need-bundle-absolute-pathname 'remove-bundle! bundle-specifier alternate-dir)))
334    (%reset-bundle! bundle-specifier)
335    (delete-file* path)
336    #t ) )
337
338;; Remove declared bundle and file, if any
339
340(define (remove-bundle-directory! bundle-specifier . alternate-dir)
341  (let ((path (need-bundle-absolute-pathname 'remove-bundle-directory! bundle-specifier alternate-dir)))
342    (delete-file* path)
343    (let ((topdir (optional alternate-dir SYSTEM-BUNDLES)))
344      (let loop ((path path))
345        (let* ((dir (pathname-directory path))
346               (fillst (directory dir)))
347          (cond ((string=? dir topdir)        #t)
348                ((positive? (length fillst))  #f)
349                (else
350                 (delete-directory dir)
351                 (loop dir) ) ) ) ) ) ) )
352
353;; Try loading from most to least specific, returns #f when failure.
354
355(define (load-best-available-bundle! bundle-specifier . alternate-dir)
356  (check-bundle-specifier 'load-best-available-bundle! bundle-specifier)
357  (let loop ((specifier (remove not bundle-specifier)))
358    (and (not (null? specifier))
359         (or (apply load-bundle! specifier alternate-dir)
360             (loop (drop-right! specifier 1)) ) ) ) )
Note: See TracBrowser for help on using the repository browser.