On Fri, Jul 19, 2019 at 02:29:52PM +0200, pelzflorian (Florian Pelz) wrote: > I will try writing a custom xgettext that combines > nested·s-expressions·that are marked for translation with G_ > to·a·single·msgstr that gets written to the·PO·file. This combined > string will not be part of the source code but will be generated from > a nested sexp. The PO file containing the combined strings can then > be translated as usual. For reading the translation, the combined > msgstr will be constructed again by the marking procedure G_ and > looked up by reading from an MO file. > > It will take me a few days and a MO file reader will still be missing. > I suppose it would be easier to use for the sxml’s author who would > not need to write special code to internationalize the sxml. >
Find attached a work-in-progress patch to guix-artwork that constructs PO entries from nested sexps. Also attached is a file marked for translation and the POT file generated from it. No custom MO reader is needed because gettext is a fine MO reader, the problem is only xgettext that cannot extract sexps. Currently missing though is a procedure or macro for deconstructing the msgstr to an sexp, so the patch can only generate unusable POT files at the moment. I will take a look at it now, but it may again take a week. Please tell me if you think this is the wrong approach. Regards, Florian
>From 1f126de9d16f1eb78d1d8846ddfad7d3e84bb1d4 Mon Sep 17 00:00:00 2001
From: Florian Pelz <pelzflor...@pelzflorian.de>
Date: Fri, 26 Jul 2019 12:58:18 +0200
Subject: [PATCH] [wip] website: Use custom xgettext implementation that can
extract from nested sexps.
* website/scripts/sexp-xgettext.scm: New file for generating a PO file.
* website/sexp-xgettext.scm: New file with module for looking up
translations.
* website/apps/base/templates/home.scm (home-t): Mark for translation
for testing.
* website/po/POTFILES: New file; list the above file here.
* website/po/guix-website.pot: New file; generated from the above.
* website/po/de.po: New file.
* website/po/LINGUAS: New file. Add linguas for testing. Currently
their country code has to be specified too.
* website/apps/i18n.scm: New file. Add utility functions.
* website/haunt.scm: Load linguas and call each builder with each.
* website/wip-howto-test-translation: New file with unfinished
instructions.
---
website/apps/base/templates/home.scm | 231 +++++------
website/apps/i18n.scm | 96 +++++
website/haunt.scm | 24 +-
website/po/LINGUAS | 2 +
website/po/POTFILES | 1 +
website/po/de.po | 30 ++
website/po/guix-website.pot | 78 ++++
website/scripts/sexp-xgettext.scm | 575 +++++++++++++++++++++++++++
website/sexp-xgettext.scm | 31 ++
website/wip-howto-test-translation | 27 ++
10 files changed, 978 insertions(+), 117 deletions(-)
create mode 100644 website/apps/i18n.scm
create mode 100644 website/po/LINGUAS
create mode 100644 website/po/POTFILES
create mode 100644 website/po/de.po
create mode 100644 website/po/guix-website.pot
create mode 100644 website/scripts/sexp-xgettext.scm
create mode 100644 website/sexp-xgettext.scm
create mode 100644 website/wip-howto-test-translation
diff --git a/website/apps/base/templates/home.scm
b/website/apps/base/templates/home.scm
index 5cb3bf5..09e24ba 100644
--- a/website/apps/base/templates/home.scm
+++ b/website/apps/base/templates/home.scm
@@ -14,17 +14,18 @@
(define (home-t context)
"Return the Home page in SHTML using the data in CONTEXT."
(theme
- #:title '("GNU's advanced distro and transactional package manager")
+ #:title (list (G_ "GNU's advanced distro and transactional package
manager"))
#:description
- "Guix is an advanced distribution of the GNU operating system.
+ (G_ "Guix is an advanced distribution of the GNU operating system.
Guix is technology that respects the freedom of computer users.
You are free to run the system for any purpose, study how it works,
- improve it, and share it with the whole world."
+ improve it, and share it with the whole world.")
#:keywords
- '("GNU" "Linux" "Unix" "Free software" "Libre software"
- "Operating system" "GNU Hurd" "GNU Guix package manager"
- "GNU Guile" "Guile Scheme" "Transactional upgrades"
- "Functional package management" "Reproducibility")
+ (string-split ;TRANSLATORS: |-separated list of webpage keywords
+ (G_ "GNU|Linux|Unix|Free software|Libre software|Operating \
+system|GNU Hurd|GNU Guix package manager|GNU Guile|Guile \
+Scheme|Transactional upgrades|Functional package \
+management|Reproducibility"))
#:active-menu-item "Overview"
#:css (list
(guix-url "static/base/css/item-preview.css")
@@ -34,83 +35,88 @@
;; Featured content.
(section
(@ (class "featured-content"))
- (h2 (@ (class "a11y-offset")) "Summary")
+ (G_ `(h2 (@ (class "a11y-offset")) "Summary"))
(ul
- (li
- (b "Liberating.")
- " Guix is an advanced
- distribution of the "
- ,(link-yellow
- #:label "GNU operating system"
- #:url (gnu-url "gnu/about-gnu.html"))
- " developed by the "
- ,(link-yellow
- #:label "GNU Project"
- #:url (gnu-url))
- "—which respects the "
- ,(link-yellow
- #:label "freedom of computer users"
- #:url (gnu-url "distros/free-system-distribution-guidelines.html"))
- ". ")
-
- (li
- (b "Dependable.")
- " Guix "
- ,(link-yellow
- #:label "supports"
- #:url (manual-url "Package-Management.html"))
- " transactional upgrades and roll-backs, unprivileged
- package management, "
- ,(link-yellow
- #:label "and more"
- #:url (manual-url "Features.html"))
- ". When used as a standalone distribution, Guix supports "
- ,(link-yellow
- #:label "declarative system configuration"
- #:url (manual-url "Using-the-Configuration-System.html"))
- " for transparent and reproducible operating systems.")
-
- (li
- (b "Hackable.")
- " It provides "
- ,(link-yellow
- #:label "Guile Scheme"
- #:url (gnu-url "software/guile/"))
- " APIs, including high-level embedded domain-specific
- languages (EDSLs) to "
- ,(link-yellow
- #:label "define packages"
- #:url (manual-url "Defining-Packages.html"))
- " and "
- ,(link-yellow
- #:label "whole-system configurations"
- #:url (manual-url "System-Configuration.html"))
- "."))
+ ,(G_
+ `(li
+ ,(G_ `(b "Liberating."))
+ " Guix is an advanced distribution of the "
+ ,(G_ (link-yellow
+ #:label "GNU operating system"
+ #:url (gnu-url "gnu/about-gnu.html")))
+ " developed by the "
+ ,(G_ (link-yellow
+ #:label "GNU Project"
+ #:url (gnu-url)))
+ "—which respects the "
+ ,(G_ (link-yellow
+ #:label "freedom of computer users"
+ #:url (gnu-url "distros/free-system-distribution-\
+guidelines.html")))
+ ". "))
+
+ (G_
+ `(li
+ ,(G_ `(b "Dependable."))
+ " Guix "
+ ,(G_ (link-yellow
+ #:label "supports"
+ #:url (manual-url "Package-Management.html")))
+ " transactional upgrades and roll-backs, unprivileged \
+package management, "
+ ,(G_ (link-yellow
+ #:label "and more"
+ #:url (manual-url "Features.html")))
+ ". When used as a standalone distribution, Guix supports "
+ ,(G_ (link-yellow
+ #:label "declarative system configuration"
+ #:url (manual-url "Using-the-Configuration-System.html")))
+ " for transparent and reproducible operating systems."))
+
+ (G_
+ `(li
+ ,(G_ `(b "Hackable."))
+ " It provides "
+ ,(G_ (link-yellow
+ #:label "Guile Scheme"
+ #:url (gnu-url "software/guile/")))
+ " APIs, including high-level embedded domain-specific \
+languages (EDSLs) to "
+ ,(G_ (link-yellow
+ #:label "define packages"
+ #:url (manual-url "Defining-Packages.html")))
+ " and "
+ ,(G_ (link-yellow
+ #:label "whole-system configurations"
+ #:url (manual-url "System-Configuration.html")))
+ ".")))
(div
(@ (class "action-box centered-text"))
,(button-big
- #:label (string-append "DOWNLOAD v" (latest-guix-version))
+ #:label (C_ (string-append "DOWNLOAD v" (latest-guix-version))
+ "button")
#:url (guix-url "download/")
#:light #true)
" " ; A space for readability in non-CSS browsers.
,(button-big
- #:label "CONTRIBUTE"
+ #:label (C_ "CONTRIBUTE" "button")
#:url (guix-url "contribute/")
#:light #true)))
;; Discover Guix.
(section
(@ (class "discovery-box"))
- (h2 "Discover Guix")
+ (G_ `(h2 "Discover Guix"))
- (p
- (@ (class "limit-width centered-block"))
- "Guix comes with thousands of packages which include
- applications, system tools, documentation, fonts, and other
- digital goods readily available for installing with the "
- ,(link-yellow #:label "GNU Guix" #:url "#guix-in-other-distros")
- " package manager.")
+ (G_
+ `(p
+ (@ (class "limit-width centered-block"))
+ "Guix comes with thousands of packages which include \
+applications, system tools, documentation, fonts, and other digital \
+goods readily available for installing with the "
+ ,(G_ `(link-yellow #:label "GNU Guix" #:url "#guix-in-other-distros"))
+ " package manager."))
(div
(@ (class "screenshots-box"))
@@ -119,55 +125,57 @@
(div
(@ (class "action-box centered-text"))
,(button-big
- #:label "ALL PACKAGES"
+ #:label (C_ "ALL PACKAGES" "button")
#:url (guix-url "packages/")
#:light #true))
,(horizontal-separator #:light #true)
;; Guix in different fields.
- (h3 "GNU Guix in your field")
+ (G_ `(h3 "GNU Guix in your field"))
- (p
- (@ (class "limit-width centered-block"))
- "Read some stories about how people are using GNU Guix in their daily
- lives.")
+ (G_
+ `(p
+ (@ (class "limit-width centered-block"))
+ "Read some stories about how people are using GNU Guix in
+their daily lives."))
(div
(@ (class "fields-box"))
" " ; A space for readability in non-CSS browsers (same below).
,(button-big
- #:label "SOFTWARE DEVELOPMENT"
- #:url (guix-url "blog/tags/software-development/")
- #:light #true)
+ #:label (C_ "SOFTWARE DEVELOPMENT" "button")
+ #:url (guix-url "blog/tags/software-development/")
+ #:light #true)
" "
,(button-big
- #:label "BIOINFORMATICS"
- #:url (guix-url "blog/tags/bioinformatics/")
- #:light #true)
+ #:label (C_ "BIOINFORMATICS" "button")
+ #:url (guix-url "blog/tags/bioinformatics/")
+ #:light #true)
" "
,(button-big
- #:label "HIGH PERFORMANCE COMPUTING"
- #:url (guix-url "blog/tags/high-performance-computing/")
- #:light #true)
+ #:label (C_ "HIGH PERFORMANCE COMPUTING" "button")
+ #:url (guix-url "blog/tags/high-performance-computing/")
+ #:light #true)
" "
,(button-big
- #:label "RESEARCH"
- #:url (guix-url "blog/tags/research/")
- #:light #true)
+ #:label (C_ "RESEARCH" "button")
+ #:url (guix-url "blog/tags/research/")
+ #:light #true)
" "
,(button-big
- #:label "ALL FIELDS..."
- #:url (guix-url "blog/")
- #:light #true))
+ #:label (C_ "ALL FIELDS..." "button")
+ #:url (guix-url "blog/")
+ #:light #true))
,(horizontal-separator #:light #true)
;; Using Guix in other distros.
- (h3
- (@ (id "guix-in-other-distros"))
- "GNU Guix in other GNU/Linux distros")
+ (G_
+ `(h3
+ (@ (id "guix-in-other-distros"))
+ "GNU Guix in other GNU/Linux distros"))
(div
(@ (class "info-box"))
@@ -176,54 +184,55 @@
(src
"https://audio-video.gnu.org/video/misc/2016-07__GNU_Guix_Demo_2.webm";)
(poster ,(guix-url "static/media/img/guix-demo.png"))
(controls "controls"))
- (p
- "Video: "
- ,(link-yellow
- #:label "Demo of Guix in another GNU/Linux distribution"
- #:url
"https://audio-video.gnu.org/video/misc/2016-07__GNU_Guix_Demo_2.webm";)
- " (1 minute, 30 seconds).")))
+ (G_
+ `(p
+ "Video: "
+ ,(G_ (link-yellow
+ #:label "Demo of Guix in another GNU/Linux distribution"
+ #:url "https://audio-video.gnu.org/video/misc/\
+2016-07__GNU_Guix_Demo_2.webm"))
+ " (1 minute, 30 seconds)."))))
(div
(@ (class "info-box justify-left"))
- (p
- "If you don't use GNU Guix as a standalone GNU/Linux distribution,
- you still can use it as a
- package manager on top of any GNU/Linux distribution. This
- way, you can benefit from all its conveniences.")
+ ,(G_ `(p
+ "If you don't use GNU Guix as a standalone GNU/Linux \
+distribution, you still can use it as a package manager on top of any \
+GNU/Linux distribution. This way, you can benefit from all its conveniences."))
- (p
- "Guix won't interfere with the package manager that comes
- with your distribution. They can live together."))
+ ,(G_ `(p
+ "Guix won't interfere with the package manager that comes \
+with your distribution. They can live together.")))
(div
(@ (class "action-box centered-text"))
,(button-big
- #:label "TRY IT OUT!"
+ #:label (C_ "TRY IT OUT!" "button")
#:url (guix-url "download/")
#:light #true)))
;; Latest Blog posts.
(section
(@ (class "centered-text"))
- (h2 "Blog")
+ (G_ `(h2 "Blog"))
,@(map post-preview (context-datum context "posts"))
(div
(@ (class "action-box centered-text"))
,(button-big
- #:label "ALL POSTS"
+ #:label (C_ "ALL POSTS" "button")
#:url (guix-url "blog/"))))
;; Contact info.
(section
(@ (class "contact-box centered-text"))
- (h2 "Contact")
+ (G_ (h2 "Contact"))
,@(map contact-preview (context-datum context "contact-media"))
(div
(@ (class "action-box centered-text"))
,(button-big
- #:label "ALL CONTACT MEDIA"
+ #:label (C_ "ALL CONTACT MEDIA" "button")
#:url (guix-url "contact/")))))))
diff --git a/website/apps/i18n.scm b/website/apps/i18n.scm
new file mode 100644
index 0000000..53fb963
--- /dev/null
+++ b/website/apps/i18n.scm
@@ -0,0 +1,96 @@
+;;; GNU Guix web site
+;;; Copyright © 2019 Florian Pelz <pelzflor...@pelzflorian.de>
+;;;
+;;; This file is part of the GNU Guix web site.
+;;;
+;;; The GNU Guix web site is free software; you can redistribute it and/or
modify it
+;;; under the terms of the GNU Affero General Public License as published by
+;;; the Free Software Foundation; either version 3 of the License, or (at
+;;; your option) any later version.
+;;;
+;;; The GNU Guix web site 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 Affero General Public License for more details.
+;;;
+;;; You should have received a copy of the GNU Affero General Public License
+;;; along with the GNU Guix web site. If not, see
<http://www.gnu.org/licenses/>.
+
+(define-module (apps i18n)
+ #:use-module (haunt page)
+ #:use-module (haunt utils)
+ #:use-module (ice-9 match)
+ #:use-module (sexp-xgettext)
+ #:use-module (srfi srfi-1)
+ #:export (G_
+ N_
+ C_
+ %current-lingua
+ builder->localized-builder
+ builders->localized-builders))
+
+(define %gettext-domain
+ "guix-website")
+
+(bindtextdomain %gettext-domain (getcwd))
+(bind-textdomain-codeset %gettext-domain "UTF-8")
+(textdomain %gettext-domain)
+
+;; TODO deconstruct an sexp instead of directly receiving a msg
+(define* (G_ msg) ;like gettext
+ (gettext msg %gettext-domain))
+
+(define* (N_ msg msgplural n) ;like ngettext
+ (ngettext msg msgplural %gettext-domain))
+
+(define* (C_ msg msgctxt) ;like pgettext
+ msg);TODO
+
+(define <page>
+ (@@ (haunt page) <page>))
+
+(define %current-lingua
+ (make-parameter "en_US"))
+
+(define (first-value arg)
+ "For some reason the builder returned by static-directory returns
+multiple values. This procedure is used to retain only the first
+return value. TODO THIS SHOULD NOT BE NECESSARY I THINK"
+ arg)
+
+(define (builder->localized-builder builder lingua)
+ (compose
+ (lambda (pages)
+ (map
+ (lambda (page)
+ (match page
+ (($ <page> file-name contents writer)
+ (if (string-suffix? ".html" file-name)
+ (let* ((base (string-drop-right
+ file-name
+ (string-length ".html")))
+ (new-name (string-append base
+ "."
+ lingua
+ ".html")))
+ (make-page new-name contents writer))
+ page))
+ (else page)))
+ pages))
+ (lambda (site posts)
+ (begin
+ (setlocale LC_ALL (string-append lingua ".utf8"))
+ (parameterize ((%current-lingua lingua))
+ (lambda _
+ (begin
+ (first-value (builder site posts)))))))))
+
+(define (builders->localized-builders builders linguas)
+ (flatten
+ (map-in-order
+ (lambda (builder)
+ (map-in-order
+ (lambda (lingua)
+ (builder->localized-builder builder lingua))
+ linguas))
+ builders)))
diff --git a/website/haunt.scm b/website/haunt.scm
index d29c0d4..eb0eafe 100644
--- a/website/haunt.scm
+++ b/website/haunt.scm
@@ -5,13 +5,23 @@
(use-modules ((apps base builder) #:prefix base:)
((apps blog builder) #:prefix blog:)
((apps download builder) #:prefix download:)
+ (apps i18n)
((apps packages builder) #:prefix packages:)
(haunt asset)
(haunt builder assets)
(haunt reader)
(haunt reader commonmark)
- (haunt site))
+ (haunt site)
+ (ice-9 rdelim)
+ (srfi srfi-1))
+(define linguas
+ (with-input-from-file "po/LINGUAS"
+ (lambda _
+ (let loop ((line (read-line)))
+ (if (eof-object? line)
+ '()
+ (cons line (loop (read-line))))))))
(site #:title "GNU Guix"
#:domain (if (getenv "GUIX_WEB_SITE_INFO")
@@ -19,8 +29,10 @@
"https://gnu.org/software/guix";)
#:build-directory "/tmp/gnu.org/software/guix"
#:readers (list sxml-reader html-reader commonmark-reader)
- #:builders (list base:builder
- blog:builder
- download:builder
- packages:builder
- (static-directory "static")))
+ #:builders (builders->localized-builders
+ (list base:builder
+ blog:builder
+ download:builder
+ packages:builder
+ (static-directory "static"))
+ linguas))
diff --git a/website/po/LINGUAS b/website/po/LINGUAS
new file mode 100644
index 0000000..782116d
--- /dev/null
+++ b/website/po/LINGUAS
@@ -0,0 +1,2 @@
+de_DE
+en_US
diff --git a/website/po/POTFILES b/website/po/POTFILES
new file mode 100644
index 0000000..0007797
--- /dev/null
+++ b/website/po/POTFILES
@@ -0,0 +1 @@
+apps/base/templates/home.scm
diff --git a/website/po/de.po b/website/po/de.po
new file mode 100644
index 0000000..3add92e
--- /dev/null
+++ b/website/po/de.po
@@ -0,0 +1,30 @@
+# German translations for guix-website package.
+# Copyright (C) 2019 Ludovic Courtès
+# This file is distributed under the same license as the guix-website package.
+# Automatically generated, 2019.
+#
+msgid ""
+msgstr ""
+"Project-Id-Version: guix-website\n"
+"Report-Msgid-Bugs-To: l...@gnu.org\n"
+"POT-Creation-Date: 2019-07-18 16:31+0200\n"
+"PO-Revision-Date: 2019-07-18 16:33+0200\n"
+"Last-Translator: Automatically generated\n"
+"Language-Team: none\n"
+"Language: de\n"
+"MIME-Version: 1.0\n"
+"Content-Type: text/plain; charset=UTF-8\n"
+"Content-Transfer-Encoding: 8bit\n"
+"Plural-Forms: nplurals=2; plural=(n != 1);\n"
+
+#: apps/base/templates/home.scm:41
+msgctxt "featured content"
+msgid "Liberating."
+msgstr "Befreiend."
+
+#: apps/base/templates/home.scm:42
+msgctxt "featured content"
+msgid ""
+" Guix is an advanced\n"
+" distribution of the "
+msgstr "Guix ist eine fortgeschrittene Distribution des "
diff --git a/website/po/guix-website.pot b/website/po/guix-website.pot
new file mode 100644
index 0000000..0c180fe
--- /dev/null
+++ b/website/po/guix-website.pot
@@ -0,0 +1,78 @@
+
+msgid "GNU's advanced distro and transactional package manager"
+msgstr ""
+
+msgid "Guix is an advanced distribution of the GNU operating system.\n Guix
is technology that respects the freedom of computer users.\n You are free to
run the system for any purpose, study how it works,\n improve it, and share
it with the whole world."
+msgstr ""
+
+msgid "GNU|Linux|Unix|Free software|Libre software|Operating system|GNU
Hurd|GNU Guix package manager|GNU Guile|Guile Scheme|Transactional
upgrades|Functional package management|Reproducibility"
+msgstr ""
+
+msgid "<1/>Summary"
+msgstr ""
+
+msgid "<1/> Guix is an advanced\n distribution of the developed by the
—which respects the . "
+msgstr ""
+
+msgid "<1/> Guix transactional upgrades and roll-backs, unprivileged\n
package management, . When used as a standalone distribution, Guix supports
for transparent and reproducible operating systems."
+msgstr ""
+
+msgid "<1/> It provides APIs, including high-level embedded domain-specific\n
languages (EDSLs) to and ."
+msgstr ""
+
+msgid "<1/>DOWNLOAD v"
+msgstr ""
+
+msgid "CONTRIBUTE"
+msgstr ""
+
+msgid "<1/>Discover Guix"
+msgstr ""
+
+msgid "<1/>Guix comes with thousands of packages which include\n
applications, system tools, documentation, fonts, and other\n digital
goods readily available for installing with the package manager."
+msgstr ""
+
+msgid "ALL PACKAGES"
+msgstr ""
+
+msgid "<1/>GNU Guix in your field"
+msgstr ""
+
+msgid "<1/>Read some stories about how people are using GNU\xa0Guix in their
daily\n lives."
+msgstr ""
+
+msgid "BIOINFORMATICS"
+msgstr ""
+
+msgid "HIGH PERFORMANCE COMPUTING"
+msgstr ""
+
+msgid "RESEARCH"
+msgstr ""
+
+msgid "ALL FIELDS..."
+msgstr ""
+
+msgid "<1/>GNU Guix in other GNU/Linux distros"
+msgstr ""
+
+msgid "<1/>Video: (1 minute, 30 seconds)."
+msgstr ""
+
+msgid "<1/>"
+msgstr ""
+
+msgid "TRY IT OUT!"
+msgstr ""
+
+msgid "<1/>Blog"
+msgstr ""
+
+msgid "ALL POSTS"
+msgstr ""
+
+msgid "<1/>Contact"
+msgstr ""
+
+msgid "ALL CONTACT MEDIA"
+msgstr ""
diff --git a/website/scripts/sexp-xgettext.scm
b/website/scripts/sexp-xgettext.scm
new file mode 100644
index 0000000..c069507
--- /dev/null
+++ b/website/scripts/sexp-xgettext.scm
@@ -0,0 +1,575 @@
+;;; GNU Guix web site
+;;; Copyright © 2019 Florian Pelz <pelzflor...@pelzflorian.de>
+;;;
+;;; This file is part of the GNU Guix web site.
+;;;
+;;; The GNU Guix web site is free software; you can redistribute it and/or
modify it
+;;; under the terms of the GNU Affero General Public License as published by
+;;; the Free Software Foundation; either version 3 of the License, or (at
+;;; your option) any later version.
+;;;
+;;; The GNU Guix web site 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 Affero General Public License for more details.
+;;;
+;;; You should have received a copy of the GNU Affero General Public License
+;;; along with the GNU Guix web site. If not, see
<http://www.gnu.org/licenses/>.
+
+(use-modules (ice-9 getopt-long)
+ (ice-9 match)
+ (ice-9 peg)
+ (ice-9 receive)
+ (ice-9 regex)
+ (ice-9 textual-ports)
+ (srfi srfi-1) ;lists
+ (srfi srfi-9)) ;records
+
+;;; This script imitates xgettext, but combines nested s-expressions
+;;; in the input Scheme files to a single msgstr in the PO file. It
+;;; works by first reading the keywords specified on the command-line,
+;;; then dealing with the remaining options using (ice-9 getopt-long).
+;;; Then, it parses each Scheme file in the POTFILES file specified
+;;; with --files-from and constructs po entries from it. For parsing,
+;;; a PEG is used instead of Scheme’s read, because we can extract
+;;; comments with it. The po entries are written to the PO file
+;;; specified with the --output option. Scheme code can then use the
+;;; (sexp-xgettext) module to deconstruct the msgids looked up in the
+;;; PO file via gettext.
+
+(define (pk a)
+ (begin
+ (write a)
+ (newline)
+ a))
+
+(define-record-type <keyword-spec>
+ (make-keyword-spec id sg pl c total xcomment)
+ keyword-spec?
+ (id keyword-spec-id) ;identifier
+ (sg keyword-spec-sg) ;arg with singular
+ (pl keyword-spec-pl) ;arg with plural
+ (c keyword-spec-c) ;arg with msgctxt or 'mixed if sg is mixed
msgctxt|singular
+ (total keyword-spec-total) ;total number of args
+ (xcomment keyword-spec-xcomment))
+
+(define (complex-keyword-spec? keyword-spec)
+ (match keyword-spec
+ (($ <keyword-spec> _ _ #f #f _ #f) #f)
+ (else #t)))
+
+(define %keyword-specs
+ ;; List of valid keywords.
+ (let loop ((opts (cdr (command-line)));command-line options from
+ ;which to extract --keyword
+ ;options
+ (remaining-opts '()) ;unhandled opts
+ (specs '()))
+ ;; Read keywords from command-line options.
+ (define (string->integer str)
+ (if (string-match "[0-9]+" str)
+ (string->number str)
+ (error "Not a decimal integer.")))
+ (define* (argnums->spec id #:optional (argnums '()))
+ (let loop ((sg #f)
+ (pl #f)
+ (c #f)
+ (total #f)
+ (xcomment #f)
+ (argnums argnums))
+ (match argnums
+ (() (make-keyword-spec id
+ (if sg sg 1)
+ pl
+ c
+ total
+ xcomment))
+ ((arg . argnums)
+ (cond
+ ((string-suffix? "c" arg)
+ (cond (c (error "c suffix clashes"))
+ (else
+ (let* ((number-str (string-drop-right arg 1))
+ (number (string->integer number-str)))
+ (loop sg pl number total xcomment argnums)))))
+ ((string-suffix? "g" arg)
+ (cond
+ (sg (error "Only first argnum can have g suffix."))
+ (c (error "g suffix clashes."))
+ (else
+ (let* ((number-str (string-drop-right arg 1))
+ (number (string->integer number-str)))
+ (loop number #f 'mixed total xcomment argnums)))))
+ ((string-suffix? "t" arg)
+ (cond (total (error "t suffix clashes"))
+ (else
+ (let* ((number-str (string-drop-right arg 1))
+ (number (string->integer number-str)))
+ (loop sg pl c number xcomment argnums)))))
+ ((string-suffix? "\"" arg)
+ (cond (xcomment (error "xcomment clashes"))
+ (else
+ (let* ((comment (substring arg
+ 1
+ (- (string-length arg) 1))))
+ (loop sg pl c total comment argnums)))))
+ (else
+ (let* ((number (string->integer arg)))
+ (if sg
+ (if pl
+ (error "Too many argnums.")
+ (loop sg number c total xcomment argnums))
+ (loop number #f c total xcomment argnums)))))))))
+
+ (define (string->spec str) ;see `info xgettext`
+ (match (string-split str #\:)
+ ((id) (argnums->spec id))
+ ((id argnums)
+ (argnums->spec id (string-split argnums #\,)))))
+ (match opts
+ (() (begin
+ ;; remove recognized --keyword command-line options:
+ (set-program-arguments (cons (car (command-line))
+ (reverse remaining-opts)))
+ specs))
+ ((current-opt . rest)
+ (cond
+ ((string=? "--" current-opt) specs)
+ ((string-prefix? "--keyword=" current-opt)
+ (let ((keyword (string-drop current-opt (string-length
"--keyword="))))
+ (loop rest remaining-opts (cons (string->spec keyword) specs))))
+ ((or (string=? "--keyword" current-opt)
+ (string=? "-k" current-opt))
+ (let ((next-opt (car rest)))
+ (loop (cdr rest)
+ remaining-opts
+ (cons (string->spec next-opt) specs))))
+ (else (loop rest (cons current-opt remaining-opts) specs)))))))
+
+;;; Other options are not repeated, so we can use getopt-long:
+
+(define %options ;; Corresponds to what is documented at `info xgettext`.
+ (let ((option-spec
+ `((files (single-char #\f) (value #t))
+ (directory (single-char #\D) (value #t))
+ (default-domain (single-char #\d) (value #t))
+ (output (single-char #\o) (value #t))
+ (output-dir (single-char #\p) (value #t))
+ (from-code (value #t))
+ (join-existing (single-char #\j) (value #f))
+ (exclude-file (single-char #\x) (value #t))
+ (add-comments (single-char #\c) (value #t))
+
+ ;; Because getopt-long does not support repeated options,
+ ;; we took care of --keyword options further up.
+ ;; (keyword (single-char #\k) (value #t))
+
+ (flag (value #t))
+ (force-po (value #f))
+ (indent (single-char #\i) (value #f))
+ (no-location (value #f))
+ (add-location (single-char #\n) (value #t))
+ (width (single-char #\w) (value #t))
+ (no-wrap (value #f))
+ (sort-output (single-char #\s) (value #f))
+ (sort-by-file (single-char #\F) (value #f))
+ (omit-header (value #f))
+ (copyright-holder (value #t))
+ (foreign-user (value #f))
+ (package-name (value #t))
+ (package-version (value #t))
+ (msgid-bugs-address (value #t))
+ (msgstr-prefix (single-char #\m) (value #t))
+ (msgstr-suffix (single-char #\m) (value #t))
+ (help (value #f))
+ (pack (value #f)))))
+ (getopt-long (command-line) option-spec)))
+
+
+;; implemented similar to guix/build/po.scm
+(define parse-scheme-file
+ ;; This procedure parses FILE and returns a parse tree.
+ (let ()
+ ;;TODO: OPTIONALLY IGNORE CASE:
+ (define-peg-pattern comment all (and ";"
+ (* (and peg-any
+ (not-followed-by "\n")))
+ (and peg-any (followed-by "\n"))))
+ (define-peg-pattern whitespace none (or " " "\t" "\n"))
+ (define-peg-pattern quotation body (or "'" "`" "," ",@")) ;TODO ALLOW USER
TO SPECIFY OTHER QUOTE CHARACTERS
+ (define-peg-pattern open body (and (? quotation)
+ (or "(" "[" "{")))
+ (define-peg-pattern close body (or ")" "]" "}"))
+ (define-peg-pattern string body (and (followed-by "\"")
+ (* (or "\\\""
+ (and peg-any
+ (not-followed-by "\""))))
+ (and peg-any (followed-by "\""))
+ "\""))
+ (define-peg-pattern token all (or string
+ (and
+ (not-followed-by open)
+ (not-followed-by close)
+ (not-followed-by comment)
+ (* (and peg-any
+ (not-followed-by open)
+ (not-followed-by close)
+ (not-followed-by comment)
+ (not-followed-by string)
+ (not-followed-by whitespace)))
+ (or
+ (and peg-any (followed-by open))
+ (and peg-any (followed-by close))
+ (and peg-any (followed-by comment))
+ (and peg-any (followed-by string))
+ (and peg-any (followed-by whitespace))
+ (not-followed-by peg-any)))))
+ (define-peg-pattern sexp all (or (and (? quotation) "(" program ")")
+ (and (? quotation) "[" program "]")
+ (and (? quotation) "{" program "}")))
+ (define-peg-pattern t-or-s body (or token sexp))
+ (define-peg-pattern program all (* (or whitespace
+ comment
+ t-or-s)))
+ (lambda (file)
+ (call-with-input-file file
+ (lambda (port)
+ ;; it would be nice to match port directly without
+ ;; converting to a string first
+ (let ((string (get-string-all port)))
+ (peg:tree (match-pattern program string))))))))
+
+
+(define-record-type <po-entry>
+ (make-po-entry ecomments ref flags ctxt id idpl)
+ po-entry?
+;;; irrelevant: (tcomments po-entry-tcomments) ;translator-comments
+ (ecomments po-entry-ecomments) ;extracted-comments
+ (ref po-entry-ref) ;reference
+ (flags po-entry-flags)
+;;; irrelevant: (prevctxt po-entry-prevctxt) ;previous-ctxt
+;;; irrelevant: (prev po-entry-prev) ;previous-translation
+ (ctxt po-entry-ctxt) ;msgctxt
+ (id po-entry-id) ;msgid
+ (idpl po-entry-idpl) ;msgid-plural
+;;; irrelevant: (str po-entry-str) ;msgstr string or association list
+;;; ;integer to string
+ )
+
+(define (write-po-entry po-entry)
+ (define* (write-component c prefix #:optional (out display))
+ (when c
+ (begin (display prefix)
+ (display " ")
+ (out c)
+ (newline))))
+ (match po-entry
+ (($ <po-entry> ecomments ref flags ctxt id idpl)
+ (write-component ecomments "#.")
+ (write-component ref "#:")
+ (write-component flags "#,")
+ (write-component ctxt "msgctxt" write)
+ (write-component id "msgid" write)
+ (write-component idpl "msgid_plural" write)
+ (display "msgstr \"\"")
+ (newline))))
+
+(define %ecomments-string
+ (make-parameter #f))
+
+(define (update-ecomments-string! str)
+ "Sets the value of the parameter object %ecomments-string if str is
+an ecomments string. An ecomments string is extracted from a comment
+because it starts with TRANSLATORS or a key specified with
+--add-comments." ;TODO NOT IMPLEMENTED YET
+ (when (string-prefix? "TRANSLATORS" str)
+ (%ecomments-string str))) ;TODO NOT THE WHOLE STRING
+
+(define %line-number
+ (make-parameter #f))
+
+(define (update-line-number! number)
+ "Sets the value of the parameter object %line-number to NUMBER."
+ (%line-number number))
+
+(define (incr-line-number!)
+ "Increments the value of the parameter object %line-number by 1."
+ (%line-number (1+ %line-number)))
+
+(define (make-simple-po-entry msgid)
+ (make-po-entry
+ (%ecomments-string)
+ (%line-number)
+ #f ;TODO use scheme-format for format strings?
+ #f ;no ctxt
+ msgid
+ #f))
+
+
+(define (matching-keyword id)
+ "Returns the keyword-spec whose identifier is the same as ID, or #f
+if ID is no string or no such keyword-spec exists."
+ (and (symbol? id)
+ (let ((found (member (symbol->string id)
+ %keyword-specs
+ (lambda (id spec)
+ (string=? id (keyword-spec-id spec))))))
+ (and found (car found)))))
+
+(define (nth-exp program n)
+ "Returns the nth 'token or 'sexp inside the PROGRAM parse tree or #f
+if no tokens or sexps exist."
+ (let loop ((i 0)
+ (rest program))
+ (define (on-hit exp)
+ (if (= i n) exp
+ ;; else:
+ (loop (1+ i) (cdr rest))))
+ (match rest
+ (() #f)
+ ((('token exp) . _) (on-hit (car rest)))
+ ((('sexp open-paren exp close-paren) . _) (on-hit (car rest)))
+ ((_ . _) (loop i (cdr rest)))
+ (else #f))))
+
+(define (more-than-one-exp? program)
+ "Returns true if PROGRAM consiste of more than one expression."
+ (if (matching-keyword (token->string-or-symbol (nth-exp program 0)))
+ (nth-exp program 2) ;if there is third element, keyword does not count
+ (nth-exp program 1)))
+
+(define (token->string-or-symbol tok)
+ "For a parse tree TOK, if it is a 'token parse tree, returns its
+value as a string or symbol, otherwise returns #f."
+ (match tok
+ (('token exp)
+ (with-input-from-string exp
+ (lambda ()
+ (read))))
+ (else #f)))
+
+(define (complex-marked-sexp->po-entries parse-tree)
+ "Checks if PARSE-TREE is marked by a keyword. If yes, for a complex
+keyword spec, returns a list of po-entries for it. For a simple
+keyword spec, returns the argument number of its singular form.
+Otherwise returns #f."
+ (let* ((first (nth-exp parse-tree 0))
+ (spec (matching-keyword (token->string-or-symbol first))))
+ (if spec
+ (if ;if the identifier of a complex keyword occurs first
+ (complex-keyword-spec? spec)
+ ;; then make po entries for it
+ (match spec
+ (($ <keyword-spec> id sg pl c total xcomment)
+ (if (eq? c 'mixed) ; if msgctxt and singular msgid are in one
string
+ (let* ((exp (nth-exp parse-tree sg))
+ (val (token->string-or-symbol exp))
+ (idx (if (string? val) (string-rindex val #\|))))
+ (list (make-po-entry
+ (%ecomments-string)
+ (%line-number)
+ #f ;TODO use scheme-format for format strings?
+ (string-take val idx)
+ (string-drop val (1+ idx))
+ #f))) ;plural forms are not supported
+ ;; else construct msgids
+ (receive (pl-id pl-entries)
+ (match pl
+ (#t (construct-msgid-and-po-entries
+ (nth-exp parse-tree pl)))
+ (#f (values #f '())))
+ (receive (sg-id sg-entries)
+ (construct-msgid-and-po-entries
+ (nth-exp parse-tree sg))
+ (cons
+ (make-po-entry
+ (%ecomments-string)
+ (%line-number)
+ #f ;TODO use scheme-format for format strings?
+ (and c (token->string-or-symbol (nth-exp parse-tree c)))
+ sg-id
+ pl-id)
+ (append sg-entries pl-entries)))))))
+ ;; else if it is a simple keyword, return the argnum:
+ (keyword-spec-sg spec))
+ ;; if no keyword occurs, then false
+ #f)))
+
+(define (construct-po-entries parse-tree)
+ "Converts a PARSE-TREE resulting from a call to parse-scheme-file to
+a list of po-entry records. Unlike construct-msgid-and-po-entries,
+strings are not collected to a msgid. The list of po-entry records is
+the return value."
+ (let ((entries (complex-marked-sexp->po-entries parse-tree)))
+ (cond
+ ((list? entries) entries)
+ ((number? entries) ;parse-tree yields a single, simple po entry
+ (receive (id entries)
+ (construct-msgid-and-po-entries
+ (nth-exp parse-tree entries))
+ (cons (make-simple-po-entry id)
+ entries)))
+ (else ;search for marked translations in parse-tree
+ (match parse-tree
+ (() '())
+ (('comment str) (begin
+ (update-ecomments-string! str)
+ '()))
+ ;; TODO UPDATE %line-number ON NL
+ (('token str) '())
+ (('sexp open-paren program close-paren)
+ (construct-po-entries program))
+ (('program . components)
+ (append-map construct-po-entries components)))))))
+
+(define* (tag counter prefix #:key (flavor 'start))
+ "Formats the number COUNTER as a tag according to FLAVOR, which is
+either 'start, 'end or 'empty for a start, end or empty tag,
+respectively."
+ (string-append "<"
+ (if (eq? flavor 'end) "/" "")
+ prefix
+ (number->string counter)
+ (if (eq? flavor 'empty) "/" "")
+ ">"))
+
+(define-record-type <construct-fold-state>
+ (make-construct-fold-state msgid-string counter po-entries)
+ construct-fold-state?
+ (msgid-string construct-fold-state-msgid-string)
+ (counter construct-fold-state-counter)
+ (po-entries construct-fold-state-po-entries))
+
+(define* (construct-msgid-and-po-entries parse-tree
+ #:optional
+ (prefix ""))
+ "Like construct-po-entries, but with two return values. The first
+is an accumulated msgid constructed from all components in PARSE-TREE
+for use in make-po-entry. Non-strings are replaced by tags containing
+PREFIX. The second return value is a list of po entries for
+subexpressions marked with a complex keyword spec."
+ (match parse-tree
+ (() (values "" '()))
+ (('comment str) (begin
+ (update-ecomments-string! str)
+ (values "" '())))
+ ;; TODO UPDATE %line-number ON NL
+ (('token exp)
+ (let ((maybe-string (token->string-or-symbol parse-tree)))
+ (if (string? maybe-string)
+ (values maybe-string '())
+ (error "Single symbol marked for translation." maybe-string))))
+ (('sexp open-paren program close-paren)
+ ;; parse program instead
+ (construct-msgid-and-po-entries program prefix))
+ (('program . components)
+ ;; Concatenate strings in parse-tree to a new msgid and add an
+ ;; <x> tag for each sexp in between.
+ (match
+ (fold
+ (lambda (component prev-state)
+ (match prev-state
+ (($ <construct-fold-state> msgid-string counter po-entries)
+ (match component
+ (('comment str) (begin (update-ecomments-string! str)
+ prev-state))
+ ;; TODO INCREASE %line-number ON NL
+ (('token exp)
+ (let ((maybe-string (token->string-or-symbol component)))
+ (cond
+ ((string? maybe-string)
+ ;; if string, append maybe-string to previous msgid
+ (make-construct-fold-state
+ (string-append msgid-string maybe-string)
+ counter
+ po-entries))
+ ((and (more-than-one-exp? components) ;not the only symbol
+ (or (string-null? msgid-string) ;no string so far
+ (string-suffix? ">" msgid-string))) ;tag before
+ prev-state) ;then ignore
+ ((matching-keyword maybe-string)
+ prev-state) ;ignore keyword token)
+ (else ;append tag representing the token
+ (make-construct-fold-state
+ (string-append msgid-string
+ (tag counter prefix
+ #:flavor 'empty))
+ (1+ counter)
+ po-entries)))))
+ (('sexp open-paren program close-paren)
+ (let ((first (nth-exp program 0)))
+ (match (complex-marked-sexp->po-entries program)
+ ((? list? result)
+ (make-construct-fold-state
+ (string-append msgid-string
+ (tag counter prefix #:flavor 'empty))
+ (1+ counter)
+ (append result po-entries)))
+ (result
+ (if (or (number? result)
+ (not (more-than-one-exp? components)))
+ (receive (id entries)
+ (construct-msgid-and-po-entries
+ program
+ (string-append prefix (number->string counter)
+ "."))
+ (make-construct-fold-state
+ (string-append msgid-string
+ (tag counter prefix
+ #:flavor 'start)
+ id
+ (tag counter prefix
+ #:flavor 'end))
+ (1+ counter)
+ (append entries po-entries)))
+ ;; else ignore unmarked sexp
+ prev-state)))))))))
+ (make-construct-fold-state "" 1 '())
+ components)
+ (($ <construct-fold-state> msgid-string counter po-entries)
+ (values msgid-string po-entries))))))
+
+(define scheme-file->po-entries
+ (compose construct-po-entries
+ parse-scheme-file))
+
+(define %files-from-port
+ (let ((files-from (option-ref %options 'files #f)))
+ (if files-from
+ (open-input-file files-from)
+ (current-input-port))))
+
+(define %scheme-files
+ (let loop ((line (get-line %files-from-port))
+ (scheme-files '()))
+ (if (eof-object? line)
+ (begin
+ (close-port %files-from-port)
+ scheme-files)
+ ;; else read file names before comment
+ (let ((before-comment (car (string-split line #\#))))
+ (loop (get-line %files-from-port)
+ (append
+ (map match:substring (list-matches "[^ \t]+" line))
+ scheme-files))))))
+
+(define %output-po-entries
+ (fold (lambda (scheme-file po-entries)
+ (append (scheme-file->po-entries scheme-file)
+ po-entries))
+ '()
+ %scheme-files))
+
+(define %output-port
+ (let ((output (option-ref %options 'output #f)))
+ (if output
+ (open-output-file output)
+ (current-output-port))))
+
+(with-output-to-port %output-port
+ (lambda ()
+ (for-each (lambda (po-entry)
+ (begin
+ (newline)
+ (write-po-entry po-entry)))
+ %output-po-entries)))
diff --git a/website/sexp-xgettext.scm b/website/sexp-xgettext.scm
new file mode 100644
index 0000000..2378d3f
--- /dev/null
+++ b/website/sexp-xgettext.scm
@@ -0,0 +1,31 @@
+;;; GNU Guix web site
+;;; Copyright © 2019 Florian Pelz <pelzflor...@pelzflorian.de>
+;;;
+;;; This file is part of the GNU Guix web site.
+;;;
+;;; The GNU Guix web site is free software; you can redistribute it and/or
modify it
+;;; under the terms of the GNU Affero General Public License as published by
+;;; the Free Software Foundation; either version 3 of the License, or (at
+;;; your option) any later version.
+;;;
+;;; The GNU Guix web site 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 Affero General Public License for more details.
+;;;
+;;; You should have received a copy of the GNU Affero General Public License
+;;; along with the GNU Guix web site. If not, see
<http://www.gnu.org/licenses/>.
+
+(define-module (sexp-xgettext)
+ #:export (%current-mo-file
+ mo-lookup))
+
+(define %current-mo-file
+ (make-parameter #f))
+
+(define (mo-lookup msg #:key number msgctxt)
+ "Return the translation of MSG from the %CURRENT-MO-FILE for
+NUMBER (like n in ngettext) that has the specified MSGCTXT (like
+pgettext)."
+ ;; TODO CURRENTLY THIS FUNCTION USES guix/build/po.scm TO LOOK UP
+ ;; TRANSLATIONS FROM A PO FILE AND NOT FROM AN MO FILE
diff --git a/website/wip-howto-test-translation
b/website/wip-howto-test-translation
new file mode 100644
index 0000000..362ef08
--- /dev/null
+++ b/website/wip-howto-test-translation
@@ -0,0 +1,27 @@
+To create a pot file:
+
+guile scripts/sexp-xgettext.scm -f po/POTFILES -o po/guix-website.pot
--from-code=UTF-8 --copyright-holder="Ludovic Courtès"
--package-name="guix-website" --msgid-bugs-address="l...@gnu.org" --keyword=G_
--keyword=N_:1,2 --keyword=C_:1,2c
+
+To create a po file from a pot file, do the usual:
+
+cd po
+msginit -l de --no-translator
+
+To merge an existing po file with a new pot file:
+
+cd po
+msgmerge -U de.po guix-website.pot
+
+To update mo files:
+
+mkdir -p de/LC_MESSAGES
+cd po
+msgfmt de.po
+cd ..
+mv po/messages.mo de/LC_MESSAGES/guix-website.mo
+
+To test:
+
+guix environment --ad-hoc haunt
+GUILE_LOAD_PATH=$(guix build
guile-syntax-highlight)/share/guile/site/2.2:$GUILE_LOAD_PATH
GUIX_WEB_SITE_LOCAL=yes haunt build
+GUILE_LOAD_PATH=$(guix build
guile-syntax-highlight)/share/guile/site/2.2:$GUILE_LOAD_PATH haunt serve
--
2.22.0
home.scm
Description: Lotus Screencam
guix-website.pot
Description: MS-Powerpoint presentation
