doc: Emit hyperlinks in HTML output for @lisp snippets.

This makes it easier to jump to the definition of a procedure or
variable when looking at a code snippet.  There can be false-positive
because scoping rules are ignored, for example, but it should be a good
approximation.

* doc/build.scm (syntax-highlighted-html)[build](highlights->sxml*): Add
'anchors' parameter.  Add clause for ('symbol text).
(syntax-highlight): Add 'anchors' parameter.  Wrap body in named let and
use it in recursive calls.  Pass ANCHORS to 'highlights->sxml*'.
(underscore-decode, anchor-id->key, collect-anchors, html?): New procedures.
(process-file): Add 'anchors' parameter. and honor it.
Rewrite mono-node and multi-node HTML files separately.

1 files changed, 130 insertions, 33 deletions

diff --git a/doc/build.scm b/doc/build.scm
index 8d5b58962a..c3d61f837b 100644
--- a/doc/build.scm
+++ b/doc/build.scm
@@ -220,8 +220,10 @@ its <pre class=\"lisp\"> blocks (as produced by 'makeinfo --html')."
                          (syntax-highlight scheme)
                          (syntax-highlight lexers)
                          (guix build utils)
+                         (srfi srfi-1)
                          (ice-9 match)
-                         (ice-9 threads))
+                         (ice-9 threads)
+                         (ice-9 vlist))
 
             (define (pair-open/close lst)
               ;; Pair 'open' and 'close' tags produced by 'highlights' and
@@ -255,10 +257,11 @@ its <pre class=\"lisp\"> blocks (as produced by 'makeinfo --html')."
                              level (reverse result)))
                    (values (reverse result) "" '())))))
 
-            (define (highlights->sxml* highlights)
+            (define (highlights->sxml* highlights anchors)
               ;; Like 'highlights->sxml', but handle nested 'paren tags.  This
               ;; allows for paren matching highlights via appropriate CSS
-              ;; "hover" properties.
+              ;; "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)))
 
@@ -269,8 +272,16 @@ its <pre class=\"lisp\"> blocks (as produced by 'makeinfo --html')."
                                                        (number->string level))))
                              ,open
                              (span (@ (class "syntax-symbol"))
-                                   ,@(highlights->sxml* body))
+                                   ,@(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))
@@ -301,35 +312,95 @@ its <pre class=\"lisp\"> blocks (as produced by 'makeinfo --html')."
                    (pk 'unsupported-code-snippet something)
                    (primitive-exit 1)))))
 
-            (define (syntax-highlight sxml)
+            (define (syntax-highlight sxml anchors)
               ;; Recurse over SXML and syntax-highlight code snippets.
-              (match sxml
-                (('*TOP* decl body ...)
-                 `(*TOP* ,decl ,@(map syntax-highlight 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))))))
-                ((tag ('@ attributes ...) body ...)
-                 `(,tag (@ ,@attributes) ,@(map syntax-highlight body)))
-                ((tag body ...)
-                 `(,tag ,@(map syntax-highlight body)))
-                ((? string? str)
-                 str)))
-
-            (define (process-html file)
+              (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 <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)))
+
+              (let ((shtml (call-with-input-file file html->shtml)))
+                (let loop ((shtml shtml)
+                           (vhash vhash))
+                  (match shtml
+                    ;; Attempt to match:
+                    ;;  <dt>Scheme Variable: <strong>x</strong></dt>
+                    ;; but not:
+                    ;;  <dt><code>cups-configuration</code> parameter: …</dt>
+                    (('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))
+                     (highlighted  (syntax-highlight shtml anchors))
                      (base         (string-drop file (string-length #$input)))
                      (target       (string-append #$output base)))
                 (mkdir-p (dirname target))
@@ -352,17 +423,43 @@ its <pre class=\"lisp\"> blocks (as produced by 'makeinfo --html')."
                       (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 (file)
-                              (if (string-suffix? ".html" file)
-                                  (process-html file)
-                                  (copy-as-is file)))
-                            (find-files #$input))))))
+                            (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))