;;;; i18n.scm --- internationalization support -*- coding: utf-8 -*- ;;;; Copyright (C) 2006, 2007, 2009, 2010, 2012, ;;;; 2017, 2019 Free Software Foundation, Inc. ;;;; ;;;; 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 ;;; Author: Ludovic Courtès ;;; Commentary: ;;; ;;; This module provides a number of routines that support ;;; internationalization (e.g., locale-dependent text collation, character ;;; mapping, etc.). It also defines `locale' objects, representing locale ;;; settings, that may be passed around to most of these procedures. ;;; ;;; Code: (define-module (ice-9 i18n) :use-module (ice-9 optargs) :export (;; `locale' type make-locale locale? %global-locale ;; text collation string-locale? string-locale-ci? string-locale-ci=? char-locale? char-locale-ci? char-locale-ci=? ;; character mapping char-locale-downcase char-locale-upcase char-locale-titlecase string-locale-downcase string-locale-upcase string-locale-titlecase ;; reading numbers locale-string->integer locale-string->inexact ;; charset/encoding locale-encoding ;; days and months locale-day-short locale-day locale-month-short locale-month ;; date and time locale-am-string locale-pm-string locale-date+time-format locale-date-format locale-time-format locale-time+am/pm-format locale-era locale-era-year locale-era-date-format locale-era-date+time-format locale-era-time-format ;; monetary locale-currency-symbol locale-monetary-decimal-point locale-monetary-thousands-separator locale-monetary-grouping locale-monetary-fractional-digits locale-currency-symbol-precedes-positive? locale-currency-symbol-precedes-negative? locale-positive-separated-by-space? locale-negative-separated-by-space? locale-monetary-positive-sign locale-monetary-negative-sign locale-positive-sign-position locale-negative-sign-position monetary-amount->locale-string ;; number formatting locale-digit-grouping locale-decimal-point locale-thousands-separator number->locale-string ;; miscellaneous locale-yes-regexp locale-no-regexp ;; debugging %locale-dump)) (eval-when (expand load eval) (load-extension (string-append "libguile-" (effective-version)) "scm_init_i18n")) ;;; ;;; Charset/encoding. ;;; (define (locale-encoding . locale) (apply nl-langinfo CODESET locale)) ;;; ;;; Months and days. ;;; ;; Helper macro: Define a procedure named NAME that maps its argument to ;; NL-ITEMS. Gnulib guarantees that these items are available. (define-macro (define-vector-langinfo-mapping name nl-items) (let* ((item-count (length nl-items)) (defines `(define %nl-items (vector #f ,@nl-items))) (make-body (lambda (result) `(if (and (integer? item) (exact? item)) (if (and (>= item 1) (<= item ,item-count)) ,result (throw 'out-of-range "out of range" item)) (throw 'wrong-type-arg "wrong argument type" item))))) `(define (,name item . locale) ,defines ,(make-body '(apply nl-langinfo (vector-ref %nl-items item) locale))))) (define-vector-langinfo-mapping locale-day-short (ABDAY_1 ABDAY_2 ABDAY_3 ABDAY_4 ABDAY_5 ABDAY_6 ABDAY_7)) (define-vector-langinfo-mapping locale-day (DAY_1 DAY_2 DAY_3 DAY_4 DAY_5 DAY_6 DAY_7)) (define-vector-langinfo-mapping locale-month-short (ABMON_1 ABMON_2 ABMON_3 ABMON_4 ABMON_5 ABMON_6 ABMON_7 ABMON_8 ABMON_9 ABMON_10 ABMON_11 ABMON_12)) (define-vector-langinfo-mapping locale-month (MON_1 MON_2 MON_3 MON_4 MON_5 MON_6 MON_7 MON_8 MON_9 MON_10 MON_11 MON_12)) ;;; ;;; Date and time. ;;; ;; Define a procedure NAME that gets langinfo item ITEM. Gnulib's ;; `nl_langinfo' does not guarantee that all these items are supported ;; (for instance, `GROUPING' is lacking on Darwin and Gnulib provides no ;; replacement), so use DEFAULT as the default value when ITEM is not ;; available. (define-macro (define-simple-langinfo-mapping name item default) (let ((body (if (defined? item) `(apply nl-langinfo ,item locale) default))) `(define (,name . locale) ,body))) (define-simple-langinfo-mapping locale-am-string AM_STR "AM") (define-simple-langinfo-mapping locale-pm-string PM_STR "PM") (define-simple-langinfo-mapping locale-date+time-format D_T_FMT "%a %b %e %H:%M:%S %Y") (define-simple-langinfo-mapping locale-date-format D_FMT "%m/%d/%y") (define-simple-langinfo-mapping locale-time-format T_FMT "%H:%M:%S") (define-simple-langinfo-mapping locale-time+am/pm-format T_FMT_AMPM "%I:%M:%S %p") (define-simple-langinfo-mapping locale-era ERA "") (define-simple-langinfo-mapping locale-era-year ERA_YEAR "") (define-simple-langinfo-mapping locale-era-date+time-format ERA_D_T_FMT "") (define-simple-langinfo-mapping locale-era-date-format ERA_D_FMT "") (define-simple-langinfo-mapping locale-era-time-format ERA_T_FMT "") ;;; ;;; Monetary information. ;;; ;; Define a procedure NAME that gets item LOCAL-ITEM or INTL-ITEM, ;; depending on whether the caller asked for the international version ;; or not. Since Gnulib's `nl_langinfo' module doesn't guarantee that ;; all these items are available, use DEFAULT/LOCAL and DEFAULT/INTL as ;; default values when the system does not support them. (define-macro (define-monetary-langinfo-mapping name local-item intl-item default/local default/intl) (let ((body (let ((intl (if (defined? intl-item) `(apply nl-langinfo ,intl-item locale) default/intl)) (local (if (defined? local-item) `(apply nl-langinfo ,local-item locale) default/local))) `(if intl? ,intl ,local)))) `(define (,name intl? . locale) ,body))) ;; FIXME: How can we use ALT_DIGITS? (define-monetary-langinfo-mapping locale-currency-symbol CRNCYSTR INT_CURR_SYMBOL "-" "") (define-monetary-langinfo-mapping locale-monetary-fractional-digits FRAC_DIGITS INT_FRAC_DIGITS 2 2) (define-simple-langinfo-mapping locale-monetary-positive-sign POSITIVE_SIGN "+") (define-simple-langinfo-mapping locale-monetary-negative-sign NEGATIVE_SIGN "-") (define-simple-langinfo-mapping locale-monetary-decimal-point MON_DECIMAL_POINT ".") (define-simple-langinfo-mapping locale-monetary-thousands-separator MON_THOUSANDS_SEP "") (define-simple-langinfo-mapping locale-monetary-grouping MON_GROUPING '()) (define-monetary-langinfo-mapping locale-currency-symbol-precedes-positive? P_CS_PRECEDES INT_P_CS_PRECEDES #t #t) (define-monetary-langinfo-mapping locale-currency-symbol-precedes-negative? N_CS_PRECEDES INT_N_CS_PRECEDES #t #t) (define-monetary-langinfo-mapping locale-positive-separated-by-space? ;; Whether a space should be inserted between a positive amount and the ;; currency symbol. P_SEP_BY_SPACE INT_P_SEP_BY_SPACE #t #t) (define-monetary-langinfo-mapping locale-negative-separated-by-space? ;; Whether a space should be inserted between a negative amount and the ;; currency symbol. N_SEP_BY_SPACE INT_N_SEP_BY_SPACE #t #t) (define-monetary-langinfo-mapping locale-positive-sign-position ;; Position of the positive sign wrt. currency symbol and quantity in a ;; monetary amount. P_SIGN_POSN INT_P_SIGN_POSN 'unspecified 'unspecified) (define-monetary-langinfo-mapping locale-negative-sign-position ;; Position of the negative sign wrt. currency symbol and quantity in a ;; monetary amount. N_SIGN_POSN INT_N_SIGN_POSN 'unspecified 'unspecified) (define (integer->string number) "Return a string representing NUMBER, an integer, written in base 10." (define (digit->char digit) (integer->char (+ digit (char->integer #\0)))) (if (zero? number) "0" (let loop ((number number) (digits '())) (if (zero? number) (list->string digits) (loop (quotient number 10) (cons (digit->char (modulo number 10)) digits)))))) (define (number-decimal-string number digit-count) "Return a string representing the decimal part of NUMBER. When DIGIT-COUNT is an integer, return exactly DIGIT-COUNT digits; when DIGIT-COUNT is #t, return as many decimals as necessary, up to an arbitrary limit." (define max-decimals 5) ;; XXX: This is brute-force and could be improved by following one of ;; the "Printing Floating-Point Numbers Quickly and Accurately" ;; papers. (if (integer? digit-count) (let ((number (* (expt 10 digit-count) (- number (floor number))))) (string-pad (integer->string (round (inexact->exact number))) digit-count #\0)) (let loop ((decimals 0)) (let ((number' (* number (expt 10 decimals)))) (if (or (= number' (floor number')) (>= decimals max-decimals)) (let* ((fraction (- number' (* (floor number) (expt 10 decimals)))) (str (integer->string (round (inexact->exact fraction))))) (if (zero? fraction) "" str)) (loop (+ decimals 1))))))) (define (%number-integer-part int grouping separator) ;; Process INT (a string denoting a number's integer part) and return a new ;; string with digit grouping and separators according to GROUPING (a list, ;; potentially circular) and SEPARATOR (a string). ;; Process INT from right to left. (let loop ((int int) (grouping grouping) (result '())) (cond ((string=? int "") (apply string-append result)) ((null? grouping) (apply string-append int result)) (else (let* ((len (string-length int)) (cut (min (car grouping) len))) (loop (substring int 0 (- len cut)) (cdr grouping) (let ((sub (substring int (- len cut) len))) (if (> len cut) (cons* separator sub result) (cons sub result))))))))) (define (add-monetary-sign+currency amount figure intl? locale) ;; Add a sign and currency symbol around FIGURE. FIGURE should be a ;; formatted unsigned amount (a string) representing AMOUNT. (let* ((positive? (> amount 0)) (sign (cond ((> amount 0) (locale-monetary-positive-sign locale)) ((< amount 0) (locale-monetary-negative-sign locale)) (else ""))) (currency (locale-currency-symbol intl? locale)) (currency-precedes? (if positive? locale-currency-symbol-precedes-positive? locale-currency-symbol-precedes-negative?)) (separated? (if positive? locale-positive-separated-by-space? locale-negative-separated-by-space?)) (sign-position (if positive? locale-positive-sign-position locale-negative-sign-position)) (currency-space (if (separated? intl? locale) " " "")) (append-currency (lambda (amt) (if (currency-precedes? intl? locale) (string-append currency currency-space amt) (string-append amt currency-space currency))))) (case (sign-position intl? locale) ((parenthesize) (string-append "(" (append-currency figure) ")")) ((sign-before) (string-append sign (append-currency figure))) ((sign-after unspecified) ;; following glibc's recommendation for `unspecified'. (if (currency-precedes? intl? locale) (string-append currency currency-space sign figure) (string-append figure currency-space currency sign))) ((sign-before-currency-symbol) (if (currency-precedes? intl? locale) (string-append sign currency currency-space figure) (string-append figure currency-space sign currency))) ;; unlikely ((sign-after-currency-symbol) (if (currency-precedes? intl? locale) (string-append currency sign currency-space figure) (string-append figure currency-space currency sign))) (else (error "unsupported sign position" (sign-position intl? locale)))))) (define* (monetary-amount->locale-string amount intl? #:optional (locale %global-locale)) "Convert @var{amount} (an inexact) into a string according to the cultural conventions of either @var{locale} (a locale object) or the current locale. If @var{intl?} is true, then the international monetary format for the given locale is used." (let* ((fraction-digits (or (locale-monetary-fractional-digits intl? locale) 2)) (decimal-part (lambda (dec) (if (or (string=? dec "") (eq? 0 fraction-digits)) "" (string-append (locale-monetary-decimal-point locale) (if (< fraction-digits (string-length dec)) (substring dec 0 fraction-digits) dec))))) (int (integer->string (inexact->exact (floor (abs amount))))) (dec (decimal-part (number-decimal-string (abs amount) fraction-digits))) (grouping (locale-monetary-grouping locale)) (separator (locale-monetary-thousands-separator locale))) (add-monetary-sign+currency amount (string-append (%number-integer-part int grouping separator) dec) intl? locale))) ;;; ;;; Number formatting. ;;; (define-simple-langinfo-mapping locale-digit-grouping GROUPING '()) (define-simple-langinfo-mapping locale-decimal-point RADIXCHAR ".") (define-simple-langinfo-mapping locale-thousands-separator THOUSEP "") (define* (number->locale-string number #:optional (fraction-digits #t) (locale %global-locale)) "Convert @var{number} (an inexact) into a string according to the cultural conventions of either @var{locale} (a locale object) or the current locale. By default, print as many fractional digits as necessary, up to an upper bound. Optionally, @var{fraction-digits} may be bound to an integer specifying the number of fractional digits to be displayed." (let* ((sign (cond ((> number 0) "") ((< number 0) "-") (else ""))) (decimal-part (lambda (dec) (if (or (string=? dec "") (eq? 0 fraction-digits)) "" (string-append (locale-decimal-point locale) (if (and (integer? fraction-digits) (< fraction-digits (string-length dec))) (substring dec 0 fraction-digits) dec)))))) (let* ((int (integer->string (inexact->exact (floor (abs number))))) (dec (decimal-part (number-decimal-string (abs number) fraction-digits))) (grouping (locale-digit-grouping locale)) (separator (locale-thousands-separator locale))) (string-append sign (%number-integer-part int grouping separator) dec)))) ;;; ;;; Miscellaneous. ;;; (define-simple-langinfo-mapping locale-yes-regexp YESEXPR "^[yY]") (define-simple-langinfo-mapping locale-no-regexp NOEXPR "^[nN]") ;; `YESSTR' and `NOSTR' are considered deprecated so we don't provide them. ;;; ;;; Debugging ;;; (define (%locale-dump loc) "Given a locale, display an association list containing all the locale information. This procedure is intended for debugging locale problems, and should not be used in production code." (when (locale? loc) (list (cons 'encoding (locale-encoding loc)) (cons 'day-short (map (lambda (n) (locale-day-short (1+ n) loc)) (iota 7))) (cons 'day (map (lambda (n) (locale-day (1+ n) loc)) (iota 7))) (cons 'month-short (map (lambda (n) (locale-month-short (1+ n) loc)) (iota 12))) (cons 'month (map (lambda (n) (locale-month (1+ n) loc)) (iota 12))) (cons 'am-string (locale-am-string loc)) (cons 'pm-string (locale-pm-string loc)) (cons 'date+time-format (locale-date+time-format loc)) (cons 'date-format (locale-date-format loc)) (cons 'time-format (locale-time-format loc)) (cons 'time+am/pm-format (locale-time+am/pm-format loc)) (cons 'era (locale-era loc)) (cons 'era-year (locale-era-year loc)) (cons 'era-date-format (locale-era-date-format loc)) (cons 'era-date+time-format (locale-era-date+time-format loc)) (cons 'era-time-format (locale-era-time-format loc)) (cons 'currency-symbol (list (locale-currency-symbol #t loc) (locale-currency-symbol #f loc))) (cons 'monetary-decimal-point (locale-monetary-decimal-point loc)) (cons 'monetary-thousands-separator (locale-monetary-thousands-separator loc)) (cons 'monetary-grouping (locale-monetary-grouping loc)) (cons 'monetary-fractional-digits (list (locale-monetary-fractional-digits #t loc) (locale-monetary-fractional-digits #f loc))) (cons 'currency-symbol-precedes-positive? (list (locale-currency-symbol-precedes-positive? #t loc) (locale-currency-symbol-precedes-positive? #f loc))) (cons 'currency-symbol-precedes-negative? (list (locale-currency-symbol-precedes-negative? #t loc) (locale-currency-symbol-precedes-negative? #f loc))) (cons 'positive-separated-by-space? (list (locale-positive-separated-by-space? #t loc) (locale-positive-separated-by-space? #f loc))) (cons 'negative-separated-by-space? (list (locale-negative-separated-by-space? #t loc) (locale-negative-separated-by-space? #f loc))) (cons 'monetary-positive-sign (locale-monetary-positive-sign loc)) (cons 'monetary-negative-sign (locale-monetary-negative-sign loc)) (cons 'positive-sign-position (list (locale-positive-sign-position #t loc) (locale-negative-sign-position #f loc))) (cons 'negative-sign-position (list (locale-negative-sign-position #t loc) (locale-negative-sign-position #f loc))) (cons 'digit-grouping (locale-digit-grouping loc)) (cons 'decimal-point (locale-decimal-point loc)) (cons 'thousands-separator (locale-thousands-separator loc)) (cons 'locale-yes-regexp (locale-yes-regexp loc)) (cons 'no-regexp (locale-no-regexp loc))))) ;;; i18n.scm ends here