;;;; locale-current.scm
;;;; 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
    locale-setup)

  (import
    scheme chicken
    (only posix seconds->local-time)
    (only type-errors warning-argument-type)
    locale-builtin
    locale-posix
    locale-components
    locale-categories)

  (require-library
    posix type-errors locale-builtin locale-posix
    locale-components locale-categories)

;;;

(define-inline (current-dstflag)
  (vector-ref (seconds->local-time (current-seconds)) 8) )

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

;;; Parameters (Well, parameter-like)

;;

(define (current-timezone . args)
  (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)
  (if (null? args) (locale-category+component-ref 'messages 'name)
    (let-optionals args ((obj #f) (src "USER"))
      (cond
        ((not obj)
          (set-locale-category! 'messages #f) )
        ((string? obj)
          (set-locale-category!
            'messages
            (posix-locale-string->locale-components obj src)) )
        ((language-components? obj)
          (set-locale-category! 'messages obj) )
        (else
          (warning-argument-type 'current-locale obj "string, #f or locale-components")
          (current-locale) ) ) ) ) )

;;

(define (current-timezone-components) (locale-category-ref 'timezone))
(define (current-locale-components) (locale-category-ref 'messages))

;;

(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))
  (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))
  (unless (locale-category-ref 'language)
    ;GNU says only obey when locale specified
    ;in this case we know locale is "specified"
    (when (use-builtin-language)))
  ;Chicken platform extensions
  (when (current-timezone-components)
    (set-timezone-component! (current-timezone-components) 'dst? (current-dstflag)) ) )

;;;
;;; Module Init
;;;

(locale-setup)
(unless (current-timezone-components) (warning "cannot determine a timezone") )
(unless (current-locale-components) (warning "cannot determine a locale") )

) ;module locale