From 35496ee17ec924a1fd43b7bbf087bec9949deb68 Mon Sep 17 00:00:00 2001
From: pho4cexa <pho4cexa@orbital.rodeo>
Date: Fri, 16 Dec 2022 09:28:55 -0800
Subject: [PATCH] enable customizable jinja-like templates via ersatz!

well this was a journey :)

behavior when running `repo2html <output directory>` remains the same;
we apply our internal sxml template as usual.

to use ersatz templates, run like this:

`repo2html <output directory> <template directory>`

the program will look for a "default.html" file in that directory.
---
 README.md              |  10 +-
 main.scm               | 328 ++++++++++++++++++++++++++---------------
 templates/default.html |  44 ++++++
 3 files changed, 259 insertions(+), 123 deletions(-)
 create mode 100644 templates/default.html

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 #<unspecified> 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 "<!DOCTYPE html>\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 "<!DOCTYPE html>\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 #<unspecified> 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 @@
+<!DOCTYPE html>
+<html lang="en">
+<head>
+<title>{{ forge_title }} - {{ repository_name }}</title>
+<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>
+    body { margin: 0 auto; max-width: 700px }
+    pre, code { background-color: #ffd9df }
+    pre { overflow: scroll; padding: 15px 20px; white-space: pre }
+    a { color: blue }
+    nav a { margin-right: 10px }
+    hr { border: 0; border-bottom: 1px solid black; margin-top: 16px }
+    td { padding: 0em .5em; vertical-align: top }
+    footer { font-size: small; text-align: right }
+</style>
+</head>
+<body>
+<h1>{{ h1 }}</h1>
+<h2>{{ repository_name }}</h2>
+<p>clone url:{{ clone_url_prefix }}/{{ repository_name }}</p>
+<nav>
+    {% if readme_file %}
+        <a href="index.html">about</a>
+        <a href="files.html">files</a>
+    {% else %}
+        <a href="index.html">files</a>
+    {% endif %}
+    {% if license_file %}
+        <a href="{{ license_file }}.html">license</a>
+    {% endif %}
+    {% if issues_file %}
+        <a href="{{ issues_file }}.html">issues</a>
+    {% endif %}
+    <a href="commits.html">commits</a>
+    <a href="contributors.html">contributors</a>
+</nav>
+<hr />
+{{ content|safe }}
+<hr />
+<footer>
+<p>Generated by <a href="https://git.m455.casa/repo2html/">repo2html</a> using ersatz templates</p></footer></html>