guile/test-suite/tests/i18n.test

;;;; i18n.test --- Exercise the i18n API.  -*- coding: utf-8; mode: scheme; -*-
;;;;
;;;; Copyright (C) 2006, 2007, 2009, 2010, 2011, 2012,
;;;;   2013, 2014, 2015, 2016, 2017 Free Software Foundation, Inc.
;;;; Ludovic Courtès
;;;;
;;;; This library is free software; you can redistribute it and/or
;;;; modify it under the terms of the GNU Lesser General Public
;;;; License as published by the Free Software Foundation; either
;;;; version 3 of the License, or (at your option) any later version.
;;;; 
;;;; This library is distributed in the hope that it will be useful,
;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
;;;; Lesser General Public License for more details.
;;;; 
;;;; You should have received a copy of the GNU Lesser General Public
;;;; License along with this library; if not, write to the Free Software
;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA

(define-module (test-suite i18n)
  #:use-module (ice-9 i18n)
  #:use-module (ice-9 format)
  #:use-module (srfi srfi-1)
  #:use-module (test-suite lib))

;; Start from a pristine locale state.
(setlocale LC_ALL "C")

(define exception:locale-error
  (cons 'system-error "Failed to install locale"))



(with-test-prefix "locale objects"

  (pass-if "make-locale (2 args)"
    (not (not (make-locale LC_ALL "C"))))

  (pass-if "make-locale (2 args, list)"
    (not (not (make-locale (list LC_COLLATE LC_NUMERIC) "C"))))

  (pass-if "make-locale (3 args)"
    (not (not (make-locale (list LC_COLLATE) "C"
                           (make-locale (list LC_NUMERIC) "C")))))

  (pass-if-exception "make-locale with unknown locale" exception:locale-error
    (make-locale LC_ALL "does-not-exist"))

  (pass-if "locale?"
    (and (locale? (make-locale (list LC_ALL) "C"))
         (locale? (make-locale (list LC_TIME LC_NUMERIC) "C"
                               (make-locale (list LC_CTYPE) "C")))))

  (pass-if "%global-locale"
    (and (locale? %global-locale))
         (locale? (make-locale (list LC_MONETARY) "C"
                               %global-locale))))



(with-test-prefix "text collation (English)"

  (pass-if "string-locale<?"
    (and (string-locale<? "hello" "world")
         (string-locale<? "hello" "world"
                          (make-locale (list LC_COLLATE) "C"))))

  (pass-if "char-locale<?"
    (and (char-locale<? #\a #\b)
         (char-locale<? #\a #\b (make-locale (list LC_COLLATE) "C"))))

  (pass-if "string-locale-ci=?"
    (and (string-locale-ci=? "Hello" "HELLO")
         (string-locale-ci=? "Hello" "HELLO"
                             (make-locale (list LC_COLLATE) "C"))))

  (pass-if "string-locale-ci<?"
    (and (string-locale-ci<? "hello" "WORLD")
         (string-locale-ci<? "hello" "WORLD"
                             (make-locale (list LC_COLLATE) "C")))))


(define mingw?
  (string-contains %host-type "-mingw32"))

(define %french-locale-name
  (if mingw?
      "fra_FRA.850"
      "fr_FR.iso88591"))         ;"iso88591" is the "normalized codeset"

;; What we really want for the following locales is that they be Unicode
;; capable, not necessarily UTF-8, which Windows does not provide.

(define %french-utf8-locale-name
  (if mingw?
      "fra_FRA.1252"
      "fr_FR.utf8"))                 ;"utf8" is the "normalized codeset"

(define %turkish-utf8-locale-name
  (if mingw?
      "tur_TRK.1254"
      "tr_TR.utf8"))

(define %german-utf8-locale-name
  (if mingw?
      "deu_DEU.1252"
      "de_DE.utf8"))

(define %greek-utf8-locale-name
  (if mingw?
      "grc_ELL.1253"
      "el_GR.utf8"))

(define %american-english-locale-name
  "en_US.utf8")

(define %french-locale
  (false-if-exception
   (make-locale (list LC_CTYPE LC_COLLATE LC_NUMERIC LC_TIME)
                %french-locale-name)))

(define %french-utf8-locale
  (false-if-exception
   (make-locale (list LC_CTYPE LC_COLLATE LC_NUMERIC LC_TIME)
                %french-utf8-locale-name)))

(define %german-utf8-locale
  (false-if-exception
   (make-locale LC_ALL
                %german-utf8-locale-name)))

(define %greek-utf8-locale
  (false-if-exception
   (make-locale LC_ALL
                %greek-utf8-locale-name)))

(define %turkish-utf8-locale
  (false-if-exception
   (make-locale LC_ALL
                %turkish-utf8-locale-name)))

(define %american-english-locale
  (false-if-exception
   (make-locale LC_ALL
                %american-english-locale-name)))

(define (under-locale-or-unresolved locale thunk)
  ;; On non-GNU systems, an exception may be raised only when the locale is
  ;; actually used rather than at `make-locale'-time.  Thus, we must guard
  ;; against both.
  (if locale
      (if (string-contains %host-type "-gnu")
          (thunk)
          (catch 'system-error thunk
                 (lambda (key . args)
                   (throw 'unresolved))))
      (throw 'unresolved)))

(define (under-french-locale-or-unresolved thunk)
  (under-locale-or-unresolved %french-locale thunk))

(define (under-french-utf8-locale-or-unresolved thunk)
  (under-locale-or-unresolved %french-utf8-locale thunk))

(define (under-turkish-utf8-locale-or-unresolved thunk)
  ;; FreeBSD 8.2 and 9.1, Solaris 2.10, Darwin 8.11.0, Cygwin, and MinGW have
  ;; a broken tr_TR locale where `i' is mapped to uppercase `I'
  ;; instead of `İ', so disable tests on that platform.
  (if (or (string-contains %host-type "freebsd8")
          (string-contains %host-type "freebsd9")
          (string-contains %host-type "solaris2.10")
          (string-contains %host-type "darwin8")
          (string-contains %host-type "mingw32")
          (string-contains %host-type "cygwin"))
      (throw 'unresolved)
      (under-locale-or-unresolved %turkish-utf8-locale thunk)))

(define (under-german-utf8-locale-or-unresolved thunk)
  (under-locale-or-unresolved %german-utf8-locale thunk))

(define (under-greek-utf8-locale-or-unresolved thunk)
  (under-locale-or-unresolved %greek-utf8-locale thunk))

(define (under-american-english-locale-or-unresolved thunk)
  (under-locale-or-unresolved %american-english-locale thunk))


(with-test-prefix "text collation (French)"

  (pass-if "string-locale<?"
    (under-french-locale-or-unresolved
      (lambda ()
        (string-locale<? "été" "hiver" %french-locale))))

  (pass-if "char-locale<?"
    (under-french-locale-or-unresolved
      (lambda ()
        (char-locale<? #\é #\h %french-locale))))

  (pass-if "string-locale-ci=?"
    (under-french-locale-or-unresolved
      (lambda ()
        (string-locale-ci=? "ÉTÉ" "été" %french-locale))))

  (pass-if "string-locale-ci=? (2 args, wide strings)"
    (under-french-utf8-locale-or-unresolved
      (lambda ()
        ;; Note: Character `œ' is not part of Latin-1, so these are wide
        ;; strings.
        (dynamic-wind
          (lambda ()
            (setlocale LC_ALL %french-utf8-locale-name))
          (lambda ()
            (string-locale-ci=? "œuf" "ŒUF"))
          (lambda ()
            (setlocale LC_ALL "C"))))))

  (pass-if "string-locale-ci=? (3 args, wide strings)"
    (under-french-utf8-locale-or-unresolved
      (lambda ()
        (string-locale-ci=? "œuf" "ŒUF" %french-utf8-locale))))

  (pass-if "string-locale-ci<>?"
    (under-french-locale-or-unresolved
      (lambda ()
        (and (string-locale-ci<? "été" "Hiver" %french-locale)
             (string-locale-ci>? "HiVeR" "été" %french-locale)))))

  (pass-if "string-locale-ci<>? (wide strings)"
    (under-french-utf8-locale-or-unresolved
      (lambda ()
        ;; One of the strings is UCS-4, the other is Latin-1.
        (and (string-locale-ci<? "Œdème" "œuf" %french-utf8-locale)
             (string-locale-ci>? "Œuf" "œdÈMe" %french-utf8-locale)))))

  (pass-if "string-locale-ci<>? (wide and narrow strings)"
    (under-french-utf8-locale-or-unresolved
      (lambda ()
        ;; One of the strings is UCS-4, the other is Latin-1.
        (and (string-locale-ci>? "Œdème" "odyssée" %french-utf8-locale)
             (string-locale-ci<? "Odyssée" "œdème" %french-utf8-locale)))))

  (pass-if "char-locale-ci<>?"
     (under-french-locale-or-unresolved
       (lambda ()
         (and (char-locale-ci<? #\é #\H %french-locale)
              (char-locale-ci>? #\h #\É %french-locale)))))

  (pass-if "char-locale-ci<>? (wide)"
     (under-french-utf8-locale-or-unresolved
       (lambda ()
         (and (char-locale-ci<? #\o #\œ %french-utf8-locale)
              (char-locale-ci>? #\Π#\e %french-utf8-locale))))))


(with-test-prefix "text collation (German)"

  (pass-if "string-locale-ci=?"
    (under-german-utf8-locale-or-unresolved
     (lambda ()
       (let ((de (make-locale LC_ALL %german-utf8-locale-name)))
         (string-locale-ci=? "Straße" "STRASSE"))))))


(with-test-prefix "text collation (Greek)"

  (pass-if "string-locale-ci=?"
    (under-greek-utf8-locale-or-unresolved
     (lambda ()
       (let ((gr (make-locale LC_ALL %greek-utf8-locale-name)))
         (string-locale-ci=? "ΧΑΟΣ" "χαος" gr))))))


(with-test-prefix "text collation (Czech)"

  (pass-if "string-locale<? for 'ch'"
    (under-locale-or-unresolved
     "cs_CZ.utf8"
     (lambda ()
       ;; Czech sorts digraph 'ch' between 'h' and 'i'.
       ;;
       ;; GNU libc 2.22 gets this wrong:
       ;; <https://sourceware.org/bugzilla/show_bug.cgi?id=18589>.  For
       ;; now, just skip it if it fails (XXX).
       (or (and (string-locale>? "chxxx" "cxxx")
                (string-locale>? "chxxx" "hxxx")
                (string-locale<? "chxxxx" "ixxx"))
           (throw 'unresolved))))))


(with-test-prefix "character mapping"

  (pass-if "char-locale-downcase"
    (and (eqv? #\a (char-locale-downcase #\A))
         (eqv? #\a (char-locale-downcase #\A (make-locale LC_ALL "C")))))

  (pass-if "char-locale-upcase"
    (and (eqv? #\Z (char-locale-upcase #\z))
         (eqv? #\Z (char-locale-upcase #\z (make-locale LC_ALL "C")))))

  (pass-if "char-locale-titlecase"
    (and (eqv? #\T (char-locale-titlecase #\t))
	 (eqv? #\T (char-locale-titlecase #\t (make-locale LC_ALL "C")))))

  (pass-if "char-locale-titlecase Dž"
    (and (eqv? #\762 (char-locale-titlecase #\763))
	 (eqv? #\762 (char-locale-titlecase #\763 (make-locale LC_ALL "C")))))

  (pass-if "char-locale-upcase Turkish"
    (under-turkish-utf8-locale-or-unresolved
     (lambda ()
       (eqv? #\İ (char-locale-upcase #\i %turkish-utf8-locale)))))

  (pass-if "char-locale-downcase Turkish"
    (under-turkish-utf8-locale-or-unresolved
     (lambda ()
       (eqv? #\i (char-locale-downcase #\İ %turkish-utf8-locale))))))


(with-test-prefix "string mapping"

  (pass-if "string-locale-downcase"
    (and (string=? "a" (string-locale-downcase "A"))
         (string=? "a" (string-locale-downcase "A" (make-locale LC_ALL "C")))))

  (pass-if "string-locale-upcase"
    (and (string=? "Z" (string-locale-upcase "z"))
         (string=? "Z" (string-locale-upcase "z" (make-locale LC_ALL "C")))))

  (pass-if "string-locale-titlecase"
    (and (string=? "Hello, World" (string-locale-titlecase "hello, world"))
	 (string=? "Hello, World" (string-locale-titlecase 
				   "hello, world" (make-locale LC_ALL "C")))))

  (pass-if "string-locale-upcase German"
    (under-german-utf8-locale-or-unresolved
     (lambda ()
       (let ((de (make-locale LC_ALL %german-utf8-locale-name)))
         (string=? "STRASSE"
                   (string-locale-upcase "Straße" de))))))

  (pass-if "string-locale-upcase Greek"
    (under-greek-utf8-locale-or-unresolved
     (lambda ()
       (let ((el (make-locale LC_ALL %greek-utf8-locale-name)))
         (string=? "ΧΑΟΣ"
                   (string-locale-upcase "χαος" el))))))

  (pass-if "string-locale-upcase Greek (two sigmas)"
    (under-greek-utf8-locale-or-unresolved
     (lambda ()
       (let ((el (make-locale LC_ALL %greek-utf8-locale-name)))
         (string=? "ΓΕΙΆ ΣΑΣ"
                   (string-locale-upcase "Γειά σας" el))))))

  (pass-if "string-locale-downcase Greek"
    (under-greek-utf8-locale-or-unresolved
     (lambda ()
       (let ((el (make-locale LC_ALL %greek-utf8-locale-name)))
         (string=? "χαος"
                   (string-locale-downcase "ΧΑΟΣ" el))))))

  (pass-if "string-locale-downcase Greek (two sigmas)"
    (under-greek-utf8-locale-or-unresolved
     (lambda ()
       (let ((el (make-locale LC_ALL %greek-utf8-locale-name)))
         (string=? "γειά σας"
                   (string-locale-downcase "ΓΕΙΆ ΣΑΣ" el))))))

  (pass-if "string-locale-upcase Turkish"
    (under-turkish-utf8-locale-or-unresolved
     (lambda ()
       (string=? "İI" (string-locale-upcase "iı" %turkish-utf8-locale)))))

  (pass-if "string-locale-downcase Turkish"
    (under-turkish-utf8-locale-or-unresolved
     (lambda ()
       (string=? "iı" (string-locale-downcase "İI" %turkish-utf8-locale))))))


(with-test-prefix "number parsing"

  (pass-if "locale-string->integer"
    (call-with-values (lambda () (locale-string->integer "123"))
      (lambda (result char-count)
        (and (equal? result 123)
             (equal? char-count 3)))))

  (pass-if "locale-string->inexact"
    (call-with-values
        (lambda ()
          (locale-string->inexact "123.456"
                                  (make-locale (list LC_NUMERIC) "C")))
      (lambda (result char-count)
        (and (equal? result 123.456)
             (equal? char-count 7)))))

  (pass-if "locale-string->inexact (French)"
    (under-french-locale-or-unresolved
     (lambda ()
       (call-with-values
           (lambda ()
             (locale-string->inexact "123,456" %french-locale))
         (lambda (result char-count)
           (and (equal? result 123.456)
                (equal? char-count 7))))))))


;;;
;;; `nl-langinfo'
;;;

(setlocale LC_ALL "C")
(define %c-locale (make-locale LC_ALL "C"))

(define %english-days
  '("Sunday" "Monday" "Tuesday" "Wednesday" "Thursday" "Friday" "Saturday"))

(define (every? . args)
  (not (not (apply every args))))


(with-test-prefix "nl-langinfo et al."

  (pass-if "locale-day (1 arg)"
    (every? equal?
            %english-days
            (map locale-day (map 1+ (iota 7)))))

  (pass-if "locale-day (2 args)"
    (every? equal?
            %english-days
            (map (lambda (day)
                   (locale-day day %c-locale))
                 (map 1+ (iota 7)))))

  (pass-if "locale-day (2 args, using `%global-locale')"
    (every? equal?
            %english-days
            (map (lambda (day)
                   (locale-day day %global-locale))
                 (map 1+ (iota 7)))))

  (pass-if "locale-day (French)"
    (under-french-locale-or-unresolved
     (lambda ()
       (let ((result (locale-day 3 %french-locale)))
         (and (string? result)
              (string-ci=? result "mardi"))))))

  (pass-if "locale-day (French, using `%global-locale')"
    ;; Make sure `%global-locale' captures the current locale settings as
    ;; installed using `setlocale'.
    (under-french-locale-or-unresolved
     (lambda ()
       (dynamic-wind
           (lambda ()
             (setlocale LC_TIME %french-locale-name))
           (lambda ()
             (let* ((fr (make-locale (list LC_MONETARY) "C" %global-locale))
                    (result (locale-day 3 fr)))
               (setlocale LC_ALL "C")
               (and (string? result)
                    (string-ci=? result "mardi"))))
           (lambda ()
             (setlocale LC_ALL "C"))))))

  (pass-if "default locale"
    ;; Make sure the default locale does not capture the current locale
    ;; settings as installed using `setlocale'.  The default locale should be
    ;; "C".
    (under-french-locale-or-unresolved
     (lambda ()
       (dynamic-wind
           (lambda ()
             (setlocale LC_ALL %french-locale-name))
           (lambda ()
             (let* ((locale (make-locale (list LC_MONETARY) "C"))
                    (result (locale-day 3 locale)))
               (setlocale LC_ALL "C")
               (and (string? result)
                    (string-ci=? result "Tuesday"))))
           (lambda ()
             (setlocale LC_ALL "C")))))))


;;;
;;; Numbers.
;;;

(with-test-prefix "number->locale-string"

  ;; We assume the global locale is "C" at this point.

  (with-test-prefix "C"

    (pass-if-equal "no thousand separator"
        ""
      ;; Unlike in English, the "C" locale has no thousand separator.
      ;; If this doesn't hold, the following tests will fail.
      (locale-thousands-separator))

    (pass-if-equal "integer"
        "123456"
      (number->locale-string 123456))

    (pass-if-equal "fraction"
        "1234.567"
      (number->locale-string 1234.567))

    (pass-if-equal "fraction, 1 digit"
        "1234.6"
      (number->locale-string 1234.567 1))

    (pass-if-equal "fraction, 10 digits"
        "0.0000300000"
      (number->locale-string .00003 10))

    (pass-if-equal "trailing zeros"
        "-10.00000"
      (number->locale-string -10.0 5))

    (pass-if-equal "positive inexact zero, 1 digit"
        "0.0"
      (number->locale-string .0 1)))

  (with-test-prefix "French"

    (pass-if-equal "integer"
        "123 456"
      (under-french-locale-or-unresolved
       (lambda ()
         (let ((fr (make-locale LC_ALL %french-locale-name)))
           (number->locale-string 123456 #t fr)))))

    (pass-if-equal "negative integer"
        "-1 234 567"
      (under-french-locale-or-unresolved
       (lambda ()
         (let ((fr (make-locale LC_ALL %french-locale-name)))
           (number->locale-string -1234567 #t fr)))))

    (pass-if-equal "fraction"
        "1 234,567"
      (under-french-locale-or-unresolved
       (lambda ()
         (let ((fr (make-locale LC_ALL %french-locale-name)))
           (number->locale-string 1234.567 #t fr)))))

    (pass-if-equal "fraction, 1 digit"
        "1 234,6"
      (under-french-locale-or-unresolved
       (lambda ()
         (let ((fr (make-locale LC_ALL %french-locale-name)))
           (number->locale-string 1234.567 1 fr)))))))

(with-test-prefix "format ~h"

  ;; Some systems like Darwin lack the `GROUPING' nl_item, and thus
  ;; `locale-digit-grouping' defaults to '(); skip the tests in that
  ;; case.

  (with-test-prefix "French"

    (pass-if-equal "12345.678"
        "12 345,678"
      (under-french-locale-or-unresolved
       (lambda ()
         (if (null? (locale-digit-grouping %french-locale))
             (throw 'unresolved)
             (format #f "~:h" 12345.678 %french-locale))))))

  (with-test-prefix "English"

    (pass-if-equal "12345.678"
        "12,345.678"
      (under-american-english-locale-or-unresolved
       (lambda ()
         (if (null? (locale-digit-grouping %american-english-locale))
             (throw 'unresolved)
             (format #f "~:h" 12345.678
                     %american-english-locale)))))))

(with-test-prefix "monetary-amount->locale-string"

  (with-test-prefix "French"

    (pass-if-equal "integer"
        "123 456,00 +EUR"
      (under-french-locale-or-unresolved
       (lambda ()
         (let ((fr (make-locale LC_ALL %french-locale-name)))
           (monetary-amount->locale-string 123456 #f fr)))))

    (pass-if-equal "fraction"
        "1 234,57 EUR "
      (under-french-locale-or-unresolved
       (lambda ()
         (let ((fr (make-locale LC_ALL %french-locale-name)))
           (monetary-amount->locale-string 1234.567 #t fr)))))

    (pass-if-equal "positive inexact zero"
        "0,00 +EUR"
      (under-french-locale-or-unresolved
       (lambda ()
         (let ((fr (make-locale LC_ALL %french-locale-name)))
           (monetary-amount->locale-string 0. #f fr)))))

    (pass-if-equal "one cent"
        "0,01 EUR "
      (under-french-locale-or-unresolved
       (lambda ()
         (let ((fr (make-locale LC_ALL %french-locale-name)))
           (monetary-amount->locale-string .01 #t fr)))))

    (pass-if-equal "very little money"
        "0,00 EUR "
      (under-french-locale-or-unresolved
       (lambda ()
         (let ((fr (make-locale LC_ALL %french-locale-name)))
           (monetary-amount->locale-string .00003 #t fr)))))))