aboutsummaryrefslogtreecommitdiff
path: root/doc/build.scm
diff options
context:
space:
mode:
Diffstat (limited to 'doc/build.scm')
-rw-r--r--doc/build.scm30
1 files changed, 28 insertions, 2 deletions
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 ...)