source: project/release/3/srfi-29/trunk/srfi-29.scm @ 11834

;;;; 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

;; Default Bundles Directory is '(repository-path) "srfi-29-bundles"'.

;; Within the bundle directory the structure
;; is [(language) [(country) [(details)]]] (module).

(eval-when (compile)
  (declare
    (usual-integrations)
    (disable-interrupts) ; We got shared data
    (fixnum)
    (inline)
    (no-procedure-checks)
    (no-bound-checks)
    (bound-to-procedure ; Forward references
      most-specific-bundle-specifier
      invalidate-package-bundle-cache )
    (export
      ;; Extensions
      most-specific-bundle-specifier
      localized-template/default
      localized-template-set!
      remove-bundle!
      undeclare-bundle!
      reset-locale-parameters
      remove-bundle-directory!
      load-best-available-bundle!
      current-locale-format-function
      localized-format
      ;; SRFI 29
      current-language
      current-country
      current-locale-details
      load-bundle!
      store-bundle!
      declare-bundle!
      localized-template ) ) )

(use srfi-1 srfi-12 srfi-13 posix files
     miscmacros lookup-table locale misc-extn-directory)

(register-feature! 'srfi-29)

;;;

;;

(define-inline (->symbol obj)
  (string->symbol (->string obj)) )

;; Constants

(define-constant DEFAULT-BUNDLE-DIR "srfi-29-bundles")

;; System bundles are here:

(define SYSTEM-BUNDLES (make-pathname (repository-path) DEFAULT-BUNDLE-DIR))

;; Um, the user really should set a locale

(define LANGUAGE-DEFAULT 'en)
(define COUNTRY-DEFAULT 'us)

;;

(define (make-srfi-29-exception loc msg . args)
  (make-composite-condition
   (make-property-condition 'exn 'message msg 'location loc 'arguments args)
   (make-property-condition 'srfi-29)) )

(define (signal-srfi-29-exception loc msg . args)
  (abort (apply make-srfi-29-exception loc msg args)) )

;;

(define-inline (locale-item? x)
  (or (not x) (symbol? x)) )

(define-inline (locale-details? obj)
  (and (list? obj)
       (every locale-item? obj)) )

;; bundle-specifier: (list-of symbol)
;; i.e. package + locale, (package-name [language] [country] [details ...])

(define (bundle-specification->pathname bundle-specifier)
  (if (null? bundle-specifier)
      (signal-srfi-29-exception 'load-bundle! "must specify package name" bundle-specifier)
      (make-pathname (reverse! (fold (lambda (x l)
                                       (if x
                                           (cons (symbol->string x) l)
                                           l ) )
                                     '()
                                     (cdr bundle-specifier)))
                     (symbol->string (car bundle-specifier))) ) )

(define-inline (bundle-specification->absolute-pathname bundle-specifier alternate-dir)
  (make-pathname (optional alternate-dir SYSTEM-BUNDLES)
                 (bundle-specification->pathname bundle-specifier)) )

;; Bundles Dictionary

(define *localization-bundles* (make-dict 1 equal?))

(define-inline (find-bundle bundle-specifier)
  (dict-ref *localization-bundles* bundle-specifier) )

(define-inline (set-bundle! bundle-specifier bundle-alist)
  (dict-set! *localization-bundles* bundle-specifier (alist->dict bundle-alist equal?)) )

(define-inline (reset-bundle! bundle-specifier)
  (invalidate-package-bundle-cache bundle-specifier)
  (dict-delete! *localization-bundles* bundle-specifier) )

;; Package Bundle Cache

(define *package-bundle-cache* (make-dict 1 eq?))

(define (invalidate-package-bundle-cache . bundle-specifier)
  (if (not (null? bundle-specifier))
      (dict-delete! *package-bundle-cache* (caar bundle-specifier))
      (set! *package-bundle-cache* (make-dict 1 eq?)) ) )

(define (cached-package-bundle package-name)
  (or (dict-ref *package-bundle-cache* package-name)
      (let loop ([specifier (remove! not (most-specific-bundle-specifier package-name))])
        (and (not (null? specifier))
             (if* (find-bundle specifier)
                  (begin
                    (dict-set! *package-bundle-cache* package-name it)
                    it )
                  (loop (drop-right! specifier 1)) ) ) ) ) )

;; Canonical current locale

(define (locale-ref what)
  (let ([locale
          (current-locale-components)]
        [as-sym
          (lambda (v)
            (cond [(locale-item? v)  v]
                  [(string? v)       (string->symbol (string-downcase v))]
                  [else              (->symbol v)]) ) ] )
    (select what
      [('language)
        (as-sym (locale-component-ref locale 'language LANGUAGE-DEFAULT))]
      [('country)
        (as-sym (locale-component-ref locale 'region COUNTRY-DEFAULT))]
      [else
        `(,(as-sym (locale-component-ref locale  'script))
          ,(as-sym (locale-component-ref locale  'codeset))
          ,(as-sym (locale-component-ref locale  'modifier))) ] ) ) )

;;; 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 'current-locale-format-function "invalid procedure" x)
          (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 'current-language "invalid locale item" x)
           (current-language) ] ) ) )

;; The default country

(define-parameter current-country
  (locale-ref 'country)
  (lambda (x)
    (cond [(locale-item? x)
           (invalidate-package-bundle-cache)
           x ]
          [else
           (warning 'current-country "invalid locale item" x)
           (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 'current-locale-details "invalid locale item" x)
            (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 'country))
  (current-locale-details (locale-ref 'details)) )

;;; 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)) )

;; Returns the localized template from the most specific bundle given
;; its' package name and a template name, if the package exists. Otherwise
;; returns the not-found argument, default #f.

(define (localized-template package-name template-name #!optional not-found)
  (if* (cached-package-bundle package-name)
       (dict-ref it template-name)
       not-found ) )

;; Returns the localized template from the most specific bundle given
;; its' package name and a template name, if the package exists. Otherwise
;; returns the not-found argument, default is the template-name.

(define (localized-template/default package-name template-name #!optional (not-found template-name))
  (localized-template package-name template-name not-found) )

;; 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 package-name template-name port . fmtargs)
  (let ([fmtstr (or (localized-template package-name template-name)
                    (and (string? template-name)
                         template-name))])
    (if fmtstr
        (apply (current-locale-format-function) port fmtstr fmtargs)
        (let ([str (conc #\[ package-name #\/ template-name
                             #\space
                             (apply conc (intersperse fmtargs #\space))
                         #\])])
          (cond [(port? port)                     (display str port)]
                [(or (string? port) (not port))   str]
                [else                             (display str) ] ) ) ) ) )

;; 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! package-name template-name value)
  (and-let* ([bundle (cached-package-bundle package-name)])
    (dict-set! bundle template-name value)
    #t ) )

;; Declare a bundle of templates with a given bundle specifier

(define (declare-bundle! bundle-specifier bundle-alist)
  (set-bundle! bundle-specifier bundle-alist)
  #t )

;; Remove declared bundle, if any

(define (undeclare-bundle! bundle-specifier)
  (reset-bundle! bundle-specifier)
  #t )

;; Reads bundle file & declares.

(define (load-bundle! bundle-specifier . alternate-dir)
  (let ([path (bundle-specification->absolute-pathname bundle-specifier alternate-dir)])
    (and (file-exists? path)
         (declare-bundle! bundle-specifier (with-input-from-file path read)) ) ) )

;; Write bundle to file

(define (store-bundle! bundle-specifier . alternate-dir)
  (let ([path (bundle-specification->absolute-pathname bundle-specifier alternate-dir)]
        [bundle (find-bundle bundle-specifier)] )
    (unless bundle
      (signal-srfi-29-exception 'store-bundle! "no such declared bundle" bundle-specifier) )
    (create-pathname-directory path)
    (delete-file* path)
    (with-output-to-file path (lambda () (write (dict->alist bundle))))
    #t ) )

;; Remove declared bundle and file, if any

(define (remove-bundle! bundle-specifier . alternate-dir)
  (let ([path (bundle-specification->absolute-pathname bundle-specifier alternate-dir)])
    (reset-bundle! bundle-specifier)
    (delete-file* path)
    #t ) )

;; Remove declared bundle and file, if any

(define (remove-bundle-directory! bundle-specifier . alternate-dir)
  (let ([pathname (bundle-specification->absolute-pathname bundle-specifier alternate-dir)])
    (delete-file* pathname)
    (let ([topdir (optional alternate-dir SYSTEM-BUNDLES)])
      (let loop ([path pathname])
        (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! bundle-specifier . alternate-dir)
  (let loop ([specifier (remove not bundle-specifier)])
    (and (not (null? specifier))
         (or (apply load-bundle! specifier alternate-dir)
             (loop (drop-right! specifier 1)))) ) )