mirror of
https://git.in.rschanz.org/ryan77627/guix.git
synced 2024-12-24 21:38:07 -05:00
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:
parent
d26c290b7d
commit
012c93e916
1 changed files with 56 additions and 3 deletions
|
@ -215,6 +215,58 @@ (define build
|
||||||
(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 @@ (define (syntax-highlight sxml)
|
||||||
(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 ...)
|
||||||
|
|
Loading…
Reference in a new issue