repair bugs in alist-update-in

dang this hurt my brain. need to figure out a better way
This commit is contained in:
pho4cexa 2022-12-27 21:51:48 -08:00
parent 80a8dbb261
commit 23487309c8

View file

@ -32,6 +32,13 @@
(when msg (print msg)) (when msg (print msg))
(exit status)) (exit status))
;; clojureish "debugging by print statement" tool since i still haven't reached
;; lisp enlightenment
(define ((inspect #!optional label #!rest args) s)
(display (list label ":" args " => " s) (current-error-port))
(newline (current-error-port))
s)
;; decompose a path s into its constituent parts. returns values: ;; decompose a path s into its constituent parts. returns values:
;; ;;
;; root: "/" if it's an absolute path, "" if relative directory-elements: a list ;; root: "/" if it's an absolute path, "" if relative directory-elements: a list
@ -76,19 +83,21 @@
(define (alist-ref-in keys alist #!optional (test eqv?)) (define (alist-ref-in keys alist #!optional (test eqv?))
(if (null? (cdr keys)) (if (null? (cdr keys))
(alist-ref (car keys) alist test) (alist-ref (car keys) alist test)
(alist-ref-in (cdr keys) (alist-ref (car keys) alist test)))) (alist-ref-in (cdr keys) (alist-ref (car keys) alist test) test)))
;; like alist-update, but works on nested alists by specifying a path (list of ;; like alist-update, but works on nested alists by specifying a path (list of
;; keys) ;; keys)
(define (alist-update-in keys value alist #!optional (test eqv?)) (define (alist-update-in keys value alist #!optional (test eqv?))
(if (null? (cdr keys)) (cond
(alist-update (car keys) value alist test) ((not alist) #f)
((null? (cdr keys))
(alist-update (car keys) value alist test))
(else
(alist-update (car keys) (alist-update (car keys)
(alist-update-in (cdr keys) value (alist-ref (car keys) alist test) test) (alist-update-in (cdr keys) value (alist-ref (car keys) alist test) test)
alist test))) alist test))))
;; auto-apply ids to headings --------------------------------- ;; auto-apply ids to headings ---------------------------------
(define (slugify _ inner) (define (slugify _ inner)
(-> (->
inner inner
@ -113,17 +122,17 @@
`(,tag `(,tag
(@ (id ,slug)) (@ (id ,slug))
,inner ,inner
(a (@ (title "Permalink to this section") (a (@ ((title "Permalink to this section")
(href "#" ,slug)))))) (href "#" ,slug)))))))
(define ((adjust-relative-link adjust-relative) tag inner) (define ((adjust-relative-link adjust-relative) tag inner)
(let ((linkurl (alist-ref-in '(@ href) inner))) (let ((linkurl (alist-ref-in '(@ href) inner equal?)))
`(,tag . `(,tag .
,(if (or (not adjust-relative) ,(if (or (not adjust-relative)
(any (cute string-prefix? <> linkurl) (any (cute string-prefix? <> (car linkurl))
'("#" "/" "https://" "http://" "mailto:" "https://"))) '("#" "/" "https://" "http://" "mailto:" "https://")))
inner inner
(alist-update-in '(@ href) (list adjust-relative linkurl) inner))))) (alist-update-in '(@ href) (cons adjust-relative linkurl) inner equal?)))))
(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
@ -133,8 +142,8 @@
(h4 . ,enumerate-tag) (h4 . ,enumerate-tag)
(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 . ,(adjust-relative-link adjust-relative)) (a . ,(adjust-relative-link adjust-relative))
;; 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 "--" #\>)))
@ -198,7 +207,7 @@
((ul ((ul
,(map ,(map
(lambda (source-file) (lambda (source-file)
`(li (a (@ href ,(make-pathname relative-root source-file ".html")) ,source-file))) `(li (a (@ (href ,(make-pathname relative-root source-file ".html"))) ,source-file)))
source-files-list))))) source-files-list)))))
(define (commits->sxml) (define (commits->sxml)
@ -228,7 +237,7 @@
(lambda (source-file) (lambda (source-file)
(and (and
(string-prefix? "ISSUES/" source-file) (string-prefix? "ISSUES/" source-file)
`(li (a (@ href ,source-file ".html") `(li (a (@ (href ,source-file ".html"))
,(-> ,(->
source-file source-file
((flip format) "git show HEAD:~a") ((flip format) "git show HEAD:~a")