source: project/release/4/srfi-29/trunk/srfi-29.scm @ 19349

Last change on this file since 19349 was 19349, checked in by Kon Lovett, 10 years ago

Better load

File size: 17.3 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(module srfi-29
18
19  (;export
20    ; SRFI 29
21    current-language
22    current-country
23    current-locale-details
24    load-bundle!
25    store-bundle!
26    declare-bundle!
27    localized-template
28    ; Extensions
29    undefined-condition?
30    system-bundle-directory
31    most-specific-bundle-specifier
32    !localized-template
33    localized-template/default
34    make-!localized-template
35    make-localized-template
36    make-localized-template/default
37    localized-template-set!
38    load-localized-compiled-code
39    remove-bundle!
40    undeclare-bundle!
41    reset-locale-parameters
42    remove-bundle-directory!
43    load-best-available-bundle!
44    current-locale-format-function
45    localized-format
46    localized-templates
47    declared-bundle-specifiers
48    declared-bundle-templates)
49
50  (import
51    scheme chicken
52    (only srfi-1
53      map! reverse! every drop-right!
54      remove remove! fold list-copy)
55    (only srfi-13
56      string-downcase)
57    (only extras
58      format)
59    (only data-structures
60      intersperse conc ->string)
61    (only files
62      delete-file*
63      make-pathname pathname-directory)
64    (only posix
65      directory? create-directory delete-directory directory)
66    (only lolevel
67      global-bound? global-ref)
68    (only lookup-table
69      make-dict dict-ref dict-set! dict-delete!
70      dict->alist alist->dict
71      dict-keys
72      dict-safe-mode)
73    (only miscmacros
74      define-parameter if*)
75    (only locale
76      current-locale-components locale-component-ref)
77    (only conditions
78      make-exn-condition+ make-condition-predicate)
79    (only type-errors
80      warning-argument-type)
81    (only type-checks
82      check-procedure check-symbol check-string check-list
83      define-check+error-type) )
84
85  (require-library
86    srfi-1 srfi-13 extras data-structures files posix lolevel
87    lookup-table miscmacros locale
88    conditions type-errors type-checks)
89
90  (declare
91    (bound-to-procedure ; Forward references
92      most-specific-bundle-specifier
93      invalidate-package-bundle-cache ) )
94
95;;; Utilities
96
97;;
98
99(define (->symbol obj)
100  (cond
101    ((symbol? obj)  obj )
102    ((string? obj)  (string->symbol obj) )
103    (else           (string->symbol (->string obj)) ) ) )
104
105;; Ensure the directory for the specified path exists.
106
107(define create-pathname-directory (cut create-directory <> #t))
108
109;;; Constants
110
111(define-constant DEFAULT-BUNDLE-DIR "srfi-29-bundles")
112
113;; System bundles are here:
114
115;Within the bundle directory the structure
116;is [(language) [(country) [(details)]]] (package-name).
117
118(define SYSTEM-BUNDLES (make-pathname (repository-path) DEFAULT-BUNDLE-DIR))
119
120;; Query it
121
122(define (system-bundle-directory) SYSTEM-BUNDLES)
123
124;;; Errors
125
126(define (error-undefined loc msg . args)
127  (abort
128    (make-exn-condition+
129      loc msg args
130      (make-property-condition 'srfi-29)
131      (make-property-condition 'undefined))) )
132
133(define undefined-condition? (make-condition-predicate exn srfi-29 undefined))
134
135;;; Locale Operations
136
137(define (locale-item? x) (or (not x) (symbol? x)))
138
139(define (locale-details? obj) (and (list? obj) (every locale-item? obj)))
140
141(define (coerce-locale-item obj)
142  (cond ((locale-item? obj) obj)
143        ((string? obj)      (string->symbol (string-downcase obj)))
144        (else               (->symbol obj) ) ) )
145
146(define (cons-locale-item lci lst)
147  (if lci (cons (symbol->string lci) lst)
148      lst ) )
149
150;; Canonical current locale
151
152(define (locale-ref what)
153  (let ((lc (current-locale-components)))
154    (case what
155      ((details)
156        (list (locale-ref 'script) (locale-ref 'codeset) (locale-ref 'modifier)))
157      (else
158        (coerce-locale-item (locale-component-ref lc what)) ) ) ) )
159
160;;; Bundle Specification Operations
161
162(define package-name? symbol?)
163(define-check+error-type package-name)
164
165(define (bundle-specifier-element? obj) (or (not obj) (symbol? obj)))
166(define-check+error-type bundle-specifier-element)
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 (pair? obj)
173       (package-name? (car obj))
174       (every bundle-specifier-element? (cdr obj))) )
175(define-check+error-type bundle-specifier)
176
177;;
178
179(define (bundle-specification-directory bndl-spec)
180  (reverse! (fold cons-locale-item '() (cdr bndl-spec))) )
181
182(define (bundle-specification-filename bndl-spec) (symbol->string (car bndl-spec)))
183
184(define (bundle-specification->pathname bndl-spec)
185  (make-pathname
186    (bundle-specification-directory bndl-spec)
187    (bundle-specification-filename bndl-spec)) )
188
189(define (bundle-specification->absolute-pathname bndl-spec alt-dir)
190  (make-pathname alt-dir (bundle-specification->pathname bndl-spec)) )
191
192(define (need-bundle-absolute-pathname loc bndl-spec alt-dir)
193  (bundle-specification->absolute-pathname
194    (check-bundle-specifier loc bndl-spec) alt-dir) )
195
196;; Bundles Dictionary
197
198;All declared bundles
199
200(define *localization-bundles* (make-dict equal?))
201
202(define (bundle-ref bndl-spec) (dict-ref *localization-bundles* bndl-spec))
203
204(define (bundle-set! bndl-spec bndl-alist)
205  (dict-set! *localization-bundles* bndl-spec (alist->dict bndl-alist equal?)) )
206
207(define (bundle-reset! bndl-spec)
208  (invalidate-package-bundle-cache bndl-spec)
209  (dict-delete! *localization-bundles* bndl-spec) )
210
211(define (*bundle-specifiers) (dict-keys *localization-bundles*))
212
213(define (need-bundle loc bndl-spec)
214  (or (bundle-ref bndl-spec)
215      (error-undefined loc "undeclared bundle specification" bndl-spec)) )
216
217;; Package Bundle Cache
218
219;Most specific declared bundles that are actually used
220;A subset of the *localization-bundles*
221
222(define *package-bundle-cache* (make-dict eq?))
223
224(define (invalidate-package-bundle-cache . bndl-spec)
225  (if (null? bndl-spec) (set! *package-bundle-cache* (make-dict eq?))
226      (dict-delete! *package-bundle-cache* (caar bndl-spec)) ) )
227
228(define (cached-package-bundle pkgnam)
229  (or (dict-ref *package-bundle-cache* pkgnam)
230      (let loop ((bndl-spec (remove! not (most-specific-bundle-specifier pkgnam))))
231        (and (not (null? bndl-spec))
232             (if* (bundle-ref bndl-spec)
233                  (begin
234                    (dict-set! *package-bundle-cache* pkgnam it)
235                    it )
236                  (loop (drop-right! bndl-spec 1)) ) ) ) ) )
237
238;;; Locale Parameters
239
240;; The default 'format' procedure
241;; Any supplied procedure MUST have the same signature as SRFI 28 'format'
242;; The initial procedure is the builtin
243
244(define-parameter current-locale-format-function format
245  (lambda (x)
246    (if (procedure? x) x
247        (begin
248          (warning-argument-type 'current-locale-format-function x 'procedure)
249          (current-locale-format-function) ) ) ) )
250
251;; The default language
252
253(define-parameter current-language (locale-ref 'language)
254  (lambda (x)
255    (cond ((locale-item? x)
256           (invalidate-package-bundle-cache)
257           x )
258          (else
259           (warning-argument-type 'current-language x 'locale-item)
260           (current-language) ) ) ) )
261
262;; The default country
263
264(define-parameter current-country (locale-ref 'region)
265  (lambda (x)
266    (cond ((locale-item? x)
267           (invalidate-package-bundle-cache)
268           x )
269          (else
270           (warning-argument-type 'current-country x 'locale-item)
271           (current-country) ) ) ) )
272
273;; The default locale-details
274
275(define-parameter current-locale-details (locale-ref 'details)
276  (lambda (x)
277    (cond ((locale-details? x)
278           (invalidate-package-bundle-cache)
279           x )
280          (else
281           (warning-argument-type 'current-locale-details x 'locale-details)
282           (current-locale-details) ) ) ) )
283
284;; If you change (current-locale), you don't have to set current-*
285;; by hand, you can simply call this procedure, and it will update
286;; those parameters to the values in the new locale. (Reset as in
287;; set anew.)
288
289(define (reset-locale-parameters)
290  (current-language (locale-ref 'language))
291  (current-country (locale-ref 'region))
292  (current-locale-details (locale-ref 'details)) )
293
294;;; Template Operations
295
296;; Returns the localized template from the most specific bundle given
297;; its' package name and a template name.
298;; If package undefined returns the package default (defaults #f).
299;; If template undefined returns the template default (defaults #f).
300
301(define (localized-template pkgnam tptnam #!optional defpkg deftpt)
302  (if* (cached-package-bundle pkgnam) (dict-ref it tptnam deftpt)
303       defpkg ) )
304
305;; Returns the localized template from the most specific bundle given
306;; its' package name and a template name.
307;; If package undefined returns the package default (defaults template-name).
308;; If template undefined returns the template default (defaults template-name).
309
310(define (localized-template/default pkgnam tptnam #!optional (defpkg tptnam) (deftpt tptnam))
311  (localized-template pkgnam tptnam defpkg deftpt) )
312
313;; Returns the localized template from the most specific bundle given
314;; its' package name and a template name.
315;;
316;; Raises an expception for undefined elements.
317
318(define +no-package-tag+ (vector 'no-package))
319(define +no-template-tag+ (vector 'no-template))
320
321(define (*!localized-template loc pkgnam tptnam)
322  (let ((res (localized-template pkgnam tptnam +no-package-tag+ +no-template-tag+)))
323    (cond
324      ((eq? res +no-package-tag+)
325        (error-undefined loc "undefined package" pkgnam) )
326      ((eq? res +no-template-tag+)
327        (error-undefined loc "undefined template in package" tptnam pkgnam) )
328      (else
329        res ) ) ) )
330
331(define (!localized-template pkgnam tptnam)
332  (*!localized-template '!localized-template pkgnam tptnam) )
333
334;; Returns a procedure the looks up a template in a fixed package
335
336(define ((make-!localized-template pkgnam) tptnam)
337  (!localized-template pkgnam tptnam) )
338
339(define ((make-localized-template pkgnam) tptnam #!optional defpkg deftpt)
340  (localized-template pkgnam tptnam defpkg deftpt) )
341
342(define ((make-localized-template/default pkgnam) tptnam #!optional (defpkg tptnam) (deftpt tptnam))
343  (localized-template pkgnam tptnam) )
344
345;; Returns the application of the default 'format' procedure to the
346;; supplied arguments, using the package template as the format-string.
347;;
348;; When a format-string is unavailable an emergency display of the
349;; relevant details is made to proper destination.
350
351(define (localized-format pkgnam tptnam . fmtargs)
352
353  (define (format-info-string pkgnam tptnam fmtargs)
354    (conc #\[ #\< pkgnam #\space tptnam #\>
355              #\space
356              (apply conc (intersperse fmtargs #\space))
357          #\]) )
358
359  (let ((fmtstr (or (localized-template pkgnam tptnam)
360                    (and (string? tptnam)
361                         tptnam))))
362    (if fmtstr (apply (current-locale-format-function) fmtstr fmtargs)
363        (format-info-string pkgnam tptnam fmtargs) ) ) )
364
365;; Create or update the value for a template in an existing package.
366;; Returns #t for success & #f when no such package.
367
368(define (localized-template-set! pkgnam tptnam value)
369  (and-let* ((bndl (cached-package-bundle pkgnam)))
370    (dict-set! bndl tptnam value)
371    #t ) )
372
373;;; "Logic Bundle"
374
375;association-list pair -> value
376;(key . (value ...))
377;(key . value)
378
379(define (alist-element-atomic-value p)
380  (if (pair? (cdr p)) (cadr p) (cdr p)) )
381
382(define (template-identifier-name? obj)
383  (or (symbol? obj)
384      (and (pair? obj)
385           (symbol? (car obj))
386           (symbol? (alist-element-atomic-value obj)))) )
387
388(define-check+error-type template-identifier-name)
389 
390(define (check-template-variable-name loc pkgnam obj #!optional argnam)
391  (check-symbol loc obj argnam)
392  (check-template-identifier-name loc (!localized-template pkgnam obj) argnam)
393  obj )
394 
395(define (check-template-variable-names loc pkgnam obj #!optional argnam)
396  (check-list loc obj argnam)
397  (every (cut check-template-variable-name loc pkgnam <> argnam) obj)
398  obj )
399
400(define (make-identifier ident)
401  (cond
402    ; unqualified name
403    ((symbol? ident)
404      ident )
405    ; qualified name
406    ((pair? ident)
407      (##sys#module-rename
408        (alist-element-atomic-value ident)
409        (car ident)) )
410    (else
411      #f ) ) )
412
413(define (!global-ref loc ident)
414  (let ((ident (make-identifier ident)))
415    (if (and ident (global-bound? ident)) (global-ref ident)
416      (error-undefined loc "undefined toplevel variable" ident) ) ) )
417
418;there must be a better way using sys namespace operations.
419;(Chicken 4.2.2 had a query for ALL loaded binaries)
420
421(define +loaded-library-names+ '())
422
423(define (load-code loc libspec)
424  (let ((unit (if (pair? libspec)
425                (and (pair? libspec) (symbol? (car libspec)) (car libspec))
426                (and (symbol? libspec) libspec) ) )
427        (path (if (pair? libspec) 
428                (and (string? (cadr libspec)) libspec)
429                (and (string? libspec) libspec) ) ) )
430    (unless (member (or path unit) +loaded-library-names+)
431      (cond
432        ; Library Unit
433        ((and unit path)
434          (load-library unit path) )
435        ; Library Unit
436        (unit
437          (load-library unit) )
438        ; Must be absolute pathaname, otherwise pathname is relative to
439        ; "current file"
440        (path
441          (load-relative path) )
442        (else
443          (error loc "invalid library load specificiation" libspec) ) )
444      (set! +loaded-library-names+ (cons (or path unit) +loaded-library-names+)) ) ) )
445
446(define (fixup-references loc pkgnam vartptnams)
447  (for-each
448    (lambda (tptnam)
449      (localized-template-set!
450        pkgnam tptnam
451        (!global-ref loc (!localized-template pkgnam tptnam))) )
452    vartptnams) )
453
454(define (*load-localized-compiled-code libspec pkgnam vartptnams)
455  (load-code 'load-localized-compiled-code libspec)
456  (fixup-references 'load-localized-compiled-code pkgnam vartptnams) )
457
458;;
459
460(define (load-localized-compiled-code libspec pkgnam vartptnams)
461  (check-package-name 'load-localized-compiled-code pkgnam)
462  (*load-localized-compiled-code
463    libspec
464    pkgnam
465    (check-template-variable-names 'load-localized-compiled-code pkgnam vartptnams)) )
466
467;;; Bundle Operations
468
469;; Returns the full bundle specifier for the specified package using the default locale
470
471(define (most-specific-bundle-specifier package-name)
472  `(,package-name ,(current-language) ,(current-country) ,@(current-locale-details)) )
473
474;; Declare a bundle of templates with a given bundle specifier
475
476(define (declare-bundle! bndl-spec bndl-alist)
477  (bundle-set!
478    (check-bundle-specifier 'declare-bundle! bndl-spec)
479    bndl-alist)
480  #t )
481
482;; Remove declared bundle, if any
483
484(define (undeclare-bundle! bndl-spec)
485  (bundle-reset!
486    (check-bundle-specifier 'undeclare-bundle! bndl-spec))
487  #t )
488
489;; Reads bundle file & declares.
490
491(define (load-bundle! bndl-spec . args)
492  (let-optionals args ((alt-dir SYSTEM-BUNDLES))
493    (let ((path (need-bundle-absolute-pathname
494                  'load-bundle! bndl-spec alt-dir)))
495      (and (file-exists? path)
496           (declare-bundle! bndl-spec
497             (with-input-from-file path read)) ) ) ) )
498
499;; Write bundle to file
500
501(define (store-bundle! bndl-spec . args)
502  (let-optionals args ((alt-dir SYSTEM-BUNDLES))
503    (let ((path (need-bundle-absolute-pathname
504                  'store-bundle! bndl-spec alt-dir))
505          (bndl (need-bundle 'store-bundle! bndl-spec)) )
506      (create-pathname-directory path)
507      (delete-file* path)
508      (with-output-to-file path (lambda () (write (dict->alist bndl))))
509      #t ) ) )
510
511;; Remove declared bundle and file, if any
512
513(define (remove-bundle! bndl-spec . args)
514  (let-optionals args ((alt-dir SYSTEM-BUNDLES))
515    (let ((path (need-bundle-absolute-pathname
516                  'remove-bundle! bndl-spec alt-dir)))
517      (bundle-reset! bndl-spec)
518      (delete-file* path)
519      #t ) ) )
520
521;; Remove declared bundle and file, if any
522
523(define (remove-bundle-directory! bndl-spec . args)
524  (let-optionals args ((alt-dir SYSTEM-BUNDLES))
525    (let ((path (need-bundle-absolute-pathname
526                  'remove-bundle-directory! bndl-spec alt-dir)))
527      (delete-file* path)
528      (let ((topdir alt-dir))
529        (let loop ((path path))
530          (let* ((dir (pathname-directory path))
531                 (fillst (directory dir)))
532            (cond ((string=? dir topdir)        #t)
533                  ((positive? (length fillst))  #f)
534                  (else
535                   (delete-directory dir)
536                   (loop dir) ) ) ) ) ) ) ) )
537
538;; Try loading from most to least specific, returns #f when failure.
539
540(define (load-best-available-bundle! bndl-spec . args)
541  (let-optionals args ((alt-dir SYSTEM-BUNDLES))
542    (let loop ((bndl-spec
543                (remove not (check-bundle-specifier
544                              'load-best-available-bundle! bndl-spec))))
545      (and (not (null? bndl-spec))
546           (or (load-bundle! bndl-spec alt-dir)
547               (loop (drop-right! bndl-spec 1)) ) ) ) ) )
548
549;;; Introspection
550
551;;
552
553(define (localized-templates pkgnam)
554  (dict->alist (cached-package-bundle pkgnam)) )
555
556;;
557
558(define (declared-bundle-specifiers)
559  (map! list-copy (*bundle-specifiers)) )
560
561;;
562
563(define (declared-bundle-templates bndl-spec)
564  (dict->alist
565    (need-bundle 'declared-bundle-templates
566      (check-bundle-specifier 'declared-bundle-templates
567        bndl-spec))) )
568
569;;;
570
571(register-feature! 'srfi-29)
572
573) ;module srfi-29
574
Note: See TracBrowser for help on using the repository browser.