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

bugfix: apply relative link html/ prefix and .html suffix correctly

Browse source
This commit is contained in:
pho4cexa 2023-01-07 12:02:19 -08:00
parent a49e5697a9
commit 6f93a9d3b4
1 changed files with 47 additions and 34 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

79
main.scm
View file

@ -97,8 +97,12 @@
(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))))
(define (unless-equals s1 s2)
;; if s1 == s2, then s1, otherwise #f
(and (equal? s1 s2) s1))
;; auto-apply ids to headings --------------------------------- ;; auto-apply ids to headings ---------------------------------
(define (slugify _ inner) (define (slugify inner)
(-> (->
inner inner
(pre-post-order* (pre-post-order*
@ -117,45 +121,56 @@
(string-intersperse "") (string-intersperse "")
(substring* 0 40))) (substring* 0 40)))
(define (enumerate-tag tag inner) (define (enumerate-tag inner)
(let ((slug (slugify tag inner))) (let ((slug (slugify inner)))
`(,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) ;; a relative link to a file within our own repo should get .html added to the
(let ((linkurl (alist-ref-in '(@ href) inner equal?))) ;; target, since we make that filename change when rendering files for the web.
`(,tag . ;;
,(if (or (not adjust-relative) ;; thought it might also be good to apply that same treatment to any absolute
(any (cute string-prefix? <> (car linkurl)) ;; links into our repo (or other repos on the same forge?) but that gets a bit
'("#" "/" "https://" "http://" "mailto:" "https://"))) ;; 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 inner
(alist-update-in '(@ href) (cons adjust-relative linkurl) inner equal?))))) (alist-update-in '(@ href) (cons adjust-relative (append linkurl '(".html"))) 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
(h1 . ,enumerate-tag) (h1 . ,(lambda (t i) (cons t (enumerate-tag i))))
(h2 . ,enumerate-tag) (h2 . ,(lambda (t i) (cons t (enumerate-tag i))))
(h3 . ,enumerate-tag) (h3 . ,(lambda (t i) (cons t (enumerate-tag i))))
(h4 . ,enumerate-tag) (h4 . ,(lambda (t i) (cons t (enumerate-tag i))))
(h5 . ,enumerate-tag) (h5 . ,(lambda (t i) (cons t (enumerate-tag i))))
;; 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 . ,(lambda (t i) (cons t (adjust-relative-link adjust-relative i))))
;; this copied from lowdown html-serialization-rules* because it ;; this copied from lowdown's html-serialization-rules* because it is for
;; is for some reason not exported?? ;; some reason not exported, so i can't just import it??
(*COMMENT* . ,(lambda (_ str) (list #\< "!--" str "--" #\>))) (*COMMENT* . ,(lambda (_t i) (list #\< "!--" i "--" #\>)))
;; ignore #<unspecified> in tree ;; ignore any #<unspecified> values in the tree
(*text* . ,(lambda (_ str) (if (unspecified? str) "" str))) (*text* . ,(lambda (_t i) (if (unspecified? i) "" i)))
,@alist-conv-rules*)) ,@alist-conv-rules*))
;; reading in data from git commands ;; reading in data from git commands ---------------------------------
(define (in-git-directory?) (define (in-git-directory?)
(not (eof-object? (call-with-input-pipe "git rev-parse --git-dir" read-line)))) (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) (define (git-file-is-text? source-file)
(not (equal? (not (equal?
"-\t-\t" "-\t-\t"
@ -172,7 +187,7 @@
(call-with-input-pipe read-lines) (call-with-input-pipe read-lines)
(string-intersperse "\n"))) (string-intersperse "\n")))
;; sxml generators for constructed pages ;; sxml generators for constructed pages ---------------------------------
(define (source->sxml source-file) ;; src/main.scm (define (source->sxml source-file) ;; src/main.scm
(define-values (_ _ basename extension _) (define-values (_ _ basename extension _)
@ -207,13 +222,14 @@
((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))) ,source-file)))
source-files-list))))) source-files-list)))))
(define (commits->sxml) (define (commits->sxml)
`((h1 "Commits") `((h1 "Commits")
(table (table
(tr (th "Date") (th "Ref") (th "Log") (th "Author")) (tr
,@(map (lambda x `(th ,x)) '("Date" "Ref" "Log" "Author")))
,(map ,(map
(lambda (line) (lambda (line)
(let-values (((date ref title author) (apply values (string-split line "\t")))) (let-values (((date ref title author) (apply values (string-split line "\t"))))
@ -237,7 +253,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))
,(-> ,(->
source-file source-file
((flip format) "git show HEAD:~a") ((flip format) "git show HEAD:~a")
@ -261,15 +277,12 @@
(let* (;; vars = global vars + file-specific vars (let* (;; vars = global vars + file-specific vars
(vars (alist-merge vars (or newvars '()))) (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 ;; render the sxml to a html string that we can hand to the template
(body-html (body-html
(with-output-to-string (with-output-to-string
(lambda () (lambda ()
(SXML->HTML (pre-post-order* body-sxml (sxml-html-rules (SXML->HTML (pre-post-order* body-sxml (sxml-html-rules adjust-relative))))))
(if (equal? rel-root-prefix "html/")
rel-root-prefix
#f)))))))
;; vars = vars + body k/v pair ;; vars = vars + body k/v pair
(vars (alist-cons 'content body-html vars))) (vars (alist-cons 'content body-html vars)))