From 6f93a9d3b4c0be42049fd8d6168993f407fa8073 Mon Sep 17 00:00:00 2001 From: pho4cexa Date: Sat, 7 Jan 2023 12:02:19 -0800 Subject: [PATCH] bugfix: apply relative link html/ prefix and .html suffix correctly --- main.scm | 81 ++++++++++++++++++++++++++++++++------------------------ 1 file changed, 47 insertions(+), 34 deletions(-) diff --git a/main.scm b/main.scm index e4f8d8c..cfea6be 100755 --- a/main.scm +++ b/main.scm @@ -97,8 +97,12 @@ (alist-update-in (cdr keys) value (alist-ref (car keys) alist test) test) alist test)))) +(define (unless-equals s1 s2) + ;; if s1 == s2, then s1, otherwise #f + (and (equal? s1 s2) s1)) + ;; auto-apply ids to headings --------------------------------- -(define (slugify _ inner) +(define (slugify inner) (-> inner (pre-post-order* @@ -117,45 +121,56 @@ (string-intersperse "") (substring* 0 40))) -(define (enumerate-tag tag inner) - (let ((slug (slugify tag inner))) - `(,tag - (@ (id ,slug)) +(define (enumerate-tag inner) + (let ((slug (slugify inner))) + `((@ (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 equal?))) - `(,tag . - ,(if (or (not adjust-relative) - (any (cute string-prefix? <> (car linkurl)) - '("#" "/" "https://" "http://" "mailto:" "https://"))) - inner - (alist-update-in '(@ href) (cons adjust-relative linkurl) inner equal?))))) +;; a relative link to a file within our own repo should get .html added to the +;; target, since we make that filename change when rendering files for the web. +;; +;; thought it might also be good to apply that same treatment to any absolute +;; links into our repo (or other repos on the same forge?) but that gets a bit +;; messy, would need to drag variables holding current site, path, repo name all +;; the way into here +;; +;; if adjust-relative is not false, it is a prefix to be added to relative +;; links, to make the top-level readme link correctly into the site. +(define (adjust-relative-link adjust-relative inner) + (let* ((linkurl (alist-ref-in '(@ href) inner equal?)) + (linkurl-startswith (cute string-prefix? <> (car linkurl)))) + (if + (any linkurl-startswith '("#" "mailto:" "gemini:" "http://" "https://")) + inner + (alist-update-in '(@ href) (cons adjust-relative (append linkurl '(".html"))) inner equal?)))) (define (sxml-html-rules adjust-relative) `(;; assign all headings an id so you can link to them - (h1 . ,enumerate-tag) - (h2 . ,enumerate-tag) - (h3 . ,enumerate-tag) - (h4 . ,enumerate-tag) - (h5 . ,enumerate-tag) + (h1 . ,(lambda (t i) (cons t (enumerate-tag i)))) + (h2 . ,(lambda (t i) (cons t (enumerate-tag i)))) + (h3 . ,(lambda (t i) (cons t (enumerate-tag i)))) + (h4 . ,(lambda (t i) (cons t (enumerate-tag i)))) + (h5 . ,(lambda (t i) (cons t (enumerate-tag i)))) ;; if adjust-relative is true, all relative links should get prefixed with ;; 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 "--" #\>))) - ;; ignore # in tree - (*text* . ,(lambda (_ str) (if (unspecified? str) "" str))) + (a . ,(lambda (t i) (cons t (adjust-relative-link adjust-relative i)))) + ;; this copied from lowdown's html-serialization-rules* because it is for + ;; some reason not exported, so i can't just import it?? + (*COMMENT* . ,(lambda (_t i) (list #\< "!--" i "--" #\>))) + ;; ignore any # values in the tree + (*text* . ,(lambda (_t i) (if (unspecified? i) "" i))) ,@alist-conv-rules*)) -;; reading in data from git commands +;; reading in data from git commands --------------------------------- (define (in-git-directory?) (not (eof-object? (call-with-input-pipe "git rev-parse --git-dir" read-line)))) +;; a weird hack to detect whether git considers a blob to be a binary or a text +;; file. works by requesting the numstat diff between it and the empty tree. +;; binary files give not a line count but '-' placeholders. (define (git-file-is-text? source-file) (not (equal? "-\t-\t" @@ -172,7 +187,7 @@ (call-with-input-pipe read-lines) (string-intersperse "\n"))) -;; sxml generators for constructed pages +;; sxml generators for constructed pages --------------------------------- (define (source->sxml source-file) ;; src/main.scm (define-values (_ _ basename extension _) @@ -207,13 +222,14 @@ ((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))) ,source-file))) source-files-list))))) (define (commits->sxml) `((h1 "Commits") (table - (tr (th "Date") (th "Ref") (th "Log") (th "Author")) + (tr + ,@(map (lambda x `(th ,x)) '("Date" "Ref" "Log" "Author"))) ,(map (lambda (line) (let-values (((date ref title author) (apply values (string-split line "\t")))) @@ -237,7 +253,7 @@ (lambda (source-file) (and (string-prefix? "ISSUES/" source-file) - `(li (a (@ (href ,source-file ".html")) + `(li (a (@ (href ,source-file)) ,(-> source-file ((flip format) "git show HEAD:~a") @@ -261,15 +277,12 @@ (let* (;; vars = global vars + file-specific vars (vars (alist-merge vars (or newvars '()))) - (rel-root-prefix (alist-ref 'relative_root vars)) + (adjust-relative (unless-equals (alist-ref 'relative_root vars) "html/")) ;; render the sxml to a html string that we can hand to the template (body-html (with-output-to-string (lambda () - (SXML->HTML (pre-post-order* body-sxml (sxml-html-rules - (if (equal? rel-root-prefix "html/") - rel-root-prefix - #f))))))) + (SXML->HTML (pre-post-order* body-sxml (sxml-html-rules adjust-relative)))))) ;; vars = vars + body k/v pair (vars (alist-cons 'content body-html vars)))