gnu/system/locale.scm

   1 ;;; GNU Guix --- Functional package management for GNU
   2 ;;; Copyright © 2014, 2015, 2016, 2017, 2019 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* (localedef-command locale
  89                             #:key (libc (canonical-package glibc)))
  90   "Return a gexp that runs 'localedef' from LIBC to build LOCALE."
  91   #~(begin
  92       (format #t "building locale '~a'...~%"
  93               #$(locale-definition-name locale))
  94       (zero? (system* (string-append #+libc "/bin/localedef")
  95                       "--no-archive" "--prefix" #$output
  96                       "-i" #$(locale-definition-source locale)
  97                       "-f" #$(locale-definition-charset locale)
  98                       (string-append #$output "/" #$(version-major+minor
  99                                                      (package-version libc))
 100                                      "/" #$(locale-definition-name locale))))))
 101
 102 (define* (single-locale-directory locales
 103                                   #:key (libc (canonical-package glibc)))
 104   "Return a directory containing all of LOCALES for LIBC compiled.
 105
 106 Because locale data formats are incompatible when switching from one libc to
 107 another, locale data is put in a sub-directory named after the 'version' field
 108 of LIBC."
 109   (define version
 110     (version-major+minor (package-version libc)))
 111
 112   (define build
 113     #~(begin
 114         (mkdir #$output)
 115
 116         (mkdir (string-append #$output "/" #$version))
 117
 118         ;; 'localedef' executes 'gzip' to access compressed locale sources.
 119         (setenv "PATH" (string-append #$gzip "/bin"))
 120
 121         (exit
 122          (and #$@(map (cut localedef-command <> #:libc libc)
 123                       locales)))))
 124
 125   (computed-file (string-append "locale-" version) build))
 126
 127 (define* (locale-directory locales
 128                            #:key (libcs %default-locale-libcs))
 129   "Return a locale directory containing all of LOCALES for each libc package
 130 listed in LIBCS.
 131
 132 It is useful to list more than one libc when willing to support
 133 already-installed packages built against a different libc since the locale
 134 data format changes between libc versions."
 135   (match libcs
 136     ((libc)
 137      (single-locale-directory locales #:libc libc))
 138     ((libcs ..1)
 139      (let ((dirs (map (lambda (libc)
 140                         (single-locale-directory locales #:libc libc))
 141                       libcs)))
 142        (computed-file "locale-multiple-versions"
 143                       (with-imported-modules '((guix build union))
 144                         #~(begin
 145                             (use-modules (guix build union))
 146                             (union-build #$output (list #$@dirs))))
 147                       #:options '(#:local-build? #t
 148                                   #:substitutable? #f))))))
 149
 150 (define %default-locale-libcs
 151   ;; The libcs for which we build locales by default.
 152   (list (canonical-package glibc)))
 153
 154 (define %default-locale-definitions
 155   ;; Arbitrary set of locales that are built by default.  They are here mostly
 156   ;; to facilitate first-time use to some people, while others may have to add
 157   ;; a specific <locale-definition>.
 158   (letrec-syntax ((utf8-locale (syntax-rules ()
 159                                  ((_ name*)
 160                                   (locale-definition
 161                                    ;; Note: We choose "utf8", which is the
 162                                    ;; "normalized codeset".
 163                                    (name (string-append name* ".utf8"))
 164                                    (source name*)
 165                                    (charset "UTF-8")))))
 166                   (utf8-locales (syntax-rules ()
 167                                   ((_ name ...)
 168                                    (list (utf8-locale name) ...)))))
 169     ;; Add "en_US.UTF-8" for compatibility with Guix 0.8.
 170     (cons (locale-definition
 171            (name "en_US.UTF-8")
 172            (source "en_US")
 173            (charset "UTF-8"))
 174           (utf8-locales "ca_ES"
 175                         "cs_CZ"
 176                         "da_DK"
 177                         "de_DE"
 178                         "el_GR"
 179                         "en_AU"
 180                         "en_CA"
 181                         "en_GB"
 182                         "en_US"
 183                         "es_AR"
 184                         "es_CL"
 185                         "es_ES"
 186                         "es_MX"
 187                         "fi_FI"
 188                         "fr_BE"
 189                         "fr_CA"
 190                         "fr_CH"
 191                         "fr_FR"
 192                         "ga_IE"
 193                         "it_IT"
 194                         "ja_JP"
 195                         "ko_KR"
 196                         "nb_NO"
 197                         "nl_NL"
 198                         "pl_PL"
 199                         "pt_PT"
 200                         "ro_RO"
 201                         "ru_RU"
 202                         "sv_SE"
 203                         "tr_TR"
 204                         "uk_UA"
 205                         "vi_VN"
 206                         "zh_CN"))))
 207
 208 \f
 209 ;;;
 210 ;;; Locales supported by glibc.
 211 ;;;
 212
 213 (define* (glibc-supported-locales #:optional (glibc glibc))
 214   "Return a file-like object that contains a list of locale name/encoding
 215 pairs such as (\"oc_FR.UTF-8\" . \"UTF-8\").  Each pair corresponds to a
 216 locale supported by GLIBC."
 217   (define build
 218     (with-imported-modules (source-module-closure
 219                             '((guix build gnu-build-system)))
 220       #~(begin
 221           (use-modules (guix build gnu-build-system)
 222                        (srfi srfi-1)
 223                        (ice-9 rdelim)
 224                        (ice-9 match)
 225                        (ice-9 regex)
 226                        (ice-9 pretty-print))
 227
 228           (define unpack
 229             (assq-ref %standard-phases 'unpack))
 230
 231           (define locale-rx
 232             ;; Regexp matching a locale line in 'localedata/SUPPORTED'.
 233             (make-regexp
 234              "^[[:space:]]*([[:graph:]]+)/([[:graph:]]+)[[:space:]]*\\\\$"))
 235
 236           (define (read-supported-locales port)
 237             ;; Read the 'localedata/SUPPORTED' file from PORT.  That file is
 238             ;; actually a makefile snippet, with one locale per line, and a
 239             ;; header that can be discarded.
 240             (let loop ((locales '()))
 241               (define line
 242                 (read-line port))
 243
 244               (cond ((eof-object? line)
 245                      (reverse locales))
 246                     ((string-prefix? "#" (string-trim line)) ;comment
 247                      (loop locales))
 248                     ((string-contains line "=")  ;makefile variable assignment
 249                      (loop locales))
 250                     (else
 251                      (match (regexp-exec locale-rx line)
 252                        (#f
 253                         (loop locales))
 254                        (m
 255                         (loop (alist-cons (match:substring m 1)
 256                                           (match:substring m 2)
 257                                           locales))))))))
 258
 259           (setenv "PATH"
 260                   (string-append #+(file-append tar "/bin") ":"
 261                                  #+(file-append xz "/bin") ":"
 262                                  #+(file-append gzip "/bin")))
 263           (unpack #:source #+(package-source glibc))
 264
 265           (let ((locales (call-with-input-file "localedata/SUPPORTED"
 266                            read-supported-locales)))
 267             (call-with-output-file #$output
 268               (lambda (port)
 269                 (pretty-print locales port)))))))
 270
 271   (computed-file "glibc-supported-locales.scm" build))
 272
 273 ;;; locale.scm ends here