nixo
/
guix-devel
1
0
Fork 0
Code Issues Pull Requests Releases Wiki Activity

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*'.
This commit is contained in:
Ludovic Courtès 2019-09-25 14:43:46 +02:00
parent d26c290b7d
commit 012c93e916
No known key found for this signature in database
GPG Key ID: 090B11993D9AEBB5
1 changed files with 56 additions and 3 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

59
doc/build.scm
View File

@ -215,6 +215,58 @@ its <pre class=\"lisp\"> blocks (as produced by 'makeinfo --html')."
(ice-9 match) (ice-9 match)
(ice-9 threads)) (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 (define entity->string
(match-lambda (match-lambda
("rArr" "⇒") ("rArr" "⇒")
@ -252,9 +304,10 @@ its <pre class=\"lisp\"> blocks (as produced by 'makeinfo --html')."
(href #$syntax-css-url))))) (href #$syntax-css-url)))))
(('pre ('@ ('class "lisp")) code-snippet ...) (('pre ('@ ('class "lisp")) code-snippet ...)
`(pre (@ (class "lisp")) `(pre (@ (class "lisp"))
,(highlights->sxml ,@(highlights->sxml*
(highlight lex-scheme (pair-open/close
(concatenate-snippets code-snippet))))) (highlight lex-scheme
(concatenate-snippets code-snippet))))))
((tag ('@ attributes ...) body ...) ((tag ('@ attributes ...) body ...)
`(,tag (@ ,@attributes) ,@(map syntax-highlight body))) `(,tag (@ ,@attributes) ,@(map syntax-highlight body)))
((tag body ...) ((tag body ...)