;;;; srfi-29.scm
;;;; Kon Lovett, Jun '17
;;;; Kon Lovett,
;;;; Kon Lovett, Dec '05

;; Issues
;;
;; - Explicit phasing !
;;
;; - 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? unbound-variable-condition?
  most-specific-bundle-specifier
  required-localized-template
  localized-template/default
  make-required-localized-template
  make-localized-template
  make-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
  package-name? check-package-name error-package-name)

(import scheme
	utf8
	(chicken base)
	(chicken module)
	(chicken type)
	(chicken syntax)
	(only (chicken condition) abort make-property-condition)
	(only (chicken string) conc ->string)
	(only (chicken platform) register-feature!)
	(only (chicken format) format)
	(only (chicken pathname)
	  make-pathname pathname-directory decompose-pathname)
	(only (chicken file)
	  delete-file* create-directory delete-directory directory file-exists?)
	(only (chicken file posix) directory?)
	(only utf8-srfi-13 string-downcase)
  (only (srfi 1)
    first second third
    reverse! every drop-right!
    remove remove! list-copy)
  (only (srfi 69)
    make-hash-table hash-table?
    hash-table-ref/default
    hash-table-set! hash-table-delete!
    hash-table->alist alist->hash-table
    hash-table-keys)
	(only locale current-locale-components locale-component-ref)
	(only posix-utils environment-variable-true?)
	(only condition-utils make-condition-predicate)
	(only exn-condition make-exn-condition+)
	(only type-errors error-argument-type warning-argument-type)
  (only type-checks
    check-procedure check-symbol check-string check-list
    define-check+error-type))

(import srfi-29-install)
(reexport srfi-29-install)

;;;

(define-type pathname string)
(define-type alist (list-of (pair (or symbol string) *)))

(define-type locale-item (or false symbol))

(define-type package-name symbol)
(define-type template-name (or symbol string))

(define-type bundle-specifier (list-of locale-item))

(: current-language (#!optional locale-item -> locale-item))
(: current-country (#!optional locale-item -> locale-item))
(: current-locale-details (#!optional (list-of locale-item) -> (list-of locale-item)))
(: load-bundle! (bundle-specifier #!optional pathname -> void))
(: store-bundle! (bundle-specifier #!optional pathname -> boolean))
(: declare-bundle! (bundle-specifier alist -> void))
(: localized-template (package-name template-name #!optional * * -> *))
(: undefined-condition? (* -> boolean : condition))
(: unbound-variable-condition? (* -> boolean : condition))
(: most-specific-bundle-specifier (package-name -> bundle-specifier))
(: required-localized-template (package-name template-name -> *))
(: localized-template/default (package-name template-name #!optional * * -> *))
(: make-required-localized-template (package-name -> (template-name -> *)))
(: make-localized-template (package-name -> (template-name #!optional * * -> *)))
(: make-localized-template/default (package-name -> (template-name #!optional * * -> *)))
(: localized-template-set! (package-name template-name * -> boolean))
(: remove-bundle! (bundle-specifier #!optional pathname -> boolean))
(: undeclare-bundle! (bundle-specifier -> boolean))
(: reset-locale-parameters (-> (list-of locale-item)))
(: remove-bundle-directory! (bundle-specifier #!optional pathname -> boolean))
(: load-best-available-bundle! (bundle-specifier #!optional pathname -> boolean))
(: current-locale-format-function (#!optional procedure -> procedure))
(: localized-format (package-name template-name #!rest -> string))
(: localized-templates (package-name -> alist))
(: declared-bundle-specifiers (-> list))
(: declared-bundle-templates (bundle-specifier -> list))
(: package-name? (* -> boolean : package-name))
(: check-package-name (symbol * #!optional (or symbol string) -> package-name))
(: error-package-name (symbol * #!optional (or symbol string) -> void))

;reexport srfi-29-install types

;NOTE more restrictive than code (accepts *)
(define-type locale-item* (or locale-item string integer))

(: system-bundle-directory (#!optional pathname -> pathname))
(: install-bundle (locale-item* #!rest (list-of locale-item*) -> void))

;;; Dependency Neurosis

;;(only miscmacros define-parameter select)

(define-syntax define-parameter
  (syntax-rules ()
    ((define-parameter name value guard)
     (define name (make-parameter value guard)))
    ((define-parameter name value)
     (define name (make-parameter value)))
    ((define-parameter name)
     (define name (make-parameter (void))))))

(define-syntax select
 (er-macro-transformer
  (lambda (form r c)
    (##sys#check-syntax 'select form '(_ _ . _))
    (let ((exp (cadr form))
	  (body (cddr form))
	  (tmp (r 'tmp))
	  (%else (r 'else))
	  (%or (r 'or)))
      `(##core#let
	((,tmp ,exp))
	,(let expand ((clauses body) (else? #f))
	   (cond ((null? clauses)
		  '(##core#undefined))
		 ((not (pair? clauses))
		  (syntax-error 'select "invalid syntax" clauses))
		 (else
		  (let ((clause (##sys#slot clauses 0))
			(rclauses (##sys#slot clauses 1)))
		    (##sys#check-syntax 'select clause '#(_ 1))
		    (cond ((c %else (car clause))
			   (expand rclauses #t)
			   `(##core#begin ,@(cdr clause)))
			  (else?
			   (##sys#notice
			    "non-`else' clause following `else' clause in `select'"
			    (strip-syntax clause))
			   (expand rclauses #t)
			   '(##core#begin))
			  (else
			   `(##core#if
			     (,%or ,@(map (lambda (x) `(##sys#eqv? ,tmp ,x))
					  (car clause)))
			     (##core#begin ,@(cdr clause))
			     ,(expand rclauses #f)))))))))))))

;;(only moremacros define-warning-parameter)

(import-for-syntax (only (chicken string) conc))

(define-for-syntax (make-identifier . elts)
  (string->symbol (apply conc (map strip-syntax elts))) )

(define-syntax define-warning-parameter
  (syntax-rules ()
    ((define-warning-parameter ?name ?init ?typnam ?body0 ...)
      (define-parameter ?name ?init (warning-guard ?name ?typnam ?body0 ...)) ) ) )

(define-syntax warning-guard
  (er-macro-transformer
    (lambda (frm rnm cmp)
      (##sys#check-syntax 'warning-guard frm '(_ symbol symbol . _))
      (let (
        (?getnam (cadr frm))
        (?typnam (caddr frm))
        (?body (cdddr frm))
        (_lambda (rnm 'lambda))
        (_if (rnm 'if))
        (_begin (rnm 'begin))
        (_warning-argument-type (rnm 'warning-argument-type)) )
        (let (
          (predname (make-identifier (symbol->string ?typnam) "?")) )
          `(,_lambda (obj)
            (,_if (,predname obj)
              (,_begin
                ,@?body
                obj)
              (,_begin
                (,_warning-argument-type ',?getnam obj ',?typnam)
                (,?getnam) ) ) ) ) ) ) ) )

;; Utilities

(include "locale-item")

;;

;; Ensure the directory for the specified path exists.

(define (create-pathname-directory pn) (create-directory pn #t))

;;

(define-constant TLS-ENVIRONMENT-VARIABLE "SRFI29_TLS")

;;

(define NO-PACKAGE-TAG #(no-package))
(define NO-TEMPLATE-TAG #(no-template))

;; Errors & Conditions

;;

(define (condition-undefined loc msg . args)
  (make-exn-condition+
    loc msg args
    (make-property-condition 'srfi-29)
    (make-property-condition 'undefined)) )

(define (condition-unbound-variable loc sym)
  (make-exn-condition+
    loc "unbound variable" `(,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))

;;

(define (error-undefined loc msg . args)
  (abort (apply condition-undefined loc msg args)) )

(define (error-unbound-variable loc sym)
  (abort (condition-unbound-variable loc sym)) )

;;; Locale Operations

(define locale-language? locale-item?)
(define locale-country? locale-item?)

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

(define-check+error-type locale-details)

;; Canonical current locale

(define (locale-ref what #!optional (lcs (current-locale-components)))
  (case what
    ((details)
      `(,(locale-ref 'script lcs)
        ,(locale-ref 'codeset lcs)
        ,(locale-ref 'modifier lcs)))
    (else
      (->locale-item (locale-component-ref lcs 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-path bndl-spec)
  (define (add-item ls lci)
    (if lci
      (cons (symbol->string lci) ls)
      ls ) )
  (reverse! (foldl add-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-path 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-hash-table equal?)))
  ;
  (set! bundle-ref (lambda (bndl-spec)
    (hash-table-ref/default +localization-bundles+ bndl-spec #f) ) )
  ;
  (set! bundle-set! (lambda (bndl-spec bndl-alist)
    (hash-table-set! +localization-bundles+
      bndl-spec (alist->hash-table bndl-alist equal?)) ) )
  ;
  (set! bundle-delete! (lambda (bndl-spec)
    (invalidate-package-bundle-cache bndl-spec)
    (hash-table-delete! +localization-bundles+ bndl-spec) ) )
  ;
  (set! bundle-specifiers (lambda ()
    (hash-table-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'

;parameter interface
(define package-bundle-cache
  (let ((+eq-dict+ (make-hash-table eq?)))
    (if (environment-variable-true? TLS-ENVIRONMENT-VARIABLE)
      ;then use a parameter for the cache so one bundle per package per thread
      (make-parameter +eq-dict+ hash-table?)
      ;else one bundle per package
      (let ((*dict* +eq-dict+))
        (case-lambda
          (() *dict*)
          ((new)
            (set! *dict* new) ) ) ) ) ) )

(define (invalidate-package-bundle-cache . args)
  (if (null? args)
    (package-bundle-cache (make-hash-table eq?))
    ;else args is (bndl-spec)
    (hash-table-delete! (package-bundle-cache) (caar args)) ) )

(define (cached-package-bundle pkgnam)
  (let ((pkg-dict (package-bundle-cache)))
    (or
      (hash-table-ref/default pkg-dict pkgnam #f)
      (let loop ((bndl-spec (most-specific-bundle-specifier pkgnam)))
        (and
          (not (null? bndl-spec))
          (let ((contents (bundle-ref bndl-spec)))
            (if contents
              (begin
                (hash-table-set! pkg-dict pkgnam contents)
                contents )
              (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-warning-parameter current-locale-format-function format procedure)

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

(define (make-locale-loadtime-guard chk)
  ;ignore initial reset
  (let ((*action* (lambda () (set! *action* invalidate-package-bundle-cache))))
    (lambda (x)
      (*action*)
      (chk x) ) ) )

(define-parameter current-language (locale-ref 'language)
  (make-locale-loadtime-guard (warning-guard current-language locale-language)))

(define-parameter current-country (locale-ref 'region)
  (make-locale-loadtime-guard (warning-guard current-country locale-country)))

(define-parameter current-locale-details (locale-ref 'details)
  (make-locale-loadtime-guard (warning-guard current-locale-details 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 tplnam #!optional defpkg deftpl)
  (let ((bundle (cached-package-bundle pkgnam)))
    (if bundle
      (hash-table-ref/default bundle tplnam deftpl)
      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 tplnam #!optional (defpkg tplnam) (deftpl tplnam))
  (localized-template pkgnam tplnam defpkg deftpl) )

;; Returns the localized template from the most specific bundle given
;; its' package name and a template name.
;;
;; Raises an expception for undefined elements.

(define (*required-localized-template loc pkgnam tplnam)
  (let ((res (localized-template pkgnam tplnam NO-PACKAGE-TAG NO-TEMPLATE-TAG)))
    (select res
      ((NO-PACKAGE-TAG)
        (error-undefined loc "undefined package" pkgnam) )
      ((NO-TEMPLATE-TAG)
        (error-undefined loc "undefined template in package" tplnam pkgnam) )
      (else
        res ) ) ) )

(define (required-localized-template pkgnam tplnam)
  (*required-localized-template 'required-localized-template pkgnam tplnam) )

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

(define ((make-required-localized-template pkgnam) tplnam)
  (required-localized-template pkgnam tplnam) )

(define ((make-localized-template pkgnam) tplnam #!optional defpkg deftpl)
  (localized-template pkgnam tplnam defpkg deftpl) )

(define ((make-localized-template/default pkgnam) tplnam #!optional (defpkg tplnam) (deftpl tplnam))
  (localized-template pkgnam tplnam) )

(define (format-info-string pkgnam tplnam fmtargs)
  (conc
    #\[
      #\< pkgnam #\space tplnam #\>
      #\space
      (apply conc (intersperse fmtargs #\space))
    #\]) )

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

;;; Bundle Operations

;; Returns the full bundle specifier for the specified package using the default locale

(define (list-delete-false! ls) (remove! not ls))

(define (full-bundle-specifier pkgnam)
  `(,pkgnam ,(current-language) ,(current-country) ,@(current-locale-details)) )

(define (most-specific-bundle-specifier pkgnam)
  (list-delete-false! (full-bundle-specifier pkgnam)) )

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

;; Remove declared bundle, if any

(define (undeclare-bundle! bndl-spec)
  (bundle-delete! (check-bundle-specifier 'undeclare-bundle! bndl-spec)) )

;; Portable Form

(define (bundle-storage-form bndl)
  (hash-table->alist bndl) )

;; Reads bundle file & declares.

(define (load-bundle! bndl-spec . args)
  (let-optionals args ((alt-dir (system-bundle-directory)))
    (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-bundle-directory)))
    (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 (bundle-storage-form bndl))))
      #t ) ) )

;; Remove declared bundle and file, if any

(define (remove-bundle! bndl-spec . args)
  (let-optionals args ((alt-dir (system-bundle-directory)))
    (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-bundle-directory)))
    (let ((path
            (need-bundle-absolute-pathname 'remove-bundle-directory! bndl-spec alt-dir)) )
      ;remove leaf node
      (delete-file* path)
      ;remove all empty parent nodes
      (let ((topdir alt-dir))
        (let delete-path ((path path))
          (let ((dir (pathname-directory path)))
            (cond
              ((string=? dir topdir)
                #t)
              ((not (null? (directory dir)))
                #f)
              (else
                (delete-directory dir)
                (delete-path dir) ) ) ) ) ) ) ) )

;; Try loading from most to least specific, returns #f when failure.

(define (*load-available-bundle bndl-spec alt-dir)
  (let try-bundle ((bndl-spec bndl-spec))
    (and (not (null? bndl-spec))
         (or (load-bundle! bndl-spec alt-dir)
             (try-bundle (drop-right! bndl-spec 1)) ) ) ) )

(define (load-best-available-bundle! bndl-spec . args)
  (let-optionals args ((alt-dir (system-bundle-directory)))
    (*load-available-bundle
      (check-bundle-specifier 'load-best-available-bundle! bndl-spec)
      alt-dir) ) )

;;; Introspection

;;

(define (localized-templates pkgnam)
  (bundle-storage-form (cached-package-bundle pkgnam)) )

;;

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

;;

(define (declared-bundle-templates bndl-spec)
  (bundle-storage-form
    (need-bundle 'declared-bundle-templates
      (check-bundle-specifier 'declared-bundle-templates bndl-spec))) )

;;;

(register-feature! 'srfi-29)

) ;module srfi-29