1 files changed, 210 insertions, 0 deletions
diff --git a/gnu/installer/locale.scm b/gnu/installer/locale.scm
new file mode 100644
index 0000000000..2b45b2200a
--- /dev/null
+++ b/gnu/installer/locale.scm
@@ -0,0 +1,210 @@
+;;; GNU Guix --- Functional package management for GNU
+;;; Copyright © 2018 Mathieu Othacehe <m.othacehe@gmail.com>
+;;;
+;;; 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)
+  "Return the locale association list built from the parsing of STRING."
+  (let ((matches (string-match locale-regexp string)))
+    `((language  . ,(match:substring matches 1))
+      (territory . ,(match:substring matches 3))
+      (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
+                   `("." ,codeset)
+                   '())
+             ,@(if modifier
+                   `("@" ,modifier)
+                   '())))))
+
+(define (supported-locales->locales supported-locales)
+  "Parse the SUPPORTED-LOCALES file from the glibc and return the matching
+list of LOCALE association lists."
+ (call-with-input-file supported-locales
+    (lambda (port)
+      (let ((lines (read-lines port)))
+        (map (lambda (line)
+               (match (string-split line #\ )
+                 ((locale-string codeset)
+                  (let ((line-locale (locale-string->locale locale-string)))
+                    (assoc-set! line-locale 'codeset codeset)))))
+             lines)))))
+
+
+;;;
+;;; 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)))