X-Git-Url: https://git.hcoop.net/jackhill/guix/guix.git/blobdiff_plain/21bec78357ff5b93a14107bbeb5798923162f4b8..f37789a523d3e4169b72312c3540b7624415c116:/doc/build.scm diff --git a/doc/build.scm b/doc/build.scm index c0952ecb89..c3d61f837b 100644 --- a/doc/build.scm +++ b/doc/build.scm @@ -1,5 +1,5 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2019 Ludovic Courtès +;;; Copyright © 2019, 2020 Ludovic Courtès ;;; ;;; This file is part of GNU Guix. ;;; @@ -29,11 +29,14 @@ (guix gexp) (guix git) (guix git-download) + (guix utils) (git) (gnu packages base) (gnu packages gawk) (gnu packages gettext) (gnu packages guile) + (gnu packages guile-xyz) + (gnu packages iso-codes) (gnu packages texinfo) (gnu packages tex) (srfi srfi-19) @@ -48,6 +51,12 @@ (define info-manual (@@ (guix self) info-manual)) +(define %manual + ;; The manual to build--i.e., the base name of a .texi file, such as "guix" + ;; or "guix-cookbook". + (or (getenv "GUIX_MANUAL") + "guix")) + (define %languages '("de" "en" "es" "fr" "ru" "zh_CN")) @@ -161,11 +170,302 @@ as well as images, OS examples, and translations." (define %makeinfo-html-options ;; Options passed to 'makeinfo --html'. - '("--css-ref=https://www.gnu.org/software/gnulib/manual.css")) + '("--css-ref=https://www.gnu.org/software/gnulib/manual.css" + "-c" "EXTRA_HEAD=")) + +(define guile-lib/htmlprag-fixed + ;; Guile-Lib with a hotfix for (htmlprag). + (package + (inherit guile-lib) + (source (origin + (inherit (package-source guile-lib)) + (modules '(( guix build utils))) + (snippet + '(begin + ;; When parsing + ;; "

foo

\n
", + ;; 'html->shtml' would mistakenly close 'blockquote' right + ;; before

. This patch removes 'p' from the + ;; 'parent-constraints' alist to fix that. + (substitute* "src/htmlprag.scm" + (("^[[:blank:]]*\\(p[[:blank:]]+\\. \\(body td th\\)\\).*") + "")) + #t)))) + (arguments + (substitute-keyword-arguments (package-arguments guile-lib) + ((#:phases phases '%standard-phases) + `(modify-phases ,phases + (add-before 'check 'skip-known-failure + (lambda _ + ;; XXX: The above change causes one test failure among + ;; the htmlprag tests. + (setenv "XFAIL_TESTS" "htmlprag.scm") + #t)))))))) + +(define* (syntax-highlighted-html input + #:key + (name "highlighted-syntax") + (syntax-css-url + "/static/base/css/code.css")) + "Return a derivation called NAME that processes all the HTML files in INPUT +to (1) add them a link to SYNTAX-CSS-URL, and (2) highlight the syntax of all +its 

 blocks (as produced by 'makeinfo --html')."
+  (define build
+    (with-extensions (list guile-lib/htmlprag-fixed guile-syntax-highlight)
+      (with-imported-modules '((guix build utils))
+        #~(begin
+            (use-modules (htmlprag)
+                         (syntax-highlight)
+                         (syntax-highlight scheme)
+                         (syntax-highlight lexers)
+                         (guix build utils)
+                         (srfi srfi-1)
+                         (ice-9 match)
+                         (ice-9 threads)
+                         (ice-9 vlist))
+
+            (define (pair-open/close lst)
+              ;; Pair 'open' and 'close' tags produced by 'highlights' and
+              ;; produce nested 'paren' tags instead.
+              (let loop ((lst lst)
+                         (level 0)
+                         (result '()))
+                (match lst
+                  ((('open open) rest ...)
+                   (call-with-values
+                       (lambda ()
+                         (loop rest (+ 1 level) '()))
+                     (lambda (inner close rest)
+                       (loop rest level
+                             (cons `(paren ,level ,open ,inner ,close)
+                                   result)))))
+                  ((('close str) rest ...)
+                   (if (> level 0)
+                       (values (reverse result) str rest)
+                       (begin
+                         (format (current-error-port)
+                                 "warning: extra closing paren; context:~% ~y~%"
+                                 (reverse result))
+                         (loop rest 0 (cons `(close ,str) result)))))
+                  ((item rest ...)
+                   (loop rest level (cons item result)))
+                  (()
+                   (when (> level 0)
+                     (format (current-error-port)
+                             "warning: missing ~a closing parens; context:~% ~y%"
+                             level (reverse result)))
+                   (values (reverse result) "" '())))))
+
+            (define (highlights->sxml* highlights anchors)
+              ;; Like 'highlights->sxml', but handle nested 'paren tags.  This
+              ;; allows for paren matching highlights via appropriate CSS
+              ;; "hover" properties.  When a symbol is encountered, look it up
+              ;; in ANCHORS, a vhash, and emit the corresponding href, if any.
+              (define (tag->class tag)
+                (string-append "syntax-" (symbol->string tag)))
+
+              (map (match-lambda
+                     ((? string? str) str)
+                     (('paren level open (body ...) close)
+                      `(span (@ (class ,(string-append "syntax-paren"
+                                                       (number->string level))))
+                             ,open
+                             (span (@ (class "syntax-symbol"))
+                                   ,@(highlights->sxml* body anchors))
+                             ,close))
+                     (('symbol text)
+                      ;; Check whether we can emit a hyperlink for TEXT.
+                      (match (vhash-assoc text anchors)
+                        (#f
+                         `(span (@ (class ,(tag->class 'symbol))) ,text))
+                        ((_ . target)
+                         `(a (@ (class ,(tag->class 'symbol)) (href ,target))
+                             ,text))))
+                     ((tag text)
+                      `(span (@ (class ,(tag->class tag))) ,text)))
+                   highlights))
+
+            (define entity->string
+              (match-lambda
+                ("rArr"   "⇒")
+                ("rarr"   "→")
+                ("hellip" "…")
+                ("rsquo"  "’")
+                (e (pk 'unknown-entity e) (primitive-exit 2))))
+
+            (define (concatenate-snippets pieces)
+              ;; Concatenate PIECES, which contains strings and entities,
+              ;; replacing entities with their corresponding string.
+              (let loop ((pieces pieces)
+                         (strings '()))
+                (match pieces
+                  (()
+                   (string-concatenate-reverse strings))
+                  (((? string? str) . rest)
+                   (loop rest (cons str strings)))
+                  ((('*ENTITY* "additional" entity) . rest)
+                   (loop rest (cons (entity->string entity) strings)))
+                  ((('span _ lst ...) . rest)     ;for 
+                   (loop (append lst rest) strings))
+                  (something
+                   (pk 'unsupported-code-snippet something)
+                   (primitive-exit 1)))))
+
+            (define (syntax-highlight sxml anchors)
+              ;; Recurse over SXML and syntax-highlight code snippets.
+              (let loop ((sxml sxml))
+                (match sxml
+                  (('*TOP* decl body ...)
+                   `(*TOP* ,decl ,@(map loop body)))
+                  (('head things ...)
+                   `(head ,@things
+                          (link (@ (rel "stylesheet")
+                                   (type "text/css")
+                                   (href #$syntax-css-url)))))
+                  (('pre ('@ ('class "lisp")) code-snippet ...)
+                   `(pre (@ (class "lisp"))
+                         ,@(highlights->sxml*
+                            (pair-open/close
+                             (highlight lex-scheme
+                                        (concatenate-snippets code-snippet)))
+                            anchors)))
+                  ((tag ('@ attributes ...) body ...)
+                   `(,tag (@ ,@attributes) ,@(map loop body)))
+                  ((tag body ...)
+                   `(,tag ,@(map loop body)))
+                  ((? string? str)
+                   str))))
+
+            (define (underscore-decode str)
+              ;; Decode STR, an "underscore-encoded" string as produced by
+              ;; makeinfo for indexes, such as "_0025base_002dservices" for
+              ;; "%base-services".
+              (let loop ((str str)
+                         (result '()))
+                (match (string-index str #\_)
+                  (#f
+                   (string-concatenate-reverse (cons str result)))
+                  (index
+                   (let ((char (string->number
+                                (substring str (+ index 1) (+ index 5))
+                                16)))
+                     (loop (string-drop str (+ index 5))
+                           (append (list (string (integer->char char))
+                                         (string-take str index))
+                                   result)))))))
+
+            (define (anchor-id->key id)
+              ;; Convert ID, an anchor ID such as
+              ;; "index-pam_002dlimits_002dservice" to the corresponding key,
+              ;; "pam-limits-service" in this example.
+              (underscore-decode
+               (string-drop id (string-length "index-"))))
+
+            (define* (collect-anchors file #:optional (vhash vlist-null))
+              ;; Collect the anchors that appear in FILE, a makeinfo-generated
+              ;; file.  Grab those from 
 tags, which corresponds to
+              ;; Texinfo @deftp, @defvr, etc.  Return VHASH augmented with
+              ;; more name/reference pairs.
+              (define string-or-entity?
+                (match-lambda
+                  ((? string?) #t)
+                  (('*ENTITY* _ ...) #t)
+                  (_ #f)))
+
+              (let ((shtml (call-with-input-file file html->shtml)))
+                (let loop ((shtml shtml)
+                           (vhash vhash))
+                  (match shtml
+                    ;; Attempt to match:
+                    ;;  
Scheme Variable: x

+                    ;; but not:
+                    ;;  
cups-configuration parameter: …

+                    (('dt ('@ ('id id))
+                          (? string-or-entity?) ... ('strong _ ...) _ ...)
+                     (if (string-prefix? "index-" id)
+                         (vhash-cons (anchor-id->key id)
+                                     (string-append (basename file)
+                                                    "#" id)
+                                     vhash)
+                         vhash))
+                    ((tag ('@ _ ...) body ...)
+                     (fold loop vhash body))
+                    ((tag body ...)
+                     (fold loop vhash body))
+                    (_ vhash)))))
+
+            (define (process-html file anchors)
+              ;; Parse FILE and perform syntax highlighting for its Scheme
+              ;; snippets.  Install the result to #$output.
+              (format (current-error-port) "processing ~a...~%" file)
+              (let* ((shtml        (call-with-input-file file html->shtml))
+                     (highlighted  (syntax-highlight shtml anchors))
+                     (base         (string-drop file (string-length #$input)))
+                     (target       (string-append #$output base)))
+                (mkdir-p (dirname target))
+                (call-with-output-file target
+                  (lambda (port)
+                    (write-shtml-as-html highlighted port)))))
+
+            (define (copy-as-is file)
+              ;; Copy FILE as is to #$output.
+              (let* ((base   (string-drop file (string-length #$input)))
+                     (target (string-append #$output base)))
+                (mkdir-p (dirname target))
+                (catch 'system-error
+                  (lambda ()
+                    (if (eq? 'symlink (stat:type (lstat file)))
+                        (symlink (readlink file) target)
+                        (link file target)))
+                  (lambda args
+                    (let ((errno (system-error-errno args)))
+                      (pk 'error-link file target (strerror errno))
+                      (primitive-exit 3))))))
+
+            (define (html? file stat)
+              (string-suffix? ".html" file))
+
+            ;; Install a UTF-8 locale so we can process UTF-8 files.
+            (setenv "GUIX_LOCPATH"
+                    #+(file-append glibc-utf8-locales "/lib/locale"))
+            (setlocale LC_ALL "en_US.utf8")
+
+            ;; First process the mono-node 'guix.html' files.
+            (n-par-for-each (parallel-job-count)
+                            (lambda (mono)
+                              (let ((anchors (collect-anchors mono)))
+                                (process-html mono anchors)))
+                            (find-files #$input "^guix(\\.[a-zA-Z_-]+)?\\.html$"))
+
+            ;; Next process the multi-node HTML files in two phases: (1)
+            ;; collect the list of anchors, and (2) perform
+            ;; syntax-highlighting.
+            (let* ((multi   (find-files #$input "^html_node$"
+                                        #:directories? #t))
+                   (anchors (n-par-map (parallel-job-count)
+                                       (lambda (multi)
+                                         (cons multi
+                                               (fold collect-anchors vlist-null
+                                                     (find-files multi html?))))
+                                       multi)))
+              (n-par-for-each (parallel-job-count)
+                              (lambda (file)
+                                (let ((anchors (assoc-ref anchors (dirname file))))
+                                  (process-html file anchors)))
+                              (append-map (lambda (multi)
+                                            (find-files multi html?))
+                                          multi)))
+
+            ;; Last, copy non-HTML files as is.
+            (for-each copy-as-is
+                      (find-files #$input (negate html?)))))))
+
+  (computed-file name build))
 
 (define* (html-manual source #:key (languages %languages)
                       (version "0.0")
-                      (manual "guix")
+                      (manual %manual)
                       (date 1)
                       (options %makeinfo-html-options))
   "Return the HTML manuals built from SOURCE for all LANGUAGES, with the given
@@ -176,6 +476,9 @@ makeinfo OPTIONS."
                            #:languages languages
                            #:date date))
 
+  (define images
+    (texinfo-manual-images source))
+
   (define build
     (with-imported-modules '((guix build utils))
       #~(begin
@@ -183,12 +486,19 @@ makeinfo OPTIONS."
                        (ice-9 match))
 
           (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
                           (#\_ #\-)
                           (chr chr))
                         (string-downcase language)))
 
+          (define (language->texi-file-name language)
+            (if (string=? language "en")
+                (string-append #$manual-source "/"
+                               #$manual ".texi")
+                (string-append #$manual-source "/"
+                               #$manual "." language ".texi")))
+
           ;; Install a UTF-8 locale so that 'makeinfo' is at ease.
           (setenv "GUIX_LOCPATH"
                   #+(file-append glibc-utf8-locales "/lib/locale"))
@@ -197,16 +507,18 @@ makeinfo OPTIONS."
           (setvbuf (current-output-port) 'line)
           (setvbuf (current-error-port) 'line)
 
+          ;; 'makeinfo' looks for "htmlxref.cnf" in the current directory, so
+          ;; copy it right here.
+          (copy-file (string-append #$manual-source "/htmlxref.cnf")
+                     "htmlxref.cnf")
+
           (for-each (lambda (language)
-                      (let ((opts `("--html"
-                                    "-c" ,(string-append "TOP_NODE_UP_URL=/manual/"
+                      (let* ((texi (language->texi-file-name language))
+                             (opts `("--html"
+                                     "-c" ,(string-append "TOP_NODE_UP_URL=/manual/"
                                                          language)
-                                    #$@options
-                                    ,(if (string=? language "en")
-                                         (string-append #$manual-source "/"
-                                                        #$manual ".texi")
-                                         (string-append #$manual-source "/"
-                                                        #$manual "." language ".texi")))))
+                                     #$@options
+                                     ,texi)))
                         (format #t "building HTML manual for language '~a'...~%"
                                 language)
                         (mkdir-p (string-append #$output "/"
@@ -227,14 +539,26 @@ makeinfo OPTIONS."
                                                   ""
                                                   (string-append "." language))
                                               ".html")
-                               opts)))
-                    '#$languages))))
+                               opts)
 
-  (computed-file (string-append manual "-html-manual") build))
+                        ;; Make sure images are available.
+                        (symlink #$images
+                                 (string-append #$output "/" (normalize language)
+                                                "/images"))
+                        (symlink #$images
+                                 (string-append #$output "/" (normalize language)
+                                                "/html_node/images"))))
+                    (filter (compose file-exists? language->texi-file-name)
+                            '#$languages)))))
+
+  (let* ((name   (string-append manual "-html-manual"))
+         (manual (computed-file name build)))
+    (syntax-highlighted-html manual
+                             #:name (string-append name "-highlighted"))))
 
 (define* (pdf-manual source #:key (languages %languages)
                      (version "0.0")
-                     (manual "guix")
+                     (manual %manual)
                      (date 1)
                      (options '()))
   "Return the HTML manuals built from SOURCE for all LANGUAGES, with the given
@@ -362,164 +686,213 @@ from SOURCE."
 (define* (html-manual-indexes source
                               #:key (languages %languages)
                               (version "0.0")
-                              (manual "guix")
+                              (manual %manual)
+                              (title (if (string=? "guix" manual)
+                                         "GNU Guix Reference Manual"
+                                         "GNU Guix Cookbook"))
                               (date 1))
   (define build
-    (with-imported-modules '((guix build utils))
-      #~(begin
-          (use-modules (guix build utils)
-                       (ice-9 match)
-                       (ice-9 popen)
-                       (sxml simple)
-                       (srfi srfi-19))
-
-          (define (normalize language)            ;XXX: deduplicate
-            ;; Normalize LANGUAGE.  For instance, "zh_CN" become "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))
-                 (write (gettext ,str "guix-manual"))))
-
-            (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-2.2
-                                                      "/bin/guile")
-                                       "-c" (object->string exp)))
-                     (str  (read pipe)))
-                (close-pipe pipe)
-                str)))
-
-          (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"))))
-
-          (define (guix-url path)
-            (string-append #$%web-site-url path))
-
-          (define (sxml-index language title body)
-            ;; FIXME: Avoid duplicating styling info from guix-artwork.git.
-            `(html (@ (lang ,language))
-                   (head
-                    (title ,(string-append title " — GNU Guix"))
-                    (meta (@ (charset "UTF-8")))
-                    (meta (@ (name "viewport") (content "width=device-width, initial-scale=1.0")))
-                    ;; Menu prefetch.
-                    (link (@ (rel "prefetch") (href ,(guix-url "menu/index.html"))))
-                    ;; Base 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/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 "GNU Guix Reference Manual" 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 one 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 (write-html file sxml)
-            (call-with-output-file file
-              (lambda (port)
-                (display "\n" port)
-                (sxml->xml sxml port))))
+    (with-extensions (list guile-json-3)
+      (with-imported-modules '((guix build utils))
+        #~(begin
+            (use-modules (guix build utils)
+                         (json)
+                         (ice-9 match)
+                         (ice-9 popen)
+                         (sxml simple)
+                         (srfi srfi-1)
+                         (srfi srfi-19))
+
+            (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-2.2
+                                                        "/bin/guile")
+                                         "-c" (object->string exp)))
+                       (str  (read pipe)))
+                  (close-pipe pipe)
+                  str)))
+
+            (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"))))
+
+            (define (guix-url path)
+              (string-append #$%web-site-url path))
+
+            (define (sxml-index language title body)
+              ;; FIXME: Avoid duplicating styling info from guix-artwork.git.
+              `(html (@ (lang ,language))
+                     (head
+                      (title ,(string-append title " — GNU Guix"))
+                      (meta (@ (charset "UTF-8")))
+                      (meta (@ (name "viewport") (content "width=device-width, initial-scale=1.0")))
+                      ;; Menu prefetch.
+                      (link (@ (rel "prefetch") (href ,(guix-url "menu/index.html"))))
+                      ;; Base 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/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 one 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"
+                   (ul
+                    ,@(map (lambda (language)
+                             `(li (a (@ (href ,(normalize language)))
+                                     ,(translate
+                                       (language-code->name language)
+                                       language
+                                       #:domain "iso_639-3"))))
+                           languages)))))))
+
+            (define (write-html file sxml)
+              (call-with-output-file file
+                (lambda (port)
+                  (display "\n" port)
+                  (sxml->xml sxml port))))
 
-          (setenv "GUIX_LOCPATH"
-                  #+(file-append glibc-utf8-locales "/lib/locale"))
-          (setenv "LC_ALL" "en_US.utf8")
-          (setlocale LC_ALL "en_US.utf8")
+            (setenv "GUIX_LOCPATH"
+                    #+(file-append glibc-utf8-locales "/lib/locale"))
+            (setenv "LC_ALL" "en_US.utf8")
+            (setlocale LC_ALL "en_US.utf8")
 
-          (bindtextdomain "guix-manual"
-                          #+(guix-manual-text-domain source languages))
+            (for-each (lambda (language)
+                        (define directory
+                          (string-append #$output "/"
+                                         (normalize language)))
 
-          (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)
 
-                      (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))
 
@@ -527,7 +900,7 @@ from SOURCE."
                           #:key (languages %languages)
                           (version "0.0")
                           (date (time-second (current-time time-utc)))
-                          (manual "guix"))
+                          (manual %manual))
   "Return the union of the HTML and PDF manuals, as well as the indexes."
   (directory-union (string-append manual "-manual")
                    (map (lambda (proc)