guix/gnu/installer/locale.scm

;;; 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 (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 (normalize-codeset codeset)
  "Compute the \"normalized\" variant of CODESET."
  ;; info "(libc) Using gettextized software", for the algorithm used to
  ;; compute the normalized codeset.
  (letrec-syntax ((-> (syntax-rules ()
                        ((_ proc value)
                         (proc value))
                        ((_ proc rest ...)
                         (proc (-> rest ...))))))
    (-> (lambda (str)
          (if (string-every char-set:digit str)
              (string-append "iso" str)
              str))
        string-downcase
        (lambda (str)
          (string-filter char-set:letter+digit str))
        codeset)))

(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."
  (map (match-lambda
         ((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)
             (let ((alpha2 (hash-ref hash "alpha_2"))
                   (alpha3 (hash-ref hash "alpha_3"))
                   (name   (hash-ref hash "name")))
               (and (supported-locale? locales alpha2 alpha3)
                    `((alpha2 . ,alpha2)
                      (alpha3 . ,alpha3)
                      (name   . ,name)))))
           (append
            (hash-ref (json->scm port-iso639-3) "639-3")
            (hash-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)
             `((alpha2 . ,(hash-ref hash "alpha_2"))
               (alpha3 . ,(hash-ref hash "alpha_3"))
               (name   . ,(hash-ref hash "name"))))
           (hash-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)))