guix/gnu/installer/locale.scm

213 lines
7.2 KiB
Scheme
Raw Normal View History

;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2018 Mathieu Othacehe <m.othacehe@gmail.com>
;;; Copyright © 2019 Ludovic Courtès <ludo@gnu.org>
;;;
;;; This file is part of GNU Guix.
;;;
;;; GNU Guix is free software; you can redistribute it and/or modify it
;;; under the terms of the GNU General Public License as published by
;;; the Free Software Foundation; either version 3 of the License, or (at
;;; your option) any later version.
;;;
;;; GNU Guix 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 General Public License for more details.
;;;
;;; You should have received a copy of the GNU General Public License
;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>.
(define-module (gnu installer locale)
#:use-module (gnu installer utils)
#:use-module ((gnu build locale) #:select (normalize-codeset))
#:use-module (guix records)
#:use-module (json)
#:use-module (srfi srfi-1)
#:use-module (ice-9 match)
#:use-module (ice-9 regex)
#:export (locale-language
locale-territory
locale-codeset
locale-modifier
locale->locale-string
supported-locales->locales
iso639->iso639-languages
language-code->language-name
iso3166->iso3166-territories
territory-code->territory-name
locale->configuration))
;;;
;;; Locale.
;;;
;; A glibc locale string has the following format:
;; language[_territory[.codeset][@modifier]].
(define locale-regexp "^([^_@]+)(_([^\\.@]+))?(\\.([^@]+))?(@([^$]+))?$")
;; LOCALE will be better expressed in a (guix record) that in an association
;; list. However, loading large files containing records does not scale
;; well. The same thing goes for ISO639 and ISO3166 association lists used
;; later in this module.
(define (locale-language assoc)
(assoc-ref assoc 'language))
(define (locale-territory assoc)
(assoc-ref assoc 'territory))
(define (locale-codeset assoc)
(assoc-ref assoc 'codeset))
(define (locale-modifier assoc)
(assoc-ref assoc 'modifier))
(define* (locale-string->locale string #:optional codeset)
"Return the locale association list built from the parsing of STRING and,
optionally, CODESET."
(let ((matches (string-match locale-regexp string)))
`((language . ,(match:substring matches 1))
(territory . ,(match:substring matches 3))
(codeset . ,(or codeset (match:substring matches 5)))
(modifier . ,(match:substring matches 7)))))
(define (locale->locale-string locale)
"Reverse operation of locale-string->locale."
(let ((language (locale-language locale))
(territory (locale-territory locale))
(codeset (locale-codeset locale))
(modifier (locale-modifier locale)))
(apply string-append
`(,language
,@(if territory
`("_" ,territory)
'())
,@(if codeset
`("." ,(normalize-codeset codeset))
'())
,@(if modifier
`("@" ,modifier)
'())))))
(define (supported-locales->locales supported-locales)
"Given SUPPORTED-LOCALES, a file produced by 'glibc-supported-locales',
return a list of locales where each locale is an alist."
(filter-map (match-lambda
(("C.UTF-8" . codeset) #f)
((locale . codeset)
(locale-string->locale locale codeset)))
(call-with-input-file supported-locales read)))
;;;
;;; Language.
;;;
(define (iso639-language-alpha2 assoc)
(assoc-ref assoc 'alpha2))
(define (iso639-language-alpha3 assoc)
(assoc-ref assoc 'alpha3))
(define (iso639-language-name assoc)
(assoc-ref assoc 'name))
(define (supported-locale? locales alpha2 alpha3)
"Find a locale in LOCALES whose alpha2 field matches ALPHA-2 or alpha3 field
matches ALPHA-3. The ISO639 standard specifies that ALPHA-2 is optional. Thus,
if ALPHA-2 is #f, only consider ALPHA-3. Return #f if not matching locale was
found."
(find (lambda (locale)
(let ((language (locale-language locale)))
(or (and=> alpha2
(lambda (code)
(string=? language code)))
(string=? language alpha3))))
locales))
(define (iso639->iso639-languages locales iso639-3 iso639-5)
"Return a list of ISO639 association lists created from the parsing of
ISO639-3 and ISO639-5 files."
(call-with-input-file iso639-3
(lambda (port-iso639-3)
(call-with-input-file iso639-5
(lambda (port-iso639-5)
(filter-map
(lambda (hash)
maint: Switch to Guile-JSON 3.x. Guile-JSON 3.x is incompatible with Guile-JSON 1.x, which we relied on until now: it maps JSON dictionaries to alists (instead of hash tables), and JSON arrays to vectors (instead of lists). This commit is about adjusting all the existing code to this new mapping. * m4/guix.m4 (GUIX_CHECK_GUILE_JSON): New macro. * configure.ac: Use it. * doc/guix.texi (Requirements): Mention the Guile-JSON version. * guix/git-download.scm (git-fetch)[guile-json]: Use GUILE-JSON-3. * guix/import/cpan.scm (string->license): Expect vectors instead of lists. (module->dist-name): Use 'json-fetch' instead of 'json-fetch-alist'. (cpan-fetch): Likewise. * guix/import/crate.scm (crate-fetch): Likewise, and call 'vector->list' for DEPS. * guix/import/gem.scm (rubygems-fetch): Likewise. * guix/import/json.scm (json-fetch-alist): Remove. * guix/import/pypi.scm (pypi-fetch): Use 'json-fetch' instead of 'json-fetch-alist'. (latest-source-release, latest-wheel-release): Call 'vector->list' on RELEASES. * guix/import/stackage.scm (stackage-lts-info-fetch): Use 'json-fetch' instead of 'json-fetch-alist'. (lts-package-version): Use 'vector->list'. * guix/import/utils.scm (hash-table->alist): Remove. (alist->package): Pass 'vector->list' on the inputs fields, and default to the empty vector. * guix/scripts/import/json.scm (guix-import-json): Remove call to 'hash-table->alist'. * guix/swh.scm (define-json-reader): Expect pair? or null? instead of hash-table?. [extract-field]: Use 'assoc-ref' instead of 'hash-ref'. (json->branches): Use 'map' instead of 'hash-map->list'. (json->checksums): Likewise. (json->directory-entries, origin-visits): Call 'vector->list' on the result of 'json->scm'. * tests/import-utils.scm ("alist->package with dependencies"): New test. * gnu/installer.scm (build-compiled-file)[builder]: Use GUILE-JSON-3. * gnu/installer.scm (installer-program)[installer-builder]: Likewise. * gnu/installer/locale.scm (iso639->iso639-languages): Use 'assoc-ref' instead of 'hash-ref', and pass vectors through 'vector->list'. (iso3166->iso3166-territories): Likewise. * gnu/system/vm.scm (system-docker-image)[build]: Use GUILE-JSON-3. * guix/docker.scm (manifest, config): Adjust for Guile-JSON 3. * guix/scripts/pack.scm (docker-image)[build]: Use GUILE-JSON-3. * guix/import/github.scm (fetch-releases-or-tags): Update docstring. (latest-released-version): Use 'assoc-ref' instead of 'hash-ref'. Pass the result of 'fetch-releases-or-tags' to 'vector->list'. * guix/import/launchpad.scm (latest-released-version): Likewise.
2019-07-21 21:05:54 +00:00
(let ((alpha2 (assoc-ref hash "alpha_2"))
(alpha3 (assoc-ref hash "alpha_3"))
(name (assoc-ref hash "name")))
(and (supported-locale? locales alpha2 alpha3)
`((alpha2 . ,alpha2)
(alpha3 . ,alpha3)
(name . ,name)))))
(append
maint: Switch to Guile-JSON 3.x. Guile-JSON 3.x is incompatible with Guile-JSON 1.x, which we relied on until now: it maps JSON dictionaries to alists (instead of hash tables), and JSON arrays to vectors (instead of lists). This commit is about adjusting all the existing code to this new mapping. * m4/guix.m4 (GUIX_CHECK_GUILE_JSON): New macro. * configure.ac: Use it. * doc/guix.texi (Requirements): Mention the Guile-JSON version. * guix/git-download.scm (git-fetch)[guile-json]: Use GUILE-JSON-3. * guix/import/cpan.scm (string->license): Expect vectors instead of lists. (module->dist-name): Use 'json-fetch' instead of 'json-fetch-alist'. (cpan-fetch): Likewise. * guix/import/crate.scm (crate-fetch): Likewise, and call 'vector->list' for DEPS. * guix/import/gem.scm (rubygems-fetch): Likewise. * guix/import/json.scm (json-fetch-alist): Remove. * guix/import/pypi.scm (pypi-fetch): Use 'json-fetch' instead of 'json-fetch-alist'. (latest-source-release, latest-wheel-release): Call 'vector->list' on RELEASES. * guix/import/stackage.scm (stackage-lts-info-fetch): Use 'json-fetch' instead of 'json-fetch-alist'. (lts-package-version): Use 'vector->list'. * guix/import/utils.scm (hash-table->alist): Remove. (alist->package): Pass 'vector->list' on the inputs fields, and default to the empty vector. * guix/scripts/import/json.scm (guix-import-json): Remove call to 'hash-table->alist'. * guix/swh.scm (define-json-reader): Expect pair? or null? instead of hash-table?. [extract-field]: Use 'assoc-ref' instead of 'hash-ref'. (json->branches): Use 'map' instead of 'hash-map->list'. (json->checksums): Likewise. (json->directory-entries, origin-visits): Call 'vector->list' on the result of 'json->scm'. * tests/import-utils.scm ("alist->package with dependencies"): New test. * gnu/installer.scm (build-compiled-file)[builder]: Use GUILE-JSON-3. * gnu/installer.scm (installer-program)[installer-builder]: Likewise. * gnu/installer/locale.scm (iso639->iso639-languages): Use 'assoc-ref' instead of 'hash-ref', and pass vectors through 'vector->list'. (iso3166->iso3166-territories): Likewise. * gnu/system/vm.scm (system-docker-image)[build]: Use GUILE-JSON-3. * guix/docker.scm (manifest, config): Adjust for Guile-JSON 3. * guix/scripts/pack.scm (docker-image)[build]: Use GUILE-JSON-3. * guix/import/github.scm (fetch-releases-or-tags): Update docstring. (latest-released-version): Use 'assoc-ref' instead of 'hash-ref'. Pass the result of 'fetch-releases-or-tags' to 'vector->list'. * guix/import/launchpad.scm (latest-released-version): Likewise.
2019-07-21 21:05:54 +00:00
(vector->list
(assoc-ref (json->scm port-iso639-3) "639-3"))
(vector->list
(assoc-ref (json->scm port-iso639-5) "639-5")))))))))
(define (language-code->language-name languages language-code)
"Using LANGUAGES as a list of ISO639 association lists, return the language
name corresponding to the given LANGUAGE-CODE."
(let ((iso639-language
(find (lambda (language)
(or
(and=> (iso639-language-alpha2 language)
(lambda (alpha2)
(string=? alpha2 language-code)))
(string=? (iso639-language-alpha3 language)
language-code)))
languages)))
(iso639-language-name iso639-language)))
;;;
;;; Territory.
;;;
(define (iso3166-territory-alpha2 assoc)
(assoc-ref assoc 'alpha2))
(define (iso3166-territory-alpha3 assoc)
(assoc-ref assoc 'alpha3))
(define (iso3166-territory-name assoc)
(assoc-ref assoc 'name))
(define (iso3166->iso3166-territories iso3166)
"Return a list of ISO3166 association lists created from the parsing of
ISO3166 file."
(call-with-input-file iso3166
(lambda (port)
(map (lambda (hash)
maint: Switch to Guile-JSON 3.x. Guile-JSON 3.x is incompatible with Guile-JSON 1.x, which we relied on until now: it maps JSON dictionaries to alists (instead of hash tables), and JSON arrays to vectors (instead of lists). This commit is about adjusting all the existing code to this new mapping. * m4/guix.m4 (GUIX_CHECK_GUILE_JSON): New macro. * configure.ac: Use it. * doc/guix.texi (Requirements): Mention the Guile-JSON version. * guix/git-download.scm (git-fetch)[guile-json]: Use GUILE-JSON-3. * guix/import/cpan.scm (string->license): Expect vectors instead of lists. (module->dist-name): Use 'json-fetch' instead of 'json-fetch-alist'. (cpan-fetch): Likewise. * guix/import/crate.scm (crate-fetch): Likewise, and call 'vector->list' for DEPS. * guix/import/gem.scm (rubygems-fetch): Likewise. * guix/import/json.scm (json-fetch-alist): Remove. * guix/import/pypi.scm (pypi-fetch): Use 'json-fetch' instead of 'json-fetch-alist'. (latest-source-release, latest-wheel-release): Call 'vector->list' on RELEASES. * guix/import/stackage.scm (stackage-lts-info-fetch): Use 'json-fetch' instead of 'json-fetch-alist'. (lts-package-version): Use 'vector->list'. * guix/import/utils.scm (hash-table->alist): Remove. (alist->package): Pass 'vector->list' on the inputs fields, and default to the empty vector. * guix/scripts/import/json.scm (guix-import-json): Remove call to 'hash-table->alist'. * guix/swh.scm (define-json-reader): Expect pair? or null? instead of hash-table?. [extract-field]: Use 'assoc-ref' instead of 'hash-ref'. (json->branches): Use 'map' instead of 'hash-map->list'. (json->checksums): Likewise. (json->directory-entries, origin-visits): Call 'vector->list' on the result of 'json->scm'. * tests/import-utils.scm ("alist->package with dependencies"): New test. * gnu/installer.scm (build-compiled-file)[builder]: Use GUILE-JSON-3. * gnu/installer.scm (installer-program)[installer-builder]: Likewise. * gnu/installer/locale.scm (iso639->iso639-languages): Use 'assoc-ref' instead of 'hash-ref', and pass vectors through 'vector->list'. (iso3166->iso3166-territories): Likewise. * gnu/system/vm.scm (system-docker-image)[build]: Use GUILE-JSON-3. * guix/docker.scm (manifest, config): Adjust for Guile-JSON 3. * guix/scripts/pack.scm (docker-image)[build]: Use GUILE-JSON-3. * guix/import/github.scm (fetch-releases-or-tags): Update docstring. (latest-released-version): Use 'assoc-ref' instead of 'hash-ref'. Pass the result of 'fetch-releases-or-tags' to 'vector->list'. * guix/import/launchpad.scm (latest-released-version): Likewise.
2019-07-21 21:05:54 +00:00
`((alpha2 . ,(assoc-ref hash "alpha_2"))
(alpha3 . ,(assoc-ref hash "alpha_3"))
(name . ,(assoc-ref hash "name"))))
(vector->list
(assoc-ref (json->scm port) "3166-1"))))))
(define (territory-code->territory-name territories territory-code)
"Using TERRITORIES as a list of ISO3166 association lists return the
territory name corresponding to the given TERRITORY-CODE."
(let ((iso3166-territory
(find (lambda (territory)
(or
(and=> (iso3166-territory-alpha2 territory)
(lambda (alpha2)
(string=? alpha2 territory-code)))
(string=? (iso3166-territory-alpha3 territory)
territory-code)))
territories)))
(iso3166-territory-name iso3166-territory)))
;;;
;;; Configuration formatter.
;;;
(define (locale->configuration locale)
"Return the configuration field for LOCALE."
`((locale ,locale)))