;;;; srfi-29.scm ;;;; Kon Lovett, Dec '05 ;; ISSUES ;; ;; - Bit of a dither about (disable-interrupts). Suspect not really ;; necessary but w/o the binary grows by ~10%! ;; ;; - Locale component symbols must have lowercase printname, as ;; such they do not truely reflect ISO 639-1 & ISO 3166-1. ;; ;; - The locale details component of the SRFI is ill-defined, which ;; symbol means what? ;; ;; - Possible race condition creating a bundle file or directory (module srfi-29 (;export ; SRFI 29 current-language current-country current-locale-details load-bundle! store-bundle! declare-bundle! localized-template ; Extensions undefined-condition? system-bundle-directory most-specific-bundle-specifier !localized-template localized-template/default make-!localized-template make-localized-template make-localized-template/default localized-template-set! load-localized-compiled-code remove-bundle! undeclare-bundle! reset-locale-parameters remove-bundle-directory! load-best-available-bundle! current-locale-format-function localized-format localized-templates declared-bundle-specifiers declared-bundle-templates) (import scheme chicken (only srfi-1 map! reverse! every drop-right! remove remove! fold list-copy) (only srfi-13 string-downcase) (only extras format) (only data-structures intersperse conc ->string) (only files delete-file* make-pathname pathname-directory) (only posix directory? create-directory delete-directory directory) (only lolevel global-bound? global-ref) (only lookup-table make-dict dict-ref dict-set! dict-delete! dict->alist alist->dict dict-keys dict-safe-mode) (only miscmacros define-parameter if*) (only locale current-locale-components locale-component-ref) (only conditions make-exn-condition+ make-condition-predicate) (only type-errors warning-argument-type) (only type-checks check-procedure check-symbol check-string check-list define-check+error-type) ) (require-library srfi-1 srfi-13 extras data-structures files posix lolevel lookup-table miscmacros locale conditions type-errors type-checks) (declare (bound-to-procedure ; Forward references most-specific-bundle-specifier invalidate-package-bundle-cache ) ) ;;; Utilities ;; (define (->symbol obj) (cond ((symbol? obj) obj ) ((string? obj) (string->symbol obj) ) (else (string->symbol (->string obj)) ) ) ) ;; Ensure the directory for the specified path exists. (define create-pathname-directory (cut create-directory <> #t)) ;;; Constants (define-constant DEFAULT-BUNDLE-DIR "srfi-29-bundles") ;; System bundles are here: ;Within the bundle directory the structure ;is [(language) [(country) [(details)]]] (package-name). (define SYSTEM-BUNDLES (make-pathname (repository-path) DEFAULT-BUNDLE-DIR)) ;; Query it (define (system-bundle-directory) SYSTEM-BUNDLES) ;;; Errors (define (error-undefined loc msg . args) (abort (make-exn-condition+ loc msg args (make-property-condition 'srfi-29) (make-property-condition 'undefined))) ) (define undefined-condition? (make-condition-predicate exn srfi-29 undefined)) ;;; Locale Operations (define (locale-item? x) (or (not x) (symbol? x))) (define (locale-details? obj) (and (list? obj) (every locale-item? obj))) (define (coerce-locale-item obj) (cond ((locale-item? obj) obj) ((string? obj) (string->symbol (string-downcase obj))) (else (->symbol obj) ) ) ) (define (cons-locale-item lci lst) (if lci (cons (symbol->string lci) lst) lst ) ) ;; Canonical current locale (define (locale-ref what) (let ((lc (current-locale-components))) (case what ((details) (list (locale-ref 'script) (locale-ref 'codeset) (locale-ref 'modifier))) (else (coerce-locale-item (locale-component-ref lc what)) ) ) ) ) ;;; Bundle Specification Operations (define package-name? symbol?) (define-check+error-type package-name) (define (bundle-specifier-element? obj) (or (not obj) (symbol? obj))) (define-check+error-type bundle-specifier-element) ;; bundle-specifier: (list-of symbol) ;; i.e. package + locale: (package-name [language] [country] [details ...]) (define (bundle-specifier? obj) (and (pair? obj) (package-name? (car obj)) (every bundle-specifier-element? (cdr obj))) ) (define-check+error-type bundle-specifier) ;; (define (bundle-specification-directory bndl-spec) (reverse! (fold cons-locale-item '() (cdr bndl-spec))) ) (define (bundle-specification-filename bndl-spec) (symbol->string (car bndl-spec))) (define (bundle-specification->pathname bndl-spec) (make-pathname (bundle-specification-directory bndl-spec) (bundle-specification-filename bndl-spec)) ) (define (bundle-specification->absolute-pathname bndl-spec alt-dir) (make-pathname alt-dir (bundle-specification->pathname bndl-spec)) ) (define (need-bundle-absolute-pathname loc bndl-spec alt-dir) (bundle-specification->absolute-pathname (check-bundle-specifier loc bndl-spec) alt-dir) ) ;; Bundles Dictionary ;All declared bundles (define *localization-bundles* (make-dict equal?)) (define (bundle-ref bndl-spec) (dict-ref *localization-bundles* bndl-spec)) (define (bundle-set! bndl-spec bndl-alist) (dict-set! *localization-bundles* bndl-spec (alist->dict bndl-alist equal?)) ) (define (bundle-reset! bndl-spec) (invalidate-package-bundle-cache bndl-spec) (dict-delete! *localization-bundles* bndl-spec) ) (define (*bundle-specifiers) (dict-keys *localization-bundles*)) (define (need-bundle loc bndl-spec) (or (bundle-ref bndl-spec) (error-undefined loc "undeclared bundle specification" bndl-spec)) ) ;; Package Bundle Cache ;Most specific declared bundles that are actually used ;A subset of the *localization-bundles* (define *package-bundle-cache* (make-dict eq?)) (define (invalidate-package-bundle-cache . bndl-spec) (if (null? bndl-spec) (set! *package-bundle-cache* (make-dict eq?)) (dict-delete! *package-bundle-cache* (caar bndl-spec)) ) ) (define (cached-package-bundle pkgnam) (or (dict-ref *package-bundle-cache* pkgnam) (let loop ((bndl-spec (remove! not (most-specific-bundle-specifier pkgnam)))) (and (not (null? bndl-spec)) (if* (bundle-ref bndl-spec) (begin (dict-set! *package-bundle-cache* pkgnam it) it ) (loop (drop-right! bndl-spec 1)) ) ) ) ) ) ;;; Locale Parameters ;; The default 'format' procedure ;; Any supplied procedure MUST have the same signature as SRFI 28 'format' ;; The initial procedure is the builtin (define-parameter current-locale-format-function format (lambda (x) (if (procedure? x) x (begin (warning-argument-type 'current-locale-format-function x 'procedure) (current-locale-format-function) ) ) ) ) ;; The default language (define-parameter current-language (locale-ref 'language) (lambda (x) (cond ((locale-item? x) (invalidate-package-bundle-cache) x ) (else (warning-argument-type 'current-language x 'locale-item) (current-language) ) ) ) ) ;; The default country (define-parameter current-country (locale-ref 'region) (lambda (x) (cond ((locale-item? x) (invalidate-package-bundle-cache) x ) (else (warning-argument-type 'current-country x 'locale-item) (current-country) ) ) ) ) ;; The default locale-details (define-parameter current-locale-details (locale-ref 'details) (lambda (x) (cond ((locale-details? x) (invalidate-package-bundle-cache) x ) (else (warning-argument-type 'current-locale-details x 'locale-details) (current-locale-details) ) ) ) ) ;; If you change (current-locale), you don't have to set current-* ;; by hand, you can simply call this procedure, and it will update ;; those parameters to the values in the new locale. (Reset as in ;; set anew.) (define (reset-locale-parameters) (current-language (locale-ref 'language)) (current-country (locale-ref 'region)) (current-locale-details (locale-ref 'details)) ) ;;; Template Operations ;; Returns the localized template from the most specific bundle given ;; its' package name and a template name. ;; If package undefined returns the package default (defaults #f). ;; If template undefined returns the template default (defaults #f). (define (localized-template pkgnam tptnam #!optional defpkg deftpt) (if* (cached-package-bundle pkgnam) (dict-ref it tptnam deftpt) defpkg ) ) ;; Returns the localized template from the most specific bundle given ;; its' package name and a template name. ;; If package undefined returns the package default (defaults template-name). ;; If template undefined returns the template default (defaults template-name). (define (localized-template/default pkgnam tptnam #!optional (defpkg tptnam) (deftpt tptnam)) (localized-template pkgnam tptnam defpkg deftpt) ) ;; Returns the localized template from the most specific bundle given ;; its' package name and a template name. ;; ;; Raises an expception for undefined elements. (define +no-package-tag+ (vector 'no-package)) (define +no-template-tag+ (vector 'no-template)) (define (*!localized-template loc pkgnam tptnam) (let ((res (localized-template pkgnam tptnam +no-package-tag+ +no-template-tag+))) (cond ((eq? res +no-package-tag+) (error-undefined loc "undefined package" pkgnam) ) ((eq? res +no-template-tag+) (error-undefined loc "undefined template in package" tptnam pkgnam) ) (else res ) ) ) ) (define (!localized-template pkgnam tptnam) (*!localized-template '!localized-template pkgnam tptnam) ) ;; Returns a procedure the looks up a template in a fixed package (define ((make-!localized-template pkgnam) tptnam) (!localized-template pkgnam tptnam) ) (define ((make-localized-template pkgnam) tptnam #!optional defpkg deftpt) (localized-template pkgnam tptnam defpkg deftpt) ) (define ((make-localized-template/default pkgnam) tptnam #!optional (defpkg tptnam) (deftpt tptnam)) (localized-template pkgnam tptnam) ) ;; Returns the application of the default 'format' procedure to the ;; supplied arguments, using the package template as the format-string. ;; ;; When a format-string is unavailable an emergency display of the ;; relevant details is made to proper destination. (define (localized-format pkgnam tptnam . fmtargs) (define (format-info-string pkgnam tptnam fmtargs) (conc #\[ #\< pkgnam #\space tptnam #\> #\space (apply conc (intersperse fmtargs #\space)) #\]) ) (let ((fmtstr (or (localized-template pkgnam tptnam) (and (string? tptnam) tptnam)))) (if fmtstr (apply (current-locale-format-function) fmtstr fmtargs) (format-info-string pkgnam tptnam fmtargs) ) ) ) ;; Create or update the value for a template in an existing package. ;; Returns #t for success & #f when no such package. (define (localized-template-set! pkgnam tptnam value) (and-let* ((bndl (cached-package-bundle pkgnam))) (dict-set! bndl tptnam value) #t ) ) ;;; "Logic Bundle" ;association-list pair -> value ;(key . (value ...)) ;(key . value) (define (alist-element-atomic-value p) (if (pair? (cdr p)) (cadr p) (cdr p)) ) (define (template-identifier-name? obj) (or (symbol? obj) (and (pair? obj) (symbol? (car obj)) (symbol? (alist-element-atomic-value obj)))) ) (define-check+error-type template-identifier-name) (define (check-template-variable-name loc pkgnam obj #!optional argnam) (check-symbol loc obj argnam) (check-template-identifier-name loc (!localized-template pkgnam obj) argnam) obj ) (define (check-template-variable-names loc pkgnam obj #!optional argnam) (check-list loc obj argnam) (every (cut check-template-variable-name loc pkgnam <> argnam) obj) obj ) (define (make-identifier ident) (cond ; unqualified name ((symbol? ident) ident ) ; qualified name ((pair? ident) (##sys#module-rename (alist-element-atomic-value ident) (car ident)) ) (else #f ) ) ) (define (!global-ref loc ident) (let ((ident (make-identifier ident))) (if (and ident (global-bound? ident)) (global-ref ident) (error-undefined loc "undefined toplevel variable" ident) ) ) ) ;there must be a better way using sys namespace operations. ;(Chicken 4.2.2 had a query for ALL loaded binaries) (define +loaded-library-names+ '()) (define (load-code loc libspec) (let ((unit (if (pair? libspec) (and (pair? libspec) (symbol? (car libspec)) (car libspec)) (and (symbol? libspec) libspec) ) ) (path (if (pair? libspec) (and (string? (cadr libspec)) libspec) (and (string? libspec) libspec) ) ) ) (unless (member (or path unit) +loaded-library-names+) (cond ; Library Unit ((and unit path) (load-library unit path) ) ; Library Unit (unit (load-library unit) ) ; Must be absolute pathaname, otherwise pathname is relative to ; "current file" (path (load-relative path) ) (else (error loc "invalid library load specificiation" libspec) ) ) (set! +loaded-library-names+ (cons (or path unit) +loaded-library-names+)) ) ) ) (define (fixup-references loc pkgnam vartptnams) (for-each (lambda (tptnam) (localized-template-set! pkgnam tptnam (!global-ref loc (!localized-template pkgnam tptnam))) ) vartptnams) ) (define (*load-localized-compiled-code libspec pkgnam vartptnams) (load-code 'load-localized-compiled-code libspec) (fixup-references 'load-localized-compiled-code pkgnam vartptnams) ) ;; (define (load-localized-compiled-code libspec pkgnam vartptnams) (check-package-name 'load-localized-compiled-code pkgnam) (*load-localized-compiled-code libspec pkgnam (check-template-variable-names 'load-localized-compiled-code pkgnam vartptnams)) ) ;;; Bundle Operations ;; Returns the full bundle specifier for the specified package using the default locale (define (most-specific-bundle-specifier package-name) `(,package-name ,(current-language) ,(current-country) ,@(current-locale-details)) ) ;; Declare a bundle of templates with a given bundle specifier (define (declare-bundle! bndl-spec bndl-alist) (bundle-set! (check-bundle-specifier 'declare-bundle! bndl-spec) bndl-alist) #t ) ;; Remove declared bundle, if any (define (undeclare-bundle! bndl-spec) (bundle-reset! (check-bundle-specifier 'undeclare-bundle! bndl-spec)) #t ) ;; Reads bundle file & declares. (define (load-bundle! bndl-spec . args) (let-optionals args ((alt-dir SYSTEM-BUNDLES)) (let ((path (need-bundle-absolute-pathname 'load-bundle! bndl-spec alt-dir))) (and (file-exists? path) (declare-bundle! bndl-spec (with-input-from-file path read)) ) ) ) ) ;; Write bundle to file (define (store-bundle! bndl-spec . args) (let-optionals args ((alt-dir SYSTEM-BUNDLES)) (let ((path (need-bundle-absolute-pathname 'store-bundle! bndl-spec alt-dir)) (bndl (need-bundle 'store-bundle! bndl-spec)) ) (create-pathname-directory path) (delete-file* path) (with-output-to-file path (lambda () (write (dict->alist bndl)))) #t ) ) ) ;; Remove declared bundle and file, if any (define (remove-bundle! bndl-spec . args) (let-optionals args ((alt-dir SYSTEM-BUNDLES)) (let ((path (need-bundle-absolute-pathname 'remove-bundle! bndl-spec alt-dir))) (bundle-reset! bndl-spec) (delete-file* path) #t ) ) ) ;; Remove declared bundle and file, if any (define (remove-bundle-directory! bndl-spec . args) (let-optionals args ((alt-dir SYSTEM-BUNDLES)) (let ((path (need-bundle-absolute-pathname 'remove-bundle-directory! bndl-spec alt-dir))) (delete-file* path) (let ((topdir alt-dir)) (let loop ((path path)) (let* ((dir (pathname-directory path)) (fillst (directory dir))) (cond ((string=? dir topdir) #t) ((positive? (length fillst)) #f) (else (delete-directory dir) (loop dir) ) ) ) ) ) ) ) ) ;; Try loading from most to least specific, returns #f when failure. (define (load-best-available-bundle! bndl-spec . args) (let-optionals args ((alt-dir SYSTEM-BUNDLES)) (let loop ((bndl-spec (remove not (check-bundle-specifier 'load-best-available-bundle! bndl-spec)))) (and (not (null? bndl-spec)) (or (load-bundle! bndl-spec alt-dir) (loop (drop-right! bndl-spec 1)) ) ) ) ) ) ;;; Introspection ;; (define (localized-templates pkgnam) (dict->alist (cached-package-bundle pkgnam)) ) ;; (define (declared-bundle-specifiers) (map! list-copy (*bundle-specifiers)) ) ;; (define (declared-bundle-templates bndl-spec) (dict->alist (need-bundle 'declared-bundle-templates (check-bundle-specifier 'declared-bundle-templates bndl-spec))) ) ;;; (register-feature! 'srfi-29) ) ;module srfi-29