;;;; 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
    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
    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 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+)
          (only type-errors warning-argument-type)
          (only type-checks check-procedure define-check+error-type) )
  (require-library srfi-1 srfi-13 extras data-structures files posix
                   lookup-table miscmacros locale
                   conditions type-errors type-checks)

  (declare
    (disable-interrupts) ; We got shared data
    (fixnum)
    (inline)
    (no-procedure-checks)
    (bound-to-procedure ; Forward references
      most-specific-bundle-specifier
      invalidate-package-bundle-cache ) )

;;; Utilities

;;

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

;; Ensure the directory for the specified path exists.

#; ;NEEDS FIX IN CHICKEN 4.1.8
(define (create-pathname-directory pathname)
  (create-directory (pathname-directory pathname) #t))

(define (create-pathname-directory pathname)
  (let loop ((dir (pathname-directory pathname)))
    (when (and dir (not (directory? dir)))
      (loop (pathname-directory dir))
      (create-directory dir)) ) )

;;; Constants

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

;; System bundles are here:

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

;; Within the bundle directory the structure
;; is [(language) [(country) [(details)]] (package-name).

;;; Errors

(define (error-undefined loc msg . args)
  (abort
    (make-exn-condition+ loc msg args
                         (make-property-condition 'srfi-29)
                         (make-property-condition '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

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

(define (bundle-specifier? obj) (and (pair? obj) (every symbol? 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)
  (check-bundle-specifier loc bndl-spec)
  (bundle-specification->absolute-pathname 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 package-name)
  (or (dict-ref *package-bundle-cache* package-name)
      (let loop ((bndl-spec (remove! not (most-specific-bundle-specifier package-name))))
        (and (not (null? bndl-spec))
             (if* (bundle-ref bndl-spec)
                  (begin
                    (dict-set! *package-bundle-cache* package-name 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 the package exists. Otherwise
;; returns the default argument, default #f.

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

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

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

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

  (define (format-info-string package-name template-name fmtargs)
    (conc #\[ package-name #\/ template-name
              #\space
              (apply conc (intersperse fmtargs #\space))
          #\]) )

  (let ((fmtstr (or (localized-template package-name template-name)
                    (and (string? template-name)
                         template-name))))
    (if fmtstr (apply (current-locale-format-function) fmtstr fmtargs)
        (format-info-string package-name template-name 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! package-name template-name value)
  (and-let* ((bndl (cached-package-bundle package-name)))
    (dict-set! bndl template-name value)
    #t ) )

;;; 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)
  (check-bundle-specifier 'declare-bundle! bndl-spec)
  (bundle-set! bndl-spec bndl-alist)
  #t )

;; Remove declared bundle, if any

(define (undeclare-bundle! bndl-spec)
  (check-bundle-specifier 'undeclare-bundle! bndl-spec)
  (bundle-reset! 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))
    (check-bundle-specifier 'load-best-available-bundle! bndl-spec)
    (let loop ((bndl-spec (remove not bndl-spec)))
      (and (not (null? bndl-spec))
           (or (apply load-bundle! bndl-spec alt-dir)
               (loop (drop-right! bndl-spec 1)) ) ) ) ) )

;;; Introspection

;;

(define (localized-templates package-name)
  (parameterize ((dict-safe-mode #t))
    (dict->alist (cached-package-bundle package-name)) ) )

;;

(define (declared-bundle-specifiers) (map! list-copy (*bundle-specifiers)))

;;

(define (declared-bundle-templates bndl-spec)
  (check-bundle-specifier 'declared-bundle-templates bndl-spec)
  (parameterize ((dict-safe-mode #t))
    (dict->alist (need-bundle 'declared-bundle-templates bndl-spec)) ) )

;;;

(register-feature! 'srfi-29)

) ;module srfi-29