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

81
main.scm
View file

@ -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 #<unspecified> 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 #<unspecified> 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)))