Merge branch 'master' into staging

1 files changed, 353 insertions, 104 deletions

diff --git a/doc/build.scm b/doc/build.scm
index 97f4ab6b83..dac62493f4 100644
--- a/doc/build.scm
+++ b/doc/build.scm
@@ -33,6 +33,7 @@
              (guix utils)
              (git)
              (gnu packages base)
+             (gnu packages compression)
              (gnu packages gawk)
              (gnu packages gettext)
              (gnu packages guile)
@@ -40,7 +41,10 @@
              (gnu packages iso-codes)
              (gnu packages texinfo)
              (gnu packages tex)
+             (ice-9 match)
+             (srfi srfi-1)
              (srfi srfi-19)
+             (srfi srfi-26)
              (srfi srfi-71))
 
 (define file-append*
@@ -204,9 +208,168 @@ content=\"width=device-width, initial-scale=1\" />"))
                (setenv "XFAIL_TESTS" "htmlprag.scm")
                #t))))))))
 
+(define (normalize-language-code language)        ;XXX: deduplicate
+  ;; Normalize LANGUAGE.  For instance, "zh_CN" becomes "zh-cn".
+  (string-map (match-lambda
+                (#\_ #\-)
+                (chr chr))
+              (string-downcase language)))
+
+(define* (html-manual-identifier-index manual base-url
+                                       #:key
+                                       (name "html-manual-identifier-index"))
+  "Return an index of all the identifiers that appear in MANUAL, a
+makeinfo-generated manual.  The index is a file that contains an alist; each
+key is an identifier and the associated value is the URL reference pointing to
+that identifier.  The URL is constructed by concatenating BASE-URL to the
+actual file name."
+  (define build
+    (with-extensions (list guile-lib/htmlprag-fixed)
+      (with-imported-modules '((guix build utils))
+        #~(begin
+            (use-modules (guix build utils)
+                         (htmlprag)
+                         (srfi srfi-1)
+                         (srfi srfi-26)
+                         (ice-9 ftw)
+                         (ice-9 match)
+                         (ice-9 threads)
+                         (ice-9 pretty-print))
+
+            (define file-url
+              (let ((prefix (string-append #$manual "/")))
+                (lambda (file)
+                  ;; Return the URL for FILE.
+                  (let ((file (string-drop file (string-length prefix)))
+                        (base #$base-url))
+                    (if (string-null? base)
+                        file
+                        (string-append base "/" file))))))
+
+            (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.  Drop the suffix of
+              ;; duplicate anchor IDs like "operating_002dsystem-1".
+              (let ((id (if (any (cut string-suffix? <> id)
+                                 '("-1" "-2" "-3" "-4" "-5"))
+                            (string-drop-right id 2)
+                            id)))
+                (underscore-decode
+                 (string-drop id (string-length "index-")))))
+
+            (define* (collect-anchors file #:optional (anchors '()))
+              ;; Collect the anchors that appear in FILE, a makeinfo-generated
+              ;; file.  Grab those from <dt> tags, which corresponds to
+              ;; Texinfo @deftp, @defvr, etc.  Return ANCHORS augmented with
+              ;; more name/reference pairs.
+              (define string-or-entity?
+                (match-lambda
+                  ((? string?) #t)
+                  (('*ENTITY* _ ...) #t)
+                  (_ #f)))
+
+              (define (worthy-entry? lst)
+                ;; Attempt to match:
+                ;;   Scheme Variable: <strong>x</strong>
+                ;; but not:
+                ;;   <code>cups-configuration</code> parameter: …
+                (let loop ((lst lst))
+                  (match lst
+                    (((? string-or-entity?) rest ...)
+                     (loop rest))
+                    ((('strong _ ...) _ ...)
+                     #t)
+                    (_ #f))))
+
+              (let ((shtml (call-with-input-file file html->shtml)))
+                (let loop ((shtml shtml)
+                           (anchors anchors))
+                  (match shtml
+                    (('dt ('@ ('id id)) rest ...)
+                     (if (and (string-prefix? "index-" id)
+                              (worthy-entry? rest))
+                         (alist-cons (anchor-id->key id)
+                                     (string-append (file-url file)
+                                                    "#" id)
+                                     anchors)
+                         anchors))
+                    ((tag ('@ _ ...) body ...)
+                     (fold loop anchors body))
+                    ((tag body ...)
+                     (fold loop anchors body))
+                    (_ anchors)))))
+
+            (define (html-files directory)
+              ;; Return the list of HTML files under DIRECTORY.
+              (map (cut string-append directory "/" <>)
+                   (scandir #$manual (lambda (file)
+                                       (string-suffix? ".html" file)))))
+
+            (define anchors
+              (sort (concatenate
+                     (n-par-map (parallel-job-count)
+                                (cut collect-anchors <>)
+                                (html-files #$manual)))
+                    (match-lambda*
+                      (((key1 . url1) (key2 . url2))
+                       (if (string=? key1 key2)
+                           (string<? url1 url2)
+                           (string<? key1 key2))))))
+
+            (call-with-output-file #$output
+              (lambda (port)
+                (display ";; Identifier index for the manual.\n\n"
+                         port)
+                (pretty-print anchors port)))))))
+
+  (computed-file name build))
+
+(define* (html-identifier-indexes manual directory-suffix
+                                  #:key (languages %languages)
+                                  (manual-name %manual)
+                                  (base-url (const "")))
+  (map (lambda (language)
+         (let ((language (normalize-language-code language)))
+           (list language
+                 (html-manual-identifier-index
+                  (file-append manual "/" language directory-suffix)
+                  (base-url language)
+                  #:name (string-append manual-name "-html-index-"
+                                        language)))))
+       languages))
+
 (define* (syntax-highlighted-html input
                                   #:key
                                   (name "highlighted-syntax")
+                                  (languages %languages)
+                                  (mono-node-indexes
+                                   (html-identifier-indexes input ""
+                                                            #:languages
+                                                            languages))
+                                  (split-node-indexes
+                                   (html-identifier-indexes input
+                                                            "/html_node"
+                                                            #:languages
+                                                            languages))
                                   (syntax-css-url
                                    "/static/base/css/code.css"))
   "Return a derivation called NAME that processes all the HTML files in INPUT
@@ -341,78 +504,6 @@ its <pre class=\"lisp\"> blocks (as produced by 'makeinfo --html')."
                   ((? 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.  Drop the suffix of
-              ;; duplicate anchor IDs like "operating_002dsystem-1".
-              (let ((id (if (any (cut string-suffix? <> id)
-                                 '("-1" "-2" "-3" "-4" "-5"))
-                            (string-drop-right id 2)
-                            id)))
-                (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 <dt> 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)))
-
-              (define (worthy-entry? lst)
-                ;; Attempt to match:
-                ;;   Scheme Variable: <strong>x</strong>
-                ;; but not:
-                ;;   <code>cups-configuration</code> parameter: …
-                (let loop ((lst lst))
-                  (match lst
-                    (((? string-or-entity?) rest ...)
-                     (loop rest))
-                    ((('strong _ ...) _ ...)
-                     #t)
-                    (_ #f))))
-
-              (let ((shtml (call-with-input-file file html->shtml)))
-                (let loop ((shtml shtml)
-                           (vhash vhash))
-                  (match shtml
-                    (('dt ('@ ('id id)) rest ...)
-                     (if (and (string-prefix? "index-" id)
-                              (worthy-entry? rest))
-                         (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.
@@ -444,38 +535,59 @@ its <pre class=\"lisp\"> blocks (as produced by 'makeinfo --html')."
             (define (html? file stat)
               (string-suffix? ".html" file))
 
+            (define language+node-anchors
+              (match-lambda
+                ((language files ...)
+                 (cons language
+                       (fold (lambda (file vhash)
+                               (let ((alist (call-with-input-file file read)))
+                                 ;; Use 'fold-right' so that the first entry
+                                 ;; wins (e.g., "car" from "Pairs" rather than
+                                 ;; from "rnrs base" in the Guile manual).
+                                 (fold-right (match-lambda*
+                                               (((key . value) vhash)
+                                                (vhash-cons key value vhash)))
+                                             vhash
+                                             alist)))
+                             vlist-null
+                             files)))))
+
+            (define mono-node-anchors
+              ;; List of language/vhash pairs, where each vhash maps an
+              ;; identifier to the corresponding URL in a single-page manual.
+              (map language+node-anchors '#$mono-node-indexes))
+
+            (define multi-node-anchors
+              ;; Likewise for split-node manuals.
+              (map language+node-anchors '#$split-node-indexes))
+
             ;; 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(-cookbook|)(\\.[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)))
+            (for-each (match-lambda
+                        ((language . anchors)
+                         (let ((files (find-files
+                                       (string-append #$input "/" language)
+                                       "^guix(-cookbook|)(\\.[a-zA-Z_-]+)?\\.html$")))
+                           (n-par-for-each (parallel-job-count)
+                                           (cut process-html <> anchors)
+                                           files))))
+                      mono-node-anchors)
+
+            ;; Process the multi-node HTML files.
+            (for-each (match-lambda
+                        ((language . anchors)
+                         (let ((files (find-files
+                                       (string-append #$input "/" language
+                                                      "/html_node")
+                                       "\\.html$")))
+                           (n-par-for-each (parallel-job-count)
+                                           (cut process-html <> anchors)
+                                           files))))
+                      multi-node-anchors)
 
             ;; Last, copy non-HTML files as is.
             (for-each copy-as-is
@@ -486,6 +598,8 @@ its <pre class=\"lisp\"> blocks (as produced by 'makeinfo --html')."
 (define* (html-manual source #:key (languages %languages)
                       (version "0.0")
                       (manual %manual)
+                      (mono-node-indexes (map list languages))
+                      (split-node-indexes (map list languages))
                       (date 1)
                       (options %makeinfo-html-options))
   "Return the HTML manuals built from SOURCE for all LANGUAGES, with the given
@@ -574,6 +688,8 @@ makeinfo OPTIONS."
   (let* ((name   (string-append manual "-html-manual"))
          (manual (computed-file name build)))
     (syntax-highlighted-html manual
+                             #:mono-node-indexes mono-node-indexes
+                             #:split-node-indexes split-node-indexes
                              #:name (string-append name "-highlighted"))))
 
 (define* (pdf-manual source #:key (languages %languages)
@@ -920,6 +1036,8 @@ languages:\n"
                           #:key (languages %languages)
                           (version "0.0")
                           (date (time-second (current-time time-utc)))
+                          (mono-node-indexes (map list %languages))
+                          (split-node-indexes (map list %languages))
                           (manual %manual))
   "Return the union of the HTML and PDF manuals, as well as the indexes."
   (directory-union (string-append manual "-manual")
@@ -930,7 +1048,12 @@ languages:\n"
                                 #:version version
                                 #:manual manual))
                         (list html-manual-indexes
-                              html-manual pdf-manual))
+                              (lambda (source . args)
+                                (apply html-manual source
+                                       #:mono-node-indexes mono-node-indexes
+                                       #:split-node-indexes split-node-indexes
+                                       args))
+                              pdf-manual))
                    #:copy? #t))
 
 (define (latest-commit+date directory)
@@ -944,17 +1067,143 @@ commit date (an integer)."
     (values (oid->string oid) (commit-time commit))))
 
 
+;;;
+;;; Guile manual.
+;;;
+
+(define guile-manual
+  ;; The Guile manual as HTML, including both the mono-node "guile.html" and
+  ;; the split-node "html_node" directory.
+  (let ((guile guile-3.0-latest))
+    (computed-file (string-append "guile-manual-" (package-version guile))
+                   (with-imported-modules '((guix build utils))
+                     #~(begin
+                         (use-modules (guix build utils)
+                                      (ice-9 match))
+
+                         (setenv "PATH"
+                                 (string-append #+tar "/bin:"
+                                                #+xz "/bin:"
+                                                #+texinfo "/bin"))
+                         (invoke "tar" "xf" #$(package-source guile))
+                         (mkdir-p (string-append #$output "/en/html_node"))
+
+                         (let* ((texi (find-files "." "^guile\\.texi$"))
+                                (documentation (match texi
+                                                 ((file) (dirname file)))))
+                           (with-directory-excursion documentation
+                             (invoke "makeinfo" "--html" "--no-split"
+                                     "-o" (string-append #$output
+                                                         "/en/guile.html")
+                                     "guile.texi")
+                             (invoke "makeinfo" "--html" "-o" "split"
+                                     "guile.texi")
+                             (copy-recursively
+                              "split"
+                              (string-append #$output "/en/html_node")))))))))
+
+(define %guile-manual-base-url
+  "https://www.gnu.org/software/guile/manual")
+
+(define (for-all-languages index)
+  (map (lambda (language)
+         (list language index))
+       %languages))
+
+(define guile-mono-node-indexes
+  ;; The Guile manual is only available in English so use the same index in
+  ;; all languages.
+  (for-all-languages
+   (html-manual-identifier-index (file-append guile-manual "/en")
+                                 %guile-manual-base-url
+                                 #:name "guile-html-index-en")))
+
+(define guile-split-node-indexes
+  (for-all-languages
+   (html-manual-identifier-index (file-append guile-manual "/en/html_node")
+                                 (string-append %guile-manual-base-url
+                                                "/html_node")
+                                 #:name "guile-html-index-en")))
+
+(define (merge-index-alists alist1 alist2)
+  "Merge ALIST1 and ALIST2, both of which are list of tuples like:
+
+  (LANGUAGE INDEX1 INDEX2 ...)
+
+where LANGUAGE is a string like \"en\" and INDEX1 etc. are indexes as returned
+by 'html-identifier-indexes'."
+  (let ((languages (delete-duplicates
+                    (append (match alist1
+                              (((languages . _) ...)
+                               languages))
+                            (match alist2
+                              (((languages . _) ...)
+                               languages))))))
+    (map (lambda (language)
+           (cons language
+                 (append (or (assoc-ref alist1 language) '())
+                         (or (assoc-ref alist2 language) '()))))
+         languages)))
+
+
 (let* ((root (canonicalize-path
               (string-append (current-source-directory) "/..")))
-       (commit date (latest-commit+date root)))
+       (commit date (latest-commit+date root))
+       (version (or (getenv "GUIX_MANUAL_VERSION")
+                    (string-take commit 7)))
+       (select? (let ((vcs? (git-predicate root)))
+                  (lambda (file stat)
+                    (and (vcs? file stat)
+                         ;; Filter out this file.
+                         (not (string=? (basename file) "build.scm"))))))
+       (source (local-file root "guix" #:recursive? #t
+                           #:select? select?)))
+
+  (define guix-manual
+    (html-manual source
+                 #:manual "guix"
+                 #:version version
+                 #:date date))
+
+  (define guix-mono-node-indexes
+    ;; Alist of indexes for GUIX-MANUAL, where each key is a language code and
+    ;; each value is a file-like object containing the identifier index.
+    (html-identifier-indexes guix-manual ""
+                             #:manual-name "guix"
+                             #:base-url (if (string=? %manual "guix")
+                                            (const "")
+                                            (cut string-append "/manual/" <>))
+                             #:languages %languages))
+
+  (define guix-split-node-indexes
+    ;; Likewise for the split-node variant of GUIX-MANUAL.
+    (html-identifier-indexes guix-manual "/html_node"
+                             #:manual-name "guix"
+                             #:base-url (if (string=? %manual "guix")
+                                            (const "")
+                                            (cut string-append "/manual/" <>
+                                                 "/html_node"))
+                             #:languages %languages))
+
+  (define mono-node-indexes
+    (merge-index-alists guix-mono-node-indexes guile-mono-node-indexes))
+
+  (define split-node-indexes
+    (merge-index-alists guix-split-node-indexes guile-split-node-indexes))
+
   (format (current-error-port)
           "building manual from work tree around commit ~a, ~a~%"
           commit
           (let* ((time (make-time time-utc 0 date))
                  (date (time-utc->date time)))
             (date->string date "~e ~B ~Y")))
-  (pdf+html-manual (local-file root "guix" #:recursive? #t
-                               #:select? (git-predicate root))
-                   #:version (or (getenv "GUIX_MANUAL_VERSION")
-                                 (string-take commit 7))
+
+  (pdf+html-manual source
+                   ;; Always use the identifier indexes of GUIX-MANUAL and
+                   ;; GUILE-MANUAL.  Both "guix" and "guix-cookbook" can
+                   ;; contain links to definitions that appear in either of
+                   ;; these two manuals.
+                   #:mono-node-indexes mono-node-indexes
+                   #:split-node-indexes split-node-indexes
+                   #:version version
                    #:date date))