;;;; 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.
;;
;; - Uses `##sys#module-rename' to construct a module qualified identifier.

(module srfi-29

  (;export
    ; SRFI 29
    current-language
    current-country
    current-locale-details
    load-bundle!
    store-bundle!
    declare-bundle!
    localized-template
    ; Extensions
    undefined-condition? unbound-variable-condition?
    system-bundle-directory
    most-specific-bundle-specifier
    required-localized-template
    localized-template/default
    make-required-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 lookup-table
      make-dict dict-ref dict-set! dict-delete!
      dict->alist alist->dict
      dict-keys
      dict-safe-mode)
    (only miscmacros if*)
    (only locale
      current-locale-components locale-component-ref)
    (only posix-utils environment-variable-true?)
    (only condition-utils
      make-exn-condition+ make-condition-predicate)
    (only type-errors
      error-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
    lookup-table miscmacros locale posix-utils
    condition-utils type-errors type-checks)

  (require-extension variable-item)

  (declare
    (bound-to-procedure
      ##sys#symbol-has-toplevel-binding?
      ; Forward references
      most-specific-bundle-specifier
      invalidate-package-bundle-cache))

;;;

(define *LOADTIME* #t)

;;; Utilities

;;

(define-inline (%global-bound? sym) (##sys#symbol-has-toplevel-binding? sym))
(define-inline (%global-ref sym) (##sys#slot sym 0))

;;

(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 (error-unbound-variable loc sym)
  (abort
    (make-exn-condition+
      loc "unbound variable" (list sym)
      (make-property-condition 'srfi-29)
      (make-property-condition 'unbound))) )

(define undefined-condition? (make-condition-predicate exn srfi-29 undefined))

(define unbound-variable-condition? (make-condition-predicate exn srfi-29 unbound))

;;; Locale Operations

(define (locale-item? x) (or (not x) (symbol? x)))
(define-check+error-type locale-item)

(define (locale-details? obj) (and (list? obj) (every locale-item? obj)))
(define-check+error-type locale-details)

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

;; 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 bundle-ref)
(define bundle-set!)
(define bundle-delete!)
(define bundle-specifiers)
(let ((localization-bundles (make-dict equal?)))

  (set! bundle-ref (lambda (bndl-spec)
    (dict-ref localization-bundles bndl-spec) ) )

  (set! bundle-set! (lambda (bndl-spec bndl-alist)
    (dict-set! localization-bundles
      bndl-spec (alist->dict bndl-alist equal?)) ) )

  (set! bundle-delete! (lambda (bndl-spec)
    (invalidate-package-bundle-cache bndl-spec)
    (dict-delete! localization-bundles bndl-spec) ) )

  (set! bundle-specifiers (lambda ()
    (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 invalidate-package-bundle-cache)
(define cached-package-bundle)
(if (environment-variable-true? "SRFI29_TLS")

    ;then use a parameter for the cache
    ;so one bundle per package per thread
    (let ((package-bundle-cache (make-parameter (make-dict eq?))))

      (set! invalidate-package-bundle-cache (lambda args
        (if (null? args) (package-bundle-cache (make-dict eq?))
          ;else args is (bndl-spec)
          (dict-delete! (package-bundle-cache) (caar args)) ) ) )

      (set! cached-package-bundle (lambda (pkgnam)
        (or (dict-ref (package-bundle-cache) pkgnam)
            (let loop ((bndl-spec (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)) ) ) ) ) ) ) )

    ;else one bundle per package
    (let ((package-bundle-cache (make-dict eq?)))

      (set! invalidate-package-bundle-cache (lambda args
        (if (null? args) (set! package-bundle-cache (make-dict eq?))
          ;else args is (bndl-spec)
          (dict-delete! package-bundle-cache (caar args)) ) ) )

      (set! cached-package-bundle (lambda (pkgnam)
        (or (dict-ref package-bundle-cache pkgnam)
            (let loop ((bndl-spec (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-checked-variable current-locale-format-function format procedure)

;; The default language, country, and locale-details

(define ((make-locale-guard chk) x)
  (let ((x (chk x)))
    (unless *LOADTIME* (invalidate-package-bundle-cache))
    x ) )

(define-parameter current-language (locale-ref 'language)
  (make-locale-guard (lambda (x) (check-locale-item 'current-language x))))
(define-parameter current-country (locale-ref 'region)
  (make-locale-guard (lambda (x) (check-locale-item 'current-country x))))
(define-parameter current-locale-details (locale-ref 'details)
  (make-locale-guard (lambda (x) (check-locale-details 'current-locale-details  x))))

;; 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 '#(no-package))
(define NO-TEMPLATE-TAG '#(no-template))

(define (*required-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 (required-localized-template pkgnam tptnam)
  (*required-localized-template 'required-localized-template pkgnam tptnam) )

;; Returns a procedure the looks up a template in a fixed package

(define ((make-required-localized-template pkgnam) tptnam)
  (required-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"

;; Support

;Support both "styles" of alist element: (key . (value ...)) & (key . value)
;where value is assumed to be an atom.
;Assumes valid argument!
(define (alist-element-atomic-value p)
  (if (pair? (cdr p)) (cadr p)
    (cdr p)) )

;Assumes valid argument!
(define (make-identifier ident)
  (cond
    ; qualified name
    ((pair? ident)
      (##sys#module-rename (alist-element-atomic-value ident) (car ident)) )
    ; unqualified name
    (else
      ident ) ) )

;Assumes valid argument!
(define (required-global-ref loc ident)
  (let ((ident (make-identifier ident)))
    (if (and ident (%global-bound? ident)) (%global-ref ident)
      (error-unbound-variable loc ident) ) ) )

;; Form checks

(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 (required-localized-template pkgnam obj) argnam)
  obj )

(define (check-template-variable-names loc pkgnam obj #!optional argnam)
  (check-list loc obj argnam)
  (for-each (cut check-template-variable-name loc pkgnam <> argnam) obj)
  obj )

;;

;There must be a better way using sys namespace operations.
;(Chicken 4.2.2 had a query for ALL loaded binaries)

; A `library-name' is a pathname or unitname.
(define +loaded-library-names+ '())

(define (load-code loc libspec)
  (let ((unit (if (not (pair? libspec)) (and (symbol? libspec) libspec)
                (and (pair? libspec) (symbol? (car libspec)) (car libspec))) )
        (path (if (not (pair? libspec)) (and (string? libspec) libspec)
                (and (string? (cadr libspec)) libspec)) ) )
    ; A pathname is preferred to a unitname
    (let ((the-name (or path unit)))
      (unless (member the-name +loaded-library-names+)
        (cond
          ; Library Unit w/ path
          ((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 the-name +loaded-library-names+)) ) ) ) )

(define (fixup-references loc pkgnam vartptnams)
  (for-each
    (lambda (tptnam)
      (localized-template-set!
        pkgnam tptnam
        (required-global-ref loc (required-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 pkgnam)
  (remove!
    not
    `(,pkgnam
      ,(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-delete!
    (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-delete! 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
                (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)
(define *LOADTIME* #f)

) ;module srfi-29