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.
master
Ludovic Courtès
parent
1ae7a9251b
commit
f37789a523
161
doc/build.scm
161
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)))
|
||||
(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 @@ 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))
|
||||
|
||||
|
|
|
|||
Reference in New Issue