ryan77627/guix
1
0
Fork 0
mirror of https://git.in.rschanz.org/ryan77627/guix.git synced 2024-12-24 21:38:07 -05:00
Code Issues Projects Releases Packages Wiki Activity Actions

doc: Support paren matching via CSS hover.

Browse source 
* 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

57
doc/build.scm
View file

@ -215,6 +215,58 @@ (define build
(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 @@ (define (syntax-highlight sxml)
(href #$syntax-css-url)))))
(('pre ('@ ('class "lisp")) code-snippet ...)
`(pre (@ (class "lisp"))
,(highlights->sxml
,@(highlights->sxml*
(pair-open/close
(highlight lex-scheme
(concatenate-snippets code-snippet)))))
(concatenate-snippets code-snippet))))))
((tag ('@ attributes ...) body ...)
`(,tag (@ ,@attributes) ,@(map syntax-highlight body)))
((tag body ...)