gnu: Add make-glibc-locales-collection.series-5492

Hi!

Efraim Flashner <efraim@flashner.co.il> skribis:

> * gnu/packages/base.scm (make-glibc-locales-collection): New macro.
> (en_us-glibc-locales): New variable.

Cool!

A while back I posted the attached patch, which reuses existing code
from (gnu system locale) and (gnu packages base).  I think I used it
just to see how much space all the UTF-8 locales take, compared to all
the locales.

Would it make sense to borrow from that?

At any rate, it’s the kind of package that’ll be more useful if/when we
have parameterized packages.

Ludo’.

1 files changed, 53 insertions, 3 deletions

diff --git a/gnu/packages/base.scm b/gnu/packages/base.scm
index c83775d8ee..3fc43b04da 100644
--- a/gnu/packages/base.scm
+++ b/gnu/packages/base.scm
@@ -53,6 +53,8 @@
   #:use-module (gnu packages python)
   #:use-module (gnu packages gettext)
   #:use-module (guix utils)
+  #:use-module (guix gexp)
+  #:use-module (guix modules)
   #:use-module (guix packages)
   #:use-module (guix download)
   #:use-module (guix git-download)
@@ -62,6 +64,8 @@
   #:use-module (srfi srfi-1)
   #:use-module (srfi srfi-26)
   #:export (glibc
+            %default-utf8-locales
+            make-glibc-utf8-locales
             libiconv-if-needed))
 
 ;;; Commentary:
@@ -1106,7 +1110,12 @@ to the @code{share/locale} sub-directory of this package.")
                                         ,(version-major+minor
                                           (package-version glibc)))))))))))
 
-(define-public (make-glibc-utf8-locales glibc)
+(define %default-utf8-locales
+  '("de_DE" "el_GR" "en_US" "fr_FR" "tr_TR"))
+
+(define* (make-glibc-utf8-locales glibc #:optional
+                                  (locales %default-utf8-locales)
+                                  (locale-file #f))
   (package
     (name "glibc-utf8-locales")
     (version (package-version glibc))
@@ -1145,10 +1154,17 @@ to the @code{share/locale} sub-directory of this package.")
 
                                ;; These are the locales commonly used for
                                ;; tests---e.g., in Guile's i18n tests.
-                               '("de_DE" "el_GR" "en_US" "fr_FR" "tr_TR"))
+                               ,(if locale-file
+                                    `(call-with-input-file
+                                         (assoc-ref %build-inputs "locale-file")
+                                       read)
+                                    `',locales))
                      #t))))
     (native-inputs `(("glibc" ,glibc)
-                     ("gzip" ,gzip)))
+                     ("gzip" ,gzip)
+                     ,@(if locale-file
+                           `(("locale-file" ,locale-file))
+                           '())))
     (synopsis "Small sample of UTF-8 locales")
     (description
      "This package provides a small sample of UTF-8 locales mostly useful in
@@ -1169,6 +1185,40 @@ test environments.")
   (package (inherit (make-glibc-utf8-locales glibc-2.29))
            (name "glibc-utf8-locales-2.29")))
 
+(define (glibc-supported-locales libc)
+  ((module-ref (resolve-interface '(gnu system locale)) ;FIXME: hack
+               'glibc-supported-locales)
+   libc))
+
+(define* (make-glibc-utf8-locales/full #:optional (glibc glibc))
+  (define utf8-locales
+    (computed-file "glibc-supported-utf8-locales.scm"
+                   #~(begin
+                       (use-modules (srfi srfi-1)
+                                    (ice-9 match)
+                                    (ice-9 pretty-print))
+
+                       (define locales
+                         (call-with-input-file
+                             #+(glibc-supported-locales glibc)
+                           read))
+
+                       (define utf8-locales
+                         (filter-map (match-lambda
+                                       ((name . "UTF-8")
+                                        (if (string-suffix? ".UTF-8" name)
+                                            (string-drop-right name 6)
+                                            name))
+                                       (_ #f))
+                                     locales))
+
+                       (call-with-output-file #$output
+                         (lambda (port)
+                           (pretty-print utf8-locales port))))))
+
+  (make-glibc-utf8-locales glibc #:locale-file utf8-locales))
+
+
 (define-public which
   (package
     (name "which")