gnu/system/locale.scm

   1 ;;; GNU Guix --- Functional package management for GNU
   2 ;;; Copyright © 2014, 2015, 2016, 2017, 2019, 2020 Ludovic Courtès <ludo@gnu.org>
   3 ;;; Copyright © 2018 Mark H Weaver <mhw@netris.org>
   4 ;;;
   5 ;;; This file is part of GNU Guix.
   6 ;;;
   7 ;;; GNU Guix is free software; you can redistribute it and/or modify it
   8 ;;; under the terms of the GNU General Public License as published by
   9 ;;; the Free Software Foundation; either version 3 of the License, or (at
  10 ;;; your option) any later version.
  11 ;;;
  12 ;;; GNU Guix is distributed in the hope that it will be useful, but
  13 ;;; WITHOUT ANY WARRANTY; without even the implied warranty of
  14 ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  15 ;;; GNU General Public License for more details.
  16 ;;;
  17 ;;; You should have received a copy of the GNU General Public License
  18 ;;; along with GNU Guix.  If not, see <http://www.gnu.org/licenses/>.
  19
  20 (define-module (gnu system locale)
  21   #:use-module (guix gexp)
  22   #:use-module (guix store)
  23   #:use-module (guix modules)
  24   #:use-module (guix records)
  25   #:use-module (guix packages)
  26   #:use-module (guix utils)
  27   #:use-module (gnu packages base)
  28   #:use-module (gnu packages compression)
  29   #:use-module (srfi srfi-26)
  30   #:use-module (ice-9 match)
  31   #:export (locale-definition
  32             locale-definition?
  33             locale-definition-name
  34             locale-definition-source
  35             locale-definition-charset
  36
  37             locale-name->definition
  38             locale-directory
  39
  40             %default-locale-libcs
  41             %default-locale-definitions
  42
  43             glibc-supported-locales))
  44
  45 ;;; Commentary:
  46 ;;;
  47 ;;; Locale definitions, and compilation thereof.
  48 ;;;
  49 ;;; Code:
  50
  51 (define-record-type* <locale-definition> locale-definition
  52   make-locale-definition
  53   locale-definition?
  54   (name    locale-definition-name)                ;string--e.g., "fr_FR.utf8"
  55   (source  locale-definition-source)              ;string--e.g., "fr_FR"
  56   (charset locale-definition-charset              ;string--e.g., "UTF-8"
  57            (default "UTF-8")))
  58
  59 (define %not-dot
  60   (char-set-complement (char-set #\.)))
  61
  62 (define (denormalize-codeset codeset)
  63   "Attempt to guess the \"real\" name of CODESET, a normalized codeset as
  64 defined in (info \"(libc) Using gettextized software\")."
  65   (cond ((string=? codeset "utf8")
  66          "UTF-8")
  67         ((string-prefix? "iso8859" codeset)
  68          (string-append "ISO-8859-" (string-drop codeset 7)))
  69         ((string=? codeset "eucjp")
  70          "EUC-JP")
  71         (else                                ;cross fingers, hope for the best
  72          codeset)))
  73
  74 (define (locale-name->definition name)
  75   "Return a <locale-definition> corresponding to NAME, guessing the charset,
  76 or #f on failure."
  77   (match (string-tokenize name %not-dot)
  78     ((source charset)
  79      ;; XXX: NAME is supposed to use the "normalized codeset", such as "utf8",
  80      ;; whereas the actual name used is different.  Add a special case to make
  81      ;; the right guess for UTF-8.
  82      (locale-definition (name name)
  83                         (source source)
  84                         (charset (denormalize-codeset charset))))
  85     (_
  86      #f)))
  87
  88 (define* (single-locale-directory locales
  89                                   #:key (libc glibc))
  90   "Return a directory containing all of LOCALES for LIBC compiled.
  91
  92 Because locale data formats are incompatible when switching from one libc to
  93 another, locale data is put in a sub-directory named after the 'version' field
  94 of LIBC."
  95   (define version
  96     (version-major+minor (package-version libc)))
  97
  98   (define build
  99     (with-imported-modules (source-module-closure
 100                             '((gnu build locale)))
 101      #~(begin
 102          (use-modules (gnu build locale))
 103
 104          (mkdir #$output)
 105          (mkdir (string-append #$output "/" #$version))
 106
 107          ;; 'localedef' executes 'gzip' to access compressed locale sources.
 108          (setenv "PATH"
 109                  (string-append #+gzip "/bin:" #+libc "/bin"))
 110
 111          (setvbuf (current-output-port) 'line)
 112          (setvbuf (current-error-port) 'line)
 113          (for-each (lambda (locale codeset name)
 114                      (build-locale locale
 115                                    #:codeset codeset
 116                                    #:name name
 117                                    #:directory
 118                                    (string-append #$output "/" #$version)))
 119                    '#$(map locale-definition-source locales)
 120                    '#$(map locale-definition-charset locales)
 121                    '#$(map locale-definition-name locales)))))
 122
 123   (computed-file (string-append "locale-" version) build))
 124
 125 (define* (locale-directory locales
 126                            #:key (libcs %default-locale-libcs))
 127   "Return a locale directory containing all of LOCALES for each libc package
 128 listed in LIBCS.
 129
 130 It is useful to list more than one libc when willing to support
 131 already-installed packages built against a different libc since the locale
 132 data format changes between libc versions."
 133   (match libcs
 134     ((libc)
 135      (single-locale-directory locales #:libc libc))
 136     ((libcs ..1)
 137      (let ((dirs (map (lambda (libc)
 138                         (single-locale-directory locales #:libc libc))
 139                       libcs)))
 140        (computed-file "locale-multiple-versions"
 141                       (with-imported-modules '((guix build union))
 142                         #~(begin
 143                             (use-modules (guix build union))
 144                             (union-build #$output (list #$@dirs))))
 145                       #:options '(#:local-build? #t
 146                                   #:substitutable? #f))))))
 147
 148 (define %default-locale-libcs
 149   ;; The libcs for which we build locales by default.
 150   ;; List the previous and current libc to ease transition.
 151   (list glibc-2.29 glibc))
 152
 153 (define %default-locale-definitions
 154   ;; Arbitrary set of locales that are built by default.  They are here mostly
 155   ;; to facilitate first-time use to some people, while others may have to add
 156   ;; a specific <locale-definition>.
 157   (letrec-syntax ((utf8-locale (syntax-rules ()
 158                                  ((_ name*)
 159                                   (locale-definition
 160                                    ;; Note: We choose "utf8", which is the
 161                                    ;; "normalized codeset".
 162                                    (name (string-append name* ".utf8"))
 163                                    (source name*)
 164                                    (charset "UTF-8")))))
 165                   (utf8-locales (syntax-rules ()
 166                                   ((_ name ...)
 167                                    (list (utf8-locale name) ...)))))
 168     ;; Add "en_US.UTF-8" for compatibility with Guix 0.8.
 169     (cons (locale-definition
 170            (name "en_US.UTF-8")
 171            (source "en_US")
 172            (charset "UTF-8"))
 173           (utf8-locales "ca_ES"
 174                         "cs_CZ"
 175                         "da_DK"
 176                         "de_DE"
 177                         "el_GR"
 178                         "en_AU"
 179                         "en_CA"
 180                         "en_GB"
 181                         "en_US"
 182                         "es_AR"
 183                         "es_CL"
 184                         "es_ES"
 185                         "es_MX"
 186                         "fi_FI"
 187                         "fr_BE"
 188                         "fr_CA"
 189                         "fr_CH"
 190                         "fr_FR"
 191                         "ga_IE"
 192                         "it_IT"
 193                         "ja_JP"
 194                         "ko_KR"
 195                         "nb_NO"
 196                         "nl_NL"
 197                         "pl_PL"
 198                         "pt_PT"
 199                         "ro_RO"
 200                         "ru_RU"
 201                         "sv_SE"
 202                         "tr_TR"
 203                         "uk_UA"
 204                         "vi_VN"
 205                         "zh_CN"))))
 206
 207 \f
 208 ;;;
 209 ;;; Locales supported by glibc.
 210 ;;;
 211
 212 (define* (glibc-supported-locales #:optional (glibc glibc))
 213   "Return a file-like object that contains a list of locale name/encoding
 214 pairs such as (\"oc_FR.UTF-8\" . \"UTF-8\").  Each pair corresponds to a
 215 locale supported by GLIBC."
 216   (define build
 217     (with-imported-modules (source-module-closure
 218                             '((guix build gnu-build-system)
 219                               (gnu build locale)))
 220       #~(begin
 221           (use-modules (guix build gnu-build-system)
 222                        (gnu build locale)
 223                        (ice-9 pretty-print))
 224
 225           (define unpack
 226             (assq-ref %standard-phases 'unpack))
 227
 228
 229           (setenv "PATH"
 230                   (string-append #+(file-append tar "/bin") ":"
 231                                  #+(file-append xz "/bin") ":"
 232                                  #+(file-append gzip "/bin")))
 233           (unpack #:source #+(package-source glibc))
 234
 235           (let ((locales (call-with-input-file "localedata/SUPPORTED"
 236                            read-supported-locales)))
 237             (call-with-output-file #$output
 238               (lambda (port)
 239                 (pretty-print locales port)))))))
 240
 241   (computed-file "glibc-supported-locales.scm" build))
 242
 243 ;;; locale.scm ends here