module/ice-9/i18n.scm

   1 ;;;; i18n.scm --- internationalization support    -*- coding: utf-8 -*-
   2
   3 ;;;;    Copyright (C) 2006, 2007, 2009, 2010, 2012 Free Software Foundation, Inc.
   4 ;;;;
   5 ;;;; This library is free software; you can redistribute it and/or
   6 ;;;; modify it under the terms of the GNU Lesser General Public
   7 ;;;; License as published by the Free Software Foundation; either
   8 ;;;; version 3 of the License, or (at your option) any later version.
   9 ;;;;
  10 ;;;; This library is distributed in the hope that it will be useful,
  11 ;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  12 ;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
  13 ;;;; Lesser General Public License for more details.
  14 ;;;;
  15 ;;;; You should have received a copy of the GNU Lesser General Public
  16 ;;;; License along with this library; if not, write to the Free Software
  17 ;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
  18
  19 ;;; Author: Ludovic Courtès <ludo@gnu.org>
  20
  21 ;;; Commentary:
  22 ;;;
  23 ;;; This module provides a number of routines that support
  24 ;;; internationalization (e.g., locale-dependent text collation, character
  25 ;;; mapping, etc.).  It also defines `locale' objects, representing locale
  26 ;;; settings, that may be passed around to most of these procedures.
  27 ;;;
  28
  29 ;;; Code:
  30
  31 (define-module (ice-9 i18n)
  32   :use-module (ice-9 optargs)
  33   :export (;; `locale' type
  34            make-locale locale?
  35            %global-locale
  36
  37            ;; text collation
  38            string-locale<? string-locale>?
  39            string-locale-ci<? string-locale-ci>? string-locale-ci=?
  40
  41            char-locale<? char-locale>?
  42            char-locale-ci<? char-locale-ci>? char-locale-ci=?
  43
  44            ;; character mapping
  45            char-locale-downcase char-locale-upcase char-locale-titlecase
  46            string-locale-downcase string-locale-upcase string-locale-titlecase
  47
  48            ;; reading numbers
  49            locale-string->integer locale-string->inexact
  50
  51            ;; charset/encoding
  52            locale-encoding
  53
  54            ;; days and months
  55            locale-day-short locale-day locale-month-short locale-month
  56
  57            ;; date and time
  58            locale-am-string locale-pm-string
  59            locale-date+time-format locale-date-format locale-time-format
  60            locale-time+am/pm-format
  61            locale-era locale-era-year
  62            locale-era-date-format locale-era-date+time-format
  63            locale-era-time-format
  64
  65            ;; monetary
  66            locale-currency-symbol
  67            locale-monetary-decimal-point locale-monetary-thousands-separator
  68            locale-monetary-grouping locale-monetary-fractional-digits
  69            locale-currency-symbol-precedes-positive?
  70            locale-currency-symbol-precedes-negative?
  71            locale-positive-separated-by-space?
  72            locale-negative-separated-by-space?
  73            locale-monetary-positive-sign locale-monetary-negative-sign
  74            locale-positive-sign-position locale-negative-sign-position
  75            monetary-amount->locale-string
  76
  77            ;; number formatting
  78            locale-digit-grouping locale-decimal-point
  79            locale-thousands-separator
  80            number->locale-string
  81
  82            ;; miscellaneous
  83            locale-yes-regexp locale-no-regexp))
  84
  85
  86 (eval-when (eval load compile)
  87   (load-extension (string-append "libguile-" (effective-version))
  88                   "scm_init_i18n"))
  89
  90 \f
  91 ;;;
  92 ;;; Charset/encoding.
  93 ;;;
  94
  95 (define (locale-encoding . locale)
  96   (apply nl-langinfo CODESET locale))
  97
  98 \f
  99 ;;;
 100 ;;; Months and days.
 101 ;;;
 102
 103 ;; Helper macro: Define a procedure named NAME that maps its argument to
 104 ;; NL-ITEMS (when `nl-langinfo' is provided).
 105 (define-macro (define-vector-langinfo-mapping name nl-items)
 106   (let* ((item-count (length nl-items))
 107          (defines   `(define %nl-items (vector #f ,@nl-items)))
 108          (make-body (lambda (result)
 109                       `(if (and (integer? item) (exact? item))
 110                            (if (and (>= item 1) (<= item ,item-count))
 111                                ,result
 112                                (throw 'out-of-range "out of range" item))
 113                            (throw 'wrong-type-arg "wrong argument type" item)))))
 114     `(define (,name item . locale)
 115        ,defines
 116        ,(make-body '(apply nl-langinfo (vector-ref %nl-items item) locale)))))
 117
 118
 119 (define-vector-langinfo-mapping locale-day-short
 120   (ABDAY_1 ABDAY_2 ABDAY_3 ABDAY_4 ABDAY_5 ABDAY_6 ABDAY_7))
 121
 122 (define-vector-langinfo-mapping locale-day
 123   (DAY_1 DAY_2 DAY_3 DAY_4 DAY_5 DAY_6 DAY_7))
 124
 125 (define-vector-langinfo-mapping locale-month-short
 126   (ABMON_1 ABMON_2 ABMON_3 ABMON_4 ABMON_5 ABMON_6
 127    ABMON_7 ABMON_8 ABMON_9 ABMON_10 ABMON_11 ABMON_12))
 128
 129 (define-vector-langinfo-mapping locale-month
 130   (MON_1 MON_2 MON_3 MON_4 MON_5 MON_6 MON_7 MON_8 MON_9 MON_10 MON_11 MON_12))
 131
 132
 133 \f
 134 ;;;
 135 ;;; Date and time.
 136 ;;;
 137
 138 ;; Define a procedure NAME that gets langinfo item ITEM.  Gnulib's
 139 ;; `nl_langinfo' guarantees that all these items are supported.
 140 (define-syntax-rule (define-simple-langinfo-mapping name item)
 141   (define* (name #:optional (locale %global-locale))
 142     (nl-langinfo item locale)))
 143
 144 (define-simple-langinfo-mapping locale-am-string
 145   AM_STR)
 146 (define-simple-langinfo-mapping locale-pm-string
 147   PM_STR)
 148 (define-simple-langinfo-mapping locale-date+time-format
 149   D_T_FMT)
 150 (define-simple-langinfo-mapping locale-date-format
 151   D_FMT)
 152 (define-simple-langinfo-mapping locale-time-format
 153   T_FMT)
 154 (define-simple-langinfo-mapping locale-time+am/pm-format
 155   T_FMT_AMPM)
 156 (define-simple-langinfo-mapping locale-era
 157   ERA)
 158 (define-simple-langinfo-mapping locale-era-year
 159   ERA_YEAR)
 160 (define-simple-langinfo-mapping locale-era-date+time-format
 161   ERA_D_T_FMT)
 162 (define-simple-langinfo-mapping locale-era-date-format
 163   ERA_D_FMT)
 164 (define-simple-langinfo-mapping locale-era-time-format
 165   ERA_T_FMT)
 166
 167
 168 \f
 169 ;;;
 170 ;;; Monetary information.
 171 ;;;
 172
 173 ;; Define a procedure NAME that gets item LOCAL-ITEM or INTL-ITEM,
 174 ;; depending on whether the caller asked for the international version
 175 ;; or not.  Since Gnulib's `nl_langinfo' module doesn't guarantee that
 176 ;; all these items are available, use DEFAULT/LOCAL and DEFAULT/INTL as
 177 ;; default values when the system does not support them.
 178 (define-macro (define-monetary-langinfo-mapping name local-item intl-item
 179                                                 default/local default/intl)
 180   (let ((body
 181          (let ((intl  (if (defined? intl-item)
 182                           `(apply nl-langinfo ,intl-item locale)
 183                           default/intl))
 184                (local (if (defined? local-item)
 185                           `(apply nl-langinfo ,local-item locale)
 186                           default/local)))
 187            `(if intl? ,intl ,local))))
 188
 189     `(define (,name intl? . locale)
 190        ,body)))
 191
 192 ;; FIXME: How can we use ALT_DIGITS?
 193 (define-monetary-langinfo-mapping locale-currency-symbol
 194   CRNCYSTR           INT_CURR_SYMBOL
 195   "-"                "")
 196 (define-monetary-langinfo-mapping locale-monetary-fractional-digits
 197   FRAC_DIGITS        INT_FRAC_DIGITS
 198   2                  2)
 199
 200 (define-simple-langinfo-mapping locale-monetary-positive-sign
 201   POSITIVE_SIGN)
 202 (define-simple-langinfo-mapping locale-monetary-negative-sign
 203   NEGATIVE_SIGN)
 204 (define-simple-langinfo-mapping locale-monetary-decimal-point
 205   MON_DECIMAL_POINT)
 206 (define-simple-langinfo-mapping locale-monetary-thousands-separator
 207   MON_THOUSANDS_SEP)
 208 (define-simple-langinfo-mapping locale-monetary-digit-grouping
 209   MON_GROUPING)
 210
 211 (define-monetary-langinfo-mapping locale-currency-symbol-precedes-positive?
 212   P_CS_PRECEDES       INT_P_CS_PRECEDES
 213   #t                  #t)
 214 (define-monetary-langinfo-mapping locale-currency-symbol-precedes-negative?
 215   N_CS_PRECEDES       INT_N_CS_PRECEDES
 216   #t                  #t)
 217
 218
 219 (define-monetary-langinfo-mapping locale-positive-separated-by-space?
 220   ;; Whether a space should be inserted between a positive amount and the
 221   ;; currency symbol.
 222   P_SEP_BY_SPACE      INT_P_SEP_BY_SPACE
 223   #t                  #t)
 224 (define-monetary-langinfo-mapping locale-negative-separated-by-space?
 225   ;; Whether a space should be inserted between a negative amount and the
 226   ;; currency symbol.
 227   N_SEP_BY_SPACE      INT_N_SEP_BY_SPACE
 228   #t                  #t)
 229
 230 (define-monetary-langinfo-mapping locale-positive-sign-position
 231   ;; Position of the positive sign wrt. currency symbol and quantity in a
 232   ;; monetary amount.
 233   P_SIGN_POSN         INT_P_SIGN_POSN
 234   'unspecified        'unspecified)
 235 (define-monetary-langinfo-mapping locale-negative-sign-position
 236   ;; Position of the negative sign wrt. currency symbol and quantity in a
 237   ;; monetary amount.
 238   N_SIGN_POSN         INT_N_SIGN_POSN
 239   'unspecified        'unspecified)
 240
 241
 242 (define (%number-integer-part int grouping separator)
 243   ;; Process INT (a string denoting a number's integer part) and return a new
 244   ;; string with digit grouping and separators according to GROUPING (a list,
 245   ;; potentially circular) and SEPARATOR (a string).
 246
 247   ;; Process INT from right to left.
 248   (let loop ((int      int)
 249              (grouping grouping)
 250              (result   '()))
 251     (cond ((string=? int "") (apply string-append result))
 252           ((null? grouping)  (apply string-append int result))
 253           (else
 254            (let* ((len (string-length int))
 255                   (cut (min (car grouping) len)))
 256              (loop (substring int 0 (- len cut))
 257                    (cdr grouping)
 258                    (let ((sub (substring int (- len cut) len)))
 259                      (if (> len cut)
 260                          (cons* separator sub result)
 261                          (cons sub result)))))))))
 262
 263 (define (add-monetary-sign+currency amount figure intl? locale)
 264   ;; Add a sign and currency symbol around FIGURE.  FIGURE should be a
 265   ;; formatted unsigned amount (a string) representing AMOUNT.
 266   (let* ((positive? (> amount 0))
 267          (sign
 268           (cond ((> amount 0) (locale-monetary-positive-sign locale))
 269                 ((< amount 0) (locale-monetary-negative-sign locale))
 270                 (else         "")))
 271          (currency (locale-currency-symbol intl? locale))
 272          (currency-precedes?
 273           (if positive?
 274               locale-currency-symbol-precedes-positive?
 275               locale-currency-symbol-precedes-negative?))
 276          (separated?
 277           (if positive?
 278               locale-positive-separated-by-space?
 279               locale-negative-separated-by-space?))
 280          (sign-position
 281           (if positive?
 282               locale-positive-sign-position
 283               locale-negative-sign-position))
 284          (currency-space
 285           (if (separated? intl? locale) " " ""))
 286          (append-currency
 287           (lambda (amt)
 288             (if (currency-precedes? intl? locale)
 289                 (string-append currency currency-space amt)
 290                 (string-append amt currency-space currency)))))
 291
 292     (case (sign-position intl? locale)
 293       ((parenthesize)
 294        (string-append "(" (append-currency figure) ")"))
 295       ((sign-before)
 296        (string-append sign (append-currency figure)))
 297       ((sign-after unspecified)
 298        ;; following glibc's recommendation for `unspecified'.
 299        (if (currency-precedes? intl? locale)
 300            (string-append currency currency-space sign figure)
 301            (string-append figure currency-space currency sign)))
 302       ((sign-before-currency-symbol)
 303        (if (currency-precedes? intl? locale)
 304            (string-append sign currency currency-space figure)
 305            (string-append figure currency-space sign currency))) ;; unlikely
 306       ((sign-after-currency-symbol)
 307        (if (currency-precedes? intl? locale)
 308            (string-append currency sign currency-space figure)
 309            (string-append figure currency-space currency sign)))
 310       (else
 311        (error "unsupported sign position" (sign-position intl? locale))))))
 312
 313
 314 (define* (monetary-amount->locale-string amount intl?
 315                                          #:optional (locale %global-locale))
 316   "Convert @var{amount} (an inexact) into a string according to the cultural
 317 conventions of either @var{locale} (a locale object) or the current locale.
 318 If @var{intl?} is true, then the international monetary format for the given
 319 locale is used."
 320
 321   (let* ((fraction-digits
 322           (or (locale-monetary-fractional-digits intl? locale) 2))
 323          (decimal-part
 324           (lambda (dec)
 325             (if (or (string=? dec "") (eq? 0 fraction-digits))
 326                 ""
 327                 (string-append (locale-monetary-decimal-point locale)
 328                                (if (< fraction-digits (string-length dec))
 329                                    (substring dec 0 fraction-digits)
 330                                    dec)))))
 331
 332          (external-repr (number->string (if (> amount 0) amount (- amount))))
 333          (int+dec   (string-split external-repr #\.))
 334          (int       (car int+dec))
 335          (dec       (decimal-part (if (null? (cdr int+dec))
 336                                       ""
 337                                       (cadr int+dec))))
 338          (grouping  (locale-monetary-digit-grouping locale))
 339          (separator (locale-monetary-thousands-separator locale)))
 340
 341       (add-monetary-sign+currency amount
 342                                   (string-append
 343                                    (%number-integer-part int grouping
 344                                                          separator)
 345                                    dec)
 346                                   intl? locale)))
 347
 348
 349 \f
 350 ;;;
 351 ;;; Number formatting.
 352 ;;;
 353
 354 (define-simple-langinfo-mapping locale-digit-grouping
 355   GROUPING)
 356 (define-simple-langinfo-mapping locale-decimal-point
 357   RADIXCHAR)
 358 (define-simple-langinfo-mapping locale-thousands-separator
 359   THOUSEP)
 360
 361 (define* (number->locale-string number
 362                                 #:optional (fraction-digits #t)
 363                                            (locale %global-locale))
 364   "Convert @var{number} (an inexact) into a string according to the cultural
 365 conventions of either @var{locale} (a locale object) or the current locale.
 366 Optionally, @var{fraction-digits} may be bound to an integer specifying the
 367 number of fractional digits to be displayed."
 368
 369   (let* ((sign
 370           (cond ((> number 0) "")
 371                 ((< number 0) "-")
 372                 (else         "")))
 373          (decimal-part
 374           (lambda (dec)
 375             (if (or (string=? dec "") (eq? 0 fraction-digits))
 376                 ""
 377                 (string-append (locale-decimal-point locale)
 378                                (if (and (integer? fraction-digits)
 379                                         (< fraction-digits
 380                                            (string-length dec)))
 381                                    (substring dec 0 fraction-digits)
 382                                    dec))))))
 383
 384     (let* ((external-repr (number->string (if (> number 0)
 385                                               number
 386                                               (- number))))
 387            (int+dec   (string-split external-repr #\.))
 388            (int       (car int+dec))
 389            (dec       (decimal-part (if (null? (cdr int+dec))
 390                                         ""
 391                                         (cadr int+dec))))
 392            (grouping  (locale-digit-grouping locale))
 393            (separator (locale-thousands-separator locale)))
 394
 395       (string-append sign
 396                      (%number-integer-part int grouping separator)
 397                      dec))))
 398
 399 \f
 400 ;;;
 401 ;;; Miscellaneous.
 402 ;;;
 403
 404 (define-simple-langinfo-mapping locale-yes-regexp
 405   YESEXPR)
 406 (define-simple-langinfo-mapping locale-no-regexp
 407   NOEXPR)
 408
 409 ;; `YESSTR' and `NOSTR' are considered deprecated so we don't provide them.
 410
 411 ;;; i18n.scm ends here