gnu/build/locale.scm

   1 ;;; GNU Guix --- Functional package management for GNU
   2 ;;; Copyright © 2019 Ludovic Courtès <ludo@gnu.org>
   3 ;;;
   4 ;;; This file is part of GNU Guix.
   5 ;;;
   6 ;;; GNU Guix is free software; you can redistribute it and/or modify it
   7 ;;; under the terms of the GNU General Public License as published by
   8 ;;; the Free Software Foundation; either version 3 of the License, or (at
   9 ;;; your option) any later version.
  10 ;;;
  11 ;;; GNU Guix is distributed in the hope that it will be useful, but
  12 ;;; WITHOUT ANY WARRANTY; without even the implied warranty of
  13 ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  14 ;;; GNU General Public License for more details.
  15 ;;;
  16 ;;; You should have received a copy of the GNU General Public License
  17 ;;; along with GNU Guix.  If not, see <http://www.gnu.org/licenses/>.
  18
  19 (define-module (gnu build locale)
  20   #:use-module (guix build utils)
  21   #:use-module (srfi srfi-1)
  22   #:use-module (ice-9 rdelim)
  23   #:use-module (ice-9 match)
  24   #:use-module (ice-9 regex)
  25   #:export (build-locale
  26             normalize-codeset
  27             locale->name+codeset
  28             read-supported-locales))
  29
  30 (define locale-rx
  31   ;; Regexp matching a locale line in 'localedata/SUPPORTED'.
  32   (make-regexp
  33    "^[[:space:]]*([[:graph:]]+)/([[:graph:]]+)[[:space:]]*\\\\$"))
  34
  35 (define (read-supported-locales port)
  36   "Read the 'localedata/SUPPORTED' file from PORT.  That file is actually a
  37 makefile snippet, with one locale per line, and a header that can be
  38 discarded."
  39   (let loop ((locales '()))
  40     (define line
  41       (read-line port))
  42
  43     (cond ((eof-object? line)
  44            (reverse locales))
  45           ((string-prefix? "#" (string-trim line)) ;comment
  46            (loop locales))
  47           ((string-contains line "=")            ;makefile variable assignment
  48            (loop locales))
  49           (else
  50            (match (regexp-exec locale-rx line)
  51              (#f
  52               (loop locales))
  53              (m
  54               (loop (alist-cons (match:substring m 1)
  55                                 (match:substring m 2)
  56                                 locales))))))))
  57
  58 (define (normalize-codeset codeset)
  59   "Compute the \"normalized\" variant of CODESET."
  60   ;; info "(libc) Using gettextized software", for the algorithm used to
  61   ;; compute the normalized codeset.
  62   (letrec-syntax ((-> (syntax-rules ()
  63                         ((_ proc value)
  64                          (proc value))
  65                         ((_ proc rest ...)
  66                          (proc (-> rest ...))))))
  67     (-> (lambda (str)
  68           (if (string-every char-set:digit str)
  69               (string-append "iso" str)
  70               str))
  71         string-downcase
  72         (lambda (str)
  73           (string-filter char-set:letter+digit str))
  74         codeset)))
  75
  76 (define* (build-locale locale
  77                        #:key
  78                        (localedef "localedef")
  79                        (directory ".")
  80                        (codeset "UTF-8")
  81                        (name (string-append locale "." codeset)))
  82   "Compute locale data for LOCALE and CODESET--e.g., \"en_US\" and
  83 \"UTF-8\"--with LOCALEDEF, and store it in DIRECTORY under NAME."
  84   (format #t "building locale '~a'...~%" name)
  85   (invoke localedef "--no-archive" "--prefix" directory
  86           "-i" locale "-f" codeset
  87           (string-append directory "/" name)))
  88
  89 (define (locale->name+codeset locale)
  90   "Split a locale name such as \"aa_ER@saaho.UTF-8\" into two values: the
  91 language/territory/modifier part, and the codeset."
  92   (match (string-rindex locale #\.)
  93     (#f  (values locale #f))
  94     (dot (values (string-take locale dot)
  95                  (string-drop locale (+ dot 1))))))