repair bugs in alist-update-in
dang this hurt my brain. need to figure out a better way
This commit is contained in:
parent
80a8dbb261
commit
23487309c8
1 changed files with 28 additions and 19 deletions
47
main.scm
47
main.scm
|
@ -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)
|
||||||
(alist-update (car keys)
|
((null? (cdr keys))
|
||||||
(alist-update-in (cdr keys) value (alist-ref (car keys) alist test) test)
|
(alist-update (car keys) value alist test))
|
||||||
alist test)))
|
(else
|
||||||
|
(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)
|
||||||
(->
|
(->
|
||||||
inner
|
inner
|
||||||
|
@ -110,20 +119,20 @@
|
||||||
|
|
||||||
(define (enumerate-tag tag inner)
|
(define (enumerate-tag tag inner)
|
||||||
(let ((slug (slugify tag inner)))
|
(let ((slug (slugify tag inner)))
|
||||||
`(,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")
|
||||||
|
|
Loading…
Reference in a new issue