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

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

Chgd to "new" arg order for 'make-dict'.

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