module/ice-9/i18n.scm

   1 ;;;; i18n.scm --- internationalization support
   2
   3 ;;;;    Copyright (C) 2006, 2007 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 2.1 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 <ludovic.courtes@laas.fr>
  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
  46            string-locale-downcase string-locale-upcase
  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-case
  87  ((load-toplevel compile-toplevel)
  88   (load-extension "libguile-i18n-v-0" "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) or DEFAULTS (when `nl-langinfo'
 105 ;; is not provided).
 106 (define-macro (define-vector-langinfo-mapping name nl-items defaults)
 107   (let* ((item-count (length nl-items))
 108          (defines    (if (provided? 'nl-langinfo)
 109                          `(define %nl-items (vector #f ,@nl-items))
 110                          `(define %defaults (vector #f ,@defaults))))
 111          (make-body (lambda (result)
 112                       `(if (and (integer? item) (exact? item))
 113                            (if (and (>= item 1) (<= item ,item-count))
 114                                ,result
 115                                (throw 'out-of-range "out of range" item))
 116                            (throw 'wrong-type-arg "wrong argument type" item)))))
 117     `(define (,name item . locale)
 118        ,defines
 119        ,(make-body (if (provided? 'nl-langinfo)
 120                        '(apply nl-langinfo (vector-ref %nl-items item) locale)
 121                        '(vector-ref %defaults item))))))
 122
 123
 124 (define-vector-langinfo-mapping locale-day-short
 125   (ABDAY_1 ABDAY_2 ABDAY_3 ABDAY_4 ABDAY_5 ABDAY_6 ABDAY_7)
 126   ("Sun" "Mon" "Tue" "Wed" "Thu" "Fri" "Sat"))
 127
 128 (define-vector-langinfo-mapping locale-day
 129   (DAY_1 DAY_2 DAY_3 DAY_4 DAY_5 DAY_6 DAY_7)
 130   ("Sunday" "Monday" "Tuesday" "Wednesday" "Thursday" "Friday" "Saturday"))
 131
 132 (define-vector-langinfo-mapping locale-month-short
 133   (ABMON_1 ABMON_2 ABMON_3 ABMON_4 ABMON_5 ABMON_6
 134    ABMON_7 ABMON_8 ABMON_9 ABMON_10 ABMON_11 ABMON_12)
 135   ("Jan" "Feb" "Mar" "Apr" "May" "Jun" "Jul" "Aug" "Sep" "Oct" "Nov" "Dec"))
 136
 137 (define-vector-langinfo-mapping locale-month
 138   (MON_1 MON_2 MON_3 MON_4 MON_5 MON_6 MON_7 MON_8 MON_9 MON_10 MON_11 MON_12)
 139   ("January" "February" "March" "April" "May" "June" "July" "August"
 140    "September" "October" "November" "December"))
 141
 142
 143 \f
 144 ;;;
 145 ;;; Date and time.
 146 ;;;
 147
 148 ;; Helper macro: Define a procedure NAME that gets langinfo item ITEM.
 149 (define-macro (define-simple-langinfo-mapping name item default)
 150   (let ((body (if (and (provided? 'nl-langinfo) (defined? item))
 151                   `(apply nl-langinfo ,item locale)
 152                   default)))
 153     `(define (,name . locale)
 154        ,body)))
 155
 156 (define-simple-langinfo-mapping locale-am-string
 157   AM_STR "AM")
 158 (define-simple-langinfo-mapping locale-pm-string
 159   PM_STR "PM")
 160 (define-simple-langinfo-mapping locale-date+time-format
 161   D_T_FMT "%a %b %e %H:%M:%S %Y")
 162 (define-simple-langinfo-mapping locale-date-format
 163   D_FMT   "%m/%d/%y")
 164 (define-simple-langinfo-mapping locale-time-format
 165   T_FMT   "%H:%M:%S")
 166 (define-simple-langinfo-mapping locale-time+am/pm-format
 167   T_FMT_AMPM "%I:%M:%S %p")
 168 (define-simple-langinfo-mapping locale-era
 169   ERA        "")
 170 (define-simple-langinfo-mapping locale-era-year
 171   ERA_YEAR   "")
 172 (define-simple-langinfo-mapping locale-era-date+time-format
 173   ERA_D_T_FMT "")
 174 (define-simple-langinfo-mapping locale-era-date-format
 175   ERA_D_FMT   "")
 176 (define-simple-langinfo-mapping locale-era-time-format
 177   ERA_T_FMT   "")
 178
 179
 180 \f
 181 ;;;
 182 ;;; Monetary information.
 183 ;;;
 184
 185 (define-macro (define-monetary-langinfo-mapping name local-item intl-item
 186                                                 default/local default/intl)
 187   (let ((body
 188          (let ((intl  (if (and (provided? 'nl-langinfo) (defined? intl-item))
 189                           `(apply nl-langinfo ,intl-item locale)
 190                           default/intl))
 191                (local (if (and (provided? 'nl-langinfo) (defined? local-item))
 192                           `(apply nl-langinfo ,local-item locale)
 193                           default/local)))
 194            `(if intl? ,intl ,local))))
 195
 196     `(define (,name intl? . locale)
 197        ,body)))
 198
 199 ;; FIXME: How can we use ALT_DIGITS?
 200 (define-monetary-langinfo-mapping locale-currency-symbol
 201   CRNCYSTR           INT_CURR_SYMBOL
 202   "-"                "")
 203 (define-monetary-langinfo-mapping locale-monetary-fractional-digits
 204   FRAC_DIGITS        INT_FRAC_DIGITS
 205   2                  2)
 206
 207 (define-simple-langinfo-mapping locale-monetary-positive-sign
 208   POSITIVE_SIGN        "+")
 209 (define-simple-langinfo-mapping locale-monetary-negative-sign
 210   NEGATIVE_SIGN        "-")
 211 (define-simple-langinfo-mapping locale-monetary-decimal-point
 212   MON_DECIMAL_POINT    "")
 213 (define-simple-langinfo-mapping locale-monetary-thousands-separator
 214   MON_THOUSANDS_SEP    "")
 215 (define-simple-langinfo-mapping locale-monetary-digit-grouping
 216   MON_GROUPING         '())
 217
 218 (define-monetary-langinfo-mapping locale-currency-symbol-precedes-positive?
 219   P_CS_PRECEDES       INT_P_CS_PRECEDES
 220   #t                  #t)
 221 (define-monetary-langinfo-mapping locale-currency-symbol-precedes-negative?
 222   N_CS_PRECEDES       INT_N_CS_PRECEDES
 223   #t                  #t)
 224
 225
 226 (define-monetary-langinfo-mapping locale-positive-separated-by-space?
 227   ;; Whether a space should be inserted between a positive amount and the
 228   ;; currency symbol.
 229   P_SEP_BY_SPACE      INT_P_SEP_BY_SPACE
 230   #t                  #t)
 231 (define-monetary-langinfo-mapping locale-negative-separated-by-space?
 232   ;; Whether a space should be inserted between a negative amount and the
 233   ;; currency symbol.
 234   N_SEP_BY_SPACE      INT_N_SEP_BY_SPACE
 235   #t                  #t)
 236
 237 (define-monetary-langinfo-mapping locale-positive-sign-position
 238   ;; Position of the positive sign wrt. currency symbol and quantity in a
 239   ;; monetary amount.
 240   P_SIGN_POSN         INT_P_SIGN_POSN
 241   'unspecified        'unspecified)
 242 (define-monetary-langinfo-mapping locale-negative-sign-position
 243   ;; Position of the negative sign wrt. currency symbol and quantity in a
 244   ;; monetary amount.
 245   N_SIGN_POSN         INT_N_SIGN_POSN
 246   'unspecified        'unspecified)
 247
 248
 249 (define (%number-integer-part int grouping separator)
 250   ;; Process INT (a string denoting a number's integer part) and return a new
 251   ;; string with digit grouping and separators according to GROUPING (a list,
 252   ;; potentially circular) and SEPARATOR (a string).
 253
 254   ;; Process INT from right to left.
 255   (let loop ((int      int)
 256              (grouping grouping)
 257              (result   '()))
 258     (cond ((string=? int "") (apply string-append result))
 259           ((null? grouping)  (apply string-append int result))
 260           (else
 261            (let* ((len (string-length int))
 262                   (cut (min (car grouping) len)))
 263              (loop (substring int 0 (- len cut))
 264                    (cdr grouping)
 265                    (let ((sub (substring int (- len cut) len)))
 266                      (if (> len cut)
 267                          (cons* separator sub result)
 268                          (cons sub result)))))))))
 269
 270 (define (add-monetary-sign+currency amount figure intl? locale)
 271   ;; Add a sign and currency symbol around FIGURE.  FIGURE should be a
 272   ;; formatted unsigned amount (a string) representing AMOUNT.
 273   (let* ((positive? (> amount 0))
 274          (sign
 275           (cond ((> amount 0) (locale-monetary-positive-sign locale))
 276                 ((< amount 0) (locale-monetary-negative-sign locale))
 277                 (else         "")))
 278          (currency (locale-currency-symbol intl? locale))
 279          (currency-precedes?
 280           (if positive?
 281               locale-currency-symbol-precedes-positive?
 282               locale-currency-symbol-precedes-negative?))
 283          (separated?
 284           (if positive?
 285               locale-positive-separated-by-space?
 286               locale-negative-separated-by-space?))
 287          (sign-position
 288           (if positive?
 289               locale-positive-sign-position
 290               locale-negative-sign-position))
 291          (currency-space
 292           (if (separated? intl? locale) " " ""))
 293          (append-currency
 294           (lambda (amt)
 295             (if (currency-precedes? intl? locale)
 296                 (string-append currency currency-space amt)
 297                 (string-append amt currency-space currency)))))
 298
 299     (case (sign-position intl? locale)
 300       ((parenthesize)
 301        (string-append "(" (append-currency figure) ")"))
 302       ((sign-before)
 303        (string-append sign (append-currency figure)))
 304       ((sign-after unspecified)
 305        ;; following glibc's recommendation for `unspecified'.
 306        (if (currency-precedes? intl? locale)
 307            (string-append currency currency-space sign figure)
 308            (string-append figure currency-space currency sign)))
 309       ((sign-before-currency-symbol)
 310        (if (currency-precedes? intl? locale)
 311            (string-append sign currency currency-space figure)
 312            (string-append figure currency-space sign currency))) ;; unlikely
 313       ((sign-after-currency-symbol)
 314        (if (currency-precedes? intl? locale)
 315            (string-append currency sign currency-space figure)
 316            (string-append figure currency-space currency sign)))
 317       (else
 318        (error "unsupported sign position" (sign-position intl? locale))))))
 319
 320
 321 (define* (monetary-amount->locale-string amount intl?
 322                                          #:optional (locale %global-locale))
 323   "Convert @var{amount} (an inexact) into a string according to the cultural
 324 conventions of either @var{locale} (a locale object) or the current locale.
 325 If @var{intl?} is true, then the international monetary format for the given
 326 locale is used."
 327
 328   (let* ((fraction-digits
 329           (or (locale-monetary-fractional-digits intl? locale) 2))
 330          (decimal-part
 331           (lambda (dec)
 332             (if (or (string=? dec "") (eq? 0 fraction-digits))
 333                 ""
 334                 (string-append (locale-monetary-decimal-point locale)
 335                                (if (< fraction-digits (string-length dec))
 336                                    (substring dec 0 fraction-digits)
 337                                    dec)))))
 338
 339          (external-repr (number->string (if (> amount 0) amount (- amount))))
 340          (int+dec   (string-split external-repr #\.))
 341          (int       (car int+dec))
 342          (dec       (decimal-part (if (null? (cdr int+dec))
 343                                       ""
 344                                       (cadr int+dec))))
 345          (grouping  (locale-monetary-digit-grouping locale))
 346          (separator (locale-monetary-thousands-separator locale)))
 347
 348       (add-monetary-sign+currency amount
 349                                   (string-append
 350                                    (%number-integer-part int grouping
 351                                                          separator)
 352                                    dec)
 353                                   intl? locale)))
 354
 355
 356 \f
 357 ;;;
 358 ;;; Number formatting.
 359 ;;;
 360
 361 (define-simple-langinfo-mapping locale-digit-grouping
 362   GROUPING             '())
 363 (define-simple-langinfo-mapping locale-decimal-point
 364   RADIXCHAR            ".")
 365 (define-simple-langinfo-mapping locale-thousands-separator
 366   THOUSEP              "")
 367
 368 (define* (number->locale-string number
 369                                 #:optional (fraction-digits #t)
 370                                            (locale %global-locale))
 371   "Convert @var{number} (an inexact) into a string according to the cultural
 372 conventions of either @var{locale} (a locale object) or the current locale.
 373 Optionally, @var{fraction-digits} may be bound to an integer specifying the
 374 number of fractional digits to be displayed."
 375
 376   (let* ((sign
 377           (cond ((> number 0) "")
 378                 ((< number 0) "-")
 379                 (else         "")))
 380          (decimal-part
 381           (lambda (dec)
 382             (if (or (string=? dec "") (eq? 0 fraction-digits))
 383                 ""
 384                 (string-append (locale-decimal-point locale)
 385                                (if (and (integer? fraction-digits)
 386                                         (< fraction-digits
 387                                            (string-length dec)))
 388                                    (substring dec 0 fraction-digits)
 389                                    dec))))))
 390
 391     (let* ((external-repr (number->string (if (> number 0)
 392                                               number
 393                                               (- number))))
 394            (int+dec   (string-split external-repr #\.))
 395            (int       (car int+dec))
 396            (dec       (decimal-part (if (null? (cdr int+dec))
 397                                         ""
 398                                         (cadr int+dec))))
 399            (grouping  (locale-digit-grouping locale))
 400            (separator (locale-thousands-separator locale)))
 401
 402       (string-append sign
 403                      (%number-integer-part int grouping separator)
 404                      dec))))
 405
 406 \f
 407 ;;;
 408 ;;; Miscellaneous.
 409 ;;;
 410
 411 (define-simple-langinfo-mapping locale-yes-regexp
 412   YESEXPR              "^[yY]")
 413 (define-simple-langinfo-mapping locale-no-regexp
 414   NOEXPR               "^[nN]")
 415
 416 ;; `YESSTR' and `NOSTR' are considered deprecated so we don't provide them.
 417
 418
 419 ;;; Local Variables:
 420 ;;; coding: latin-1
 421 ;;; End:
 422
 423 ;;; i18n.scm ends here