source: project/release/5/srfi-29/tags/3.0.2/srfi-29.scm @ 38538

Last change on this file since 38538 was 38538, checked in by Kon Lovett, 16 months ago

rel 3.0.2

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