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

Last change on this file since 35378 was 35378, checked in by kon, 13 months ago

remove use of anaphoric if

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