c943210189
- rename main.scm to repo2html.scm to match binary - remove unused imports from utils.scm
88 lines
2.9 KiB
Scheme
88 lines
2.9 KiB
Scheme
|
|
;; small utilities ---------------------------------
|
|
|
|
(module utils *
|
|
(import
|
|
scheme
|
|
(chicken base)
|
|
(chicken pathname)
|
|
(clojurian syntax)
|
|
srfi-1 ;; list utils
|
|
)
|
|
;; (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 #!optional msg (status 1))
|
|
(when msg (print msg))
|
|
(exit status))
|
|
|
|
;; clojureish "debugging by print statement" tool since i still haven't reached
|
|
;; lisp enlightenment
|
|
(define ((inspect #!optional label #!rest args) s)
|
|
(display (list label ":" args " => " s) (current-error-port))
|
|
(newline (current-error-port))
|
|
s)
|
|
|
|
;; 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))))
|
|
|
|
;; like (substring) but doesn't break if start and end are too big/small
|
|
(define (substring* s start end)
|
|
(substring s (max start 0) (min end (string-length s))))
|
|
|
|
;; 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))
|
|
|
|
;; like alist-ref but works on nested alists by specifying a path (list of keys)
|
|
(define (alist-ref-in keys alist #!optional (test eqv?))
|
|
(if (null? (cdr keys))
|
|
(alist-ref (car keys) alist test)
|
|
(alist-ref-in (cdr keys) (alist-ref (car keys) alist test) test)))
|
|
|
|
;; like alist-update, but works on nested alists by specifying a path (list of
|
|
;; keys)
|
|
(define (alist-update-in keys value alist #!optional (test eqv?))
|
|
(cond
|
|
((not alist) #f)
|
|
((null? (cdr keys))
|
|
(alist-update (car keys) value alist test))
|
|
(else
|
|
(alist-update (car keys)
|
|
(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))
|
|
)
|