Move stuff from calp/util to hnh/util.

This is the first (major) step in splitting the generally useful items
into its own library.

7 files changed, 1 insertions, 317 deletions

diff --git a/module/calp/util/color.scm b/module/calp/util/color.scm
deleted file mode 100644
index 161e6707..00000000
--- a/module/calp/util/color.scm
+++ /dev/null
@@ -1,22 +0,0 @@
-(define-module (calp 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/calp/util/config.scm b/module/calp/util/config.scm
index fbe35d59..2fe2b9b0 100644
--- a/module/calp/util/config.scm
+++ b/module/calp/util/config.scm
@@ -5,7 +5,7 @@
 ;;; Code:
 
 (define-module (calp util config)
-  :use-module (calp util)
+  :use-module (hnh util)
   :use-module (srfi srfi-1)
   :use-module (ice-9 format) ; for format-procedure
   :use-module (ice-9 curried-definitions) ; for ensure
diff --git a/module/calp/util/exceptions.scm b/module/calp/util/exceptions.scm
deleted file mode 100644
index d9df30ed..00000000
--- a/module/calp/util/exceptions.scm
+++ /dev/null
@@ -1,57 +0,0 @@
-(define-module (calp util exceptions)
-  #:use-module (srfi srfi-1)
-  #:use-module (calp 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/calp/util/graph.scm b/module/calp/util/graph.scm
deleted file mode 100644
index 6a01a9ee..00000000
--- a/module/calp/util/graph.scm
+++ /dev/null
@@ -1,93 +0,0 @@
-;;; Commentary:
-;; An immutable directed graph.
-;; Most operations are O(n), since there is no total
-;; order on symbols in scheme.
-;;; Code:
-
-(define-module (calp util graph)
-  :use-module (calp 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/calp/util/io.scm b/module/calp/util/io.scm
deleted file mode 100644
index 7db1eee2..00000000
--- a/module/calp/util/io.scm
+++ /dev/null
@@ -1,59 +0,0 @@
-(define-module (calp 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/calp/util/options.scm b/module/calp/util/options.scm
deleted file mode 100644
index 20263c45..00000000
--- a/module/calp/util/options.scm
+++ /dev/null
@@ -1,45 +0,0 @@
-(define-module (calp util options)
-  :use-module (calp 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/calp/util/tree.scm b/module/calp/util/tree.scm
deleted file mode 100644
index b7856aa9..00000000
--- a/module/calp/util/tree.scm
+++ /dev/null
@@ -1,40 +0,0 @@
-(define-module (calp util tree)
-  #:use-module (srfi srfi-1)
-  #:use-module (calp 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)))))