source: project/release/5/srfi-29/trunk/srfi-29.scm @ 38454

Last change on this file since 38454 was 38454, checked in by Kon Lovett, 18 months ago

style, update comment

File size: 15.3 KB
Line 
1;;;; srfi-29.scm
2;;;; Kon Lovett, Jun '17
3;;;; Kon Lovett,
4;;;; Kon Lovett, Dec '05
5
6;; Issues
7;;
8;; - Explicit phasing !
9;;
10;; - Bit of a dither about (disable-interrupts). Suspect not really
11;; necessary but w/o the binary grows by ~10%!
12;;
13;; - Locale component symbols must have lowercase printname, as
14;; such they do not truely reflect ISO 639-1 & ISO 3166-1.
15;;
16;; - The locale details component of the SRFI is ill-defined, which
17;; symbol means what?
18;;
19;; - Possible race condition creating a bundle file or directory.
20
21(module srfi-29
22
23(;export
24  ;SRFI 29
25  current-language
26  current-country
27  current-locale-details
28  load-bundle!
29  store-bundle!
30  declare-bundle!
31  localized-template
32  ;Extensions
33  undefined-condition? unbound-variable-condition?
34  most-specific-bundle-specifier
35  required-localized-template
36  localized-template/default
37  make-required-localized-template
38  make-localized-template
39  make-localized-template/default
40  localized-template-set!
41  remove-bundle!
42  undeclare-bundle!
43  reset-locale-parameters
44  remove-bundle-directory!
45  load-best-available-bundle!
46  current-locale-format-function
47  localized-format
48  localized-templates
49  declared-bundle-specifiers
50  declared-bundle-templates
51  package-name? check-package-name error-package-name)
52
53(import scheme)
54(import (chicken base))
55(import (chicken module))
56(import utf8)
57(import (only utf8-srfi-13 string-downcase))
58(import (only (srfi 1)
59  first second third
60  reverse! every drop-right!
61  remove remove! list-copy))
62(import srfi-69)
63(import (only (srfi 69)
64  make-hash-table
65  hash-table-ref/default
66  hash-table-set! hash-table-delete!
67  hash-table->alist alist->hash-table
68  hash-table-keys))
69(import (only (chicken condition) abort make-property-condition))
70(import (only (chicken string) conc ->string))
71(import (only (chicken platform) register-feature!))
72(import (only (chicken format) format))
73(import (only (chicken pathname) make-pathname pathname-directory decompose-pathname))
74(import (only (chicken file) delete-file* create-directory delete-directory directory file-exists?))
75(import (only (chicken file posix) directory?))
76(import (only miscmacros define-parameter select))
77(import (only moremacros define-warning-parameter warning-guard))
78(import (only locale current-locale-components locale-component-ref))
79(import (only posix-utils environment-variable-true?))
80(import (only condition-utils make-condition-predicate))
81(import (only exn-condition make-exn-condition+))
82(import (only type-errors error-argument-type warning-argument-type))
83(import (only type-checks
84  check-procedure check-symbol check-string check-list
85  define-check+error-type))
86
87(import srfi-29-install)
88(reexport srfi-29-install)
89
90;;; Utilities
91
92(define (->symbol obj) (string->symbol (->string obj)))
93
94(include "locale-item")
95
96;;
97
98;; Ensure the directory for the specified path exists.
99
100(define (create-pathname-directory pn) (create-directory pn #t))
101
102;;
103
104(define-constant TLS-ENVIRONMENT-VARIABLE "SRFI29_TLS")
105
106;;
107
108(define NO-PACKAGE-TAG #(no-package))
109(define NO-TEMPLATE-TAG #(no-template))
110
111;;; Errors & Conditions
112
113;;
114
115(define (condition-undefined loc msg . args)
116  (make-exn-condition+
117    loc msg args
118    (make-property-condition 'srfi-29)
119    (make-property-condition 'undefined)) )
120
121(define (condition-unbound-variable loc sym)
122  (make-exn-condition+
123    loc "unbound variable" `(,sym)
124    (make-property-condition 'srfi-29)
125    (make-property-condition 'unbound)) )
126
127(define undefined-condition? (make-condition-predicate exn srfi-29 undefined))
128
129(define unbound-variable-condition? (make-condition-predicate exn srfi-29 unbound))
130
131;;
132
133(define (error-undefined loc msg . args)
134  (abort (apply condition-undefined loc msg args)) )
135
136(define (error-unbound-variable loc sym)
137  (abort (condition-unbound-variable loc sym)) )
138
139;;; Locale Operations
140
141(define locale-language? locale-item?)
142(define locale-country? locale-item?)
143
144(define (locale-details? obj)
145  (and (list? obj) (every locale-item? obj)) )
146
147(define-check+error-type locale-details)
148
149;; Canonical current locale
150
151(define (locale-ref what #!optional (lcs (current-locale-components)))
152  (case what
153    ((details)
154      `(,(locale-ref 'script lcs)
155        ,(locale-ref 'codeset lcs)
156        ,(locale-ref 'modifier lcs)))
157    (else
158      (->locale-item (locale-component-ref lcs what)) ) ) )
159
160;;; Bundle Specification Operations
161
162(define package-name? symbol?)
163
164(define-check+error-type package-name)
165
166(define (bundle-specifier-element? obj)
167  (or (not obj) (symbol? obj)) )
168
169;; bundle-specifier: (list-of symbol)
170;; i.e. package + locale: (package-name [language] [country] [details ...])
171
172(define (bundle-specifier? obj)
173  (and
174    (pair? obj)
175    (package-name? (car obj))
176    (every bundle-specifier-element? (cdr obj))) )
177
178(define-check+error-type bundle-specifier)
179
180;;
181
182(define (bundle-specification-directory-path bndl-spec)
183  (define (add-item ls lci)
184    (if lci
185      (cons (symbol->string lci) ls)
186      ls ) )
187  (reverse! (foldl add-item '() (cdr bndl-spec))) )
188
189(define (bundle-specification-filename bndl-spec)
190  (symbol->string (car bndl-spec)) )
191
192(define (bundle-specification->pathname bndl-spec)
193  (make-pathname
194    (bundle-specification-directory-path bndl-spec)
195    (bundle-specification-filename bndl-spec)) )
196
197(define (bundle-specification->absolute-pathname bndl-spec alt-dir)
198  (make-pathname alt-dir (bundle-specification->pathname bndl-spec)) )
199
200(define (need-bundle-absolute-pathname loc bndl-spec alt-dir)
201  (bundle-specification->absolute-pathname
202    (check-bundle-specifier loc bndl-spec)
203    alt-dir) )
204
205;; Bundles Dictionary
206
207;All declared bundles
208
209(define bundle-ref)
210(define bundle-set!)
211(define bundle-delete!)
212(define bundle-specifiers)
213(let ((+localization-bundles+ (make-hash-table equal?)))
214  ;
215  (set! bundle-ref (lambda (bndl-spec)
216    (hash-table-ref/default +localization-bundles+ bndl-spec #f) ) )
217  ;
218  (set! bundle-set! (lambda (bndl-spec bndl-alist)
219    (hash-table-set! +localization-bundles+
220      bndl-spec (alist->hash-table bndl-alist equal?)) ) )
221  ;
222  (set! bundle-delete! (lambda (bndl-spec)
223    (invalidate-package-bundle-cache bndl-spec)
224    (hash-table-delete! +localization-bundles+ bndl-spec) ) )
225  ;
226  (set! bundle-specifiers (lambda ()
227    (hash-table-keys +localization-bundles+))) )
228
229(define (need-bundle loc bndl-spec)
230  (or
231    (bundle-ref bndl-spec)
232    (error-undefined loc "undeclared bundle specification" bndl-spec)) )
233
234;; Package Bundle Cache
235
236;Most specific declared bundles that are actually used
237;A subset of the `localization-bundles'
238
239;parameter interface
240(define package-bundle-cache
241  (let ((+eq-dict+ (make-hash-table eq?)))
242    (if (environment-variable-true? TLS-ENVIRONMENT-VARIABLE)
243      ;then use a parameter for the cache so one bundle per package per thread
244      (make-parameter +eq-dict+ hash-table?)
245      ;else one bundle per package
246      (let ((*dict* +eq-dict+))
247        (case-lambda
248          (() *dict*)
249          ((new)
250            (set! *dict* new) ) ) ) ) ) )
251
252(define (invalidate-package-bundle-cache . args)
253  (if (null? args)
254    (package-bundle-cache (make-hash-table eq?))
255    ;else args is (bndl-spec)
256    (hash-table-delete! (package-bundle-cache) (caar args)) ) )
257
258(define (cached-package-bundle pkgnam)
259  (let ((pkg-dict (package-bundle-cache)))
260    (or
261      (hash-table-ref/default pkg-dict pkgnam #f)
262      (let loop ((bndl-spec (most-specific-bundle-specifier pkgnam)))
263        (and
264          (not (null? bndl-spec))
265          (let ((contents (bundle-ref bndl-spec)))
266            (if contents
267              (begin
268                (hash-table-set! pkg-dict pkgnam contents)
269                contents )
270              (loop (drop-right! bndl-spec 1)) ) ) ) ) ) ) )
271
272;;; Locale Parameters
273
274;; The default 'format' procedure
275;; Any supplied procedure MUST have the same signature as SRFI 28 'format'
276;; The initial procedure is the builtin
277
278(define-warning-parameter current-locale-format-function format procedure)
279
280;; The default language, country, and locale-details
281
282(define (make-locale-loadtime-guard chk)
283  ;ignore initial reset
284  (let ((*action* (lambda () (set! *action* invalidate-package-bundle-cache))))
285    (lambda (x)
286      (*action*)
287      (chk x) ) ) )
288
289(define-parameter current-language (locale-ref 'language)
290  (make-locale-loadtime-guard (warning-guard current-language locale-language)))
291
292(define-parameter current-country (locale-ref 'region)
293  (make-locale-loadtime-guard (warning-guard current-country locale-country)))
294
295(define-parameter current-locale-details  (locale-ref 'details)
296  (make-locale-loadtime-guard (warning-guard current-locale-details locale-details)))
297
298;; If you change (current-locale), you don't have to set current-*
299;; by hand, you can simply call this procedure, and it will update
300;; those parameters to the values in the new locale. (Reset as in
301;; set anew.)
302
303(define (reset-locale-parameters)
304  (current-language (locale-ref 'language))
305  (current-country (locale-ref 'region))
306  (current-locale-details (locale-ref 'details)) )
307
308;;; Template Operations
309
310;; Returns the localized template from the most specific bundle given
311;; its' package name and a template name.
312;; If package undefined returns the package default (defaults #f).
313;; If template undefined returns the template default (defaults #f).
314
315(define (localized-template pkgnam tplnam #!optional defpkg deftpl)
316  (let ((bundle (cached-package-bundle pkgnam)))
317    (if bundle
318      (hash-table-ref/default bundle tplnam deftpl)
319      defpkg ) ) )
320
321;; Returns the localized template from the most specific bundle given
322;; its' package name and a template name.
323;; If package undefined returns the package default (defaults template-name).
324;; If template undefined returns the template default (defaults template-name).
325
326(define (localized-template/default pkgnam tplnam #!optional (defpkg tplnam) (deftpl tplnam))
327  (localized-template pkgnam tplnam defpkg deftpl) )
328
329;; Returns the localized template from the most specific bundle given
330;; its' package name and a template name.
331;;
332;; Raises an expception for undefined elements.
333
334(define (*required-localized-template loc pkgnam tplnam)
335  (let ((res (localized-template pkgnam tplnam NO-PACKAGE-TAG NO-TEMPLATE-TAG)))
336    (select res
337      ((NO-PACKAGE-TAG)
338        (error-undefined loc "undefined package" pkgnam) )
339      ((NO-TEMPLATE-TAG)
340        (error-undefined loc "undefined template in package" tplnam pkgnam) )
341      (else
342        res ) ) ) )
343
344(define (required-localized-template pkgnam tplnam)
345  (*required-localized-template 'required-localized-template pkgnam tplnam) )
346
347;; Returns a procedure the looks up a template in a fixed package
348
349(define ((make-required-localized-template pkgnam) tplnam)
350  (required-localized-template pkgnam tplnam) )
351
352(define ((make-localized-template pkgnam) tplnam #!optional defpkg deftpl)
353  (localized-template pkgnam tplnam defpkg deftpl) )
354
355(define ((make-localized-template/default pkgnam) tplnam #!optional (defpkg tplnam) (deftpl tplnam))
356  (localized-template pkgnam tplnam) )
357
358(define (format-info-string pkgnam tplnam fmtargs)
359  (conc
360    #\[
361      #\< pkgnam #\space tplnam #\>
362      #\space
363      (apply conc (intersperse fmtargs #\space))
364    #\]) )
365
366;; Returns the application of the default 'format' procedure to the
367;; supplied arguments, using the package template as the format-string.
368;;
369;; When a format-string is unavailable an emergency display of the
370;; relevant details is made to proper destination.
371
372(define (localized-format pkgnam tplnam . fmtargs)
373  (let (
374    (fmtstr
375      (or
376        (localized-template pkgnam tplnam)
377        (and (string? tplnam) tplnam))) )
378    (if fmtstr
379      (apply (current-locale-format-function) fmtstr fmtargs)
380      (format-info-string pkgnam tplnam fmtargs) ) ) )
381
382;; Create or update the value for a template in an existing package.
383;; Returns #t for success & #f when no such package.
384
385(define (localized-template-set! pkgnam tplnam value)
386  (and-let* (
387    (bndl (cached-package-bundle pkgnam)) )
388    (hash-table-set! bndl tplnam value)
389    #t ) )
390
391;;; Bundle Operations
392
393;; Returns the full bundle specifier for the specified package using the default locale
394
395(define (most-specific-bundle-specifier pkgnam)
396  (remove!
397    not
398    `(,pkgnam ,(current-language) ,(current-country) ,@(current-locale-details))) )
399
400;; Declare a bundle of templates with a given bundle specifier
401
402(define (declare-bundle! bndl-spec bndl-alist)
403  (bundle-set!
404    (check-bundle-specifier 'declare-bundle! bndl-spec)
405    bndl-alist) )
406
407;; Remove declared bundle, if any
408
409(define (undeclare-bundle! bndl-spec)
410  (bundle-delete!
411    (check-bundle-specifier 'undeclare-bundle! bndl-spec)) )
412
413;; Portable Form
414
415(define (bundle-storage-form bndl)
416  (hash-table->alist bndl) )
417
418;; Reads bundle file & declares.
419
420(define (load-bundle! bndl-spec . args)
421  (let-optionals args (
422    (alt-dir (system-bundle-directory)) )
423    (let (
424      (path
425        (need-bundle-absolute-pathname 'load-bundle! bndl-spec alt-dir)))
426      (and
427        (file-exists? path)
428        (declare-bundle! bndl-spec (with-input-from-file path read)) ) ) ) )
429
430;; Write bundle to file
431
432(define (store-bundle! bndl-spec . args)
433  (let-optionals args (
434    (alt-dir (system-bundle-directory)) )
435    (let (
436      (path
437        (need-bundle-absolute-pathname 'store-bundle! bndl-spec alt-dir))
438      (bndl
439        (need-bundle 'store-bundle! bndl-spec)) )
440      (create-pathname-directory path)
441      (delete-file* path)
442      (with-output-to-file path (lambda () (write (bundle-storage-form bndl))))
443      #t ) ) )
444
445;; Remove declared bundle and file, if any
446
447(define (remove-bundle! bndl-spec . args)
448  (let-optionals args (
449    (alt-dir (system-bundle-directory)) )
450    (let (
451      (path
452        (need-bundle-absolute-pathname 'remove-bundle! bndl-spec alt-dir)) )
453      (bundle-delete! bndl-spec)
454      (delete-file* path)
455      #t ) ) )
456
457;; Remove declared bundle and file, if any
458
459(define (remove-bundle-directory! bndl-spec . args)
460  (let-optionals args (
461    (alt-dir (system-bundle-directory)) )
462    (let (
463      (path
464        (need-bundle-absolute-pathname 'remove-bundle-directory!
465          bndl-spec alt-dir)) )
466      ;remove leaf node
467      (delete-file* path)
468      ;remove all empty parent nodes
469      (let (
470        (topdir alt-dir) )
471        (let delete-path ((path path))
472          (let (
473            (dir (pathname-directory path)) )
474            (cond
475              ((string=? dir topdir)          #t)
476              ((not (null? (directory dir)))  #f)
477              (else
478                (delete-directory dir)
479                (delete-path dir) ) ) ) ) ) ) ) )
480
481;; Try loading from most to least specific, returns #f when failure.
482
483(define (*load-available-bundle bndl-spec alt-dir)
484  (let try-bundle ((bndl-spec bndl-spec))
485    (and
486      (not (null? bndl-spec))
487      (or
488        (load-bundle! bndl-spec alt-dir)
489        (try-bundle (drop-right! bndl-spec 1)) ) ) ) )
490
491(define (load-best-available-bundle! bndl-spec . args)
492  (let-optionals args (
493    (alt-dir (system-bundle-directory)) )
494    (*load-available-bundle
495      (check-bundle-specifier 'load-best-available-bundle! bndl-spec)
496      alt-dir) ) )
497
498;;; Introspection
499
500;;
501
502(define (localized-templates pkgnam)
503  (bundle-storage-form (cached-package-bundle pkgnam)) )
504
505;;
506
507(define (declared-bundle-specifiers)
508  (map list-copy (bundle-specifiers)) )
509
510;;
511
512(define (declared-bundle-templates bndl-spec)
513  (bundle-storage-form
514    (need-bundle 'declared-bundle-templates
515      (check-bundle-specifier 'declared-bundle-templates bndl-spec))) )
516
517;;;
518
519(register-feature! 'srfi-29)
520
521) ;module srfi-29
522
Note: See TracBrowser for help on using the repository browser.