test-suite/tests/i18n.test

   1 ;;;; i18n.test --- Exercise the i18n API.  -*- coding: utf-8; mode: scheme; -*-
   2 ;;;;
   3 ;;;; Copyright (C) 2006, 2007, 2009, 2010, 2011, 2012,
   4 ;;;;   2013, 2014 Free Software Foundation, Inc.
   5 ;;;; Ludovic Courtès
   6 ;;;;
   7 ;;;; This library is free software; you can redistribute it and/or
   8 ;;;; modify it under the terms of the GNU Lesser General Public
   9 ;;;; License as published by the Free Software Foundation; either
  10 ;;;; version 3 of the License, or (at your option) any later version.
  11 ;;;;
  12 ;;;; This library is distributed in the hope that it will be useful,
  13 ;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  14 ;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
  15 ;;;; Lesser General Public License for more details.
  16 ;;;;
  17 ;;;; You should have received a copy of the GNU Lesser General Public
  18 ;;;; License along with this library; if not, write to the Free Software
  19 ;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
  20
  21 (define-module (test-suite i18n)
  22   #:use-module (ice-9 i18n)
  23   #:use-module (ice-9 format)
  24   #:use-module (srfi srfi-1)
  25   #:use-module (test-suite lib))
  26
  27 ;; Start from a pristine locale state.
  28 (setlocale LC_ALL "C")
  29
  30 (define exception:locale-error
  31   (cons 'system-error "Failed to install locale"))
  32
  33
  34 \f
  35 (with-test-prefix "locale objects"
  36
  37   (pass-if "make-locale (2 args)"
  38     (not (not (make-locale LC_ALL "C"))))
  39
  40   (pass-if "make-locale (2 args, list)"
  41     (not (not (make-locale (list LC_COLLATE LC_NUMERIC) "C"))))
  42
  43   (pass-if "make-locale (3 args)"
  44     (not (not (make-locale (list LC_COLLATE) "C"
  45                            (make-locale (list LC_NUMERIC) "C")))))
  46
  47   (pass-if-exception "make-locale with unknown locale" exception:locale-error
  48     (make-locale LC_ALL "does-not-exist"))
  49
  50   (pass-if "locale?"
  51     (and (locale? (make-locale (list LC_ALL) "C"))
  52          (locale? (make-locale (list LC_TIME LC_NUMERIC) "C"
  53                                (make-locale (list LC_CTYPE) "C")))))
  54
  55   (pass-if "%global-locale"
  56     (and (locale? %global-locale))
  57          (locale? (make-locale (list LC_MONETARY) "C"
  58                                %global-locale))))
  59
  60
  61 \f
  62 (with-test-prefix "text collation (English)"
  63
  64   (pass-if "string-locale<?"
  65     (and (string-locale<? "hello" "world")
  66          (string-locale<? "hello" "world"
  67                           (make-locale (list LC_COLLATE) "C"))))
  68
  69   (pass-if "char-locale<?"
  70     (and (char-locale<? #\a #\b)
  71          (char-locale<? #\a #\b (make-locale (list LC_COLLATE) "C"))))
  72
  73   (pass-if "string-locale-ci=?"
  74     (and (string-locale-ci=? "Hello" "HELLO")
  75          (string-locale-ci=? "Hello" "HELLO"
  76                              (make-locale (list LC_COLLATE) "C"))))
  77
  78   (pass-if "string-locale-ci<?"
  79     (and (string-locale-ci<? "hello" "WORLD")
  80          (string-locale-ci<? "hello" "WORLD"
  81                              (make-locale (list LC_COLLATE) "C")))))
  82
  83 \f
  84 (define mingw?
  85   (string-contains %host-type "-mingw32"))
  86
  87 (define %french-locale-name
  88   (if mingw?
  89       "fra_FRA.850"
  90       "fr_FR.ISO-8859-1"))
  91
  92 ;; What we really want for the following locales is that they be Unicode
  93 ;; capable, not necessarily UTF-8, which Windows does not provide.
  94
  95 (define %french-utf8-locale-name
  96   (if mingw?
  97       "fra_FRA.1252"
  98       "fr_FR.UTF-8"))
  99
 100 (define %turkish-utf8-locale-name
 101   (if mingw?
 102       "tur_TRK.1254"
 103       "tr_TR.UTF-8"))
 104
 105 (define %german-utf8-locale-name
 106   (if mingw?
 107       "deu_DEU.1252"
 108       "de_DE.UTF-8"))
 109
 110 (define %greek-utf8-locale-name
 111   (if mingw?
 112       "grc_ELL.1253"
 113       "el_GR.UTF-8"))
 114
 115 (define %american-english-locale-name
 116   "en_US")
 117
 118 (define %french-locale
 119   (false-if-exception
 120    (make-locale (list LC_CTYPE LC_COLLATE LC_NUMERIC LC_TIME)
 121                 %french-locale-name)))
 122
 123 (define %french-utf8-locale
 124   (false-if-exception
 125    (make-locale (list LC_CTYPE LC_COLLATE LC_NUMERIC LC_TIME)
 126                 %french-utf8-locale-name)))
 127
 128 (define %german-utf8-locale
 129   (false-if-exception
 130    (make-locale LC_ALL
 131                 %german-utf8-locale-name)))
 132
 133 (define %greek-utf8-locale
 134   (false-if-exception
 135    (make-locale LC_ALL
 136                 %greek-utf8-locale-name)))
 137
 138 (define %turkish-utf8-locale
 139   (false-if-exception
 140    (make-locale LC_ALL
 141                 %turkish-utf8-locale-name)))
 142
 143 (define %american-english-locale
 144   (false-if-exception
 145    (make-locale LC_ALL
 146                 %american-english-locale-name)))
 147
 148 (define (under-locale-or-unresolved locale thunk)
 149   ;; On non-GNU systems, an exception may be raised only when the locale is
 150   ;; actually used rather than at `make-locale'-time.  Thus, we must guard
 151   ;; against both.
 152   (if locale
 153       (if (string-contains %host-type "-gnu")
 154           (thunk)
 155           (catch 'system-error thunk
 156                  (lambda (key . args)
 157                    (throw 'unresolved))))
 158       (throw 'unresolved)))
 159
 160 (define (under-french-locale-or-unresolved thunk)
 161   (under-locale-or-unresolved %french-locale thunk))
 162
 163 (define (under-french-utf8-locale-or-unresolved thunk)
 164   (under-locale-or-unresolved %french-utf8-locale thunk))
 165
 166 (define (under-turkish-utf8-locale-or-unresolved thunk)
 167   ;; FreeBSD 8.2 and 9.1, Solaris 2.10, Darwin 8.11.0, and MinGW have
 168   ;; a broken tr_TR locale where `i' is mapped to uppercase `I'
 169   ;; instead of `İ', so disable tests on that platform.
 170   (if (or (string-contains %host-type "freebsd8")
 171           (string-contains %host-type "freebsd9")
 172           (string-contains %host-type "solaris2.10")
 173           (string-contains %host-type "darwin8")
 174           (string-contains %host-type "mingw32"))
 175       (throw 'unresolved)
 176       (under-locale-or-unresolved %turkish-utf8-locale thunk)))
 177
 178 (define (under-german-utf8-locale-or-unresolved thunk)
 179   (under-locale-or-unresolved %german-utf8-locale thunk))
 180
 181 (define (under-greek-utf8-locale-or-unresolved thunk)
 182   (under-locale-or-unresolved %greek-utf8-locale thunk))
 183
 184 (define (under-american-english-locale-or-unresolved thunk)
 185   (under-locale-or-unresolved %american-english-locale thunk))
 186
 187
 188 (with-test-prefix "text collation (French)"
 189
 190   (pass-if "string-locale<?"
 191     (under-french-locale-or-unresolved
 192       (lambda ()
 193         (string-locale<? "été" "hiver" %french-locale))))
 194
 195   (pass-if "char-locale<?"
 196     (under-french-locale-or-unresolved
 197       (lambda ()
 198         (char-locale<? #\é #\h %french-locale))))
 199
 200   (pass-if "string-locale-ci=?"
 201     (under-french-locale-or-unresolved
 202       (lambda ()
 203         (string-locale-ci=? "ÉTÉ" "été" %french-locale))))
 204
 205   (pass-if "string-locale-ci=? (2 args, wide strings)"
 206     (under-french-utf8-locale-or-unresolved
 207       (lambda ()
 208         ;; Note: Character `œ' is not part of Latin-1, so these are wide
 209         ;; strings.
 210         (dynamic-wind
 211           (lambda ()
 212             (setlocale LC_ALL %french-utf8-locale-name))
 213           (lambda ()
 214             (string-locale-ci=? "œuf" "ŒUF"))
 215           (lambda ()
 216             (setlocale LC_ALL "C"))))))
 217
 218   (pass-if "string-locale-ci=? (3 args, wide strings)"
 219     (under-french-utf8-locale-or-unresolved
 220       (lambda ()
 221         (string-locale-ci=? "œuf" "ŒUF" %french-utf8-locale))))
 222
 223   (pass-if "string-locale-ci<>?"
 224     (under-french-locale-or-unresolved
 225       (lambda ()
 226         (and (string-locale-ci<? "été" "Hiver" %french-locale)
 227              (string-locale-ci>? "HiVeR" "été" %french-locale)))))
 228
 229   (pass-if "string-locale-ci<>? (wide strings)"
 230     (under-french-utf8-locale-or-unresolved
 231       (lambda ()
 232         ;; One of the strings is UCS-4, the other is Latin-1.
 233         (and (string-locale-ci<? "Œdème" "œuf" %french-utf8-locale)
 234              (string-locale-ci>? "Œuf" "œdÈMe" %french-utf8-locale)))))
 235
 236   (pass-if "string-locale-ci<>? (wide and narrow strings)"
 237     (under-french-utf8-locale-or-unresolved
 238       (lambda ()
 239         ;; One of the strings is UCS-4, the other is Latin-1.
 240         (and (string-locale-ci>? "Œdème" "odyssée" %french-utf8-locale)
 241              (string-locale-ci<? "Odyssée" "œdème" %french-utf8-locale)))))
 242
 243   (pass-if "char-locale-ci<>?"
 244      (under-french-locale-or-unresolved
 245        (lambda ()
 246          (and (char-locale-ci<? #\é #\H %french-locale)
 247               (char-locale-ci>? #\h #\É %french-locale)))))
 248
 249   (pass-if "char-locale-ci<>? (wide)"
 250      (under-french-utf8-locale-or-unresolved
 251        (lambda ()
 252          (and (char-locale-ci<? #\o #\œ %french-utf8-locale)
 253               (char-locale-ci>? #\Œ #\e %french-utf8-locale))))))
 254
 255 \f
 256 (with-test-prefix "text collation (German)"
 257
 258   (pass-if "string-locale-ci=?"
 259     (under-german-utf8-locale-or-unresolved
 260      (lambda ()
 261        (let ((de (make-locale LC_ALL %german-utf8-locale-name)))
 262          (string-locale-ci=? "Straße" "STRASSE"))))))
 263
 264 \f
 265 (with-test-prefix "text collation (Greek)"
 266
 267   (pass-if "string-locale-ci=?"
 268     (under-greek-utf8-locale-or-unresolved
 269      (lambda ()
 270        (let ((gr (make-locale LC_ALL %greek-utf8-locale-name)))
 271          (string-locale-ci=? "ΧΑΟΣ" "χαος" gr))))))
 272
 273 \f
 274 (with-test-prefix "character mapping"
 275
 276   (pass-if "char-locale-downcase"
 277     (and (eqv? #\a (char-locale-downcase #\A))
 278          (eqv? #\a (char-locale-downcase #\A (make-locale LC_ALL "C")))))
 279
 280   (pass-if "char-locale-upcase"
 281     (and (eqv? #\Z (char-locale-upcase #\z))
 282          (eqv? #\Z (char-locale-upcase #\z (make-locale LC_ALL "C")))))
 283
 284   (pass-if "char-locale-titlecase"
 285     (and (eqv? #\T (char-locale-titlecase #\t))
 286          (eqv? #\T (char-locale-titlecase #\t (make-locale LC_ALL "C")))))
 287
 288   (pass-if "char-locale-titlecase Dž"
 289     (and (eqv? #\762 (char-locale-titlecase #\763))
 290          (eqv? #\762 (char-locale-titlecase #\763 (make-locale LC_ALL "C")))))
 291
 292   (pass-if "char-locale-upcase Turkish"
 293     (under-turkish-utf8-locale-or-unresolved
 294      (lambda ()
 295        (eqv? #\İ (char-locale-upcase #\i %turkish-utf8-locale)))))
 296
 297   (pass-if "char-locale-downcase Turkish"
 298     (under-turkish-utf8-locale-or-unresolved
 299      (lambda ()
 300        (eqv? #\i (char-locale-downcase #\İ %turkish-utf8-locale))))))
 301
 302 \f
 303 (with-test-prefix "string mapping"
 304
 305   (pass-if "string-locale-downcase"
 306     (and (string=? "a" (string-locale-downcase "A"))
 307          (string=? "a" (string-locale-downcase "A" (make-locale LC_ALL "C")))))
 308
 309   (pass-if "string-locale-upcase"
 310     (and (string=? "Z" (string-locale-upcase "z"))
 311          (string=? "Z" (string-locale-upcase "z" (make-locale LC_ALL "C")))))
 312
 313   (pass-if "string-locale-titlecase"
 314     (and (string=? "Hello, World" (string-locale-titlecase "hello, world"))
 315          (string=? "Hello, World" (string-locale-titlecase
 316                                    "hello, world" (make-locale LC_ALL "C")))))
 317
 318   (pass-if "string-locale-upcase German"
 319     (under-german-utf8-locale-or-unresolved
 320      (lambda ()
 321        (let ((de (make-locale LC_ALL %german-utf8-locale-name)))
 322          (string=? "STRASSE"
 323                    (string-locale-upcase "Straße" de))))))
 324
 325   (pass-if "string-locale-upcase Greek"
 326     (under-greek-utf8-locale-or-unresolved
 327      (lambda ()
 328        (let ((el (make-locale LC_ALL %greek-utf8-locale-name)))
 329          (string=? "ΧΑΟΣ"
 330                    (string-locale-upcase "χαος" el))))))
 331
 332   (pass-if "string-locale-upcase Greek (two sigmas)"
 333     (under-greek-utf8-locale-or-unresolved
 334      (lambda ()
 335        (let ((el (make-locale LC_ALL %greek-utf8-locale-name)))
 336          (string=? "ΓΕΙΆ ΣΑΣ"
 337                    (string-locale-upcase "Γειά σας" el))))))
 338
 339   (pass-if "string-locale-downcase Greek"
 340     (under-greek-utf8-locale-or-unresolved
 341      (lambda ()
 342        (let ((el (make-locale LC_ALL %greek-utf8-locale-name)))
 343          (string=? "χαος"
 344                    (string-locale-downcase "ΧΑΟΣ" el))))))
 345
 346   (pass-if "string-locale-downcase Greek (two sigmas)"
 347     (under-greek-utf8-locale-or-unresolved
 348      (lambda ()
 349        (let ((el (make-locale LC_ALL %greek-utf8-locale-name)))
 350          (string=? "γειά σας"
 351                    (string-locale-downcase "ΓΕΙΆ ΣΑΣ" el))))))
 352
 353   (pass-if "string-locale-upcase Turkish"
 354     (under-turkish-utf8-locale-or-unresolved
 355      (lambda ()
 356        (string=? "İI" (string-locale-upcase "iı" %turkish-utf8-locale)))))
 357
 358   (pass-if "string-locale-downcase Turkish"
 359     (under-turkish-utf8-locale-or-unresolved
 360      (lambda ()
 361        (string=? "iı" (string-locale-downcase "İI" %turkish-utf8-locale))))))
 362
 363 \f
 364 (with-test-prefix "number parsing"
 365
 366   (pass-if "locale-string->integer"
 367     (call-with-values (lambda () (locale-string->integer "123"))
 368       (lambda (result char-count)
 369         (and (equal? result 123)
 370              (equal? char-count 3)))))
 371
 372   (pass-if "locale-string->inexact"
 373     (call-with-values
 374         (lambda ()
 375           (locale-string->inexact "123.456"
 376                                   (make-locale (list LC_NUMERIC) "C")))
 377       (lambda (result char-count)
 378         (and (equal? result 123.456)
 379              (equal? char-count 7)))))
 380
 381   (pass-if "locale-string->inexact (French)"
 382     (under-french-locale-or-unresolved
 383      (lambda ()
 384        (call-with-values
 385            (lambda ()
 386              (locale-string->inexact "123,456" %french-locale))
 387          (lambda (result char-count)
 388            (and (equal? result 123.456)
 389                 (equal? char-count 7))))))))
 390
 391 \f
 392 ;;;
 393 ;;; `nl-langinfo'
 394 ;;;
 395
 396 (setlocale LC_ALL "C")
 397 (define %c-locale (make-locale LC_ALL "C"))
 398
 399 (define %english-days
 400   '("Sunday" "Monday" "Tuesday" "Wednesday" "Thursday" "Friday" "Saturday"))
 401
 402 (define (every? . args)
 403   (not (not (apply every args))))
 404
 405
 406 (with-test-prefix "nl-langinfo et al."
 407
 408   (pass-if "locale-day (1 arg)"
 409     (every? equal?
 410             %english-days
 411             (map locale-day (map 1+ (iota 7)))))
 412
 413   (pass-if "locale-day (2 args)"
 414     (every? equal?
 415             %english-days
 416             (map (lambda (day)
 417                    (locale-day day %c-locale))
 418                  (map 1+ (iota 7)))))
 419
 420   (pass-if "locale-day (2 args, using `%global-locale')"
 421     (every? equal?
 422             %english-days
 423             (map (lambda (day)
 424                    (locale-day day %global-locale))
 425                  (map 1+ (iota 7)))))
 426
 427   (pass-if "locale-day (French)"
 428     (under-french-locale-or-unresolved
 429      (lambda ()
 430        (let ((result (locale-day 3 %french-locale)))
 431          (and (string? result)
 432               (string-ci=? result "mardi"))))))
 433
 434   (pass-if "locale-day (French, using `%global-locale')"
 435     ;; Make sure `%global-locale' captures the current locale settings as
 436     ;; installed using `setlocale'.
 437     (under-french-locale-or-unresolved
 438      (lambda ()
 439        (dynamic-wind
 440            (lambda ()
 441              (setlocale LC_TIME %french-locale-name))
 442            (lambda ()
 443              (let* ((fr (make-locale (list LC_MONETARY) "C" %global-locale))
 444                     (result (locale-day 3 fr)))
 445                (setlocale LC_ALL "C")
 446                (and (string? result)
 447                     (string-ci=? result "mardi"))))
 448            (lambda ()
 449              (setlocale LC_ALL "C"))))))
 450
 451   (pass-if "default locale"
 452     ;; Make sure the default locale does not capture the current locale
 453     ;; settings as installed using `setlocale'.  The default locale should be
 454     ;; "C".
 455     (under-french-locale-or-unresolved
 456      (lambda ()
 457        (dynamic-wind
 458            (lambda ()
 459              (setlocale LC_ALL %french-locale-name))
 460            (lambda ()
 461              (let* ((locale (make-locale (list LC_MONETARY) "C"))
 462                     (result (locale-day 3 locale)))
 463                (setlocale LC_ALL "C")
 464                (and (string? result)
 465                     (string-ci=? result "Tuesday"))))
 466            (lambda ()
 467              (setlocale LC_ALL "C")))))))
 468
 469 \f
 470 ;;;
 471 ;;; Numbers.
 472 ;;;
 473
 474 (with-test-prefix "number->locale-string"
 475
 476   ;; We assume the global locale is "C" at this point.
 477
 478   (with-test-prefix "C"
 479
 480     (pass-if "no thousand separator"
 481       ;; Unlike in English, the "C" locale has no thousand separator.
 482       ;; If this doesn't hold, the following tests will fail.
 483       (string=? "" (locale-thousands-separator)))
 484
 485     (pass-if "integer"
 486       (string=? "123456" (number->locale-string 123456)))
 487
 488     (pass-if "fraction"
 489       (string=? "1234.567" (number->locale-string 1234.567)))
 490
 491     (pass-if "fraction, 1 digit"
 492       (string=? "1234.5" (number->locale-string 1234.567 1))))
 493
 494   (with-test-prefix "French"
 495
 496     (pass-if "integer"
 497       (under-french-locale-or-unresolved
 498        (lambda ()
 499          (let ((fr (make-locale LC_ALL %french-locale-name)))
 500            (string=? "123 456" (number->locale-string 123456 #t fr))))))
 501
 502     (pass-if "fraction"
 503       (under-french-locale-or-unresolved
 504        (lambda ()
 505          (let ((fr (make-locale LC_ALL %french-locale-name)))
 506            (string=? "1 234,567" (number->locale-string 1234.567 #t fr))))))
 507
 508     (pass-if "fraction, 1 digit"
 509       (under-french-locale-or-unresolved
 510        (lambda ()
 511          (let ((fr (make-locale LC_ALL %french-locale-name)))
 512            (string=? "1 234,5"
 513                      (number->locale-string 1234.567 1 fr))))))))
 514
 515 (with-test-prefix "format ~h"
 516
 517   ;; Some systems like Darwin lack the `GROUPING' nl_item, and thus
 518   ;; `locale-digit-grouping' defaults to '(); skip the tests in that
 519   ;; case.
 520
 521   (with-test-prefix "French"
 522
 523     (pass-if "12345.5678"
 524       (under-french-locale-or-unresolved
 525        (lambda ()
 526          (if (null? (locale-digit-grouping %french-locale))
 527              (throw 'unresolved)
 528              (string=? "12 345,6789"
 529                        (format #f "~:h" 12345.6789 %french-locale)))))))
 530
 531   (with-test-prefix "English"
 532
 533     (pass-if "12345.5678"
 534       (under-american-english-locale-or-unresolved
 535        (lambda ()
 536          (if (null? (locale-digit-grouping %american-english-locale))
 537              (throw 'unresolved)
 538              (string=? "12,345.6789"
 539                        (format #f "~:h" 12345.6789
 540                                %american-english-locale))))))))
 541
 542 (with-test-prefix "monetary-amount->locale-string"
 543
 544   (with-test-prefix "French"
 545
 546     (pass-if "integer"
 547       (under-french-locale-or-unresolved
 548        (lambda ()
 549          (let ((fr (make-locale LC_ALL %french-locale-name)))
 550            (string=? "123 456 +EUR"
 551                      (monetary-amount->locale-string 123456 #f fr))))))
 552
 553     (pass-if "fraction"
 554       (under-french-locale-or-unresolved
 555        (lambda ()
 556          (let ((fr (make-locale LC_ALL %french-locale-name)))
 557            (string=? "1 234,56 EUR "
 558                      (monetary-amount->locale-string 1234.567 #t fr))))))))