summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorLudovic Courtès <ludo@gnu.org>2019-09-25 14:43:46 +0200
committerLudovic Courtès <ludo@gnu.org>2019-09-25 15:46:48 +0200
commit012c93e916279f7df0e495aa1a73f696de15b80e (patch)
treee942fa7f1a59256699135697fac04e540fd09b7b
parentd26c290b7dac642c39f23fd65b4eb0d10534d58d (diff)
downloadpatches-012c93e916279f7df0e495aa1a73f696de15b80e.tar
patches-012c93e916279f7df0e495aa1a73f696de15b80e.tar.gz
doc: Support paren matching via CSS hover.
* doc/build.scm (syntax-highlighted-html)[build](pair-open/close) (highlights->sxml*): New procedures. (syntax-highlight): Use 'highlights->sxml*'.
-rw-r--r--doc/build.scm59
1 files changed, 56 insertions, 3 deletions
diff --git a/doc/build.scm b/doc/build.scm
index 5bc95d2517..b6a921c421 100644
--- a/doc/build.scm
+++ b/doc/build.scm
@@ -215,6 +215,58 @@ its <pre class=\"lisp\"> blocks (as produced by 'makeinfo --html')."
(ice-9 match)
(ice-9 threads))
+ (define (pair-open/close lst)
+ ;; Pair 'open' and 'close' tags produced by 'highlights' and
+ ;; produce nested 'paren' tags instead.
+ (let loop ((lst lst)
+ (level 0)
+ (result '()))
+ (match lst
+ ((('open open) rest ...)
+ (call-with-values
+ (lambda ()
+ (loop rest (+ 1 level) '()))
+ (lambda (inner close rest)
+ (loop rest level
+ (cons `(paren ,level ,open ,inner ,close)
+ result)))))
+ ((('close str) rest ...)
+ (if (> level 0)
+ (values (reverse result) str rest)
+ (begin
+ (format (current-error-port)
+ "warning: extra closing paren; context:~% ~y~%"
+ (reverse result))
+ (loop rest 0 (cons `(close ,str) result)))))
+ ((item rest ...)
+ (loop rest level (cons item result)))
+ (()
+ (when (> level 0)
+ (format (current-error-port)
+ "warning: missing ~a closing parens; context:~% ~y%"
+ level (reverse result)))
+ (values (reverse result) "" '())))))
+
+ (define (highlights->sxml* highlights)
+ ;; Like 'highlights->sxml', but handle nested 'paren tags. This
+ ;; allows for paren matching highlights via appropriate CSS
+ ;; "hover" properties.
+ (define (tag->class tag)
+ (string-append "syntax-" (symbol->string tag)))
+
+ (map (match-lambda
+ ((? string? str) str)
+ (('paren level open (body ...) close)
+ `(span (@ (class ,(string-append "syntax-paren"
+ (number->string level))))
+ ,open
+ (span (@ (class "syntax-symbol"))
+ ,@(highlights->sxml* body))
+ ,close))
+ ((tag text)
+ `(span (@ (class ,(tag->class tag))) ,text)))
+ highlights))
+
(define entity->string
(match-lambda
("rArr" "⇒")
@@ -252,9 +304,10 @@ its <pre class=\"lisp\"> blocks (as produced by 'makeinfo --html')."
(href #$syntax-css-url)))))
(('pre ('@ ('class "lisp")) code-snippet ...)
`(pre (@ (class "lisp"))
- ,(highlights->sxml
- (highlight lex-scheme
- (concatenate-snippets code-snippet)))))
+ ,@(highlights->sxml*
+ (pair-open/close
+ (highlight lex-scheme
+ (concatenate-snippets code-snippet))))))
((tag ('@ attributes ...) body ...)
`(,tag (@ ,@attributes) ,@(map syntax-highlight body)))
((tag body ...)