;;;; locale-current.scm
;;;; Kon Lovett, Mar '19
;;;; Kon Lovett, May '06

;; Issues
;;
;; - Only Posix for now.
;;
;; - Uses the `messages' locale category as a proxy for the singleton
;; concept of locale.

(module locale-current

(;export
  current-timezone
  current-locale
  current-timezone-components
  current-locale-components
  current-dst?
  ;
  locale-setup)

(import scheme)
(import (chicken base))
(import (chicken type))
(import (only (chicken time posix) seconds->local-time local-timezone-abbreviation))
(import (only (chicken process-context) get-environment-variable))
(import (only (srfi 13) string-null?))
(import (only type-errors warning-argument-type))
(import locale-builtin)
(import locale-posix)
(import locale-components)
(import locale-categories)

;;; Local Utility

;;

;TLS
(define *setup?* (make-parameter #f))

(define-inline (ensure-setup)
  ;critical region ?
  (unless (*setup?*)
    (*setup?* #t)
    (locale-setup)) )

;;

;only useful for non-scalar (non-boolean) component
(define-inline (locale-category-component-ref catnam cmpnam)
  (and-let* (
    (lc (locale-category-ref catnam)) )
    (locale-component-ref lc cmpnam)) )

(define-inline (language-components? obj)
  (and (not (timezone-components? obj)) (locale-components? obj)) )

;;; Utility

(define (current-dst?) (vector-ref (seconds->local-time) 8))

;;; Parameters (Well, parameter-like)

;;

(define (current-timezone . args)
  (ensure-setup)
  (if (null? args)
    (locale-category-component-ref 'timezone 'name)
    (let-optionals args ((obj #f) (src "USER"))
      (cond
        ((not obj)
          (set-locale-category! 'timezone #f) )
        ((string? obj)
          (set-locale-category! 'timezone
            (posix-timezone-string->timezone-components obj src)) )
        ((timezone-components? obj)
          (set-locale-category! 'timezone obj) )
        (else
          (warning-argument-type 'current-timezone obj "string, #f or timezone-components")
          (current-timezone) ) ) ) ) )

;; A'la MzScheme
;; Treat locale as messages category

(define (current-locale . args)
  (ensure-setup)
  (if (null? args)
    (locale-category-component-ref 'current 'name)
    (let-optionals args ((obj #f) (src "USER"))
      (cond
        ((not obj)
          (set-locale-category! 'current #f) )
        ((string? obj)
          (set-locale-category!
            'current
            (posix-locale-string->locale-components obj src)) )
        ((language-components? obj)
          (set-locale-category! 'current obj) )
        (else
          (warning-argument-type 'current-locale obj "string, #f or locale-components")
          (current-locale) ) ) ) ) )

;;

(define (current-timezone-components)
  (ensure-setup)
  (locale-category-ref 'timezone) )

(define (current-locale-components)
  (ensure-setup)
  (locale-category-ref 'current) )

;;

;Chicken platform extension

(define (nonnull-getenv varnam)
  (let ((str (get-environment-variable varnam)))
    (and (string? str) (not (string-null? str)) str) ) )

(define (tm-dst? tm) (vector-ref tm 8))
(define (tm-off tm) (vector-ref tm 9))

(define (synthetic-posix-timezone-components tz-str tz-src)
  (let* (
    (tz (make-timezone-components tz-str tz-src))
    (tm (seconds->local-time))
    (keys (if (tm-dst? tm) '(dst-name . dst-offset) '(std-name . std-offset))) )
    (set-timezone-component! tz 'dst? (tm-dst? tm))
    (set-timezone-component! tz (car keys) (local-timezone-abbreviation))
    (set-timezone-component! tz (cdr keys) (tm-off tm))
    tz ) )

(define (synthetic-posix-timezone)
  (and-let* ((tz-str (nonnull-getenv "TZ")))
    (let (
      (tz (synthetic-posix-timezone-components tz-str (list "POSIX" "TZ"))) )
      (set-locale-category! 'timezone tz) ) ) )

;;

(define (locale-setup . args)
  ;Native locale system 1st
  ;FIXME platform locale system here
  ;
  ;Posix locale system 2nd
  (unless (current-timezone) (posix-load-timezone))
  (unless (current-locale) (posix-load-locale))
  ;
  ;TZ Posix locale
  (unless (current-timezone) (synthetic-posix-timezone))
  ;
  ;GNU locale system extension
  (unless (locale-category-ref 'language)
    ;GNU says only obey when locale specified
    (when (current-locale) (gnu-load-locale)) )
  ;
  ;Builtin (faked) locale system last
  (unless (current-timezone) (use-builtin-timezone))
  (unless (current-locale) (use-builtin-locale))
  ;
  ;Utility check
  (unless (current-timezone-components) (warning "cannot determine a timezone"))
  (unless (current-locale-components) (warning "cannot determine a locale"))
  ;
  ;Chicken platform extensions
  (and-let* ((tz (locale-category-ref 'timezone)))
    (unless (locale-component-exists? tz 'dst?)
      (set-timezone-component! tz 'dst? (current-dst?)) ) ) )

) ;module locale