[website] translations

+++ b/website/posts/back-from-seagl-2018.sxml

+               (apps base utils)

+               (srfi srfi-19))

+++ b/website/posts/guix-at-libreplanet-2016.sxml

+  (use-modules (srfi srfi-19)

+               (apps base templates components))

+++ b/website/apps/base/templates/contribute.scm

+         about your experience. Help the project by reporting bugs.")

+++ b/website/apps/base/templates/security.scm

+   "Important information about getting security updates for your

+++ b/website/.guix.scm

+;;; Copyright © 2019 Florian Pelz <pelzflorian@pelzflorian.de>

+;; We need %linguas from the (sexp-xgettext) module.  Therefore, we

+;; add its path to the load path.  FIXME: Adding "." to the load path

+;; only works if sexp-xgettext.scm is in the current working

+;; directory.

+(set! %load-path (cons "." %load-path))

+

+             (ice-9 match)

+             (ice-9 rdelim)

+             (ice-9 regex)

+             (sexp-xgettext))

+          ;; 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")

+                                           "/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))

+

+          ;; Build the website for each translation.

+          (for-each

+           (lambda (lingua)

+             (begin

+               (setenv "LC_ALL" (string-append lingua ".utf8"))

+               (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 (string-append "guix." lingua ".html")

+                        (string-append #$output "/index." lingua ".html"))))

+           (list #$@%linguas))))))

+++ b/website/README

+$ 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

+Then, visit http://localhost:8080/en/guix.html in a web browser.

+See also the file i18n-howto.txt for information on working with

+translations.

+

+++ b/website/apps/i18n.scm

+;;; GNU Guix web site

+;;; Copyright © 2019 Florian Pelz <pelzflorian@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_

+            NC_

+            %current-lingua

+            %current-lang

+            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)

+

+;; 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 <page>

+  (@@ (haunt page) <page>))

+

+(define %current-lingua

+  (car (string-split (setlocale LC_ALL) #\.)))

+

+(define %current-lang

+  (car (string-split %current-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 (builder->localized-builder builder)

+  "Returns a Haunt builder procedure generated from an existing

+BUILDER with translations for the current system locale coming from

+sexp-xgettext."

+  (compose

+   (lambda (pages)

+     (map

+      (lambda (page)

+        (match page

+          (($ <page> file-name contents writer)

+           (let ((new-name (string-append %current-lang

+                                          "/"

+                                          file-name)))

+             (make-page new-name contents writer)))

+          (else page)))

+      pages))

+   (lambda (site posts)

+     (first-value (builder site posts)))))

+

+(define (builders->localized-builders builders)

+  "Returns 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)))

+++ b/website/haunt.scm

+             (apps i18n)

+             (haunt site)

+             (ice-9 rdelim)

+             (srfi srfi-1))

+      #:builders (builders->localized-builders

+                  (list base:builder

+                        blog:builder

+                        download:builder

+                        packages:builder

+                        (static-directory "static"))))

+++ b/website/i18n-howto.txt

+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="ludo@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 -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:

+

+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

+++ b/website/po/LINGUAS

+# Translation with sexp-xgettext requires the full LL_CC locale name

+# to be specified.

+en_US

+++ b/website/po/POTFILES

+# high-priority files that should come first in the PO file

+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/screenshot.scm

+apps/base/templates/security.scm

+apps/download/data.scm

+apps/download/templates/components.scm

+apps/download/templates/download.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/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

+++ b/website/scripts/sexp-xgettext.scm

+;;; GNU Guix web site

+;;; Copyright © 2019 Florian Pelz <pelzflorian@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)

+  (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)

+  "Returns 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)

+  "Returns 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, returns #f.  Otherwise corrects 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)))))

+

+(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)) (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)

+  "Returns 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)

+  "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 '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)

+  "Returns 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, returns its

+value as a string, symbol or #:-keyword, otherwise returns #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)

+  "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-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 <LL@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)))))

+++ b/website/sexp-xgettext.scm

+;;; GNU Guix web site

+;;; Copyright © 2019 Florian Pelz <pelzflorian@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)

+    "Returns 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)

+    "Returns 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)

+    "Returns 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)

+    "Returns PREFIX with the number COUNTER appended."

+    (string-append prefix (number->string counter)))

+  (let loop ((exp exp)

+             (msgstr msgstr)

+             (prefix ""))

+    (define (unwrap-marked-expression exp)

+      "Returns 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)

+      "Returns 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)

+                          "Returns 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)

+                          "Returns 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)

+                          "Returns 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)

+                          "Returns 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

+  ;; (cf. section Plural forms in the gettext manual), 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)))))))))

+++ b/website/apps/base/data.scm

+;;; Copyright © 2019 Florian Pelz <pelzflorian@pelzflorian.de>

+  #:use-module (apps base templates components)

+  #:use-module (apps i18n)

+  #:use-module (srfi srfi-1)

+  #:use-module (sexp-xgettext)

+    #:name (G_ "IRC Channel")

+    (G_

+     `(p

+       "Join the " (code "#guix") " channel on the Freenode IRC network to chat

+       with the community about GNU Guix or to get help in

+       real-time."))

+    #:name (G_ "Info Mailing List")

+    (G_

+     `(p

+       "Subscribe to the " (code "info-guix") " low-traffic mailing

+English)."))

+    #:name (G_ "Help Mailing List")

+    ;; Compute an association list from language code to blurb.

+    ;; If possible, look up translated blurbs from the PO file.

+    ;; Fall back to old hard-coded translations.

+    (let ((original '(G_

+                      "Subscribe to the Help mailing list to get support

+from the GNU Guix community via email.  You can post messages in English

+though we also accept other languages."))

+          (lang-code '(C_ "unique lingua code like en or zh-cn" "en")))

+      (sort

+       (delete-duplicates

+        (append

+         (delete ;delete untranslated blurbs other than "en"

+          (cons original lang-code)

+          (map-in-order

+           (lambda (lingua)

+             (begin

+               (setlocale LC_ALL (string-append lingua ".utf8"))

+               (let ((out (list (gettext (string-append

+                                          (cadr lang-code) ;msgctxt

+                                          (string #\eot) ;separates msgctxt

+                                          (caddr lang-code))) ;msgid

+                                (gettext (cadr original)))))

+                 (setlocale LC_ALL "")

+                 (if (string-index (car out) #\eot) ;if untranslated

+                     (list (caddr lang-code) (cadr original)) ;use original

+                     out)))) ;else use what has been looked up via gettext

+           %linguas)

+          (lambda (to-delete b) (and ;delete where text is equal to original

+                                 (string=? (cadar to-delete) (cadr b))

+                                 ;; but language code is different

+                                 (not (string=? (cadddr to-delete) (car b))))))

+         `(("de"

+            "Melden Sie sich bei der „Help“-Mailingliste an, um per E-Mail

+           ("eo"

+            "Subskribu al la retmesaĝolisto \"Help\" por demandi helpon pri

+           ("es"

+            "Suscríbete a la lista de correo electrónico \"Help\" por pedir

+           ("fr"

+             "Abonnez-vous à la liste de diffusion « Help » pour obtenir l'aide

+           ("hu"

+            "Iratkozzon fel a „Help“ levelezőlistára, hogy segítséget kaphasson

+           ("it"

+            "Iscrivetevi alla mailing list 'Help' per essere aiutati da altri

+           ("ja"

+            "メールでGNU GuixとGuixSDのコミュニティからサポートを受けるには、

+           ("nb"

+            "Meld deg på diskusjonslisten «Help» for å få råd og tips fra

+           ("nl"

+            "Abonneer je op de discussielijst \"Help\" om hulp te vragen

+           ("ru"

+            "Подпишитесь на список рассылки «Help», чтобы получить помощь от

+           ("zh"

+            "訂閱「Help」郵件群組以電郵從GuixSD及GNU Guix社群取得支援。你可以使用

+正體、繁體中文發送訊息")))

+        (lambda (a b) (string=? (car a) (car b))))

+       (lambda (a b) (string<? (car a) (car b)))))

+    #:name (G_ "Bug Reporting")

+    (G_

+     `(p

+       "If you found a bug in Guix, check whether the bug is

+       already in the "

+       ,(G_ `(a (@ (href "https://issues.guix.gnu.org"))

+                "bug database"))

+       ". If it is not, please "

+       ,(G_ `(a (@ (href "mailto:bug-guix@gnu.org")) "report it."))))

+    #:name (G_ "Development Mailing List")

+    (G_

+     `(p

+       "Discussion about the development of GNU Guix. "

+       ,(G_ `(a (@ (href "https://lists.gnu.org/archive/html/bug-guix/2013-07/msg00039.html"))

+                " Until July 2013"))

+       ", the bug-Guix mailing list filled that role. "))

+    #:name (G_ "Patches Mailing List")

+    (G_

+     `(p

+       "Submission of patches.  Every message sent to this mailing list

+       leads to a new entry in our "

+       ,(G_ `(a (@ (href "https://issues.guix.gnu.org"))

+                "patch tracking tool"))

+       ".  See "

+       ,(G_ `(a (@ (href "https://debbugs.gnu.org/Advanced.html")) "this page"))

+       " for more information on how to use it; see "

+       ,(G_ (manual-href "the manual" (G_ "en") (G_ "Submitting-Patches.html")))

+       " for more information on how to submit a patch.  "

+       ,(G_

+         `(a (@ (href "https://lists.gnu.org/archive/html/guix-devel/2017-02/msg00627.html"))

+             "Until February 2017"))

+       ", the guix-devel mailing list filled that role."))

+    #:name (G_ "Commits Mailing List")

+    (G_

+     `(p

+       "Notifications of commits made to the "

+       ,(G_ `(a (@ (href ,(guix-url "contribute/"))) "Git repositories"))

+       "."))

+    #:name (G_ "Security Mailing List")

+    (G_

+     `(p

+       "This is a private mailing list that anyone can post to to "

+       ,(G_ `(a (@ (href ,(guix-url "security/"))) "report security issues"))

+       " in Guix itself or in "

+       "the " ,(G_ `(a (@ (href ,(guix-url "packages/"))) "packages"))

+       " it provides.  Posting here allows Guix developers to address

+       the problem before it is widely publicized."))

+    #:name (G_ "Sysadmin Mailing List")

+    (G_

+     `(p

+       "Private mailing list for the "

+       ,(G_ `(a (@ (href "https://hydra.gnu.org/")) "build farm"))

+       " system administration."))

+    #:name (G_ "GNU System Discuss Mailing List")

+    (G_ '(p "Discussion about the development of the broader GNU system."))

+    #:name (G_ "GNU/Linux-libre Mailing List")

+    (G_ '(p "Workgroup for fully free GNU/Linux distributions."))