From 807409d41f8b1a4435ee1cf7ddc3d1a1b9116799 Mon Sep 17 00:00:00 2001
From: =?UTF-8?q?Hugo=20H=C3=B6rnquist?= <hugo@lysator.liu.se>
Date: Mon, 31 Jan 2022 20:24:18 +0100
Subject: Move stuff from calp/util to hnh/util.

This is the first (major) step in splitting the generally useful items
into its own library.
---
 module/hnh/util.scm            | 616 +++++++++++++++++++++++++++++++++++++++++
 module/hnh/util/color.scm      |  22 ++
 module/hnh/util/exceptions.scm |  57 ++++
 module/hnh/util/graph.scm      |  93 +++++++
 module/hnh/util/io.scm         |  59 ++++
 module/hnh/util/options.scm    |  45 +++
 module/hnh/util/tree.scm       |  40 +++
 7 files changed, 932 insertions(+)
 create mode 100644 module/hnh/util.scm
 create mode 100644 module/hnh/util/color.scm
 create mode 100644 module/hnh/util/exceptions.scm
 create mode 100644 module/hnh/util/graph.scm
 create mode 100644 module/hnh/util/io.scm
 create mode 100644 module/hnh/util/options.scm
 create mode 100644 module/hnh/util/tree.scm

(limited to 'module/hnh')

diff --git a/module/hnh/util.scm b/module/hnh/util.scm
new file mode 100644
index 00000000..0b22555b
--- /dev/null
+++ b/module/hnh/util.scm
@@ -0,0 +1,616 @@
+(define-module (hnh util)
+  #:use-module (srfi srfi-1)
+  #:use-module (srfi srfi-88)           ; postfix keywords
+  #:use-module ((ice-9 optargs) #:select (define*-public))
+  #:use-module ((sxml fold) #:select (fold-values))
+  #:use-module ((srfi srfi-9 gnu) #:select (set-fields))
+  #:re-export (define*-public fold-values)
+  #:export (for sort* sort*!
+                set/r!
+                catch-multiple
+                quote?
+                -> ->> set set-> aif awhen
+                let-lazy let-env
+                case* define-many
+                and=>> label
+                print-and-return
+                begin1
+                )
+  #:replace (let* set! define-syntax
+                  when unless))
+
+((@ (guile) define-syntax) define-syntax
+  (syntax-rules ()
+    ((_ (name args ...) body ...)
+     ((@ (guile) define-syntax) name
+      (lambda (args ...)
+        body ...)))
+    ((_ otherwise ...)
+     ((@ (guile) define-syntax) otherwise ...))))
+
+
+
+;; NOTE
+;; Instead of returning the empty list a better default value
+;; for when and unless would be the identity element for the
+;; current context.
+;; So (string-append (when #f ...)) would expand into
+;; (string-append (if #f ... "")).
+;; This however requires type interferance, which i don't
+;; *currently* have.
+
+(define-syntax-rule (when pred body ...)
+  (if pred (begin body ...) '()))
+
+(define-syntax-rule (unless pred body ...)
+  (if pred '() (begin body ...)))
+
+
+(define-syntax (aif stx)
+  (syntax-case stx ()
+    [(_ condition true-clause false-clause)
+     (with-syntax ((it (datum->syntax stx 'it)))
+       #'(let ((it condition))
+           (if it true-clause false-clause)))]))
+
+(define-syntax (awhen stx)
+  (syntax-case stx ()
+    [(_ condition body ...)
+     (with-syntax ((it (datum->syntax stx 'it)))
+       #'(let ((it condition))
+           (when it body ...)))]))
+
+#;
+(define-macro (awhen pred . body)
+  `(let ((it ,pred))
+     (when it
+       ,@body)))
+
+
+
+(define-syntax for
+  (syntax-rules (in)
+    ((for (<var> <vars> ...) in <collection> b1 body ...)
+     (map ((@ (ice-9 match) match-lambda) [(<var> <vars> ...) b1 body ...])
+          <collection>))
+    ((for <var> in <collection> b1 body ...)
+     (map (lambda (<var>) b1 body ...)
+          <collection>))))
+
+
+
+;; Replace let* with a version that can bind from lists.
+;; Also supports SRFI-71 (extended let-syntax for multiple values)
+;; @lisp
+;; (let* ([a b (values 1 2)]               ; @r{SRFI-71}
+;;        [(c d) '(3 4)]                   ; @r{Let-list (mine)}
+;;        [(a b . c) (cons* 1 2 3)]        ; @r{Improper list matching (mine)}
+;;        [e 5])                           ; @r{Regular}
+;;   (list e d c b a))
+;; ;; => (5 4 3 2 1)
+;; @end lisp
+(define-syntax let*
+  (syntax-rules ()
+
+    ;; Base case
+    [(_ () body ...)
+     (begin body ...)]
+
+    ;; (let (((a b) '(1 2))) (list b a)) => (2 1)
+    [(_ (((k ... . (k*)) list-value) rest ...)
+        body ...)
+     (apply (lambda (k ... k*)
+              (let* (rest ...)
+                body ...))
+            list-value)]
+
+    ;; Improper list matching
+    ;; (let* (((a b . c) (cons* 1 2 3))) (list a c)) ; => (1 3)
+    [(_ (((k1 k ... . k*) imp-list) rest ...)
+        body ...)
+     (apply (lambda (k1 k ... k*)
+              (let* (rest ...)
+                body ...))
+            (improper->proper-list
+             imp-list (length (quote (k1 k ...)))))]
+
+    ;; "Regular" case
+    [(_ ((k value) rest ...) body ...)
+     (let ((k value))
+       (let* (rest ...)
+         body ...))]
+
+    ;; SRFI-71 let-values
+    [(_ ((k k* ... values) rest ...) body ...)
+     (call-with-values (lambda () values)
+       (lambda (k k* ...)
+         (let* (rest ...)
+           body ...)))]
+
+    ;; Declare variable without a value (actuall #f).
+    ;; Useful for inner mutation.
+    [(_ (v rest ...) body ...)
+     (let* ((v #f) rest ...) body ...)]
+    ))
+
+(define (improper->proper-list lst len)
+  (let* ((head tail (split-at lst len)))
+    (append head (list tail))))
+
+
+(define-syntax-rule (begin1 first rest ...)
+  (let ((return first))
+    rest ...
+    return))
+
+
+
+
+
+(define-macro (print-and-return expr)
+  (let ((str (gensym "str"))
+        (result (gensym "result")))
+    `(let* ((,result ,expr)
+            (,str (format #f "~a [~a]~%" ,result (quote ,expr))))
+       (display ,str (current-error-port))
+       ,result)))
+
+
+
+(define-public (swap f)
+  (lambda args (apply f (reverse args))))
+
+
+(define-syntax case*%
+  (syntax-rules (else)
+    [(_ _ else)
+     #t]
+    [(_ invalue (value ...))
+     (memv invalue (list value ...))]
+    #;
+    [(_ invalue target)
+     (eq? invalue target)]))
+
+;; Like `case', but evals the case parameters
+(define-syntax case*
+  (syntax-rules (else)
+    [(_ invalue (cases body ...) ...)
+     (cond ((case*% invalue cases)
+            body ...)
+           ...)]))
+
+;; Allow set to work on multiple values at once,
+;; similar to Common Lisp's @var{setf}
+;; @example
+;; (set! x 10
+;;       y 20)
+;; @end example
+;; Still requires all variables to be defined beforehand.
+(define-syntax set!
+  (syntax-rules (=)
+    ((_ field = (op args ...) rest ...)
+     (set! field (op field args ...)
+           rest ...))
+    ((_ field = proc rest ...)
+     (set! field (proc field)
+           rest ...))
+    ((_ field val)
+     ((@ (guile) set!) field val))
+    ((_ field val rest ...)
+     (begin ((@ (guile) set!) field val)
+            (set! rest ...)))))
+
+;; only evaluates the final form once
+(define-syntax set/r!
+  (syntax-rules (=)
+    ((_ args ... v = something)
+     (begin
+       (set! args ... v = something)
+       v))
+    ((_ args ... final)
+     (let ((val final))
+       (set! args ... val)
+       val))))
+
+
+(define-syntax define-many
+  (syntax-rules ()
+    [(_) (begin)]
+    [(_ def) (begin)]
+    [(_ (symbols ...) value rest ...)
+     (begin (define symbols value) ...
+            (define-many rest ...))]
+    [(_ def (symbols ...) value rest ...)
+     (begin (def symbols value) ...
+            (define-many def rest ...))]))
+
+;; Attach a label to a function, allowing it to call itself
+;; without actually giving it a name (can also be thought
+;; of as letrec-1).
+;; @example
+;; ((label fact
+;;   (match-lambda
+;;     [0 1]
+;;     [x (* x (fact (1- x)))]))
+;;  5)
+;; @end example
+(define-syntax label
+  (syntax-rules ()
+    [(_ self proc)
+     (letrec ((self proc))
+       proc)]))
+
+
+;; This function borrowed from web-ics (calendar util)
+(define* (sort* items comperator #:optional (get identity))
+  "A sort function more in line with how python's sorted works"
+  (sort items (lambda (a b)
+                (comperator (get a)
+                            (get b)))))
+
+;; Sorts the list @var{items}. @emph{May} destroy the input list in the process
+(define* (sort*! items comperator #:optional (get identity))
+  "A sort function more in line with how python's sorted works"
+  (sort! items (lambda (a b)
+                 (comperator (get a)
+                             (get b)))))
+
+;; Given {items, <} finds the most extreme value.
+;; Returns 2 values. The extremest item in @var{items},
+;; and the other items in some order.
+;; Ord b => (list a) [, (b, b -> bool), (a -> b)] -> a, (list a)
+(define*-public (find-extreme items optional: (< <) (access identity))
+  (if (null? items)
+      (error "Can't find extreme in an empty list")
+      (fold-values
+       (lambda (c min other)
+         (if (< (access c) (access min))
+             ;; Current stream head is smaller that previous min
+             (values c (cons min other))
+             ;; Previous min is still smallest
+             (values min (cons c other))))
+       (cdr items)
+       ;; seeds:
+       (car items) '())))
+
+(define*-public (find-min list optional: (access identity))
+  (find-extreme list < access))
+
+(define*-public (find-max list optional: (access identity))
+  (find-extreme list > access))
+
+(define-public (filter-sorted proc list)
+  (take-while
+   proc (drop-while
+         (negate proc) list)))
+
+;; (define (!= a b) (not (= a b)))
+(define-public != (negate =))
+
+(define-public (take-to lst i)
+  "Like @var{take}, but might lists shorter than length."
+  (if (> i (length lst))
+      lst (take lst i)))
+
+(define-public (string-take-to str i)
+  (if (> i (string-length str))
+      str (string-take str i)))
+
+(define-public (string-first str)
+  (string-ref str 0))
+
+(define-public (string-last str)
+  (string-ref str (1- (string-length str))))
+
+(define-public (as-symb s)
+  (if (string? s) (string->symbol s) s))
+
+(define-public (enumerate lst)
+  (zip (iota (length lst))
+       lst))
+
+;; Takes a procedure returning multiple values, and returns a function which
+;; takes the same arguments as the original procedure, but only returns one of
+;; the procedures. Which procedure can be sent as an additional parameter.
+(define*-public (unval proc #:optional (n 0))
+  (lambda args
+    (call-with-values (lambda () (apply proc args))
+      (lambda args (list-ref args n)))))
+
+(define-public (flatten lst)
+  (fold (lambda (subl done)
+          (append done ((if (list? subl) flatten list) subl)))
+        '() lst))
+
+(define-syntax let-lazy
+  (syntax-rules ()
+    [(_ ((field value) ...)
+        body ...)
+     (let ((field (delay value)) ...)
+       (let-syntax ((field (identifier-syntax (force field))) ...)
+         body ...))]))
+
+(define-public (map/dotted proc dotted-list)
+  (cond ((null? dotted-list) '())
+        ((not-pair? dotted-list) (proc dotted-list))
+        (else
+         (cons (proc (car dotted-list))
+               (map/dotted proc (cdr dotted-list))))))
+
+;; Merges two association lists, comparing with eq.
+;; The cdrs in all pairs in both lists should be lists,
+;; If a key is present in both then the contents of b is
+;; put @emph{before} the contents in a.
+;; @example
+;; (assq-merge '((k 1)) '((k 2)))
+;; => ((k 2 1))
+;; @end example
+(define-public (assq-merge a b)
+  (fold (lambda (entry alist)
+          (let* (((k . v) entry)
+                 (o (assq-ref alist k)))
+            (assq-set! alist k (append v (or o '())))))
+        (copy-tree a) b))
+
+(define-public (kvlist->assq kvlist)
+  (map (lambda (pair)
+         (cons (keyword->symbol (car pair)) (cdr pair)))
+       (group kvlist 2)))
+
+(define*-public (assq-limit alist optional: (number 1))
+  (map (lambda (pair)
+         (take-to pair (1+ number)))
+       alist))
+
+(define-public (group-by proc lst)
+  (let ((h (make-hash-table)))
+    (for value in lst
+         (let ((key (proc value)))
+           (hash-set! h key (cons value (hash-ref h key '())))))
+    ;; NOTE changing this list to cons allows the output to work with assq-merge.
+    (hash-map->list list h)))
+
+;; (split-by '(0 1 2 3 4 2 5 6) 2)
+;; ⇒ ((0 1) (3 4) (5 6))
+(define-public (split-by list item)
+  (let loop ((done '())
+             (current '())
+             (rem list))
+    (cond [(null? rem)
+           (reverse (cons (reverse current) done))]
+          [(eqv? item (car rem))
+           (loop (cons (reverse current) done)
+                 '()
+                 (cdr rem))]
+          [else
+           (loop done
+                 (cons (car rem) current)
+                 (cdr rem))])))
+
+
+
+;; Simar to span from srfi-1, but never takes more than
+;; @var{count} items. Can however still take less.
+;; @example
+;; (span-upto 2 char-numeric? (string->list "123456"))
+;; ⇒ (#\1 #\2)
+;; ⇒ (#\3 #\4 #\5 #\6)
+;; (span-upto 2 char-numeric? (string->list "H123456"))
+;; ⇒ ()
+;; ⇒ (#\H #\1 #\2 #\3 #\4 #\5 #\6)
+;; @end example
+(define-public (span-upto count predicate list)
+  (let loop ((remaining count)
+             (taken '())
+             (list list))
+    (if (or (zero? remaining) (null? list))
+        (values (reverse! taken) list)
+        (if (predicate (car list))
+            (loop (1- remaining)
+                  (cons (car list) taken)
+                  (cdr list))
+            (loop (1- remaining)
+                  taken list)))))
+
+
+;; Returns the cross product between l1 and l2.
+;; each element is a cons cell.
+(define (cross-product% l1 l2)
+  (concatenate
+   (map (lambda (a)
+          (map (lambda (b) (cons a b))
+               l2))
+        l1)))
+
+(define-public (cross-product . args)
+  (if (null? args)
+      '()
+      (let* ((last rest (car+cdr (reverse args))))
+        (reduce-right cross-product% '()
+                      (reverse (cons (map list last) rest ))))))
+
+;; Given an arbitary tree, do a pre-order traversal, appending all strings.
+;; non-strings allso allowed, converted to strings and also appended.
+(define-public (string-flatten tree)
+  (cond [(string? tree) tree]
+        [(list? tree) (string-concatenate (map string-flatten tree))]
+        [else (format #f "~a" tree)]))
+
+(define-public (intersperse item list)
+  (let loop ((flipflop #f)
+             (rem list))
+    (if (null? rem)
+        '()
+        (if flipflop
+            (cons item (loop (not flipflop) rem))
+            (cons (car rem) (loop (not flipflop) (cdr rem)))
+            ))))
+
+;; @example
+;; (insert-ordered 5 (iota 10))
+;; ⇒ (0 1 2 3 4 5 5 6 7 8 9)
+;; @end example
+(define*-public (insert-ordered item collection optional: (< <))
+  (cond [(null? collection)
+         (list item)]
+        [(< item (car collection))
+         (cons item collection)]
+        [else
+         (cons (car collection)
+               (insert-ordered item (cdr collection) <))]))
+
+
+
+(define-syntax ->
+  (syntax-rules ()
+    [(-> obj) obj]
+    [(-> obj (func args ...) rest ...)
+     (-> (func obj args ...) rest ...)]
+    [(-> obj func rest ...)
+     (-> (func obj) rest ...)]))
+
+(define-syntax ->>
+  (syntax-rules ()
+    ((->> obj)
+     obj)
+    ((->> obj (func args ...) rest ...)
+     (->> (func args ... obj) rest ...))
+    ((->> obj func rest ...)
+     (->> (func obj) rest ...))))
+
+;; Non-destructive set, syntax extension from set-fields from (srfi
+;; srfi-9 gnu).
+(define-syntax set
+  (syntax-rules (=)
+    [(set (acc obj) value)
+     (set-fields
+      obj ((acc) value))]
+    [(set (acc obj) = (op rest ...))
+     (set-fields
+      obj ((acc) (op (acc obj) rest ...)))]))
+
+(define-syntax set->
+  (syntax-rules (=)
+    [(_ obj) obj]
+    [(_ obj (func = (op args ...)) rest ...)
+     (set-> (set (func obj) (op (func obj) args ...)) rest ...)]
+    [(_ obj (func args ...) rest ...)
+     (set-> (set (func obj) args ...) rest ...)]))
+
+(define-syntax and=>>
+  (syntax-rules ()
+    [(_ value) value]
+    [(_ value proc rest ...)
+     (and=>> (and=> value proc)
+             rest ...)]))
+
+(define-public (downcase-symbol symb)
+  (-> symb
+      symbol->string
+      string-downcase
+      string->symbol))
+
+
+;; @example
+;; (group (iota 10) 2)
+;; ⇒ ((0 1) (2 3) (4 5) (6 7) (8 9))
+;; @end example
+;; Requires that width|(length list)
+(define-public (group list width)
+  (unless (null? list)
+    (let* ((row rest (split-at list width)))
+      (cons row (group rest width)))))
+
+;; repeatedly apply @var{proc} to @var{base}
+;; unitl @var{until} is satisfied.
+;; (a → a), (a → bool), a → a
+(define-public (iterate proc until base)
+  (let loop ((o base))
+    (if (until o)
+        o
+        (loop (proc o)))))
+
+;; (a → values a), list ... → values a
+(define-public (valued-map proc . lists)
+  (apply values
+   (apply append-map
+          (lambda args
+            (call-with-values (lambda () (apply proc args)) list))
+          lists)))
+
+(define (ass%-ref-all alist key =)
+  (map cdr (filter (lambda (pair) (= key (car pair)))
+                   alist)))
+
+;; Equivalent to assoc-ref (and family), but works on association lists with
+;; non-unique keys, returning all mathing records (instead of just the first).
+;; @begin lisp
+;; (assoc-ref-all '((a . 1) (b . 2) (a . 3)) 'a)
+;; ⇒ (1 3)
+;; @end
+(define-public (assoc-ref-all alist key) (ass%-ref-all alist key equal?))
+(define-public (assq-ref-all alist key)  (ass%-ref-all alist key eq?))
+(define-public (assv-ref-all alist key)  (ass%-ref-all alist key eqv?))
+
+
+
+
+(define-public (vector-last v)
+  (vector-ref v (1- (vector-length v))))
+
+(define-public (->str any)
+  (with-output-to-string (lambda () (display any))))
+
+(define-public ->string ->str)
+
+(define-public (->quoted-string any)
+  (with-output-to-string (lambda () (write any))))
+
+
+
+
+;; TODO shouldn't this use `file-name-separator-string'?
+(define-public (path-append . strings)
+  (fold (lambda (s done)
+            (string-append
+             done
+             (if (string-null? s)
+                 (string-append s "/")
+                 (if (char=? #\/ (string-last done))
+                     (if (char=? #\/ (string-first s))
+                         (string-drop s 1) s)
+                     (if (char=? #\/ (string-first s))
+                         s (string-append "/" s))))))
+        (let ((s (car strings)))
+          (if (string-null? s)
+              "/" s))
+        (cdr strings)))
+
+
+
+
+(define-syntax let-env
+  (syntax-rules ()
+    [(_ ((name value) ...)
+        body ...)
+
+     (let ((env-pairs #f))
+       (dynamic-wind
+         (lambda ()
+           (set! env-pairs
+             (map (lambda (n new-value)
+                    (list n new-value (getenv n)))
+                  (list (symbol->string (quote name)) ...)
+                  (list value ...)))
+           (for-each (lambda (pair) (setenv (car pair) (cadr pair)))
+                     env-pairs))
+         (lambda () body ...)
+         (lambda ()
+           (for-each (lambda (pair) (setenv (car pair) (caddr pair)))
+                     env-pairs))))]))
+
+
+(define-public (uuidgen)
+  ((@ (rnrs io ports) call-with-port)
+   ((@ (ice-9 popen) open-input-pipe) "uuidgen")
+   (@ (ice-9 rdelim) read-line)))
diff --git a/module/hnh/util/color.scm b/module/hnh/util/color.scm
new file mode 100644
index 00000000..b626316d
--- /dev/null
+++ b/module/hnh/util/color.scm
@@ -0,0 +1,22 @@
+(define-module (hnh util color)
+  )
+
+;; Returns a color with good contrast to the given background color.
+;; https://stackoverflow.com/questions/1855884/determine-font-color-based-on-background-color/1855903#1855903
+(define-public (calculate-fg-color c)
+  (catch #t
+    (lambda ()
+      (define (str->num c n) (string->number (substring/shared c n (+ n 2)) 16))
+      ;; (format (current-error-port) "COLOR = ~s~%" c)
+      (let ((r (str->num c 1))
+            (g (str->num c 3))
+            (b (str->num c 5)))
+        (if (< 1/2 (/ (+ (* 0.299 r)
+                         (* 0.587 g)
+                         (* 0.114 b))
+                      #xFF))
+            "#000000" "#FFFFFF")))
+    (lambda args
+      (format (current-error-port) "Error calculating foreground color?~%~s~%" args)
+      "#FF0000"
+      )))
diff --git a/module/hnh/util/exceptions.scm b/module/hnh/util/exceptions.scm
new file mode 100644
index 00000000..fef0f1b5
--- /dev/null
+++ b/module/hnh/util/exceptions.scm
@@ -0,0 +1,57 @@
+(define-module (hnh util exceptions)
+  #:use-module (srfi srfi-1)
+  #:use-module (hnh util)
+  #:use-module (calp util config)
+  #:use-module (ice-9 format)
+
+  #:use-module ((system vm frame)
+                :select (frame-bindings binding-ref))
+
+  #:export (assert))
+
+
+(define-public warning-handler
+  (make-parameter
+   (lambda (fmt . args)
+     (format #f "WARNING: ~?~%" fmt args))))
+
+(define-public warnings-are-errors
+  (make-parameter #f))
+
+(define-config warnings-are-errors #f
+  description: "Crash on warnings."
+  post: warnings-are-errors)
+
+;; forwards return from warning-hander. By default returns an unspecified value,
+;; but instances are free to provide a proper return value and use it.
+(define-public (warning fmt . args)
+  (display (apply (warning-handler) fmt (or args '()))
+           (current-error-port))
+  (when (warnings-are-errors)
+    (throw 'warning fmt args)))
+
+(define-public (fatal fmt . args)
+  (display (format #f "FATAL: ~?~%" fmt (or args '()))
+           (current-error-port))
+  (raise 2)
+  )
+
+(define (prettify-tree tree)
+  (cond [(pair? tree) (cons (prettify-tree (car tree))
+                            (prettify-tree (cdr tree)))]
+        [(and (procedure? tree) (procedure-name tree))
+         => identity]
+        [else tree]))
+
+
+(define-macro (assert form)
+  `(unless ,form
+     (throw 'assertion-error "Assertion failed. ~a expected, ~a got"
+            (quote ,form)
+            ((@@ (calp util exceptions) prettify-tree) (list ,form)))))
+
+
+(define-public (filter-stack pred? stk)
+  (concatenate
+   (for i in (iota (stack-length stk))
+        (filter pred? (map binding-ref (frame-bindings (stack-ref stk i)))))))
diff --git a/module/hnh/util/graph.scm b/module/hnh/util/graph.scm
new file mode 100644
index 00000000..912f9612
--- /dev/null
+++ b/module/hnh/util/graph.scm
@@ -0,0 +1,93 @@
+;;; Commentary:
+;; An immutable directed graph.
+;; Most operations are O(n), since there is no total
+;; order on symbols in scheme.
+;;; Code:
+
+(define-module (hnh util graph)
+  :use-module (hnh util)
+  :use-module (srfi srfi-1)
+  :use-module (srfi srfi-9 gnu))
+
+;; Immutable directed graph
+(define-immutable-record-type <graph>
+  (make-graph% nodes edges node-key-proc node-equal?)
+  graph?
+  (nodes graph-nodes)
+  (edges graph-edges) ; (list (symb . symb))
+  (node-key-proc node-key-proc) ; node → symb
+  (node-equal? node-equal?) ; node, node -> symb
+  )
+
+(define*-public (make-graph optional:
+                            (node-key-proc identity)
+                            (node-equal? eq?))
+  (make-graph% '() '() node-key-proc node-equal?))
+
+(define*-public (rebuild-graph optional: old-graph
+                               (nodes '()) (edges '()))
+  (make-graph% nodes edges
+               (if old-graph (node-key-proc old-graph) identity)
+               (if old-graph (node-equal? old-graph) eq?)))
+
+(define-public (graph-empty? graph)
+  (null? (graph-nodes graph)))
+
+;; Add node to graph. Adds directed edges from node to neighbours
+;; graph, node, (list node-key) → graph
+(define-public (add-node graph node edge-neighbours)
+  (rebuild-graph
+   graph
+   (lset-adjoin (node-equal? graph) (graph-nodes graph)
+                node)
+   (lset-union equal? (graph-edges graph)
+               (map (lambda (o) (cons ((node-key-proc graph) node) o))
+                    edge-neighbours))))
+
+;; get node by key
+(define-public (get-node graph key)
+  (find (lambda (node) (eq? key ((node-key-proc graph) node)))
+        (graph-nodes graph)))
+
+;; Remove node by @var{node-equal?}
+(define-public (remove-node graph node)
+  (rebuild-graph
+   graph
+   (remove (lambda (other) ((node-equal? graph) node other))
+           (graph-nodes graph))
+   (let ((key ((node-key-proc graph) node)))
+     (remove (lambda (edge) (or (eq? key (car edge))
+                           (eq? key (cdr edge))))
+             (graph-edges graph)))))
+
+;; NOTE this is O(n^2) (maybe, sort of?)
+;; Getting it faster would require building an index, which
+;; is hard since there isn't a total order on symbols.
+(define-public (find-node-without-dependencies graph)
+  (find (lambda (node)
+          (let ((key ((node-key-proc graph) node)))
+            (not (find (lambda (edge) (eq? key (car edge))) (graph-edges graph)))))
+        (graph-nodes graph)))
+
+;; graph → node x graph
+(define-public (find-and-remove-node-without-dependencies graph)
+  (let ((node (find-node-without-dependencies graph)))
+    (unless node
+      (throw 'graph-error 'find-and-remove-node-without-dependencies
+             "No node without dependencies in graph" '() graph))
+    (values node (remove-node graph node))))
+
+;; Assumes that the edges of the graph are dependencies.
+;; Returns a list of all nodes so that each node is before its dependants.
+;; A missing dependency (and probably a loop) is an error, and currently
+;; leads to some weird error messages.
+(define-public (resolve-dependency-graph graph)
+  (catch 'graph-error
+    (lambda ()
+      (let loop ((graph graph))
+        (if (graph-empty? graph)
+            '()
+            (let* ((node graph* (find-and-remove-node-without-dependencies graph)))
+              (cons node (loop graph*))))))
+    (lambda (err caller fmt args graph . data)
+      graph)))
diff --git a/module/hnh/util/io.scm b/module/hnh/util/io.scm
new file mode 100644
index 00000000..04e54a9e
--- /dev/null
+++ b/module/hnh/util/io.scm
@@ -0,0 +1,59 @@
+(define-module (hnh util io)
+  :use-module ((ice-9 rdelim) :select (read-line)))
+
+(define-public (open-input-port str)
+  (if (string=? "-" str)
+      (current-input-port)
+      (open-input-file str)))
+
+(define-public (open-output-port str)
+  (if (string=? "-" str)
+      (current-output-port)
+      (open-output-file str)))
+
+
+
+(define-public (read-lines port)
+  (with-input-from-port port
+    (lambda ()
+      (let loop ((line (read-line)))
+        (if (eof-object? line)
+            '() (cons line (loop (read-line))))))))
+
+;; Same functionality as the regular @var{with-output-to-file}, but
+;; with the difference that either everything is written, or nothing
+;; is written, and if anything is written it's all written atomicaly at
+;; once (the original file will never contain an intermidiate state).
+;; Does NOT handle race conditions between threads.
+;; Return #f on failure, something truthy otherwise
+(define-public (with-atomic-output-to-file filename thunk)
+  ;; copy to enusre writable string
+  (define tmpfile (string-copy (string-append
+                                (dirname filename)
+                                file-name-separator-string
+                                "." (basename filename)
+                                "XXXXXX")))
+  (define port #f)
+  (dynamic-wind
+    (lambda () (set! port (mkstemp! tmpfile)))
+    (lambda ()
+      (with-output-to-port port thunk)
+      ;; Closing a port forces a write, due to buffering
+      ;; some of the errors that logically would come
+      ;; from write calls are first raised here. But since
+      ;; crashing is acceptable here, that's fine.
+      (close-port port)
+      (rename-file tmpfile filename))
+    (lambda ()
+      (when (access? tmpfile F_OK)
+        ;; I'm a bit unclear on how to trash our write buffer.
+        ;; hopefully first removing the file, followed by closing
+        ;; the port is enough for the kernel to do the sensible
+        ;; thing.
+        (delete-file tmpfile)
+        (close-port port)
+        ;; `when' defaults to the truthy `()', see (calp util)
+        ;; (note that #<unspecified> is thruthy, but shouldn't be
+        ;; counted on, since anything with an unspecified return
+        ;; value might as well return #f)
+        #f))))
diff --git a/module/hnh/util/options.scm b/module/hnh/util/options.scm
new file mode 100644
index 00000000..57473816
--- /dev/null
+++ b/module/hnh/util/options.scm
@@ -0,0 +1,45 @@
+(define-module (hnh util options)
+  :use-module (hnh util)
+  :use-module (ice-9 match)
+  :use-module (srfi srfi-1)
+  :use-module (text markup)
+  )
+
+;; option-assoc → getopt-valid option-assoc
+(define-public (getopt-opt options)
+  (define ice-9-names '(single-char required? value predicate))
+  (for (option-name flags ...) in options
+       (cons option-name
+             (map (match-lambda
+                    (('value (_ ...))       `(value #t))
+                    (('value (? symbol? _)) `(value optional))
+                    ((key v)                `(,key ,v)))
+                  (filter (match-lambda ((key _ ...) (memv key ice-9-names)))
+                          flags)))))
+
+
+;; (name (key value) ...) → sxml
+(define (fmt-help option-line)
+  (match option-line
+    ((name args ...)
+     (let ((valuefmt (match (assoc-ref args 'value)
+                       [(#t) '(" " (i value))]
+                       [(or #f (#f)) '()]
+                       [(('options options ...))
+                        `(" {" ,(string-join options "|") "}")]
+                       [(s) `(" [" (i ,s) "]")])))
+       `(*TOP* (b "--" ,name) ,@valuefmt
+               ,@(awhen (assoc-ref args 'single-char)
+                        `("," (ws)
+                          (b "-" ,(car it))
+                          ,@valuefmt))
+               (br)
+               ,@(awhen (assoc-ref args 'description)
+                        `((blockquote ,@it)
+                          (br))))))))
+
+(define-public (format-arg-help options)
+  (sxml->ansi-text (cons '*TOP* (map sxml->ansi-text (map fmt-help options)))))
+
+(define*-public (print-arg-help options optional: (port (current-error-port)))
+  (display (format-arg-help options) port))
diff --git a/module/hnh/util/tree.scm b/module/hnh/util/tree.scm
new file mode 100644
index 00000000..6c4f765d
--- /dev/null
+++ b/module/hnh/util/tree.scm
@@ -0,0 +1,40 @@
+(define-module (hnh util tree)
+  #:use-module (srfi srfi-1)
+  #:use-module (hnh util)
+  #:export (make-tree left-subtree
+                      right-subtree
+                      length-of-longst-branch
+                      tree-map))
+
+;; Constructs a binary tree where each node's children is partitioned
+;; into a left and right branch using @var{pred?}.
+;; Has thee form @var{(node left-subtree right-subtree)}. A leaf has
+;; both it's children equal to @var{null}.
+(define (make-tree pred? lst)
+  (unless (null? lst)
+    (let* ((head tail (partition (lambda (el) (pred? (car lst) el))
+                                 (cdr lst))))
+      (list (car lst)
+            (make-tree pred? head)
+            (make-tree pred? tail)))))
+
+(define (left-subtree tree)
+  (list-ref tree 1))
+
+(define (right-subtree tree)
+  (list-ref tree 2))
+
+;; Length includes current node, so the length of a leaf is 1.
+(define (length-of-longst-branch tree)
+  (if (null? tree)
+      ;; Having the @var{1+} outside the @var{max} also works,
+      ;; but leads to events overlapping many other to be thinner.
+      ;; Having it inside makes all events as evenly wide as possible.
+      0 (max (1+ (length-of-longst-branch (left-subtree tree)))
+             (length-of-longst-branch (right-subtree tree)))))
+
+(define (tree-map proc tree)
+  (unless (null? tree)
+    (list (proc (car tree))
+          (tree-map proc (left-subtree tree))
+          (tree-map proc (right-subtree tree)))))
-- 
cgit v1.2.3