gnu/installer/locale.scm

   1 ;;; GNU Guix --- Functional package management for GNU
   2 ;;; Copyright © 2018 Mathieu Othacehe <m.othacehe@gmail.com>
   3 ;;; Copyright © 2019 Ludovic Courtès <ludo@gnu.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 installer locale)
  21   #:use-module (gnu installer utils)
  22   #:use-module ((gnu build locale) #:select (normalize-codeset))
  23   #:use-module (guix records)
  24   #:use-module (json)
  25   #:use-module (srfi srfi-1)
  26   #:use-module (ice-9 match)
  27   #:use-module (ice-9 regex)
  28   #:export (locale-language
  29             locale-territory
  30             locale-codeset
  31             locale-modifier
  32
  33             locale->locale-string
  34             supported-locales->locales
  35
  36             iso639->iso639-languages
  37             language-code->language-name
  38
  39             iso3166->iso3166-territories
  40             territory-code->territory-name
  41
  42             locale->configuration))
  43
  44 \f
  45 ;;;
  46 ;;; Locale.
  47 ;;;
  48
  49 ;; A glibc locale string has the following format:
  50 ;; language[_territory[.codeset][@modifier]].
  51 (define locale-regexp "^([^_@]+)(_([^\\.@]+))?(\\.([^@]+))?(@([^$]+))?$")
  52
  53 ;; LOCALE will be better expressed in a (guix record) that in an association
  54 ;; list. However, loading large files containing records does not scale
  55 ;; well. The same thing goes for ISO639 and ISO3166 association lists used
  56 ;; later in this module.
  57 (define (locale-language assoc)
  58   (assoc-ref assoc 'language))
  59 (define (locale-territory assoc)
  60   (assoc-ref assoc 'territory))
  61 (define (locale-codeset assoc)
  62   (assoc-ref assoc 'codeset))
  63 (define (locale-modifier assoc)
  64   (assoc-ref assoc 'modifier))
  65
  66 (define* (locale-string->locale string #:optional codeset)
  67   "Return the locale association list built from the parsing of STRING and,
  68 optionally, CODESET."
  69   (let ((matches (string-match locale-regexp string)))
  70     `((language  . ,(match:substring matches 1))
  71       (territory . ,(match:substring matches 3))
  72       (codeset   . ,(or codeset (match:substring matches 5)))
  73       (modifier  . ,(match:substring matches 7)))))
  74
  75 (define (locale->locale-string locale)
  76   "Reverse operation of locale-string->locale."
  77   (let ((language (locale-language locale))
  78         (territory (locale-territory locale))
  79         (codeset (locale-codeset locale))
  80         (modifier (locale-modifier locale)))
  81     (apply string-append
  82            `(,language
  83              ,@(if territory
  84                    `("_" ,territory)
  85                    '())
  86              ,@(if codeset
  87                    `("." ,(normalize-codeset codeset))
  88                    '())
  89              ,@(if modifier
  90                    `("@" ,modifier)
  91                    '())))))
  92
  93 (define (supported-locales->locales supported-locales)
  94   "Given SUPPORTED-LOCALES, a file produced by 'glibc-supported-locales',
  95 return a list of locales where each locale is an alist."
  96   (map (match-lambda
  97          ((locale . codeset)
  98           (locale-string->locale locale codeset)))
  99        (call-with-input-file supported-locales read)))
 100
 101 \f
 102 ;;;
 103 ;;; Language.
 104 ;;;
 105
 106 (define (iso639-language-alpha2 assoc)
 107   (assoc-ref assoc 'alpha2))
 108
 109 (define (iso639-language-alpha3 assoc)
 110   (assoc-ref assoc 'alpha3))
 111
 112 (define (iso639-language-name assoc)
 113   (assoc-ref assoc 'name))
 114
 115 (define (supported-locale? locales alpha2 alpha3)
 116   "Find a locale in LOCALES whose alpha2 field matches ALPHA-2 or alpha3 field
 117 matches ALPHA-3. The ISO639 standard specifies that ALPHA-2 is optional. Thus,
 118 if ALPHA-2 is #f, only consider ALPHA-3. Return #f if not matching locale was
 119 found."
 120   (find (lambda (locale)
 121           (let ((language (locale-language locale)))
 122             (or (and=> alpha2
 123                        (lambda (code)
 124                          (string=? language code)))
 125                 (string=? language alpha3))))
 126         locales))
 127
 128 (define (iso639->iso639-languages locales iso639-3 iso639-5)
 129   "Return a list of ISO639 association lists created from the parsing of
 130 ISO639-3 and ISO639-5 files."
 131   (call-with-input-file iso639-3
 132     (lambda (port-iso639-3)
 133       (call-with-input-file iso639-5
 134         (lambda (port-iso639-5)
 135           (filter-map
 136            (lambda (hash)
 137              (let ((alpha2 (assoc-ref hash "alpha_2"))
 138                    (alpha3 (assoc-ref hash "alpha_3"))
 139                    (name   (assoc-ref hash "name")))
 140                (and (supported-locale? locales alpha2 alpha3)
 141                     `((alpha2 . ,alpha2)
 142                       (alpha3 . ,alpha3)
 143                       (name   . ,name)))))
 144            (append
 145             (vector->list
 146              (assoc-ref (json->scm port-iso639-3) "639-3"))
 147             (vector->list
 148              (assoc-ref (json->scm port-iso639-5) "639-5")))))))))
 149
 150 (define (language-code->language-name languages language-code)
 151   "Using LANGUAGES as a list of ISO639 association lists, return the language
 152 name corresponding to the given LANGUAGE-CODE."
 153   (let ((iso639-language
 154          (find (lambda (language)
 155                  (or
 156                   (and=> (iso639-language-alpha2 language)
 157                          (lambda (alpha2)
 158                            (string=? alpha2 language-code)))
 159                   (string=? (iso639-language-alpha3 language)
 160                             language-code)))
 161                languages)))
 162     (iso639-language-name iso639-language)))
 163
 164 \f
 165 ;;;
 166 ;;; Territory.
 167 ;;;
 168
 169 (define (iso3166-territory-alpha2 assoc)
 170   (assoc-ref assoc 'alpha2))
 171
 172 (define (iso3166-territory-alpha3 assoc)
 173   (assoc-ref assoc 'alpha3))
 174
 175 (define (iso3166-territory-name assoc)
 176   (assoc-ref assoc 'name))
 177
 178 (define (iso3166->iso3166-territories iso3166)
 179   "Return a list of ISO3166 association lists created from the parsing of
 180 ISO3166 file."
 181   (call-with-input-file iso3166
 182     (lambda (port)
 183       (map (lambda (hash)
 184              `((alpha2 . ,(assoc-ref hash "alpha_2"))
 185                (alpha3 . ,(assoc-ref hash "alpha_3"))
 186                (name   . ,(assoc-ref hash "name"))))
 187            (vector->list
 188             (assoc-ref (json->scm port) "3166-1"))))))
 189
 190 (define (territory-code->territory-name territories territory-code)
 191   "Using TERRITORIES as a list of ISO3166 association lists return the
 192 territory name corresponding to the given TERRITORY-CODE."
 193   (let ((iso3166-territory
 194          (find (lambda (territory)
 195                  (or
 196                   (and=> (iso3166-territory-alpha2 territory)
 197                          (lambda (alpha2)
 198                            (string=? alpha2 territory-code)))
 199                   (string=? (iso3166-territory-alpha3 territory)
 200                             territory-code)))
 201                territories)))
 202     (iso3166-territory-name iso3166-territory)))
 203
 204 \f
 205 ;;;
 206 ;;; Configuration formatter.
 207 ;;;
 208
 209 (define (locale->configuration locale)
 210   "Return the configuration field for LOCALE."
 211   `((locale ,locale)))