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

repair bugs in alist-update-in

Browse source 
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
1 changed files with 28 additions and 19 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

37
main.scm
View file

@ -32,6 +32,13 @@
(when msg (print msg))
(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:
;;
;; 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?))
(if (null? (cdr keys))
(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
;; keys)
(define (alist-update-in keys value alist #!optional (test eqv?))
(if (null? (cdr keys))
(alist-update (car keys) value alist test)
(cond
((not alist) #f)
((null? (cdr keys))
(alist-update (car keys) value alist test))
(else
(alist-update (car keys)
(alist-update-in (cdr keys) value (alist-ref (car keys) alist test) test)
alist test)))
alist test))))
;; auto-apply ids to headings ---------------------------------
(define (slugify _ inner)
(->
inner
@ -113,17 +122,17 @@
`(,tag
(@ (id ,slug))
,inner
(a (@ (title "Permalink to this section")
(href "#" ,slug))))))
(a (@ ((title "Permalink to this section")
(href "#" ,slug)))))))
(define ((adjust-relative-link adjust-relative) tag inner)
(let ((linkurl (alist-ref-in '(@ href) inner)))
(let ((linkurl (alist-ref-in '(@ href) inner equal?)))
`(,tag .
,(if (or (not adjust-relative)
(any (cute string-prefix? <> linkurl)
(any (cute string-prefix? <> (car linkurl))
'("#" "/" "https://" "http://" "mailto:" "https://")))
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)
`(;; assign all headings an id so you can link to them
@ -133,8 +142,8 @@
(h4 . ,enumerate-tag)
(h5 . ,enumerate-tag)
;; if adjust-relative is true, all relative links should get prefixed with
;; the relative-root.
`(a . ,(adjust-relative-link adjust-relative))
;; the relative-root
(a . ,(adjust-relative-link adjust-relative))
;; this copied from lowdown html-serialization-rules* because it
;; is for some reason not exported??
(*COMMENT* . ,(lambda (_ str) (list #\< "!--" str "--" #\>)))
@ -198,7 +207,7 @@
((ul
,(map
(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)))))
(define (commits->sxml)
@ -228,7 +237,7 @@
(lambda (source-file)
(and
(string-prefix? "ISSUES/" source-file)
`(li (a (@ href ,source-file ".html")
`(li (a (@ (href ,source-file ".html"))
,(->
source-file
((flip format) "git show HEAD:~a")