repo2html/utils.scm

;; 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))
)