pelzflorian pushed a commit to branch wip-i18n
in repository guix-artwork.

commit 77675f1778bbc8602e16f6b52ce66524cc892710
Author: Florian Pelz <pelzflor...@pelzflorian.de>
Date:   Wed Oct 30 08:22:47 2019 +0000

    website: Add custom xgettext to extract from nested sexps for i18n.
    
    * website/po/POTFILES: New file.  List apps files here.
    * website/po/LINGUAS: New file.  List en_US lingua.
    * website/po/ietf-tags.scm: New file.  Add association for en_US lingua.
    * website/scripts/sexp-xgettext.scm: New file for generating a POT file.
    (<keyword-spec>, <po-entry>, <construct-fold-state>): New record types.
    (combine-duplicate-po-entries, complex-keyword-spec?, parse-scheme-file,
    po-equal?, write-po-entry, update-ecomments-string!, update-file-name!,
    update-old-line-number!, update-line-number!, incr-line-number!,
    incr-line-number-for-each-nl!, current-ref, make-simple-po-entry,
    matching-keyword, nth-exp, more-than-one-exp?, token->string-symbol-or-keyw,
    complex-marked-list->po-entries, construct-po-entries, tag,
    construct-msgid-and-po-entries, scheme-file->po-entries): New procedures.
    (%keyword-specs, %options, %comments-line, %ecomments-string, %file-name,
    %old-line-number, %line-number, %files-from-port, %source-files,
    %output-po-entries, %output-port): New variables.
    * website/sexp-xgettext.scm: New file with module for looking up
    translations.
    (%complex-keywords, %simple-keywords, %plural-numbers, %linguas):
    New variables.
    (<construct-fold-state>, <deconstruct-fold-state>): New record types.
    (set-complex-keywords!, set-simple-keywords!, gettext-keyword?, tag,
    sexp->msgid, deconstruct): New procedures.
    (sgettext, spgettext, sngettext, snpgettext): New macro helpers.
    * website/apps/i18n.scm: New file.
    (G_, N_, C_, NC_, ietf-tags-file-contents): New syntax to use for i18n.
    (%current-ietf-tag, %current-lang, %current-lingua): New variables.
    (builder->localized-builder, builders->localized-builders,
    localized-root-path, first-value): New utility procedures.
    (<asset>, <page>): New imports from Haunt.
    * website/haunt.scm: Wrap each builder to build the locale set in LC_ALL.
    * website/.guix.scm: Make Haunt build directory writable so Haunt can
    overwrite duplicate assets.  Convert PO files to MO files and build for
    each lingua.
    * website/README: Adapt build instructions for i18n.
    * website/i18n-howto: New file with usage instructions.
---
 website/.guix.scm                 |  80 +++-
 website/README                    |   8 +-
 website/apps/i18n.scm             | 132 ++++++
 website/haunt.scm                 |  19 +-
 website/i18n-howto.txt            |  86 ++++
 website/po/LINGUAS                |   3 +
 website/po/POTFILES               |  36 ++
 website/po/ietf-tags.scm          |   9 +
 website/scripts/sexp-xgettext.scm | 830 ++++++++++++++++++++++++++++++++++++++
 website/sexp-xgettext.scm         | 530 ++++++++++++++++++++++++
 10 files changed, 1707 insertions(+), 26 deletions(-)

diff --git a/website/.guix.scm b/website/.guix.scm
index 8f44c90..9510779 100644
--- a/website/.guix.scm
+++ b/website/.guix.scm
@@ -1,5 +1,6 @@
 ;;; GNU Guix web site
 ;;; Copyright © 2017, 2019 Ludovic Courtès <l...@gnu.org>
+;;; Copyright © 2019 Florian Pelz <pelzflor...@pelzflorian.de>
 ;;;
 ;;; This file is part of the GNU Guix web site.
 ;;;
@@ -18,16 +19,27 @@
 
 ;; Run 'guix build -f .guix.scm' to build the web site.
 
+(define this-directory
+  (dirname (current-filename)))
+
+;; Make sure po/LINGUAS will be found in the current working
+;; directory.
+(chdir this-directory)
+
+;; We need %linguas from the (sexp-xgettext) module.
+;; Therefore, we add its path to the load path.
+(set! %load-path (cons this-directory %load-path))
+
 (use-modules (guix) (gnu)
              (guix modules)
              (guix git-download)
              (guix gexp)
              (guix channels)
              (srfi srfi-9)
-             (ice-9 match))
-
-(define this-directory
-  (dirname (current-filename)))
+             (ice-9 match)
+             (ice-9 rdelim)
+             (ice-9 regex)
+             (sexp-xgettext))
 
 (define source
   (local-file this-directory "guix-web-site"
@@ -73,9 +85,7 @@
 
           (setvbuf (current-output-port) 'line)
           (setvbuf (current-error-port) 'line)
-
           (copy-recursively #$source ".")
-
           ;; Set 'GUILE_LOAD_PATH' so that Haunt find the Guix modules and
           ;; its dependencies.  To find out the load path of Guix and its
           ;; dependencies, fetch its value over 'guix repl'.
@@ -96,24 +106,62 @@
                                     ":"))))
             (close-pipe pipe))
 
+          ;; Make the copy writable so Haunt can overwrite duplicate assets.
+          (invoke #+(file-append (specification->package "coreutils")
+                                 "/bin/chmod")
+                  "--recursive" "u+w" ".")
+
+          ;; For translations, create MO files from PO files.
+          (for-each
+           (lambda (lingua)
+             (let* ((msgfmt #+(file-append
+                               (specification->package "gettext-minimal")
+                               "/bin/msgfmt"))
+                    (lingua-file (string-append "po/" lingua ".po"))
+                    (lang (car (string-split lingua #\_)))
+                    (lang-file (string-append "po/" lang ".po")))
+               (define (create-mo filename)
+                 (begin
+                   (invoke msgfmt filename)
+                   (mkdir-p (string-append lingua "/LC_MESSAGES"))
+                   (rename-file "messages.mo"
+                                (string-append lingua "/LC_MESSAGES/"
+                                               "guix-website.mo"))))
+               (cond
+                ((file-exists? lingua-file)
+                 (create-mo lingua-file))
+                ((file-exists? lang-file)
+                 (create-mo lang-file))
+                (else #t))))
+           (list #$@%linguas))
+
           ;; So we can read/write UTF-8 files.
           (setenv "GUIX_LOCPATH"
                   #+(file-append (specification->package "glibc-utf8-locales")
                                  "/lib/locale"))
-          (setenv "LC_ALL" "en_US.utf8")
 
           ;; Use a sane default.
           (setenv "XDG_CACHE_HOME" "/tmp/.cache")
 
-          (format #t "Running 'haunt build'...~%")
-          (invoke #+(file-append (specification->package "haunt")
-                                 "/bin/haunt")
-                  "build")
-
-          (mkdir-p #$output)
-          (copy-recursively "/tmp/gnu.org/software/guix" #$output
-                            #:log (%make-void-port "w"))
-          (symlink "guix.html" (string-append #$output "/index.html"))))))
+          ;; Build the website for each translation.
+          (for-each
+           (lambda (lingua)
+             (begin
+               (setenv "LC_ALL" (string-append lingua ".utf8"))
+               (format #t "Running 'haunt build' for lingua ~a...~%" lingua)
+               (invoke #+(file-append (specification->package "haunt")
+                                      "/bin/haunt")
+                       "build")
+               (mkdir-p #$output)
+               (copy-recursively "/tmp/gnu.org/software/guix" #$output
+                                 #:log (%make-void-port "w"))
+               (let ((tag (assoc-ref
+                           (call-with-input-file "po/ietf-tags.scm"
+                             (lambda (port) (read port)))
+                           lingua)))
+                 (symlink "guix.html"
+                          (string-append #$output "/" tag "/index.html")))))
+           (list #$@%linguas))))))
 
 (computed-file "guix-web-site" build)
 
diff --git a/website/README b/website/README
index d3a3a78..ff54053 100644
--- a/website/README
+++ b/website/README
@@ -24,14 +24,18 @@ commands:
 
 #+BEGIN_EXAMPLE
 $ cd path/to/guix-artwork/website
-$ GUIX_WEB_SITE_LOCAL=yes haunt build
+$ export GUILE_LOAD_PATH=$(guix build 
guile-syntax-highlight)/share/guile/site/2.2:$GUILE_LOAD_PATH
+$ LC_ALL=en_US.utf8 GUIX_WEB_SITE_LOCAL=yes haunt build
 $ haunt serve
 #+END_EXAMPLE
 
-Then, visit http://localhost:8080/guix.html in a web browser.
+Then, visit http://localhost:8080/en/guix.html in a web browser.
 
 You can stop the server pressing ~Ctrl + C~ twice.
 
+See also the file i18n-howto.txt for information on working with
+translations.
+
 * Deploying
 
 Like the pages of many GNU websites, this website is managed through
diff --git a/website/apps/i18n.scm b/website/apps/i18n.scm
new file mode 100644
index 0000000..d88333a
--- /dev/null
+++ b/website/apps/i18n.scm
@@ -0,0 +1,132 @@
+;;; 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 asset)
+  #: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_
+            NC_
+            %current-ietf-tag
+            %current-lang
+            %current-lingua
+            builder->localized-builder
+            builders->localized-builders
+            ietf-tags-file-contents
+            localized-root-path))
+
+(define %gettext-domain
+  "guix-website")
+
+(bindtextdomain %gettext-domain (getcwd))
+(bind-textdomain-codeset %gettext-domain "UTF-8")
+(textdomain %gettext-domain)
+
+;; NOTE: The sgettext macros have no hygiene because they use
+;; datum->syntax and do not preserve the semantics of anything looking
+;; like an sgettext macro.  This is an exceptional use case; do not
+;; try this at home.
+
+(define-syntax G_
+  sgettext)
+
+(set-simple-keywords! '(G_))
+
+(define-syntax N_ ;like ngettext
+  sngettext)
+
+(define-syntax C_ ;like pgettext
+  spgettext)
+
+(define-syntax NC_ ;like npgettext
+  snpgettext)
+
+(set-complex-keywords! '(N_ C_ NC_))
+
+(define %current-lingua
+  ;; strip the character encoding:
+  (car (string-split (setlocale LC_ALL) #\.)))
+
+(define-syntax ietf-tags-file-contents
+  (identifier-syntax
+   (force (delay (call-with-input-file
+                     "po/ietf-tags.scm"
+                   (lambda (port) (read port)))))))
+
+
+(define %current-ietf-tag
+  (or (assoc-ref ietf-tags-file-contents %current-lingua)
+      "en"))
+
+(define %current-lang
+  (car (string-split %current-ietf-tag #\-)))
+
+(define* (localized-root-path url #:key (lingua %current-ietf-tag))
+  "Given a URL as used in a href attribute, return the URL prefix
+'builder->localized-builder' would use for the URL when called with
+LINGUA."
+  (if (or (string-suffix? ".html" url)
+          (string-suffix? "/" url))
+      (string-append lingua "/")
+      ""))
+
+(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."
+  arg)
+
+(define <asset>
+  (@@ (haunt asset) <asset>))
+
+(define <page>
+  (@@ (haunt page) <page>))
+
+(define (builder->localized-builder builder)
+  "Return a Haunt builder procedure generated from an existing BUILDER
+with translations for the current system locale coming from
+sexp-xgettext."
+  (compose
+   (lambda (pages-and-assets)
+     (map
+      (lambda (page-or-asset)
+        (match page-or-asset
+          (($ <page> file-name contents writer)
+           (let ((new-name (string-append (localized-root-path file-name)
+                                          file-name)))
+             (make-page new-name contents writer)))
+          (($ <asset> source target)
+           (let ((new-name (string-append (localized-root-path target) 
target)))
+             (make-asset source new-name)))))
+      pages-and-assets))
+   (lambda (site posts)
+     (first-value (builder site posts)))))
+
+(define (builders->localized-builders builders)
+  "Return a list of new Haunt builder procedures generated from
+BUILDERS and localized via sexp-xgettext for the current system
+locale."
+  (flatten
+   (map-in-order
+    builder->localized-builder
+    builders)))
diff --git a/website/haunt.scm b/website/haunt.scm
index 0cb7177..01e2af7 100644
--- a/website/haunt.scm
+++ b/website/haunt.scm
@@ -5,22 +5,25 @@
 (use-modules ((apps base builder) #:prefix base:)
             ((apps blog builder) #:prefix blog:)
             ((apps download builder) #:prefix download:)
+             (apps i18n)
              ((apps media builder) #:prefix media:)
             ((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))
 
 (site #:title "GNU Guix"
       #:domain "https://guix.gnu.org";
       #:build-directory "/tmp/gnu.org/software/guix"
       #:readers (list sxml-reader html-reader commonmark-reader)
-      #:builders (list base:builder
-                      blog:builder
-                      download:builder
-                       media:builder
-                      packages:builder
-                      (static-directory "static")))
+      #:builders (builders->localized-builders
+                  (list base:builder
+                        blog:builder
+                        download:builder
+                        media:builder
+                        packages:builder
+                        (static-directory "static"))))
diff --git a/website/i18n-howto.txt b/website/i18n-howto.txt
new file mode 100644
index 0000000..54f85f0
--- /dev/null
+++ b/website/i18n-howto.txt
@@ -0,0 +1,86 @@
+With sexp-xgettext, arbitrary s-expressions can be marked for
+translation (not only strings like with normal xgettext).
+
+S-expressions can be marked with G_ (simple marking for translation),
+N_ (“complex” marking with different forms depending on number like
+ngettext), C_ (“complex” marking distinguished from other markings by
+a msgctxt like pgettext) or NC_ (mix of both).
+
+Marking a string for translation behaves like normal gettext.  Marking
+a parenthesized expression (i.e. a list or procedure call) extracts
+each string from the parenthesized expression.  If a symbol, keyword
+or other parenthesized expression occurs between the strings, it is
+extracted as an XML element.  Expressions before or after all strings
+are not extracted.  If strings from a parenthesized sub-expression
+shall be extracted too, the sub-expression must again be marked with
+G_ unless it is the only sub-expression or it follows a quote,
+unquote, quasiquote or unquote-splicing.  The order of XML elements
+can be changed in the translation to produce a different ordering
+inside a parenthesized expression.  If a string shall not be extracted
+from a marked expression, it must be wrapped, for example by a call to
+the identity procedure.  Be careful when marking non-SHTML content
+such as procedure calls for translation: Additional strings will be
+inserted between non-string elements.
+
+Known issues:
+
+* Line numbers are sometimes off.
+
+* Some less important other TODOs in the comments.
+
+=====
+
+The following commands are an example of the translation for locale
+de_DE.  Adapt as necessary.  We assume the software requirements
+mentioned in the README are installed.
+
+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_:1c,2 \
+                                --keyword=NC_:1c,2,3
+
+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 --previous -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 build all languages:
+
+guix build -f .guix.scm
+
+To test the de_DE translation, update its mo file as above, then:
+
+guix environment --ad-hoc haunt
+LC_ALL=de_DE.utf8 \
+ 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
+
+For checking for errors / debugging newly marked files you can try:
+
+GUILE_LOAD_PATH=.:$(guix build haunt)/share/guile/site/2.2:\
+$(guix build guile-syntax-highlight)/share/guile/site/2.2:$GUILE_LOAD_PATH \
+ guile apps/base/templates/about.scm   # an example for debugging about.scm
diff --git a/website/po/LINGUAS b/website/po/LINGUAS
new file mode 100644
index 0000000..d4dd759
--- /dev/null
+++ b/website/po/LINGUAS
@@ -0,0 +1,3 @@
+# Translation with sexp-xgettext requires the full LL_CC locale name
+# to be specified.
+en_US
diff --git a/website/po/POTFILES b/website/po/POTFILES
new file mode 100644
index 0000000..e538f84
--- /dev/null
+++ b/website/po/POTFILES
@@ -0,0 +1,36 @@
+# high-priority files that should come first in the PO file
+apps/base/utils.scm
+apps/base/templates/home.scm
+apps/base/templates/theme.scm
+apps/base/templates/components.scm
+apps/base/templates/about.scm
+apps/base/data.scm
+apps/base/templates/help.scm
+# other files
+apps/base/templates/contact.scm
+apps/base/templates/contribute.scm
+apps/base/templates/donate.scm
+apps/base/templates/graphics.scm
+apps/base/templates/irc.scm
+apps/base/templates/menu.scm
+apps/base/templates/security.scm
+apps/blog/templates/components.scm
+apps/blog/templates/feed.scm
+apps/blog/templates/post-list.scm
+apps/blog/templates/post.scm
+apps/blog/templates/tag.scm
+apps/download/data.scm
+apps/download/templates/components.scm
+apps/download/templates/download.scm
+apps/media/data.scm
+apps/media/templates/components.scm
+apps/media/templates/screenshot.scm
+apps/media/templates/screenshots-overview.scm
+apps/media/templates/video.scm
+apps/media/templates/video-list.scm
+apps/packages/templates/components.scm
+apps/packages/templates/detailed-index.scm
+apps/packages/templates/detailed-package-list.scm
+apps/packages/templates/index.scm
+apps/packages/templates/package-list.scm
+apps/packages/templates/package.scm
diff --git a/website/po/ietf-tags.scm b/website/po/ietf-tags.scm
new file mode 100644
index 0000000..8102a49
--- /dev/null
+++ b/website/po/ietf-tags.scm
@@ -0,0 +1,9 @@
+;;; This file contains an association list for each translation from
+;;; the locale to an IETF language tag to be used in the URL path of
+;;; translated pages.  The language tag results from the translation
+;;; team’s language code from
+;;; <https://translationproject.org/team/index.html>.  The underscore
+;;; in the team’s code is replaced by a hyphen.  For example, az would
+;;; be used for the Azerbaijani language (not az-Latn) and zh-CN would
+;;; be used for mainland Chinese (not zh-Hans-CN).
+(("en_US" . "en"))
diff --git a/website/scripts/sexp-xgettext.scm 
b/website/scripts/sexp-xgettext.scm
new file mode 100644
index 0000000..aba527f
--- /dev/null
+++ b/website/scripts/sexp-xgettext.scm
@@ -0,0 +1,830 @@
+;;; 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
+             (srfi srfi-19) ;date
+             (srfi srfi-26)) ;cut
+
+;;; 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-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)
+  "Return for a keyword passed on the command-line whether it is
+complex, i.e. whether occurrences inside another marked expression may
+be part of that other expression.  See i18n-howto.txt."
+  (match keyword-spec
+    (($ <keyword-spec> _ _ #f #f _ #f) #f)
+    (else #t)))
+
+(define %keyword-specs
+  ;; List of valid xgettext keyword options.
+  ;; Read keywords from command-line options.
+  (let loop ((opts (cdr (command-line)));command-line options from
+                                        ;which to extract --keyword
+                                        ;options
+             (remaining-opts '()) ;unhandled opts
+             (specs '()))
+    (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)))
+
+
+(define parse-scheme-file
+  ;; This procedure parses FILE and returns a parse tree.
+  (let ()
+    ;;TODO: Optionally ignore case.
+    (define-peg-pattern NL all "\n")
+    (define-peg-pattern comment all (and ";"
+                                         (* (and peg-any
+                                                 (not-followed-by NL)))
+                                         (and peg-any (followed-by NL))))
+    (define-peg-pattern empty none (or " " "\t"))
+    (define-peg-pattern whitespace body (or empty NL))
+    (define-peg-pattern quotation body (or "'" "`" "," ",@"))
+                                        ;TODO: Allow user to specify
+                                        ;other quote reader macros to
+                                        ;be ignored and also ignore
+                                        ;quote spelled out without
+                                        ;reader macro.
+    (define-peg-pattern open body (and (? quotation)
+                                       (or "(" "[" "{")))
+    (define-peg-pattern close body (or ")" "]" "}"))
+    (define-peg-pattern string body (and (followed-by "\"")
+                                         (* (or "\\\""
+                                                (and (or NL peg-any)
+                                                     (not-followed-by "\""))))
+                                         (and (or NL 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 list all (or (and (? quotation) "(" program ")")
+                                     (and (? quotation) "[" program "]")
+                                     (and (? quotation) "{" program "}")))
+    (define-peg-pattern t-or-s body (or token list))
+    (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, but apparently guile cannot
+          ;; do that yet.
+          (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 (po-equal? po1 po2)
+  "Return whether PO1 and PO2 have equal ctxt, id and idpl."
+  (and (equal? (po-entry-ctxt po1) (po-entry-ctxt po2))
+       (equal? (po-entry-id po1) (po-entry-id po2))
+       (equal? (po-entry-idpl po1) (po-entry-idpl po2))))
+
+(define (combine-duplicate-po-entries list)
+  "Return LIST with duplicate po entries replaced by a single PO entry
+with both refs."
+  (let loop ((remaining list))
+    (match remaining
+      (() '())
+      ((head . tail)
+       (receive (before from)
+           (break (cut po-equal? head <>) tail)
+         (cond
+          ((null? from) (cons head (loop tail)))
+          (else
+           (loop
+            (cons
+             (match head
+               (($ <po-entry> ecomments1 ref1 flags ctxt id idpl)
+                (match (car from)
+                  (($ <po-entry> ecomments2 ref2 _ _ _ _)
+                   (let ((ecomments (if (or ecomments1 ecomments2)
+                                        (append (or ecomments1 '())
+                                                (or ecomments2 '()))
+                                        #f))
+                         (ref (if (or ref1 ref2)
+                                  (string-join
+                                   (cons
+                                    (or ref1 "")
+                                    (cons
+                                     (or ref2 "")
+                                     '())))
+                                  #f)))
+                     (make-po-entry ecomments ref flags ctxt id idpl))))))
+             (append before (cdr from)))))))))))
+
+(define (write-po-entry po-entry)
+  (define (prepare-text text)
+    "If TEXT is false, return #f.  Otherwise correct the formatting of
+TEXT by escaping backslashes and newlines and enclosing TEXT in
+quotes. Note that Scheme’s write is insufficient because it would
+escape far more.  TODO: Strings should be wrappable to a maximum line
+width."
+    (and text
+         (string-append "\""
+                        (with-output-to-string
+                          (lambda ()
+                            (call-with-input-string text
+                              (lambda (port)
+                                (let loop ((c (get-char port)))
+                                  (unless (eof-object? c)
+                                    (case c
+                                      ((#\\) (display "\\"))
+                                      ((#\newline) (display "\\n"))
+                                      (else (write-char c)))
+                                    (loop (get-char port))))))))
+                        "\"")))
+  (define (write-component c prefix)
+    (when c
+      (begin (display prefix)
+             (display " ")
+             (display c)
+             (newline))))
+  (match po-entry
+    (($ <po-entry> ecomments ref flags ctxt id idpl)
+     (let ((prepared-ctxt (prepare-text ctxt))
+           (prepared-id (prepare-text id))
+           (prepared-idpl (prepare-text idpl)))
+       (when ecomments
+         (for-each
+          (lambda (line)
+            (write-component line "#."))
+          (reverse ecomments)))
+       (write-component ref "#:")
+       (write-component (and flags (string-join flags ", ")) "#,")
+       (write-component prepared-ctxt "msgctxt")
+       (write-component prepared-id "msgid")
+       (write-component prepared-idpl "msgid_plural")
+       (if idpl
+           (begin
+             (display "msgstr[0] \"\"")
+             (newline)
+             (display "msgstr[1] \"\""))
+           (display "msgstr \"\""))
+       (newline)))))
+
+;; Extraction of TRANSLATORS comments:
+
+(define %comments-line
+  (make-parameter #f))
+
+(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: Support for other keys is missing.
+  (cond
+   ((not str) (%ecomments-string #f))
+   ((= (1+ (or (%comments-line)
+               -42)) ;arbitrary unequal initial value
+       (or (%line-number) 0))
+    (let ((m (string-match ";+[ \t]*(.*)" str)))
+      (when m
+        (%comments-line (%line-number))
+        (%ecomments-string
+         (if (%ecomments-string)
+             (cons (match:substring m 1) (%ecomments-string))
+             (list (match:substring m 1)))))))
+   (else
+    (let ((m (string-match ";+[ \t]*(TRANSLATORS:.*)" str)))
+      (if m
+          (begin
+            (%comments-line (%line-number))
+            (%ecomments-string
+             (if (%ecomments-string)
+                 (cons (match:substring m 1) (%ecomments-string))
+                 (list (match:substring m 1)))))
+          (%ecomments-string '#f))))))
+
+(define %file-name
+  (make-parameter #f))
+
+(define (update-file-name! name)
+  "Sets the value of the parameter object %file-name to NAME."
+  (%file-name name))
+
+(define %old-line-number
+  (make-parameter #f))
+
+(define (update-old-line-number! number)
+  "Sets the value of the parameter object %old-line-number to NUMBER."
+  (%old-line-number number))
+
+(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 (incr-line-number-for-each-nl! list)
+  "Increments %line-number once for each NL recursively in LIST.  Does
+nothing if LIST is no list but e.g. an empty 'program."
+  (when (list? list)
+    (for-each
+     (lambda (part)
+       (match part
+         ('NL (incr-line-number!))
+         ((? list?) (incr-line-number-for-each-nl! part))
+         (else #f)))
+     list)))
+
+(define (current-ref)
+  "Return the location field for a PO entry."
+  (let ((add (option-ref %options 'add-location 'full)))
+    (cond
+     ((option-ref %options 'no-location #f) #f)
+     ((eq? add 'full)
+      (string-append (%file-name) ":" (number->string (%line-number))))
+     ((eq? add 'file)
+      (%file-name))
+     ((eq? add 'never)
+      #f))))
+
+(define (make-simple-po-entry msgid)
+  (let ((po (make-po-entry
+             (%ecomments-string)
+             (current-ref)
+             #f ;TODO: Use scheme-format for format strings?
+             #f ;no ctxt
+             msgid
+             #f)))
+    (update-ecomments-string! #f)
+    po))
+
+
+(define (matching-keyword id)
+  "Return 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)
+  "Return the Nth 'token or 'list inside the PROGRAM parse tree or #f
+if no tokens or lists 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 . _) . _) (on-hit (car rest)))
+      ((('list open-paren exp close-paren) . _) (on-hit (car rest)))
+      ((_ . _) (loop i (cdr rest)))
+      (else #f))))
+
+(define (more-than-one-exp? program)
+  "Return true if PROGRAM consiste of more than one expression."
+  (if (matching-keyword (token->string-symbol-or-keyw (nth-exp program 0)))
+      (nth-exp program 2) ;if there is third element, keyword does not count
+      (nth-exp program 1)))
+
+(define (token->string-symbol-or-keyw tok)
+  "For a parse tree TOK, if it is a 'token parse tree, return its
+value as a string, symbol or #:-keyword, otherwise return #f."
+  (match tok
+    (('token (parts ...) . remaining)
+     ;; This is a string with line breaks in it.
+     (with-input-from-string
+         (string-append
+          (apply string-append
+                 (map-in-order
+                  (lambda (part)
+                    (match part
+                      (('NL _)
+                       (begin (incr-line-number!)
+                              "\n"))
+                      (else part)))
+                  parts))
+          (car remaining))
+       (lambda ()
+         (read))))
+    (('token exp)
+     (with-input-from-string exp
+       (lambda ()
+         (read))))
+    (else #f)))
+
+(define (complex-marked-list->po-entries parse-tree)
+  "Check if PARSE-TREE is marked by a keyword.  If yes, for a complex
+keyword spec, return a list of po-entries for it.  For a simple
+keyword spec, return the argument number of its singular form.
+Otherwise return #f."
+  (let* ((first (nth-exp parse-tree 0))
+         (spec (matching-keyword (token->string-symbol-or-keyw 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-symbol-or-keyw exp))
+                       (idx (if (string? val) (string-rindex val #\|))))
+                  (list
+                   (let ((po (make-po-entry
+                              (%ecomments-string)
+                              (current-ref)
+                              #f ;TODO: Use scheme-format for format strings?
+                              (string-take val idx)
+                              (string-drop val (1+ idx))
+                              #f))) ;plural forms are unsupported here
+                     (update-ecomments-string! #f)
+                     po)))
+                ;; else construct msgids
+                (receive (pl-id pl-entries)
+                    (match pl
+                      (#f (values #f '()))
+                      (else (construct-msgid-and-po-entries
+                             (nth-exp parse-tree pl))))
+                  (receive (sg-id sg-entries)
+                      (construct-msgid-and-po-entries
+                       (nth-exp parse-tree sg))
+                    (cons
+                     (let ((po (make-po-entry
+                                (%ecomments-string)
+                                (current-ref)
+                                #f ;TODO: Use scheme-format for format strings?
+                                (and c (token->string-symbol-or-keyw
+                                        (nth-exp parse-tree c)))
+                                sg-id
+                                pl-id)))
+                       (update-ecomments-string! #f)
+                       po)
+                     (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-list->po-entries parse-tree)))
+    (cond
+     ((list? entries) entries)
+     ((number? entries) ;parse-tree yields a single, simple po entry
+      (update-old-line-number! (%line-number))
+      (receive (id entries)
+          (construct-msgid-and-po-entries
+           (nth-exp parse-tree entries))
+        (update-line-number! (%old-line-number))
+        (let ((po (make-simple-po-entry id)))
+          (incr-line-number-for-each-nl! parse-tree)
+          (cons po entries))))
+     (else ;search for marked translations in parse-tree
+      (match parse-tree
+        (() '())
+        (('comment str) (begin
+                          (update-ecomments-string! str)
+                          '()))
+        (('NL _) (begin (incr-line-number!) '()))
+        (('token . _) (begin (incr-line-number-for-each-nl! parse-tree) '()))
+        (('list open-paren program close-paren)
+         (construct-po-entries program))
+        (('program . components)
+         (append-map construct-po-entries components))
+        ;; Note: PEG compresses empty programs to non-lists:
+        ('program
+         '()))))))
+
+(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 maybe-part counter po-entries)
+  construct-fold-state?
+  ;; msgid constructed so far; #f if none, "" if only empty string:
+  (msgid-string construct-fold-state-msgid-string)
+  ;; only append this if string follows:
+  (maybe-part construct-fold-state-maybe-part)
+  ;; counter for next tag:
+  (counter construct-fold-state-counter)
+  ;; complete po entries from marked sub-expressions:
+  (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
+sub-expressions marked with a complex keyword spec."
+  (match parse-tree
+    (() (values "" '()))
+    ;; Note: PEG compresses empty programs to non-lists:
+    ('program (values "" '()))
+    (('comment str) (begin
+                      (update-ecomments-string! str)
+                      (values "" '())))
+    (('NL _) (begin (incr-line-number!)
+                    (error "Program consists only of line break."
+                           `(,(%file-name) ,(%line-number)))))
+    (('token . _)
+     (let ((maybe-string (token->string-symbol-or-keyw parse-tree)))
+       (if (string? maybe-string)
+           (values maybe-string '())
+           (error "Single symbol marked for translation."
+                  `(,maybe-string ,(%file-name) ,(%line-number))))))
+    (('list open-paren program close-paren)
+     ;; parse program instead
+     (construct-msgid-and-po-entries program prefix))
+    (('program (? matching-keyword))
+     (error "Double-marked for translation."
+            `(,parse-tree ,(%file-name) ,(%line-number))))
+    (('program . components)
+     ;; Concatenate strings in parse-tree to a new msgid and add an
+     ;; <x> tag for each list in between.
+     (match
+         (fold
+          (lambda (component prev-state)
+            (match prev-state
+              (($ <construct-fold-state> msgid-string maybe-part
+                  counter po-entries)
+               (match component
+                 (('comment str) (begin (update-ecomments-string! str)
+                                        prev-state))
+                 (('NL _) (begin (incr-line-number!)
+                                 prev-state))
+                 (('token . _)
+                  (let ((maybe-string (token->string-symbol-or-keyw 
component)))
+                    (cond
+                     ((string? maybe-string)
+                      ;; if string, append maybe-string to previous msgid
+                      (make-construct-fold-state
+                       (string-append (or msgid-string "")
+                                      maybe-part maybe-string)
+                       ""
+                       counter
+                       po-entries))
+                     ((and (more-than-one-exp? components) ;not the only symbol
+                           (or (not msgid-string) ;no string so far
+                               (string-suffix? ">" msgid-string))) ;tag before
+                      prev-state) ;then ignore
+                     (else ;append tag representing the token
+                      (make-construct-fold-state
+                       msgid-string
+                       (string-append
+                        maybe-part
+                        (tag counter prefix #:flavor 'empty))
+                       (1+ counter)
+                       po-entries)))))
+                 (('list open-paren program close-paren)
+                  (let ((first (nth-exp program 0)))
+                    (incr-line-number-for-each-nl! list)
+                    (match (complex-marked-list->po-entries program)
+                      ((? list? result)
+                       (make-construct-fold-state
+                        msgid-string
+                        (string-append
+                         maybe-part
+                         (tag counter prefix #:flavor 'empty))
+                        (1+ counter)
+                        (append result po-entries)))
+                      (result
+                       (cond
+                        ((number? result)
+                         (receive (id entries)
+                             (construct-msgid-and-po-entries
+                              (nth-exp program result)
+                              (string-append prefix
+                                             (number->string counter)
+                                             "."))
+                           (make-construct-fold-state
+                            (string-append (or msgid-string "")
+                                           maybe-part
+                                           (tag counter prefix
+                                                #:flavor 'start)
+                                           id
+                                           (tag counter prefix
+                                                #:flavor 'end))
+                            ""
+                            (1+ counter)
+                            (append entries po-entries))))
+                        ((not (more-than-one-exp? components))
+                         ;; Singletons do not need to be marked.
+                         (receive (id entries)
+                             (construct-msgid-and-po-entries
+                              program
+                              prefix)
+                           (make-construct-fold-state
+                            id
+                            ""
+                            counter
+                            (append entries po-entries))))
+                        (else ;unmarked list
+                         (if (not msgid-string)
+                             ;; then ignore
+                             prev-state
+                             ;; else:
+                             (make-construct-fold-state
+                              msgid-string
+                              (string-append
+                               maybe-part
+                               (tag counter prefix #:flavor 'empty))
+                              (1+ counter)
+                              po-entries))))))))))))
+          (make-construct-fold-state #f "" 1 '())
+          components)
+       (($ <construct-fold-state> msgid-string maybe-part counter po-entries)
+        (values (or msgid-string
+                    (error "Marking for translation yields empty msgid."
+                           %file-name %line-number))
+                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 %source-files
+  (let loop ((line (get-line %files-from-port))
+             (source-files '()))
+    (if (eof-object? line)
+        (begin
+          (close-port %files-from-port)
+          source-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]+" before-comment))
+                 source-files))))))
+
+(define %output-po-entries
+  (fold (lambda (scheme-file po-entries)
+          (begin
+            (update-file-name! scheme-file)
+            (update-line-number! 1)
+            (update-old-line-number! #f)
+            (%comments-line #f)
+            (append (scheme-file->po-entries scheme-file)
+                    po-entries)))
+        '()
+        %source-files))
+
+(define %output-port
+  (let ((output (option-ref %options 'output #f))
+        (domain (option-ref %options 'default-domain #f)))
+    (cond
+     (output (open-output-file output))
+     (domain (open-output-file (string-append domain ".po")))
+     (else (open-output-file "messages.po")))))
+
+(with-output-to-port %output-port
+  (lambda ()
+    (let ((copyright (option-ref %options 'copyright-holder
+                                 "THE PACKAGE'S COPYRIGHT HOLDER"))
+          (package (option-ref %options 'package-name "PACKAGE"))
+          (version (option-ref %options 'package-version #f))
+          (bugs-email (option-ref %options 'msgid-bugs-address "")))
+      (display "# SOME DESCRIPTIVE TITLE.\n")
+      (display (string-append "# Copyright (C) YEAR " copyright "\n"))
+      (display (string-append "# This file is distributed under the same \
+license as the " package " package.\n"))
+      (display "# FIRST AUTHOR <EMAIL@ADDRESS>, YEAR.\n")
+      (display "#\n")
+      (write-po-entry (make-po-entry #f #f '("fuzzy") #f "" #f))
+      (display (string-append "\"Project-Id-Version: "
+                              package
+                              (if version
+                                  (string-append " " version)
+                                  "")
+                              "\\n\"\n"))
+      (display (string-append "\"Report-Msgid-Bugs-To: "
+                              bugs-email
+                              "\\n\"\n"))
+      (display (string-append "\"POT-Creation-Date: "
+                              (date->string (current-date) "~1 ~H:~M~z")
+                              "\\n\"\n"))
+      (display "\"PO-Revision-Date: YEAR-MO-DA HO:MI+ZONE\\n\"\n")
+      (display "\"Last-Translator: FULL NAME <EMAIL@ADDRESS>\\n\"\n")
+      (display "\"Language-Team: LANGUAGE <l...@li.org>\\n\"\n")
+      (display "\"Language: \\n\"\n")
+      (display "\"MIME-Version: 1.0\\n\"\n")
+      (display "\"Content-Type: text/plain; charset=UTF-8\\n\"\n")
+      (display "\"Content-Transfer-Encoding: 8bit\\n\"\n")
+      (for-each (lambda (po-entry)
+                  (begin
+                    (newline)
+                    (write-po-entry po-entry)))
+                (combine-duplicate-po-entries %output-po-entries)))))
diff --git a/website/sexp-xgettext.scm b/website/sexp-xgettext.scm
new file mode 100644
index 0000000..71ef4a9
--- /dev/null
+++ b/website/sexp-xgettext.scm
@@ -0,0 +1,530 @@
+;;; 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)
+  #:use-module (ice-9 match)
+  #:use-module (ice-9 peg)
+  #:use-module (ice-9 rdelim)
+  #:use-module (ice-9 receive)
+  #:use-module (ice-9 regex)
+  #:use-module (srfi srfi-1) ;lists
+  #:use-module (srfi srfi-9) ;records
+  #:export (set-complex-keywords!
+            set-simple-keywords!
+            sgettext
+            sngettext
+            spgettext
+            snpgettext
+            %linguas))
+
+(define %complex-keywords
+  ;; Use set-complex-keywords! to change this to a list of keywords
+  ;; for sexp-xgettext functions other than sgettext.
+  (make-parameter '()))
+
+(define (set-complex-keywords! kw)
+  (%complex-keywords kw))
+
+(define %simple-keywords
+  ;; Use set-simple-keywords! to change this to a list of keywords
+  ;; for sgettext.
+  (make-parameter '()))
+
+(define (set-simple-keywords! kw)
+  (%simple-keywords kw))
+
+(define (gettext-keyword? id)
+  (or (member id (%complex-keywords))
+      (member id (%simple-keywords))))
+
+;;COPIED FROM scripts/sexp-xgettext.scm:
+(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) "/" "")
+                 ">"))
+;;END COPIED FROM scripts/sexp-xgettext.scm
+
+;;ADAPTED FROM scripts/sexp-xgettext.scm
+(define-record-type <construct-fold-state>
+  (make-construct-fold-state msgid-string maybe-part counter)
+  construct-fold-state?
+  ;; msgid constructed so far; #f if none, "" if only empty string
+  (msgid-string construct-fold-state-msgid-string)
+  ;; only append this if string follows:
+  (maybe-part construct-fold-state-maybe-part)
+  ;; counter for next tag:
+  (counter construct-fold-state-counter))
+;;END ADAPTED FROM scripts/sexp-xgettext.scm
+
+(define (sexp->msgid exp)
+  "Return the msgid as constructed by construct-msgid-and-po-entries
+in scripts/sexp-xgettext.scm from the expression EXP."
+  (let loop ((exp exp)
+             (prefix ""))
+    (match exp
+      (() "")
+      ((or ('quote inner-exp)
+           ('quasiquote inner-exp)
+           ('unquote inner-exp)
+           ('unquote-splicing inner-exp))
+       (loop inner-exp prefix))
+      ((first-component . components)
+       (cond
+        ((gettext-keyword? first-component)
+         (error "Double-marked for translation." exp))
+        (else
+         (or
+          (construct-fold-state-msgid-string
+           (fold
+            (lambda (component prev-state)
+              (match prev-state
+                (($ <construct-fold-state> msgid-string maybe-part counter)
+                 (let inner-loop ((exp component))
+                   (match exp
+                     ((or (? symbol?) (? keyword?))
+                      (if (not msgid-string)
+                          ;; ignore symbols at the beginning
+                          prev-state
+                          ;; else make a tag for the symbol
+                          (make-construct-fold-state
+                           msgid-string
+                           (string-append maybe-part
+                                          (tag counter prefix #:flavor 'empty))
+                           (1+ counter))))
+                     ((? string?)
+                      (make-construct-fold-state
+                       (string-append (or msgid-string "")
+                                      maybe-part exp)
+                       "" counter))
+                     ((? list?)
+                      (match exp
+                        (() ;ignore empty list
+                         prev-state)
+                        ((or (singleton)
+                             ('quote singleton)
+                             ('quasiquote singleton)
+                             ('unquote singleton)
+                             ('unquote-splicing singleton))
+                         (inner-loop singleton))
+                        ((components ...)
+                         (cond
+                          ((and (not (null? components))
+                                (member (car components) (%simple-keywords)))
+                           ;; if marked for translation, insert inside tag
+                           (make-construct-fold-state
+                            (string-append (or msgid-string "")
+                                           maybe-part
+                                           (tag counter prefix #:flavor 'start)
+                                           (loop (cadr components)
+                                                 (string-append
+                                                  prefix
+                                                  (number->string counter)
+                                                  "."))
+                                           (tag counter prefix #:flavor 'end))
+                            ""
+                            (1+ counter)))
+                          ;; else ignore if first
+                          ((not msgid-string)
+                           prev-state)
+                          ;; else make empty tag
+                          (else (make-construct-fold-state
+                                 msgid-string
+                                 (string-append
+                                  maybe-part
+                                  (tag counter prefix #:flavor 'empty))
+                                 (1+ counter))))))))))))
+            (make-construct-fold-state #f "" 1)
+            exp))
+          (error "Marking for translation yields empty msgid." exp)))))
+      ((? string?) exp)
+      (else (error "Single symbol marked for translation." exp)))))
+
+(define-record-type <deconstruct-fold-state>
+  (make-deconstruct-fold-state tagged maybe-tagged counter)
+  deconstruct-fold-state?
+  ;; XML-tagged expressions as an association list name->expression:
+  (tagged deconstruct-fold-state-tagged)
+  ;; associate this not-yet-tagged expression with pre if string
+  ;; follows, with post if not:
+  (maybe-tagged deconstruct-fold-state-maybe-tagged)
+  ;; counter for next tag:
+  (counter deconstruct-fold-state-counter))
+
+(define (deconstruct exp msgstr)
+  "Return an s-expression like EXP, but filled with the content from
+MSGSTR."
+  (define (find-empty-element msgstr name)
+    "Return the regex match structure for the empty tag for XML
+element of type NAME inside MSGSTR.  If the element does not exist or
+is more than the empty tag, #f is returned."
+    (string-match (string-append "<" (regexp-quote name) "/>") msgstr))
+  (define (find-element-with-content msgstr name)
+    "Return the regex match structure for the non-empty XML element of
+type NAME inside MSGSTR.  Submatch 1 is its content.  If the element
+does not exist or is just the empty tag, #f is returned."
+    (string-match (string-append "<" (regexp-quote name) ">"
+                                 "(.*)"
+                                 "</" (regexp-quote name) ">")
+                  msgstr))
+  (define (get-first-element-name prefix msgstr)
+    "Return the name of the first XML element in MSGSTR whose name
+begins with PREFIX, or #f if there is none."
+    (let ((m (string-match
+              (string-append "<(" (regexp-quote prefix) "[^>/.]+)/?>") 
msgstr)))
+      (and m (match:substring m 1))))
+  (define (prefix+counter prefix counter)
+    "Return PREFIX with the number COUNTER appended."
+    (string-append prefix (number->string counter)))
+  (let loop ((exp exp)
+             (msgstr msgstr)
+             (prefix ""))
+    (define (unwrap-marked-expression exp)
+      "Return two values for an expression EXP containing a (possibly
+quoted/unquoted) marking for translation with a simple keyword at its
+root.  The first return value is a list with the inner expression, the
+second is a procedure to wrap the processed inner expression in the
+same quotes or unquotes again."
+      (match exp
+        (('quote inner-exp)
+         (receive (unwrapped quotation)
+             (unwrap-marked-expression inner-exp)
+           (values unwrapped
+                   (lambda (res)
+                     (list 'quote (quotation res))))))
+        (('quasiquote inner-exp)
+         (receive (unwrapped quotation)
+             (unwrap-marked-expression inner-exp)
+           (values unwrapped
+                   (lambda (res)
+                     (list 'quasiquote (quotation res))))))
+        (('unquote inner-exp)
+         (receive (unwrapped quotation)
+             (unwrap-marked-expression inner-exp)
+           (values unwrapped
+                   (lambda (res)
+                     (list 'unquote (quotation res))))))
+        (('unquote-splicing inner-exp)
+         (receive (unwrapped quotation)
+             (unwrap-marked-expression inner-exp)
+           (values unwrapped
+                   (lambda (res)
+                     (list 'unquote-splicing (quotation res))))))
+        ((marking . rest) ;list with marking as car
+         ;; assume arg to translate is first argument to marking:
+         (values (list-ref rest 0) identity))))
+    (define (assemble-parenthesized-expression prefix tagged)
+      "Return a parenthesized expression deconstructed from MSGSTR
+with the meaning of XML elements taken from the name->expression
+association list TAGGED.  The special tags [prefix]pre and
+[prefix]post are associated with a list of expressions before or after
+all others in the parenthesized expression with the prefix,
+respectively, in reverse order."
+      (append ;prepend pre elements to what is in msgstr
+       (reverse (or (assoc-ref tagged (string-append prefix "pre")) '()))
+       (let assemble ((rest msgstr))
+         (let ((name (get-first-element-name prefix rest)))
+           (cond
+            ((and name (find-empty-element rest name)) =>
+             ;; first XML element in rest is empty element
+             (lambda (m)
+               (cons*
+                (match:prefix m) ;prepend string before name
+                (assoc-ref tagged name) ;and expression for name
+                (assemble (match:suffix m)))))
+            ((and name (find-element-with-content rest name)) =>
+             ;; first XML element in rest has content
+             (lambda (m)
+               (receive (unwrapped quotation)
+                   (unwrap-marked-expression (assoc-ref tagged name))
+                 (cons*
+                  (match:prefix m) ;prepend string before name
+                  ;; and the deconstructed element with the content as msgstr:
+                  (quotation
+                   (loop
+                    unwrapped
+                    (match:substring m 1)
+                    (string-append name ".")))
+                  (assemble (match:suffix m))))))
+            (else
+             ;; there is no first element
+             (cons
+              rest ;return remaining string
+              (reverse ;and post expressions
+               (or (assoc-ref tagged (string-append prefix "post")) 
'())))))))))
+    (match exp
+      (() '())
+      (('quote singleton)
+       (cons 'quote (list (loop singleton msgstr prefix))))
+      (('quasiquote singleton)
+       (cons 'quasiquote (list (loop singleton msgstr prefix))))
+      (('unquote singleton)
+       (cons 'unquote (list (loop singleton msgstr prefix))))
+      (('unquote-splicing singleton)
+       (cons 'unquote-splicing (list (loop singleton msgstr prefix))))
+      ((singleton)
+       (list (loop singleton msgstr prefix)))
+      ((first-component . components)
+       (cond
+        ((gettext-keyword? first-component)
+         ;; another marking for translation
+         ;; -> should be an error anyway; just retain exp
+         exp)
+        (else
+         ;; This handles a single level of a parenthesized expression.
+         ;; assemble-parenthesized-expression will call loop to
+         ;; recurse to deeper levels.
+         (let ((tagged-state
+                (fold
+                 (lambda (component prev-state)
+                   (match prev-state
+                     (($ <deconstruct-fold-state> tagged maybe-tagged counter)
+                      (let inner-loop ((exp component) ;sexp to handle
+                                       (quoting identity)) ;for wrapping state
+                        (define (tagged-with-maybes)
+                          "Return the value of tagged after adding all
+maybe-tagged expressions.  This should be used as the base value for
+tagged when a string or marked expression is seen."
+                          (match counter
+                            (#f
+                             (alist-cons (string-append prefix "pre")
+                                         maybe-tagged
+                                         tagged))
+                            ((? number?)
+                             (let accumulate ((prev-counter counter)
+                                              (maybes (reverse maybe-tagged)))
+                               (match maybes
+                                 (() tagged)
+                                 ((head . tail)
+                                  (alist-cons
+                                   (prefix+counter prefix prev-counter)
+                                   head
+                                   (accumulate (1+ prev-counter) tail))))))))
+                        (define (add-maybe exp)
+                          "Return a deconstruct-fold-state with EXP
+added to maybe-tagged.  This should be used for expressions that are
+neither strings nor marked for translation with a simple keyword."
+                          (make-deconstruct-fold-state
+                           tagged
+                           (cons (quoting exp) maybe-tagged)
+                           counter))
+                        (define (counter-with-maybes)
+                          "Return the old counter value incremented by
+one for each expression in maybe-tagged.  This should be used together
+with tagged-with-maybes."
+                          (match counter
+                            ((? number?)
+                             (+ counter (length maybe-tagged)))
+                            (#f
+                             1)))
+                        (define (add-tagged exp)
+                          "Return a deconstruct-fold-state with an
+added association in tagged from the current counter to EXP.  If
+MAYBE-TAGGED is not empty, associations for its expressions are added
+to pre or their respective counter.  This should be used for
+expressions marked for translation with a simple keyword."
+                          (let ((c (counter-with-maybes)))
+                            (make-deconstruct-fold-state
+                             (alist-cons
+                              (prefix+counter prefix c)
+                              (quoting exp)
+                              (tagged-with-maybes))
+                             '()
+                             (1+ c))))
+                        (match exp
+                          (('quote inner-exp)
+                           (inner-loop inner-exp
+                                       (lambda (res)
+                                         (list 'quote res))))
+                          (('quasiquote inner-exp)
+                           (inner-loop inner-exp
+                                       (lambda (res)
+                                         (list 'quasiquote res))))
+                          (('unquote inner-exp)
+                           (inner-loop inner-exp
+                                       (lambda (res)
+                                         (list 'unquote res))))
+                          (('unquote-splicing inner-exp)
+                           (inner-loop inner-exp
+                                       (lambda (res)
+                                         (list 'unquote-splicing res))))
+                          (((? gettext-keyword?) . rest)
+                           (add-tagged exp))
+                          ((or (? symbol?) (? keyword?) (? list?))
+                           (add-maybe exp))
+                          ((? string?)
+                           ;; elements in maybe-tagged appear between strings
+                           (let ((c (counter-with-maybes)))
+                             (make-deconstruct-fold-state
+                              (tagged-with-maybes)
+                              '()
+                              c))))))))
+                 (make-deconstruct-fold-state '() '() #f)
+                 exp)))
+           (match tagged-state
+             (($ <deconstruct-fold-state> tagged maybe-tagged counter)
+              (assemble-parenthesized-expression
+               prefix
+               (match maybe-tagged
+                 (() tagged)
+                 (else ;associate maybe-tagged with pre or post
+                  (alist-cons
+                   (cond ;if there already is a pre, use post
+                    ((assoc-ref tagged (string-append prefix "pre"))
+                     (string-append prefix "post"))
+                    (else (string-append prefix "pre")))
+                   maybe-tagged
+                   tagged))))))))))
+      ((? string?) msgstr)
+      (else (error "Single symbol marked for translation." exp)))))
+
+;; NOTE: The sgettext macros have no hygiene because they use
+;; datum->syntax and do not preserve the semantics of anything looking
+;; like an sgettext macro.  This is an exceptional use case; do not
+;; try this at home.
+
+(define (sgettext x)
+  "After choosing an identifier for marking s-expressions for
+translation, make it usable by defining a macro with it calling
+sgettext.  If for example the chosen identifier is G_,
+use (define-syntax G_ sgettext)."
+  (syntax-case x ()
+    ((id exp)
+     (let* ((msgid (sexp->msgid (syntax->datum #'exp)))
+            (new-exp (deconstruct (syntax->datum #'exp)
+                                  (gettext msgid))))
+       (datum->syntax #'id new-exp)))))
+
+;; gettext’s share/gettext/gettext.h tells us we can prepend a msgctxt
+;; and #\eot before a msgid in a gettext call.
+
+(define (spgettext x)
+  "After choosing an identifier for behavior similar to pgettext:1c,2,
+make it usable like (define-syntax C_ spgettext)."
+  (syntax-case x ()
+    ((id msgctxt exp)
+     (let* ((gettext-context-glue #\eot) ;as defined in gettext.h
+            (lookup (string-append (syntax->datum #'msgctxt)
+                                   (string gettext-context-glue)
+                                   (sexp->msgid (syntax->datum #'exp))))
+            (msgstr (car (reverse (string-split (gettext lookup)
+                                                gettext-context-glue))))
+            (new-exp (deconstruct (syntax->datum #'exp)
+                                  msgstr)))
+       (datum->syntax #'id new-exp)))))
+
+(define %plural-numbers
+  ;; Hard-coded list of input numbers such that for each language’s
+  ;; plural formula, for each possible output grammatical number,
+  ;; there is an n among %plural-numbers that yields this output (for
+  ;; any language documented when running “info "(gettext) Plural
+  ;; forms"”), except 1 is omitted from this list because it is a
+  ;; special case for sngettext.  That is, calling ngettext with each
+  ;; number from %plural-numbers and with 1 in any locale is
+  ;; guaranteed to return each plural form at least once.  It would be
+  ;; more resilient towards new languages if instead of hard-coding we
+  ;; computed this from the Plural-Forms in the MO file header entry,
+  ;; but that is not worth the incurred code complexity.
+  '(0 2 3 11 100))
+
+(define (sngettext x)
+  "After choosing an identifier for behavior similar to ngettext:1,2,
+make it usable like (define-syntax N_ sngettext).  sngettext takes
+into account that not all languages have only singular and plural
+forms."
+  (syntax-case x ()
+    ((id exp1 exp2 n)
+     (let* ((msgid1 (sexp->msgid (syntax->datum #'exp1)))
+            (msgid2 (sexp->msgid (syntax->datum #'exp2)))
+            (msgstr1 (ngettext msgid1 msgid2 1))
+            (result (acons ;return an association list msgstr->deconstructed
+                     ;; msgstr for n=1:
+                     msgstr1
+                     `(,'unquote ,(deconstruct (syntax->datum #'exp1)
+                                               msgstr1))
+                     ;; other msgstr for n of each plural form:
+                     (map
+                      (lambda (n)
+                        (let ((msgstr (ngettext msgid1 msgid2 n)))
+                          (cons msgstr `(,'unquote
+                                         ,(deconstruct (syntax->datum #'exp2)
+                                                       msgstr)))))
+                      %plural-numbers))))
+       (datum->syntax
+        #'id
+        `(,assoc-ref (,'quasiquote ,result)
+                     (,ngettext ,msgid1 ,msgid2 ,(syntax->datum #'n))))))))
+
+(define (snpgettext x)
+  "After choosing an identifier for behavior similar to npgettext:1c,2,3,
+make it usable like (define-syntax NC_ snpgettext)."
+  (syntax-case x ()
+    ((id msgctxt exp1 exp2 n)
+     (let* ((gettext-context-glue #\eot) ;as defined in gettext.h
+            (msgid1 (string-append (syntax->datum #'msgctxt)
+                                   (string gettext-context-glue)
+                                   (sexp->msgid (syntax->datum #'exp1))))
+            ;; gettext.h implementation shows: msgctxt is only part of msgid1.
+            (msgid2 (sexp->msgid (syntax->datum #'exp2)))
+            (msgstr1 (car
+                      (reverse
+                       (string-split
+                        (ngettext msgid1 msgid2 1)
+                        gettext-context-glue))))
+            (result (acons ;return an association list msgstr->deconstructed
+                     ;; msgstr for n=1:
+                     msgstr1
+                     `(,'unquote ,(deconstruct (syntax->datum #'exp1)
+                                               msgstr1))
+                     ;; other msgstr for n of each plural form:
+                     (map
+                      (lambda (n)
+                        (let ((msgstr (car
+                                       (reverse
+                                        (string-split
+                                         (ngettext msgid1 msgid2 n)
+                                         gettext-context-glue)))))
+                          (cons msgstr `(,'unquote
+                                         ,(deconstruct (syntax->datum #'exp2)
+                                                       msgstr)))))
+                      %plural-numbers))))
+       (datum->syntax
+        #'id
+        `(,assoc-ref (,'quasiquote ,result)
+                     (,car
+                      (,reverse
+                       (,string-split
+                        (,ngettext ,msgid1 ,msgid2 ,(syntax->datum #'n))
+                        ,gettext-context-glue)))))))))
+
+(define %linguas
+  (with-input-from-file "po/LINGUAS"
+    (lambda _
+      (let loop ((line (read-line)))
+        (if (eof-object? line)
+            '()
+            ;; else read linguas before comment
+            (let ((before-comment (car (string-split line #\#))))
+              (append
+               (map match:substring (list-matches "[^ \t]+" before-comment))
+               (loop (read-line)))))))))

Reply via email to