github/repo2html
1
0
Fork 0
Code Issues Pull requests Projects Releases Packages Wiki Activity

pull the relative-link-adjustment rule into a procedure

Browse source
This commit is contained in:
pho4cexa 2022-12-25 23:28:51 -08:00
parent 31b11de1a6
commit 206984b099
1 changed files with 10 additions and 9 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

19
main.scm
View file

@ -116,6 +116,15 @@
(a (@ (title "Permalink to this section") (a (@ (title "Permalink to this section")
(href "#" ,slug)))))) (href "#" ,slug))))))
(define (adjust-relative-link tag inner)
(let ((linkurl (alist-ref-in '(@ href) inner)))
`(,tag .
,(if (or (not adjust-relative)
(any (cute string-prefix? <> linkurl)
'("#" "/" "https://" "http://" "mailto:" "https://")))
inner
(alist-update-in '(@ href) (list adjust-relative linkurl) inner)))))
(define (sxml-html-rules adjust-relative) (define (sxml-html-rules adjust-relative)
`(;; assign all headings an id so you can link to them `(;; assign all headings an id so you can link to them
(h1 . ,enumerate-tag) (h1 . ,enumerate-tag)
@ -125,15 +134,7 @@
(h5 . ,enumerate-tag) (h5 . ,enumerate-tag)
;; if adjust-relative is true, all relative links should get prefixed with ;; if adjust-relative is true, all relative links should get prefixed with
;; the relative-root. ;; the relative-root.
`(a . `(a . ,adjust-relative-link)
,(lambda (t i)
(let ((linkurl (alist-ref-in '(@ href) i)))
`(,t .
,(if (or (not adjust-relative)
(any (cute string-prefix? <> linkurl)
'("#" "/" "https://" "http://" "mailto:" "https://")))
i
(alist-update-in '(@ href) (list adjust-relative linkurl) i))))))
;; this copied from lowdown html-serialization-rules* because it ;; this copied from lowdown html-serialization-rules* because it
;; is for some reason not exported?? ;; is for some reason not exported??
(*COMMENT* . ,(lambda (_ str) (list #\< "!--" str "--" #\>))) (*COMMENT* . ,(lambda (_ str) (list #\< "!--" str "--" #\>)))