amaharaneko/guix-mirrors
1
1
Fork 0
mirror of https://codeberg.org/guix/guix.git synced 2025-10-02 02:15:12 +00:00
Code Issues Projects Releases Packages Wiki Activity Actions

doc: Produce stylable HTML for @deftp, @deffn, etc.

Browse source 
'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.
This commit is contained in:
Ludovic Courtès 2020-10-19 13:21:26 +02:00
parent a9105c2c4c
commit d66a4eac44
No known key found for this signature in database
GPG key ID: 090B11993D9AEBB5
1 changed files with 28 additions and 2 deletions
Download patch file Download diff file Expand all files Collapse all files

30
doc/build.scm
View file

@ -298,13 +298,17 @@ actual file name."
(loop rest)) (loop rest))
((('strong _ ...) _ ...) ((('strong _ ...) _ ...)
#t) #t)
(_ #f)))) ((('span ('@ ('class "symbol-definition-category"))
(? string-or-entity?) ...) rest ...)
#t)
(x
#f))))
(let ((shtml (call-with-input-file file html->shtml))) (let ((shtml (call-with-input-file file html->shtml)))
(let loop ((shtml shtml) (let loop ((shtml shtml)
(anchors anchors)) (anchors anchors))
(match shtml (match shtml
(('dt ('@ ('id id)) rest ...) (('dt ('@ ('id id) _ ...) rest ...)
(if (and (string-prefix? "index-" id) (if (and (string-prefix? "index-" id)
(worthy-entry? rest)) (worthy-entry? rest))
(alist-cons (anchor-id->key id) (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) (pk 'unsupported-code-snippet something)
(primitive-exit 1))))) (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) (define (syntax-highlight sxml anchors)
;; Recurse over SXML and syntax-highlight code snippets. ;; Recurse over SXML and syntax-highlight code snippets.
(let loop ((sxml sxml)) (let loop ((sxml sxml))
@ -497,6 +514,15 @@ its <pre class=\"lisp\"> blocks (as produced by 'makeinfo --html')."
(highlight lex-scheme (highlight lex-scheme
(concatenate-snippets code-snippet))) (concatenate-snippets code-snippet)))
anchors))) 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 ...) body ...)
`(,tag (@ ,@attributes) ,@(map loop body))) `(,tag (@ ,@attributes) ,@(map loop body)))
((tag body ...) ((tag body ...)