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