diff --git a/main.scm b/main.scm index b4409dd..e4f8d8c 100755 --- a/main.scm +++ b/main.scm @@ -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) - (alist-update (car keys) - (alist-update-in (cdr keys) value (alist-ref (car keys) alist test) test) - 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)))) ;; auto-apply ids to headings --------------------------------- - (define (slugify _ inner) (-> inner @@ -110,20 +119,20 @@ (define (enumerate-tag tag inner) (let ((slug (slugify tag inner))) - `(,tag - (@ (id ,slug)) - ,inner - (a (@ (title "Permalink to this section") - (href "#" ,slug)))))) + `(,tag + (@ (id ,slug)) + ,inner + (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")