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

update-in and ref-in (takes a path of keys) for nested alists

Browse source
This commit is contained in:
pho4cexa 2022-12-25 23:16:07 -08:00
parent 17ce8565f8
commit 31b11de1a6
1 changed files with 21 additions and 9 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

30
main.scm
View file

@ -72,6 +72,21 @@
(define (alist-merge a b) (define (alist-merge a b)
(lset-union (lambda (x y) (eq? (car x) (car y))) a b)) (lset-union (lambda (x y) (eq? (car x) (car y))) a b))
;; like alist-ref but works on nested alists by specifying a path (list of keys)
(define (alist-ref-in keys alist #!optional (test eqv?))
(if (null? (cdr keys))
(alist-ref (car keys) alist test)
(alist-ref-in (cdr keys) (alist-ref (car keys) alist test))))
;; like alist-update, but works on nested alists by specifying a path (list of
;; keys)
(define (alist-update-in keys value alist #!optional (test eqv?))
(if (null? (cdr keys))
(alist-update (car keys) value alist test)
(alist-update (car keys)
(alist-update-in (cdr keys) value (alist-ref (car keys) alist test) test)
alist test)))
;; auto-apply ids to headings --------------------------------- ;; auto-apply ids to headings ---------------------------------
(define (slugify _ inner) (define (slugify _ inner)
@ -112,16 +127,13 @@
;; the relative-root. ;; the relative-root.
`(a . `(a .
,(lambda (t i) ,(lambda (t i)
(let ((linkurl (alist-ref 'href (alist-ref '@ i)))) (let ((linkurl (alist-ref-in '(@ href) i)))
`(,t . `(,t .
,(if (and adjust-relative ,(if (or (not adjust-relative)
(not (any (any (cute string-prefix? <> linkurl)
(cute string-prefix? <> linkurl) '("#" "/" "https://" "http://" "mailto:" "https://")))
'("#" "/" "https://" "http://" "mailto:" "https://")))) i
(alist-update '@ (alist-update-in '(@ href) (list adjust-relative linkurl) i))))))
(alist-update 'href `(,adjust-relative ,linkurl) (alist-ref '@ i))
i)
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 "--" #\>)))