diff --git a/main.scm b/main.scm
index 84939fc..8ab87a5 100755
--- a/main.scm
+++ b/main.scm
@@ -19,22 +19,60 @@
(define DESCRIPTION (or (get-environment-variable "REPO2HTML_DESCRIPTION") "my git repositories"))
(define H1 (or (get-environment-variable "REPO2HTML_H1") "git.example.com"))
+;; small utilities ---------------------------------
+
+;; return the first x in xs for which (pred? member) is true,
+;; or #f if no such member is found.
+(define (first-if pred? xs)
+ (cond ((null? xs) #f)
+ ((pred? (car xs)) (car xs))
+ (else (first-if pred? (cdr xs)))))
+
+;; (bail [message [exit-status]])
+;; end the program immediately.
+;; if a message is provided, print it to the screen.
+;; exit-status defaults to 1.
+(define (bail . args)
+ (let-optionals args ((msg "") (status 1))
+ (unless (equal? "" msg) (print msg))
+ (exit status)))
+
+;; 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
+;; e.g foo/bar/baz.html -> ../../
+;;
+;; this is intended to provide default values that make for easier reassembly
+;; into filenames.
+;;
+;; typical use:
+;; (->> source-file
+;; (pathparts)
+;; (define-values (root elements basename extension relative-root)))
+;;
+(define (pathparts s)
+ (define-values (dirname basename extension)
+ (decompose-pathname s))
+ (define-values (origin root directory-elements)
+ (decompose-directory (or dirname "")))
+ ;; discarding origin because idgaf about windows
+ (values (or root "")
+ (or directory-elements '())
+ basename
+ (if extension (string-append "." extension) "")
+ (->>
+ (or directory-elements '())
+ (map (constantly "../"))
+ (apply string-append))))
+
+;; main code ---------------------------------
+
(define (populate-html-template repository-name source-files-list source-file display-body-thunk)
- (define-values (source-directory source-filename source-extension)
- (decompose-pathname source-file))
- (define-values (base-origin base-directory directory-elements)
- (if source-directory
- (decompose-directory source-directory)
- (values #f #f '())))
- (define relative-root
- (->>
- directory-elements
- (map (lambda (_) "../"))
- ;; why is there no inverse function for decompose-directory in pathname?
- ;; idgas about portability but a portable program would refer to the
- ;; current platform's directory-separator here.
- (apply string-append)
- ))
+ (define-values (_ _ _ _ relative-root) (pathparts source-file))
(display #<#string-block
@@ -107,7 +145,7 @@ string-block
(define (in-git-directory?)
(not (eof-object? (call-with-input-pipe "git rev-parse --git-dir" read-line))))
-(define (is-text? path)
+(define (git-file-is-text? path)
(not (equal?
"-\t-\t"
(call-with-input-pipe
@@ -124,26 +162,18 @@ string-block
(string-intersperse "\n")))
(define (display-source-html source-file) ;; src/main.scm
- (define-values (source-directory source-filename source-extension)
- (decompose-pathname source-file))
- (define-values (base-origin base-directory directory-elements)
- (if source-directory
- (decompose-directory source-directory)
- (values #f #f '())))
-
+ (define-values (_ _ basename extension _) (pathparts source-file))
(define (image-link)
- (format #t "![](\"~a\")
" (make-pathname "" source-filename source-extension)))
+ (format #t "![](\"~a~a\")
" basename extension))
(define (plaintext)
(display "")
(display-escaped-html (git-file->string source-file))
(display ""))
(define (binary)
- (display "(Binary file)
"))
+ (display "(Binary file)
"))
(format #t "~a
" source-file)
- (case (string->symbol (or source-extension source-filename))
- ;; markdown files get rendered in-place, unless there's an error, in which
- ;; case escaped plaintext inside a
- ((md markdown)
+ (case (string->symbol extension)
+ ((.md .markdown)
(handle-exceptions exn
(begin
(display "Error parsing " (current-error-port))
@@ -152,14 +182,14 @@ string-block
(display "There was an error parsing this file as Markdown.
")
(plaintext))
(markdown->html (git-file->string source-file))))
- ((jpg jpeg png gif webp webm apng avif svgz ico)
+ ((.jpg .jpeg .png .gif .webp .webm .apng .avif .svgz .ico)
(image-link))
- ((svg)
+ ((.svg)
(image-link) (plaintext))
- ((gz pack idx)
+ ((.gz .pack .idx)
(binary))
(else
- (if (is-text? source-file)
+ (if (git-file-is-text? source-file)
(plaintext)
(binary)))))
@@ -191,15 +221,10 @@ string-block
(tr (th "Author") (th "Commits"))
,(map
(lambda (line)
- (let-values (((commits . author) (apply values (string-split line "\t"))))
+ (let-values (((commits author) (apply values (string-split line "\t"))))
`(tr (td ,author) (td ,commits))))
(call-with-input-pipe "git shortlog -ns HEAD" read-lines))))))
-(define (first-if pred lst)
- (cond ((null? lst) #f)
- ((pred (car lst)) (car lst))
- (else (first-if pred (cdr lst)))))
-
(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 "/"))))
@@ -238,19 +263,14 @@ string-block
(make-pathname html-repo-path "index.html")
#t)))
-(define (bail . args)
- (let-optionals args ((status 1) (msg ""))
- (unless (equal? "" msg) (print msg))
- (exit status)))
-
(define (main args)
(let-optionals args ((html-repo-path ""))
(when (equal? html-repo-path "")
- (bail 1 "please specify a destination directory for html files"))
+ (bail "please specify a destination directory for html files"))
(unless (in-git-directory?)
- (bail 1 "woops this isn't a git directory"))
+ (bail "woops this isn't a git directory"))
(generate-html-files html-repo-path)))