From d66a4eac4402614a1938fdc4ef0fde0c06badb52 Mon Sep 17 00:00:00 2001
From: =?UTF-8?q?Ludovic=20Court=C3=A8s?= <ludo@gnu.org>
Date: Mon, 19 Oct 2020 13:21:26 +0200
Subject: doc: Produce stylable HTML for @deftp, @deffn, etc.

'makeinfo --help' uses <strong> and <em> for those entries.  Replace
that with CSS classes.

* doc/build.scm (html-manual-identifier-index)[build]: Adjust to handle
rewritten forms of <dt> entries.
* doc/build.scm (syntax-highlighted-html)[build][syntax-highlight]:
Handle <dt> forms and replace them.
[highlight-definition, space?]: New procedures.
---
 doc/build.scm | 30 ++++++++++++++++++++++++++++--
 1 file changed, 28 insertions(+), 2 deletions(-)

(limited to 'doc/build.scm')

diff --git a/doc/build.scm b/doc/build.scm
index dac62493f4..7d17a16d2a 100644
--- a/doc/build.scm
+++ b/doc/build.scm
@@ -298,13 +298,17 @@ actual file name."
                      (loop rest))
                     ((('strong _ ...) _ ...)
                      #t)
-                    (_ #f))))
+                    ((('span ('@ ('class "symbol-definition-category"))
+                             (? string-or-entity?) ...) rest ...)
+                     #t)
+                    (x
+                     #f))))
 
               (let ((shtml (call-with-input-file file html->shtml)))
                 (let loop ((shtml shtml)
                            (anchors anchors))
                   (match shtml
-                    (('dt ('@ ('id id)) rest ...)
+                    (('dt ('@ ('id id) _ ...) rest ...)
                      (if (and (string-prefix? "index-" id)
                               (worthy-entry? rest))
                          (alist-cons (anchor-id->key id)
@@ -479,6 +483,19 @@ its <pre class=\"lisp\"> blocks (as produced by 'makeinfo --html')."
                    (pk 'unsupported-code-snippet something)
                    (primitive-exit 1)))))
 
+            (define (highlight-definition id category symbol args)
+              ;; Produce stylable HTML for the given definition (an @deftp,
+              ;; @deffn, or similar).
+              `(dt (@ (id ,id) (class "symbol-definition"))
+                   (span (@ (class "symbol-definition-category"))
+                         ,@category)
+                   (span (@ (class "symbol-definition-prototype"))
+                         ,symbol " " ,@args)))
+
+            (define (space? obj)
+              (and (string? obj)
+                   (string-every char-set:whitespace obj)))
+
             (define (syntax-highlight sxml anchors)
               ;; Recurse over SXML and syntax-highlight code snippets.
               (let loop ((sxml sxml))
@@ -497,6 +514,15 @@ its <pre class=\"lisp\"> blocks (as produced by 'makeinfo --html')."
                              (highlight lex-scheme
                                         (concatenate-snippets code-snippet)))
                             anchors)))
+
+                  ;; Replace the ugly <strong> used for @deffn etc., which
+                  ;; translate to <dt>, with more stylable markup.
+                  (('dt (@ ('id id)) category ... ('strong thing))
+                   (highlight-definition id category thing '()))
+                  (('dt (@ ('id id)) category ... ('strong thing)
+                        (? space?) ('em args ...))
+                   (highlight-definition id category thing args))
+
                   ((tag ('@ attributes ...) body ...)
                    `(,tag (@ ,@attributes) ,@(map loop body)))
                   ((tag body ...)
-- 
cgit v1.2.3