(define-module (disfluid i18n)
  #:use-module (ice-9 i18n)
  #:use-module (ice-9 threads)
  #:use-module (ice-9 match)
  #:use-module (srfi srfi-26)
  #:use-module (web request)
  #:declarative? #t
  #:export ((MY_LC_ALL . LC_ALL) domain G_ (my-ngettext . ngettext))
  #:re-export (bindtextdomain textdomain))

(define switching-locale-mutex
  (make-mutex))

(define sort-qlist
  (cute stable-sort <>
        (match-lambda*
          (((px . _) (py . _))
           (> px py)))))

(define get-preferred-language
  (match-lambda
    ((? request?
        (= request-accept-language
           (= sort-qlist
              ((_ . language) _ ...))))
     (get-preferred-language language))
    ((? string?
        (= (cute string-split <> #\-)
           ((? string? lang)
            (? string? (= string-upcase region)))))
     (format #f "~a_~a.UTF-8" lang region))
    (else "")))

(define MY_LC_ALL
  (make-parameter "" get-preferred-language))

(define domain
  (make-parameter "disfluid"))

(define (disambiguate str out)
  (if (string=? out str)
      ;; No translation, disambiguate
      (match (string-index str #\|)
        (#f str)
        (start (substring str (+ start 1))))
      ;; Translation performed
      out))

(define (set-lc-all locale)
  (catch #t
    (lambda ()
      (setlocale LC_ALL locale))
    (lambda error
      (setlocale LC_ALL ""))))

(define (with-locale-lock thunk)
  (with-mutex switching-locale-mutex
    (let ((previous-locale (setlocale LC_ALL)))
      (dynamic-wind
        (lambda ()
          (set-lc-all (MY_LC_ALL)))
        thunk
        (lambda ()
          (set-lc-all previous-locale))))))

(define (G_ str)
  (disambiguate
   str
   (with-locale-lock
    (lambda ()
      (gettext str (domain))))))

(define (my-ngettext msg msgplural n)
  (let ((out (with-locale-lock
              (lambda ()
                (ngettext msg msgplural n (domain))))))
    (disambiguate
     msg
     (disambiguate msgplural out))))