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