doc: Extract (localization) module.
* doc/build.scm (localization-helper-module): New procedure. (html-manual-indexes)[build]: Use it. Remove use of GUILE-JSON-3.
This commit is contained in:
Ludovic Courtès
parent
6edcf688c0
commit
62fc6fdb4c
396
doc/build.scm
396
doc/build.scm
@ -825,6 +825,98 @@ from SOURCE."
|
|||||||
|
|
||||||
(computed-file "guix-manual-po" build))
|
(computed-file "guix-manual-po" build))
|
||||||
|
|
||||||
|
(define* (localization-helper-module source
|
||||||
|
#:optional (languages %languages))
|
||||||
|
"Return a file-like object for use as the (localization) module. SOURCE
|
||||||
|
must be the Guix top-level source directory, from which PO files are taken."
|
||||||
|
(define content
|
||||||
|
(with-extensions (list guile-json-3)
|
||||||
|
#~(begin
|
||||||
|
(define-module (localization)
|
||||||
|
#:use-module (json)
|
||||||
|
#:use-module (srfi srfi-1)
|
||||||
|
#:use-module (srfi srfi-19)
|
||||||
|
#:use-module (ice-9 match)
|
||||||
|
#:use-module (ice-9 popen)
|
||||||
|
#:export (normalize
|
||||||
|
with-language
|
||||||
|
translate
|
||||||
|
language-code->name
|
||||||
|
seconds->string))
|
||||||
|
|
||||||
|
(define (normalize language) ;XXX: deduplicate
|
||||||
|
;; Normalize LANGUAGE. For instance, "zh_CN" becomes "zh-cn".
|
||||||
|
(string-map (match-lambda
|
||||||
|
(#\_ #\-)
|
||||||
|
(chr chr))
|
||||||
|
(string-downcase language)))
|
||||||
|
|
||||||
|
(define-syntax-rule (with-language language exp ...)
|
||||||
|
(let ((lang (getenv "LANGUAGE")))
|
||||||
|
(dynamic-wind
|
||||||
|
(lambda ()
|
||||||
|
(setenv "LANGUAGE" language)
|
||||||
|
(setlocale LC_MESSAGES))
|
||||||
|
(lambda () exp ...)
|
||||||
|
(lambda ()
|
||||||
|
(if lang
|
||||||
|
(setenv "LANGUAGE" lang)
|
||||||
|
(unsetenv "LANGUAGE"))
|
||||||
|
(setlocale LC_MESSAGES)))))
|
||||||
|
|
||||||
|
;; (put 'with-language 'scheme-indent-function 1)
|
||||||
|
(define* (translate str language
|
||||||
|
#:key (domain "guix-manual"))
|
||||||
|
(define exp
|
||||||
|
`(begin
|
||||||
|
(bindtextdomain "guix-manual"
|
||||||
|
#+(guix-manual-text-domain
|
||||||
|
source
|
||||||
|
languages))
|
||||||
|
(bindtextdomain "iso_639-3" ;language names
|
||||||
|
#+(file-append iso-codes
|
||||||
|
"/share/locale"))
|
||||||
|
(write (gettext ,str ,domain))))
|
||||||
|
|
||||||
|
(with-language language
|
||||||
|
;; Since the 'gettext' function caches msgid translations,
|
||||||
|
;; regardless of $LANGUAGE, we have to spawn a new process each
|
||||||
|
;; time we want to translate to a different language. Bah!
|
||||||
|
(let* ((pipe (open-pipe* OPEN_READ
|
||||||
|
#+(file-append guile-3.0
|
||||||
|
"/bin/guile")
|
||||||
|
"-c" (object->string exp)))
|
||||||
|
(str (read pipe)))
|
||||||
|
(close-pipe pipe)
|
||||||
|
str)))
|
||||||
|
|
||||||
|
(define %iso639-languages
|
||||||
|
(vector->list
|
||||||
|
(assoc-ref (call-with-input-file
|
||||||
|
#+(file-append iso-codes
|
||||||
|
"/share/iso-codes/json/iso_639-3.json")
|
||||||
|
json->scm)
|
||||||
|
"639-3")))
|
||||||
|
|
||||||
|
(define (language-code->name code)
|
||||||
|
"Return the full name of a language from its ISO-639-3 code."
|
||||||
|
(let ((code (match (string-index code #\_)
|
||||||
|
(#f code)
|
||||||
|
(index (string-take code index)))))
|
||||||
|
(any (lambda (language)
|
||||||
|
(and (string=? (or (assoc-ref language "alpha_2")
|
||||||
|
(assoc-ref language "alpha_3"))
|
||||||
|
code)
|
||||||
|
(assoc-ref language "name")))
|
||||||
|
%iso639-languages)))
|
||||||
|
|
||||||
|
(define (seconds->string seconds language)
|
||||||
|
(let* ((time (make-time time-utc 0 seconds))
|
||||||
|
(date (time-utc->date time)))
|
||||||
|
(with-language language (date->string date "~e ~B ~Y")))))))
|
||||||
|
|
||||||
|
(scheme-file "localization.scm" content))
|
||||||
|
|
||||||
(define* (html-manual-indexes source
|
(define* (html-manual-indexes source
|
||||||
#:key (languages %languages)
|
#:key (languages %languages)
|
||||||
(version "0.0")
|
(version "0.0")
|
||||||
@ -834,207 +926,135 @@ from SOURCE."
|
|||||||
"GNU Guix Cookbook"))
|
"GNU Guix Cookbook"))
|
||||||
(date 1))
|
(date 1))
|
||||||
(define build
|
(define build
|
||||||
(with-extensions (list guile-json-3)
|
(with-imported-modules `((guix build utils)
|
||||||
(with-imported-modules '((guix build utils))
|
((localization)
|
||||||
#~(begin
|
=> ,(localization-helper-module
|
||||||
(use-modules (guix build utils)
|
source languages)))
|
||||||
(json)
|
#~(begin
|
||||||
(ice-9 match)
|
(use-modules (guix build utils)
|
||||||
(ice-9 popen)
|
(localization)
|
||||||
(sxml simple)
|
(sxml simple)
|
||||||
(srfi srfi-1)
|
(srfi srfi-1))
|
||||||
(srfi srfi-19))
|
|
||||||
|
|
||||||
(define (normalize language) ;XXX: deduplicate
|
(define (guix-url path)
|
||||||
;; Normalize LANGUAGE. For instance, "zh_CN" becomes "zh-cn".
|
(string-append #$%web-site-url path))
|
||||||
(string-map (match-lambda
|
|
||||||
(#\_ #\-)
|
|
||||||
(chr chr))
|
|
||||||
(string-downcase language)))
|
|
||||||
|
|
||||||
(define-syntax-rule (with-language language exp ...)
|
(define (sxml-index language title body)
|
||||||
(let ((lang (getenv "LANGUAGE")))
|
;; FIXME: Avoid duplicating styling info from guix-artwork.git.
|
||||||
(dynamic-wind
|
`(html (@ (lang ,language))
|
||||||
(lambda ()
|
(head
|
||||||
(setenv "LANGUAGE" language)
|
(title ,(string-append title " — GNU Guix"))
|
||||||
(setlocale LC_MESSAGES))
|
(meta (@ (charset "UTF-8")))
|
||||||
(lambda () exp ...)
|
(meta (@ (name "viewport") (content "width=device-width, initial-scale=1.0")))
|
||||||
(lambda ()
|
;; Menu prefetch.
|
||||||
(if lang
|
(link (@ (rel "prefetch") (href ,(guix-url "menu/index.html"))))
|
||||||
(setenv "LANGUAGE" lang)
|
;; Base CSS.
|
||||||
(unsetenv "LANGUAGE"))
|
(link (@ (rel "stylesheet") (href ,(guix-url "static/base/css/elements.css"))))
|
||||||
(setlocale LC_MESSAGES)))))
|
(link (@ (rel "stylesheet") (href ,(guix-url "static/base/css/common.css"))))
|
||||||
|
(link (@ (rel "stylesheet") (href ,(guix-url "static/base/css/messages.css"))))
|
||||||
|
(link (@ (rel "stylesheet") (href ,(guix-url "static/base/css/navbar.css"))))
|
||||||
|
(link (@ (rel "stylesheet") (href ,(guix-url "static/base/css/breadcrumbs.css"))))
|
||||||
|
(link (@ (rel "stylesheet") (href ,(guix-url "static/base/css/buttons.css"))))
|
||||||
|
(link (@ (rel "stylesheet") (href ,(guix-url "static/base/css/footer.css"))))
|
||||||
|
|
||||||
;; (put 'with-language 'scheme-indent-function 1)
|
(link (@ (rel "stylesheet") (href ,(guix-url "static/base/css/page.css"))))
|
||||||
(define* (translate str language
|
(link (@ (rel "stylesheet") (href ,(guix-url "static/base/css/post.css")))))
|
||||||
#:key (domain "guix-manual"))
|
(body
|
||||||
(define exp
|
(header (@ (class "navbar"))
|
||||||
`(begin
|
(h1 (a (@ (class "branding")
|
||||||
(bindtextdomain "guix-manual"
|
(href #$%web-site-url)))
|
||||||
#+(guix-manual-text-domain
|
(span (@ (class "a11y-offset"))
|
||||||
source
|
"Guix"))
|
||||||
languages))
|
(nav (@ (class "menu"))))
|
||||||
(bindtextdomain "iso_639-3" ;language names
|
(nav (@ (class "breadcrumbs"))
|
||||||
#+(file-append iso-codes
|
(a (@ (class "crumb")
|
||||||
"/share/locale"))
|
(href #$%web-site-url))
|
||||||
(write (gettext ,str ,domain))))
|
"Home"))
|
||||||
|
,body
|
||||||
|
(footer))))
|
||||||
|
|
||||||
(with-language language
|
(define (language-index language)
|
||||||
;; Since the 'gettext' function caches msgid translations,
|
(define title
|
||||||
;; regardless of $LANGUAGE, we have to spawn a new process each
|
(translate #$title language))
|
||||||
;; time we want to translate to a different language. Bah!
|
|
||||||
(let* ((pipe (open-pipe* OPEN_READ
|
|
||||||
#+(file-append guile-2.2
|
|
||||||
"/bin/guile")
|
|
||||||
"-c" (object->string exp)))
|
|
||||||
(str (read pipe)))
|
|
||||||
(close-pipe pipe)
|
|
||||||
str)))
|
|
||||||
|
|
||||||
(define (seconds->string seconds language)
|
(sxml-index
|
||||||
(let* ((time (make-time time-utc 0 seconds))
|
language title
|
||||||
(date (time-utc->date time)))
|
`(main
|
||||||
(with-language language (date->string date "~e ~B ~Y"))))
|
(article
|
||||||
|
(@ (class "page centered-block limit-width"))
|
||||||
|
(h2 ,title)
|
||||||
|
(p (@ (class "post-metadata centered-text"))
|
||||||
|
#$version " — "
|
||||||
|
,(seconds->string #$date language))
|
||||||
|
|
||||||
(define (guix-url path)
|
(div
|
||||||
(string-append #$%web-site-url path))
|
(ul
|
||||||
|
(li (a (@ (href "html_node"))
|
||||||
|
"HTML, with a separate page per node"))
|
||||||
|
(li (a (@ (href
|
||||||
|
,(string-append
|
||||||
|
#$manual
|
||||||
|
(if (string=? language
|
||||||
|
"en")
|
||||||
|
""
|
||||||
|
(string-append "."
|
||||||
|
language))
|
||||||
|
".html")))
|
||||||
|
"HTML, entirely on one page"))
|
||||||
|
,@(if (member language '("ru" "zh_CN"))
|
||||||
|
'()
|
||||||
|
`((li (a (@ (href ,(string-append
|
||||||
|
#$manual
|
||||||
|
(if (string=? language "en")
|
||||||
|
""
|
||||||
|
(string-append "."
|
||||||
|
language))
|
||||||
|
".pdf"))))
|
||||||
|
"PDF")))))))))
|
||||||
|
|
||||||
(define (sxml-index language title body)
|
(define (top-level-index languages)
|
||||||
;; FIXME: Avoid duplicating styling info from guix-artwork.git.
|
(define title #$title)
|
||||||
`(html (@ (lang ,language))
|
(sxml-index
|
||||||
(head
|
"en" title
|
||||||
(title ,(string-append title " — GNU Guix"))
|
`(main
|
||||||
(meta (@ (charset "UTF-8")))
|
(article
|
||||||
(meta (@ (name "viewport") (content "width=device-width, initial-scale=1.0")))
|
(@ (class "page centered-block limit-width"))
|
||||||
;; Menu prefetch.
|
(h2 ,title)
|
||||||
(link (@ (rel "prefetch") (href ,(guix-url "menu/index.html"))))
|
(div
|
||||||
;; Base CSS.
|
"This document is available in the following
|
||||||
(link (@ (rel "stylesheet") (href ,(guix-url "static/base/css/elements.css"))))
|
|
||||||
(link (@ (rel "stylesheet") (href ,(guix-url "static/base/css/common.css"))))
|
|
||||||
(link (@ (rel "stylesheet") (href ,(guix-url "static/base/css/messages.css"))))
|
|
||||||
(link (@ (rel "stylesheet") (href ,(guix-url "static/base/css/navbar.css"))))
|
|
||||||
(link (@ (rel "stylesheet") (href ,(guix-url "static/base/css/breadcrumbs.css"))))
|
|
||||||
(link (@ (rel "stylesheet") (href ,(guix-url "static/base/css/buttons.css"))))
|
|
||||||
(link (@ (rel "stylesheet") (href ,(guix-url "static/base/css/footer.css"))))
|
|
||||||
|
|
||||||
(link (@ (rel "stylesheet") (href ,(guix-url "static/base/css/page.css"))))
|
|
||||||
(link (@ (rel "stylesheet") (href ,(guix-url "static/base/css/post.css")))))
|
|
||||||
(body
|
|
||||||
(header (@ (class "navbar"))
|
|
||||||
(h1 (a (@ (class "branding")
|
|
||||||
(href #$%web-site-url)))
|
|
||||||
(span (@ (class "a11y-offset"))
|
|
||||||
"Guix"))
|
|
||||||
(nav (@ (class "menu"))))
|
|
||||||
(nav (@ (class "breadcrumbs"))
|
|
||||||
(a (@ (class "crumb")
|
|
||||||
(href #$%web-site-url))
|
|
||||||
"Home"))
|
|
||||||
,body
|
|
||||||
(footer))))
|
|
||||||
|
|
||||||
(define (language-index language)
|
|
||||||
(define title
|
|
||||||
(translate #$title language))
|
|
||||||
|
|
||||||
(sxml-index
|
|
||||||
language title
|
|
||||||
`(main
|
|
||||||
(article
|
|
||||||
(@ (class "page centered-block limit-width"))
|
|
||||||
(h2 ,title)
|
|
||||||
(p (@ (class "post-metadata centered-text"))
|
|
||||||
#$version " — "
|
|
||||||
,(seconds->string #$date language))
|
|
||||||
|
|
||||||
(div
|
|
||||||
(ul
|
|
||||||
(li (a (@ (href "html_node"))
|
|
||||||
"HTML, with a separate page per node"))
|
|
||||||
(li (a (@ (href
|
|
||||||
,(string-append
|
|
||||||
#$manual
|
|
||||||
(if (string=? language
|
|
||||||
"en")
|
|
||||||
""
|
|
||||||
(string-append "."
|
|
||||||
language))
|
|
||||||
".html")))
|
|
||||||
"HTML, entirely on one page"))
|
|
||||||
,@(if (member language '("ru" "zh_CN"))
|
|
||||||
'()
|
|
||||||
`((li (a (@ (href ,(string-append
|
|
||||||
#$manual
|
|
||||||
(if (string=? language "en")
|
|
||||||
""
|
|
||||||
(string-append "."
|
|
||||||
language))
|
|
||||||
".pdf"))))
|
|
||||||
"PDF")))))))))
|
|
||||||
|
|
||||||
(define %iso639-languages
|
|
||||||
(vector->list
|
|
||||||
(assoc-ref (call-with-input-file
|
|
||||||
#+(file-append iso-codes
|
|
||||||
"/share/iso-codes/json/iso_639-3.json")
|
|
||||||
json->scm)
|
|
||||||
"639-3")))
|
|
||||||
|
|
||||||
(define (language-code->name code)
|
|
||||||
"Return the full name of a language from its ISO-639-3 code."
|
|
||||||
(let ((code (match (string-index code #\_)
|
|
||||||
(#f code)
|
|
||||||
(index (string-take code index)))))
|
|
||||||
(any (lambda (language)
|
|
||||||
(and (string=? (or (assoc-ref language "alpha_2")
|
|
||||||
(assoc-ref language "alpha_3"))
|
|
||||||
code)
|
|
||||||
(assoc-ref language "name")))
|
|
||||||
%iso639-languages)))
|
|
||||||
|
|
||||||
(define (top-level-index languages)
|
|
||||||
(define title #$title)
|
|
||||||
(sxml-index
|
|
||||||
"en" title
|
|
||||||
`(main
|
|
||||||
(article
|
|
||||||
(@ (class "page centered-block limit-width"))
|
|
||||||
(h2 ,title)
|
|
||||||
(div
|
|
||||||
"This document is available in the following
|
|
||||||
languages:\n"
|
languages:\n"
|
||||||
(ul
|
(ul
|
||||||
,@(map (lambda (language)
|
,@(map (lambda (language)
|
||||||
`(li (a (@ (href ,(normalize language)))
|
`(li (a (@ (href ,(normalize language)))
|
||||||
,(translate
|
,(translate
|
||||||
(language-code->name language)
|
(language-code->name language)
|
||||||
language
|
language
|
||||||
#:domain "iso_639-3"))))
|
#:domain "iso_639-3"))))
|
||||||
languages)))))))
|
languages)))))))
|
||||||
|
|
||||||
(define (write-html file sxml)
|
(define (write-html file sxml)
|
||||||
(call-with-output-file file
|
(call-with-output-file file
|
||||||
(lambda (port)
|
(lambda (port)
|
||||||
(display "<!DOCTYPE html>\n" port)
|
(display "<!DOCTYPE html>\n" port)
|
||||||
(sxml->xml sxml port))))
|
(sxml->xml sxml port))))
|
||||||
|
|
||||||
(setenv "GUIX_LOCPATH"
|
(setenv "GUIX_LOCPATH"
|
||||||
#+(file-append glibc-utf8-locales "/lib/locale"))
|
#+(file-append glibc-utf8-locales "/lib/locale"))
|
||||||
(setenv "LC_ALL" "en_US.utf8")
|
(setenv "LC_ALL" "en_US.utf8")
|
||||||
(setlocale LC_ALL "en_US.utf8")
|
(setlocale LC_ALL "en_US.utf8")
|
||||||
|
|
||||||
(for-each (lambda (language)
|
(for-each (lambda (language)
|
||||||
(define directory
|
(define directory
|
||||||
(string-append #$output "/"
|
(string-append #$output "/"
|
||||||
(normalize language)))
|
(normalize language)))
|
||||||
|
|
||||||
(mkdir-p directory)
|
(mkdir-p directory)
|
||||||
(write-html (string-append directory "/index.html")
|
(write-html (string-append directory "/index.html")
|
||||||
(language-index language)))
|
(language-index language)))
|
||||||
'#$languages)
|
'#$languages)
|
||||||
|
|
||||||
(write-html (string-append #$output "/index.html")
|
(write-html (string-append #$output "/index.html")
|
||||||
(top-level-index '#$languages))))))
|
(top-level-index '#$languages)))))
|
||||||
|
|
||||||
(computed-file "html-indexes" build))
|
(computed-file "html-indexes" build))
|
||||||
|
|
||||||
|
|||||||
Loading…
x
Reference in New Issue
Block a user