locale: Add 'glibc-supported-locales'.

* gnu/system/locale.scm (glibc-supported-locales): New procedure.

1 files changed, 70 insertions, 2 deletions

diff --git a/gnu/system/locale.scm b/gnu/system/locale.scm
index 75417f6698..533a45e149 100644
--- a/gnu/system/locale.scm
+++ b/gnu/system/locale.scm
@@ -1,5 +1,5 @@
 ;;; GNU Guix --- Functional package management for GNU
-;;; Copyright © 2014, 2015, 2016, 2017 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2014, 2015, 2016, 2017, 2019 Ludovic Courtès <ludo@gnu.org>
 ;;; Copyright © 2018 Mark H Weaver <mhw@netris.org>
 ;;;
 ;;; This file is part of GNU Guix.
@@ -20,6 +20,7 @@
 (define-module (gnu system locale)
   #:use-module (guix gexp)
   #:use-module (guix store)
+  #:use-module (guix modules)
   #:use-module (guix records)
   #:use-module (guix packages)
   #:use-module (guix utils)
@@ -37,7 +38,9 @@
             locale-directory
 
             %default-locale-libcs
-            %default-locale-definitions))
+            %default-locale-definitions
+
+            glibc-supported-locales))
 
 ;;; Commentary:
 ;;;
@@ -202,4 +205,69 @@ data format changes between libc versions."
                         "vi_VN"
                         "zh_CN"))))
 
+
+;;;
+;;; Locales supported by glibc.
+;;;
+
+(define* (glibc-supported-locales #:optional (glibc glibc))
+  "Return a file-like object that contains a list of locale name/encoding
+pairs such as (\"oc_FR.UTF-8\" . \"UTF-8\").  Each pair corresponds to a
+locale supported by GLIBC."
+  (define build
+    (with-imported-modules (source-module-closure
+                            '((guix build gnu-build-system)))
+      #~(begin
+          (use-modules (guix build gnu-build-system)
+                       (srfi srfi-1)
+                       (ice-9 rdelim)
+                       (ice-9 match)
+                       (ice-9 regex)
+                       (ice-9 pretty-print))
+
+          (define unpack
+            (assq-ref %standard-phases 'unpack))
+
+          (define locale-rx
+            ;; Regexp matching a locale line in 'localedata/SUPPORTED'.
+            (make-regexp
+             "^[[:space:]]*([[:graph:]]+)/([[:graph:]]+)[[:space:]]*\\\\$"))
+
+          (define (read-supported-locales port)
+            ;; Read the 'localedata/SUPPORTED' file from PORT.  That file is
+            ;; actually a makefile snippet, with one locale per line, and a
+            ;; header that can be discarded.
+            (let loop ((locales '()))
+              (define line
+                (read-line port))
+
+              (cond ((eof-object? line)
+                     (reverse locales))
+                    ((string-prefix? "#" (string-trim line)) ;comment
+                     (loop locales))
+                    ((string-contains line "=")  ;makefile variable assignment
+                     (loop locales))
+                    (else
+                     (match (regexp-exec locale-rx line)
+                       (#f
+                        (loop locales))
+                       (m
+                        (loop (alist-cons (match:substring m 1)
+                                          (match:substring m 2)
+                                          locales))))))))
+
+          (setenv "PATH"
+                  (string-append #+(file-append tar "/bin") ":"
+                                 #+(file-append xz "/bin") ":"
+                                 #+(file-append gzip "/bin")))
+          (unpack #:source #+(package-source glibc))
+
+          (let ((locales (call-with-input-file "localedata/SUPPORTED"
+                           read-supported-locales)))
+            (call-with-output-file #$output
+              (lambda (port)
+                (pretty-print locales port)))))))
+
+  (computed-file "glibc-supported-locales.scm" build))
+
 ;;; locale.scm ends here