clone url: git://git.m455.casa/repo2html
utils.scm
| 1 | |
| 2 | ;; small utilities --------------------------------- |
| 3 | |
| 4 | (module utils * |
| 5 | (import |
| 6 | scheme |
| 7 | (chicken base) |
| 8 | (chicken pathname) |
| 9 | (clojurian syntax) |
| 10 | srfi-1 ;; list utils |
| 11 | ) |
| 12 | ;; (bail [message [exit-status]]) |
| 13 | ;; end the program immediately. |
| 14 | ;; if a message is provided, print it to the screen. |
| 15 | ;; exit-status defaults to 1. |
| 16 | (define (bail #!optional msg (status 1)) |
| 17 | (when msg (print msg)) |
| 18 | (exit status)) |
| 19 | |
| 20 | ;; clojureish "debugging by print statement" tool since i still haven't reached |
| 21 | ;; lisp enlightenment |
| 22 | (define ((inspect #!optional label #!rest args) s) |
| 23 | (display (list label ":" args " => " s) (current-error-port)) |
| 24 | (newline (current-error-port)) |
| 25 | s) |
| 26 | |
| 27 | ;; decompose a path s into its constituent parts. returns values: |
| 28 | ;; |
| 29 | ;; root: "/" if it's an absolute path, "" if relative directory-elements: a list |
| 30 | ;; of each directory from root, () if none basename: the filename with extension |
| 31 | ;; removed like "readme" or ".bashrc" extension: the file extension with the |
| 32 | ;; dot, like ".txt" or "" if none relative-root: the relative path from the |
| 33 | ;; given path to the root |
| 34 | ;; e.g foo/bar/baz.html -> ../../ |
| 35 | ;; |
| 36 | ;; this is intended to provide default values that make for easier reassembly |
| 37 | ;; into filenames. |
| 38 | ;; |
| 39 | ;; typical use: |
| 40 | ;; (->> source-file |
| 41 | ;; (pathparts) |
| 42 | ;; (define-values (root elements basename extension relative-root))) |
| 43 | ;; |
| 44 | (define (pathparts s) |
| 45 | (define-values (dirname basename extension) |
| 46 | (decompose-pathname s)) |
| 47 | (define-values (origin root directory-elements) |
| 48 | (decompose-directory (or dirname ""))) |
| 49 | ;; discarding origin because idgaf about windows |
| 50 | (values (or root "") |
| 51 | (or directory-elements '()) |
| 52 | basename |
| 53 | (if extension (string-append "." extension) "") |
| 54 | (->> |
| 55 | (or directory-elements '()) |
| 56 | (map (constantly "../")) |
| 57 | (apply string-append)))) |
| 58 | |
| 59 | ;; like (substring) but doesn't break if start and end are too big/small |
| 60 | (define (substring* s start end) |
| 61 | (substring s (max start 0) (min end (string-length s)))) |
| 62 | |
| 63 | ;; merge alists a and b. values in b "win" |
| 64 | (define (alist-merge a b) |
| 65 | (lset-union (lambda (x y) (eq? (car x) (car y))) a b)) |
| 66 | |
| 67 | ;; like alist-ref but works on nested alists by specifying a path (list of keys) |
| 68 | (define (alist-ref-in keys alist #!optional (test eqv?)) |
| 69 | (if (null? (cdr keys)) |
| 70 | (alist-ref (car keys) alist test) |
| 71 | (alist-ref-in (cdr keys) (alist-ref (car keys) alist test) test))) |
| 72 | |
| 73 | ;; like alist-update, but works on nested alists by specifying a path (list of |
| 74 | ;; keys) |
| 75 | (define (alist-update-in keys value alist #!optional (test eqv?)) |
| 76 | (cond |
| 77 | ((not alist) #f) |
| 78 | ((null? (cdr keys)) |
| 79 | (alist-update (car keys) value alist test)) |
| 80 | (else |
| 81 | (alist-update (car keys) |
| 82 | (alist-update-in (cdr keys) value (alist-ref (car keys) alist test) test) |
| 83 | alist test)))) |
| 84 | |
| 85 | (define (unless-equals s1 s2) |
| 86 | ;; if s1 == s2, then s1, otherwise #f |
| 87 | (and (equal? s1 s2) s1)) |
| 88 | ) |