diff --git a/README.md b/README.md index 81808d1..d1bc96a 100644 --- a/README.md +++ b/README.md @@ -28,15 +28,16 @@ no one is liable if this software breaks, deletes, corrupts, or ruins anything ## requirements - [chicken scheme](https://call-cc.org/), and eggs: - - [utf8](https://wiki.call-cc.org/eggref/5/utf8) - - [lowdown](https://wiki.call-cc.org/eggref/5/lowdown) - - [sxml-transforms](https://wiki.call-cc.org/eggref/5/sxml-transforms) - [clojurian](https://wiki.call-cc.org/eggref/5/clojurian) - - [symbol-utils](https://wiki.call-cc.org/eggref/5/symbol-utils) + - [ersatz](https://wiki.call-cc.org/eggref/5/ersatz) + - [lowdown](https://wiki.call-cc.org/eggref/5/lowdown) - [scss](https://wiki.call-cc.org/eggref/5/scss) - [srfi-1](https://wiki.call-cc.org/eggref/5/srfi-1) - [srfi-13](https://wiki.call-cc.org/eggref/5/srfi-13) - [srfi-14](https://wiki.call-cc.org/eggref/5/srfi-14) + - [sxml-transforms](https://wiki.call-cc.org/eggref/5/sxml-transforms) + - [symbol-utils](https://wiki.call-cc.org/eggref/5/symbol-utils) + - [utf8](https://wiki.call-cc.org/eggref/5/utf8) - git ### installation @@ -65,7 +66,6 @@ TODO - **feature**: multi-page or collapse-able files list - **feature**: branches and releases (tags) - **feature**: clickable line numbers in source files -- **feature**: customizable templates - **feature**: display binary files as output from binary-file analysis tools like hexdump, xxd, dumpelf, elfls, readelf, etc.? - **feature**: syntax highlighting? - **feature**: markdown-render git log text diff --git a/main.scm b/main.scm index 9b2e304..633cad3 100755 --- a/main.scm +++ b/main.scm @@ -10,8 +10,9 @@ (chicken process-context) (chicken string) (clojurian syntax) - scss + ersatz lowdown + scss srfi-1 ;; list utils srfi-13 ;; string utils srfi-14 ;; charsets @@ -37,11 +38,11 @@ ;; decompose a path s into its constituent parts. returns values: ;; -;; root: "/" if it's an absolute path, "" if relative -;; directory-elements: a list of each directory from root, () if none -;; basename: the filename with extension removed like "readme" or ".bashrc" -;; extension: the file extension with the dot, like ".txt" or "" if none -;; relative-root: the relative path from the given path to the root +;; root: "/" if it's an absolute path, "" if relative directory-elements: a list +;; of each directory from root, () if none basename: the filename with extension +;; removed like "readme" or ".bashrc" extension: the file extension with the +;; dot, like ".txt" or "" if none relative-root: the relative path from the +;; given path to the root ;; e.g foo/bar/baz.html -> ../../ ;; ;; this is intended to provide default values that make for easier reassembly @@ -71,9 +72,113 @@ (define (substring* s start end) (substring s (max start 0) (min end (string-length s)))) -;; main code --------------------------------- +;; merge alists a and b. values in b "win" +(define (alist-merge a b) + (lset-union (lambda (x y) (eq? (car x) (car y))) a b)) -(define mycss +;; auto-apply ids to headings --------------------------------- + +(define (slugify _ inner) + (-> + inner + (pre-post-order* + `((*text* . + ,(lambda (_ str) + (if (string? str) + (-> + str + (string-downcase) + (string-translate "/,:;\"[]{}()=+") + (string-translate " _." "---")) + str))) + ,@alist-conv-rules*)) + (flatten) + ((flip map) ->string) + (string-intersperse "") + (substring* 0 40))) + +(define (enumerate-tag tag inner) + `(,tag (@ (id ,tag "-" ,(slugify tag inner))) ,inner)) + +(define sxml-html-rules + `(;; 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) + ;; 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))) + ,@alist-conv-rules*)) + +;; vvv sxml template writer ------------------------------------------------ +;; +;; if we decide to only use the ersatz templates, this whole chunk can be deleted! +;; +;; or we can keep it as a fall-back, or let the user choose which they prefer? idk + +(define (make-template-writer-sxml #!optional vars) + (let* ((source-files-list (alist-ref 'source_files_list vars))) + + (lambda (output-filename body-sxml #!optional newvars) + (if-let (destination-directory (pathname-directory output-filename)) + (create-directory destination-directory #t) + '()) + (let ((vars (alist-merge vars (or newvars '())))) + (with-output-to-file output-filename + (lambda () + (define-values (_ _ _ _ relative-root) (pathparts (or (alist-ref 'source_file vars) ""))) + (display "\n") + (SXML->HTML + (pre-post-order* + (my-sxml-template body-sxml vars) + sxml-html-rules)))))))) + +(define (my-sxml-template body-sxml vars) + (let ( + (clone-url-prefix (alist-ref 'clone_url_prefix vars)) + (forge-title (alist-ref 'forge_title vars)) + (h1 (alist-ref 'h1 vars)) + (issues-file (alist-ref 'issues_file vars)) + (license-file (alist-ref 'license_file vars)) + (readme-file (alist-ref 'readme_file vars)) + (relative-root (alist-ref 'relative_root vars)) + (repository-description (alist-ref 'repository_description vars)) + (repository-name (alist-ref 'repository_name vars)) + (source-file (alist-ref 'source_file vars)) + ) + `(html (@ lang en) + (head + (title ,(string-append forge-title " - " repository-name)) + (meta (@ charset utf-8)) + (meta (@ (name viewport) (content "width=device-width, initial-scale-1.0, user-scalable=yes"))) + (link (@ (rel icon) (href "data:,"))) + (meta (@ (name description) (content ,repository-description))) + (style ,my-css)) + (body + (h1 ,h1) + (h2 ,repository-name) + (p "clone url:" ,clone-url-prefix "/" ,repository-name) + (nav + ,(if readme-file + `((a (@ href ,relative-root "index.html") "about") + (a (@ href ,relative-root "files.html") "files")) + `((a (@ href ,relative-root "index.html") "files"))) + ,(when license-file + `(a (@ href ,relative-root ,license-file ".html") "license")) + ,(when issues-file + `(a (@ href ,relative-root ,issues-file ".html") "issues")) + (a (@ href ,relative-root "commits.html") "commits") + (a (@ href ,relative-root "contributors.html") "contributors"))) + (hr) + ,body-sxml + (hr) + (footer (p "Generated by " (a (@ href "https://git.m455.casa/repo2html/") "repo2html") " using sxml templates"))))) + +(define my-css (with-output-to-string (lambda () (write-css @@ -105,86 +210,31 @@ ;; change this to your liking )))))) -(define (make-sxml-template-wrapper repository-name source-files-list) - (let ((readme-file - (find (lambda (x) (member x source-files-list)) - '("README" "README.md" "README.txt"))) - (license-file - (find (lambda (x) (member x source-files-list)) - '("LICENSE" "LICENSE.md" "LICENSE.txt"))) - (issues-present? - (find (lambda (x) (string-prefix? "ISSUES/" x)) source-files-list))) +;; ^^^ sxml template writer ------------------------------------------------ - (lambda (source-file body-sxml) - (define-values (_ _ _ _ relative-root) (pathparts source-file)) - `(html (@ lang en) - (head - (title ,(string-append TITLE " - " repository-name)) - (meta (@ charset utf-8)) - (meta (@ (name viewport) (content "width=device-width, initial-scale-1.0, user-scalable=yes"))) - (link (@ (rel icon) (href "data:,"))) - (meta (@ (name description) (content ,DESCRIPTION))) - (style ,mycss)) - (body - (h1 ,H1) - (h2 ,repository-name) - (p "clone url:" ,CLONE-URL "/" ,repository-name) - (nav - ,(when readme-file - `(a (@ href ,relative-root "index.html") "about")) - (a (@ href ,relative-root "files.html") "files") - ,(when license-file - `(a (@ href ,relative-root ,license-file ".html") "license")) - ,(when issues-present? - `(a (@ href ,relative-root "ISSUES.html") "issues")) - (a (@ href ,relative-root "commits.html") "commits") - (a (@ href ,relative-root "contributors.html") "contributors"))) - (hr) - ,body-sxml - (hr) - (footer (p "Generated by " (a (@ href "https://git.m455.casa/repo2html/") "repo2html"))))))) - -(define (slugify _ inner) - (-> - inner - (pre-post-order* - `((*text* . - ,(lambda (_ str) - (if (string? str) - (-> - str - (string-downcase) - (string-translate "/,:;\"[]{}()=+") - (string-translate " _." "---")) - str))) - ,@alist-conv-rules*)) - (flatten) - ((flip map) ->string) - (string-intersperse "") - (substring* 0 40))) - -(define (enumerate-tag tag inner) - `(,tag (@ (id ,tag "-" ,(slugify tag inner))) ,inner)) +;; reading in data from git commands (define (in-git-directory?) (not (eof-object? (call-with-input-pipe "git rev-parse --git-dir" read-line)))) -(define (git-file-is-text? path) +(define (git-file-is-text? source-file) (not (equal? - "-\t-\t" - (call-with-input-pipe - (string-append "git diff 4b825dc642cb6eb9a060e54bf8d69288fbee4904 --numstat HEAD -- " path) - (lambda (port) (read-line port 4)))))) + "-\t-\t" + (call-with-input-pipe + (string-append "git diff 4b825dc642cb6eb9a060e54bf8d69288fbee4904 --numstat HEAD -- " source-file) + (lambda (port) (read-line port 4)))))) (define (git-repository->paths-list) (call-with-input-pipe "git ls-tree -r --name-only HEAD" read-lines)) -(define (git-file->string path) +(define (git-file->string source-file) (-> - (format "git show HEAD:~a" path) + (format "git show HEAD:~a" source-file) (call-with-input-pipe read-lines) (string-intersperse "\n"))) +;; sxml generators for constructed pages + (define (source->sxml source-file) ;; src/main.scm (define-values (_ _ basename extension _) (pathparts source-file)) @@ -257,70 +307,112 @@ (string-trim (string->char-set "# "))))))) source-files-list))))) -(define (generate-html-files html-repo-path) - (let* ((source-files-list (git-repository->paths-list)) - (repository-name (pathname-strip-directory (string-chomp html-repo-path "/"))) - (template-wrap->sxml (make-sxml-template-wrapper repository-name source-files-list))) +;; used by ersatz writer +(define (alist->tvals vars) + (map (lambda (pair) + `(,(car pair) . ,(sexpr->tvalue (cdr pair)))) vars)) - (define (write-with-template filename sxml) - (let ((destination-directory (pathname-directory filename))) - (when destination-directory - (create-directory (make-pathname html-repo-path destination-directory) #t))) - (with-output-to-file (make-pathname html-repo-path filename) +;; this version uses a jinja-style template via ersatz +(define (make-template-writer-ersatz templates-directory #!optional vars) + (define template (statements-from-file (template-std-env search-path: (list templates-directory)) "default.html")) + (lambda (output-filename body-sxml #!optional newvars) + ;; create destination directory if needed + (if-let (destination-directory (pathname-directory output-filename)) + (create-directory destination-directory #t) + '()) + + (let* (;; 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))))) + ;; vars = global vars + file-specific vars + body k/v pair + (vars + (alist-cons + 'content body-html + (alist-merge vars (or newvars '()))))) + + (with-output-to-file output-filename (lambda () - (display "\n") - (SXML->HTML - (pre-post-order* - (template-wrap->sxml filename sxml) - `(;; 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) - ;; 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))) - ,@alist-conv-rules*)))))) + (display (eval-statements template models: (alist->tvals vars)))))))) + + ; main program ------------------------------------------------------------------------------ + +(define (generate-html-files html-repo-path templates-directory) + (let* ((source-files-list (git-repository->paths-list)) + (repository-name (pathname-strip-directory (string-chomp html-repo-path "/"))) + (template-alist `(;; variables provided to template at all times + (source_files_list . ,source-files-list) + (clone_url_prefix . ,CLONE-URL) + (forge_title . ,TITLE) + (h1 . ,H1) + (repository_description . ,DESCRIPTION) + (repository_name . ,repository-name) + (readme_file + . ,(find (lambda (x) (member x source-files-list)) + '("README" "README.md" "README.txt"))) + (license_file + . ,(find (lambda (x) (member x source-files-list)) + '("LICENSE" "LICENSE.md" "LICENSE.txt"))) + (issues_file + . ,(and (find (lambda (x) (string-prefix? "ISSUES/" x)) source-files-list) "ISSUES")) + )) + (write-with-template + ;; which template writer do you prefer to use? uncomment one of the next two lines. + (if (equal? "sxml" templates-directory) + (make-template-writer-sxml template-alist) + (make-template-writer-ersatz templates-directory template-alist) + ))) (create-directory html-repo-path #t) ;; special files - (write-with-template "files.html" (filelist->sxml source-files-list)) - (write-with-template "contributors.html" (contributors->sxml)) - (write-with-template "commits.html" (commits->sxml)) + (write-with-template (make-pathname html-repo-path "files" "html") (filelist->sxml source-files-list)) + (write-with-template (make-pathname html-repo-path "contributors" "html") (contributors->sxml)) + (write-with-template (make-pathname html-repo-path "commits" "html") (commits->sxml)) ;; htmlified repo contents (for-each (lambda (source-file) + (->> source-file + (pathparts) + (define-values (root elements basename extension relative-root))) (write-with-template - (string-append source-file ".html") - (source->sxml source-file)) + (make-pathname html-repo-path source-file "html") + (source->sxml source-file) + `(;; additional per-page variables provided to template + (source_file . ,source-file) + (root . ,root) + (elements . ,elements) + (basename . ,basename) + (extension . ,extension) + (relative_root . ,relative-root) + )) + ;; if it's an image also copy it verbatim to output directory (case (string->symbol (or (pathname-extension source-file) "")) ((jpg jpeg png gif webp webm svg apng avif svgz ico) (system (format "git show HEAD:~a > ~a" source-file (make-pathname html-repo-path source-file)))))) source-files-list) - ;; if README.md, README, or README.txt exists, copy that to index.html. - ;; otherwise copy files.html to index.html. + ;; if (the output version of) README.md, README, or README.txt exists, copy + ;; that to index.html. otherwise copy files.html to index.html. (->> - '("README.md.html" "README.html" "README.txt.html" "files.html") - (map (lambda (x) (make-pathname html-repo-path x))) + '("README.md" "README" "README.txt" "files") + (map (lambda (x) (make-pathname html-repo-path x "html"))) (find file-exists?) - ((lambda (x) (copy-file x (make-pathname html-repo-path "index.html") #t)))) - + ((lambda (x) (copy-file x (make-pathname html-repo-path "index" "html") #t)))) + ;; if the ISSUES directory got created, write out an index file for the + ;; stuff in there. (when (file-exists? (make-pathname html-repo-path "ISSUES")) - (write-with-template "ISSUES.html" (issueslist->sxml source-files-list))))) + (write-with-template (make-pathname html-repo-path "ISSUES" "html") (issueslist->sxml source-files-list))))) -(define (main #!optional html-repo-path) +(define (main #!optional html-repo-path (templates-directory "sxml")) - (unless html-repo-path - (bail "please specify a destination directory for html files")) + (unless html-repo-path + (bail "please specify a destination directory for html files")) - (unless (in-git-directory?) - (bail "woops this isn't a git directory")) + (unless (in-git-directory?) + (bail "woops this isn't a git directory")) - (generate-html-files html-repo-path)) + (generate-html-files html-repo-path templates-directory)) -(main (command-line-arguments)) +(apply main (command-line-arguments)) diff --git a/templates/default.html b/templates/default.html new file mode 100644 index 0000000..a37666d --- /dev/null +++ b/templates/default.html @@ -0,0 +1,44 @@ + + + +{{ forge_title }} - {{ repository_name }} + + + + + + + +

{{ h1 }}

+

{{ repository_name }}

+

clone url:{{ clone_url_prefix }}/{{ repository_name }}

+ +
+{{ content|safe }} +
+