mirror/guix
1
0
Fork 0
mirror of https://git.savannah.gnu.org/git/guix.git synced 2025-01-31 06:46:50 +01:00
Code Issues Projects Releases Packages Wiki Activity Actions

doc: Build a top-level index of the manuals.

Browse source 
Suggested by Julien Lepiller.

* doc/build.scm (html-manual-indexes)[build]: Add 'with-extensions'.
(translate): Actually honor DOMAIN.  Add call to 'bindtextdomain' for
ISO-CODES.
(%iso639-languages): New variable.
(language-code->name, top-level-index): New procedures.
Add call to 'write-html' for OUTPUT/index.html.
This commit is contained in:
Ludovic Courtès 2019-07-15 12:33:07 +02:00
parent 4e67f20488
commit 0c04bdb948
No known key found for this signature in database
GPG key ID: 090B11993D9AEBB5
1 changed files with 188 additions and 140 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

328
doc/build.scm
View file

@ -34,6 +34,7 @@
(gnu packages gawk) (gnu packages gawk)
(gnu packages gettext) (gnu packages gettext)
(gnu packages guile) (gnu packages guile)
(gnu packages iso-codes)
(gnu packages texinfo) (gnu packages texinfo)
(gnu packages tex) (gnu packages tex)
(srfi srfi-19) (srfi srfi-19)
@ -183,7 +184,7 @@ (define build
(ice-9 match)) (ice-9 match))
(define (normalize language) (define (normalize language)
;; Normalize LANGUAGE. For instance, "zh_CN" become "zh-cn". ;; Normalize LANGUAGE. For instance, "zh_CN" becomes "zh-cn".
(string-map (match-lambda (string-map (match-lambda
(#\_ #\-) (#\_ #\-)
(chr chr)) (chr chr))
@ -365,161 +366,208 @@ (define* (html-manual-indexes source
(manual "guix") (manual "guix")
(date 1)) (date 1))
(define build (define build
(with-imported-modules '((guix build utils)) (with-extensions (list guile-json-3)
#~(begin (with-imported-modules '((guix build utils))
(use-modules (guix build utils) #~(begin
(ice-9 match) (use-modules (guix build utils)
(ice-9 popen) (json)
(sxml simple) (ice-9 match)
(srfi srfi-19)) (ice-9 popen)
(sxml simple)
(srfi srfi-1)
(srfi srfi-19))
(define (normalize language) ;XXX: deduplicate (define (normalize language) ;XXX: deduplicate
;; Normalize LANGUAGE. For instance, "zh_CN" become "zh-cn". ;; Normalize LANGUAGE. For instance, "zh_CN" becomes "zh-cn".
(string-map (match-lambda (string-map (match-lambda
(#\_ #\-) (#\_ #\-)
(chr chr)) (chr chr))
(string-downcase language))) (string-downcase language)))
(define-syntax-rule (with-language language exp ...) (define-syntax-rule (with-language language exp ...)
(let ((lang (getenv "LANGUAGE"))) (let ((lang (getenv "LANGUAGE")))
(dynamic-wind (dynamic-wind
(lambda () (lambda ()
(setenv "LANGUAGE" language) (setenv "LANGUAGE" language)
(setlocale LC_MESSAGES)) (setlocale LC_MESSAGES))
(lambda () exp ...) (lambda () exp ...)
(lambda () (lambda ()
(if lang (if lang
(setenv "LANGUAGE" lang) (setenv "LANGUAGE" lang)
(unsetenv "LANGUAGE")) (unsetenv "LANGUAGE"))
(setlocale LC_MESSAGES))))) (setlocale LC_MESSAGES)))))
;; (put 'with-language 'scheme-indent-function 1) ;; (put 'with-language 'scheme-indent-function 1)
(define* (translate str language (define* (translate str language
#:key (domain "guix-manual")) #:key (domain "guix-manual"))
(define exp (define exp
`(begin `(begin
(bindtextdomain "guix-manual" (bindtextdomain "guix-manual"
#+(guix-manual-text-domain #+(guix-manual-text-domain
source source
languages)) languages))
(write (gettext ,str "guix-manual")))) (bindtextdomain "iso_639-3" ;language names
#+(file-append iso-codes
"/share/locale"))
(write (gettext ,str ,domain))))
(with-language language (with-language language
;; Since the 'gettext' function caches msgid translations, ;; Since the 'gettext' function caches msgid translations,
;; regardless of $LANGUAGE, we have to spawn a new process each ;; regardless of $LANGUAGE, we have to spawn a new process each
;; time we want to translate to a different language. Bah! ;; time we want to translate to a different language. Bah!
(let* ((pipe (open-pipe* OPEN_READ (let* ((pipe (open-pipe* OPEN_READ
#+(file-append guile-2.2 #+(file-append guile-2.2
"/bin/guile") "/bin/guile")
"-c" (object->string exp))) "-c" (object->string exp)))
(str (read pipe))) (str (read pipe)))
(close-pipe pipe) (close-pipe pipe)
str))) str)))
(define (seconds->string seconds language) (define (seconds->string seconds language)
(let* ((time (make-time time-utc 0 seconds)) (let* ((time (make-time time-utc 0 seconds))
(date (time-utc->date time))) (date (time-utc->date time)))
(with-language language (date->string date "~e ~B ~Y")))) (with-language language (date->string date "~e ~B ~Y"))))
(define (guix-url path) (define (guix-url path)
(string-append #$%web-site-url path)) (string-append #$%web-site-url path))
(define (sxml-index language title body) (define (sxml-index language title body)
;; FIXME: Avoid duplicating styling info from guix-artwork.git. ;; FIXME: Avoid duplicating styling info from guix-artwork.git.
`(html (@ (lang ,language)) `(html (@ (lang ,language))
(head (head
(title ,(string-append title " — GNU Guix")) (title ,(string-append title " — GNU Guix"))
(meta (@ (charset "UTF-8"))) (meta (@ (charset "UTF-8")))
(meta (@ (name "viewport") (content "width=device-width, initial-scale=1.0"))) (meta (@ (name "viewport") (content "width=device-width, initial-scale=1.0")))
;; Menu prefetch. ;; Menu prefetch.
(link (@ (rel "prefetch") (href ,(guix-url "menu/index.html")))) (link (@ (rel "prefetch") (href ,(guix-url "menu/index.html"))))
;; Base CSS. ;; Base CSS.
(link (@ (rel "stylesheet") (href ,(guix-url "static/base/css/elements.css")))) (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/common.css"))))
(link (@ (rel "stylesheet") (href ,(guix-url "static/base/css/messages.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/navbar.css"))))
(link (@ (rel "stylesheet") (href ,(guix-url "static/base/css/breadcrumbs.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/buttons.css"))))
(link (@ (rel "stylesheet") (href ,(guix-url "static/base/css/footer.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/page.css"))))
(link (@ (rel "stylesheet") (href ,(guix-url "static/base/css/post.css"))))) (link (@ (rel "stylesheet") (href ,(guix-url "static/base/css/post.css")))))
(body (body
(header (@ (class "navbar")) (header (@ (class "navbar"))
(h1 (a (@ (class "branding") (h1 (a (@ (class "branding")
(href #$%web-site-url))) (href #$%web-site-url)))
(span (@ (class "a11y-offset")) (span (@ (class "a11y-offset"))
"Guix")) "Guix"))
(nav (@ (class "menu")))) (nav (@ (class "menu"))))
(nav (@ (class "breadcrumbs")) (nav (@ (class "breadcrumbs"))
(a (@ (class "crumb") (a (@ (class "crumb")
(href #$%web-site-url)) (href #$%web-site-url))
"Home")) "Home"))
,body ,body
(footer)))) (footer))))
(define (language-index language) (define (language-index language)
(define title (define title
(translate "GNU Guix Reference Manual" language)) (translate "GNU Guix Reference Manual" language))
(sxml-index (sxml-index
language title language title
`(main `(main
(article (article
(@ (class "page centered-block limit-width")) (@ (class "page centered-block limit-width"))
(h2 ,title) (h2 ,title)
(p (@ (class "post-metadata centered-text")) (p (@ (class "post-metadata centered-text"))
#$version " — " #$version " — "
,(seconds->string #$date language)) ,(seconds->string #$date language))
(div (div
(ul (ul
(li (a (@ (href "html_node")) (li (a (@ (href "html_node"))
"HTML, with one page per node")) "HTML, with one page per node"))
(li (a (@ (href (li (a (@ (href
,(string-append ,(string-append
#$manual #$manual
(if (string=? language (if (string=? language
"en") "en")
"" ""
(string-append "." (string-append "."
language)) language))
".html"))) ".html")))
"HTML, entirely on one page")) "HTML, entirely on one page"))
,@(if (member language '("ru" "zh_CN")) ,@(if (member language '("ru" "zh_CN"))
'() '()
`((li (a (@ (href ,(string-append `((li (a (@ (href ,(string-append
#$manual #$manual
(if (string=? language "en") (if (string=? language "en")
"" ""
(string-append "." (string-append "."
language)) language))
".pdf")))) ".pdf"))))
"PDF"))))))))) "PDF")))))))))
(define (write-html file sxml) (define %iso639-languages
(call-with-output-file file (vector->list
(lambda (port) (assoc-ref (call-with-input-file
(display "<!DOCTYPE html>\n" port) #+(file-append iso-codes
(sxml->xml sxml port)))) "/share/iso-codes/json/iso_639-3.json")
json->scm)
"639-3")))
(setenv "GUIX_LOCPATH" (define (language-code->name code)
#+(file-append glibc-utf8-locales "/lib/locale")) "Return the full name of a language from its ISO-639-3 code."
(setenv "LC_ALL" "en_US.utf8") (let ((code (match (string-index code #\_)
(setlocale LC_ALL "en_US.utf8") (#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)))
(bindtextdomain "guix-manual" (define (top-level-index languages)
#+(guix-manual-text-domain source languages)) (define title
"GNU Guix Reference Manual")
(sxml-index
"en" title
`(main
(article
(@ (class "page centered-block limit-width"))
(h2 ,title)
(div
"The GNU Guix Reference Manual is available in the following
languages:\n"
(ul
,@(map (lambda (language)
`(li (a (@ (href ,(normalize language)))
,(translate
(language-code->name language)
language
#:domain "iso_639-3"))))
languages)))))))
(for-each (lambda (language) (define (write-html file sxml)
(define directory (call-with-output-file file
(string-append #$output "/" (lambda (port)
(normalize language))) (display "<!DOCTYPE html>\n" port)
(sxml->xml sxml port))))
(mkdir-p directory) (setenv "GUIX_LOCPATH"
(write-html (string-append directory "/index.html") #+(file-append glibc-utf8-locales "/lib/locale"))
(language-index language))) (setenv "LC_ALL" "en_US.utf8")
'#$languages)))) (setlocale LC_ALL "en_US.utf8")
(for-each (lambda (language)
(define directory
(string-append #$output "/"
(normalize language)))
(mkdir-p directory)
(write-html (string-append directory "/index.html")
(language-index language)))
'#$languages)
(write-html (string-append #$output "/index.html")
(top-level-index '#$languages))))))
(computed-file "html-indexes" build)) (computed-file "html-indexes" build))