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.
This commit is contained in:
Ludovic Courtès 2020-04-13 00:12:20 +02:00
parent b36217c54d
commit da9deba13d
No known key found for this signature in database
GPG key ID: 090B11993D9AEBB5

View file

@ -220,8 +220,10 @@ (define build
(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 @@ (define (pair-open/close lst)
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 @@ (define (tag->class tag)
(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 @@ (define (concatenate-snippets pieces)
(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)))
(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 (process-html 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.
(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 @@ (define (copy-as-is file)
(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))