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

Last change on this file since 35217 was 35217, checked in by kon, 14 months ago

use moremacros - warning checked parameters , re-flow , use csi+csc test runner

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