- (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. 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)