Move util modules into calp module..

9 files changed, 0 insertions, 549 deletions

diff --git a/module/util/color.scm b/module/util/color.scm
deleted file mode 100644
index 7b6dacec..00000000
--- a/module/util/color.scm
+++ /dev/null
@@ -1,22 +0,0 @@
-(define-module (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/util/config.scm b/module/util/config.scm
deleted file mode 100644
index 29269ce5..00000000
--- a/module/util/config.scm
+++ /dev/null
@@ -1,136 +0,0 @@
-;;; Commentary:
-
-;; Configuration system.
-
-;;; Code:
-
-(define-module (util config)
-  :use-module (util)
-  :use-module (srfi srfi-1)
-  :use-module (ice-9 format) ; for format-procedure
-  :use-module (ice-9 curried-definitions) ; for ensure
-  :export (define-config)
-)
-
-(define-once config-values (make-hash-table))
-
-;; properties declared before being bound into hash-map
-;; to allow nicer scripting in this file.
-
-(define-once config-properties (make-hash-table))
-(define description (make-object-property))
-(define source-module (make-object-property))
-(define pre (make-object-property))
-(define post (make-object-property))
-(hashq-set! config-properties #:description description)
-(hashq-set! config-properties #:source-module source-module)
-(hashq-set! config-properties #:pre pre)
-(hashq-set! config-properties #:post post)
-
-
-;; Config cells "are" immutable. @var{set-property!} is
-;; therefore intentionally unwritten.
-
-(define-public (get-property config-name property-key)
-  ((hashq-ref config-properties property-key) config-name))
-
-
-(define (define-config% name default-value kwargs)
-  (for (key value) in (group kwargs 2)
-       (set! ((or (hashq-ref config-properties key)
-                  (error "Missing config protperty slot " key))
-              name)
-         value))
-  (set-config! name (get-config name default-value)))
-
-(define-syntax define-config
-  (syntax-rules ()
-    ((_ name default kwargs ...)
-     (define-config% (quote name) default
-       (list source-module: (current-module)
-             kwargs ...)))))
-
-(define-public (set-config! name value)
-  (hashq-set! config-values name
-              (aif (pre name)
-                   (or (it value) (error "Pre crashed for" name))
-                   value))
-
-  (awhen (post name) (it value)))
-
-;; unique symbol here since #f is a valid configuration value.
-(define %uniq (gensym))
-(define*-public (get-config key optional: (default %uniq))
-  (if (eq? default %uniq)
-      (let ((v (hashq-ref config-values key %uniq)))
-        (when (eq? v %uniq)
-          (error "Missing config" key))
-        v)
-      (hashq-ref config-values key default)))
-
-
-
-(define-public ((ensure predicate) value)
-  (if (not (predicate value))
-      #f value))
-
-
-
-;; (format-procedure (lambda (x y) ...)) => λx, y
-;; (define (f x) ...)
-;; (format-procedure f) => f(x)
-(define (format-procedure proc)
-  ((aif (procedure-name proc)
-        (lambda (s) (string-append (symbol->string it) "(" s ")"))
-        (lambda (s) (string-append "λ" s)))
-   (let ((args ((@ (ice-9 session) procedure-arguments)
-                proc)))
-     (string-join
-      (remove null?
-              (list
-               (awhen ((ensure (negate null?))
-                       (assoc-ref args 'required))
-                      (format #f "~{~a~^, ~}" it))
-               (awhen ((ensure (negate null?))
-                       (assoc-ref args 'optional))
-                      (format #f "[~{~a~^, ~}]" it))
-               (awhen ((ensure (negate null?))
-                       (assoc-ref args 'keyword))
-                      (format #f "key: ~{~a~^, ~}"
-                              (map keyword->symbol
-                                   (map car it))))
-               (awhen ((ensure (negate null?))
-                       (assoc-ref args 'rest))
-                      (format #f "~a ..." it))))
-      ", "))))
-
-(export format-procedure)
-
-(define (->str any)
-  (with-output-to-string
-    (lambda () (display any))))
-
-(define-public (get-configuration-documentation)
-  (define groups
-    (group-by (compose source-module car)
-              (hash-map->list list config-values)))
-
-  `(*TOP*
-    (header "Configuration variables")
-    (dl
-     ,@(concatenate
-        (for (module values) in groups
-             `((dt "") (dd (header ,(aif module
-                                         (->str (module-name it))
-                                         #f)))
-               ,@(concatenate
-                  (for (key value) in values
-                       `((dt ,key)
-                         (dd (p (@ (inline))
-                                ,(or (description key) "")))
-                         (dt "V:")
-                         (dd ,(if (procedure? value)
-                                  (format-procedure value)
-                                  `(scheme ,value))
-                             (br)))))))))))
-
diff --git a/module/util/exceptions.scm b/module/util/exceptions.scm
deleted file mode 100644
index f316451d..00000000
--- a/module/util/exceptions.scm
+++ /dev/null
@@ -1,95 +0,0 @@
-(define-module (util exceptions)
-  #:use-module (srfi srfi-1)
-  #:use-module (util)
-  #:use-module (util config)
-  #:use-module (ice-9 format)
-  #:export (throw-returnable
-            catch-multiple
-            assert))
-
-(define-syntax-rule (throw-returnable symb args ...)
-  (call/cc (lambda (cont) (throw symb cont args ...))))
-
-;; Takes a (non nested) list, and replaces all single underscore
-;; symbols with a generated symbol. For macro usage.
-(define (multiple-ignore lst)
-  (map/dotted (lambda (symb) (if (eq? symb '_) (gensym "ignored_") symb))
-              lst))
-
-;; Like @var{catch}, but multiple handlers can be specified.
-;; Each handler is on the form
-;; @example
-;; [err-symb (args ...) body ...]
-;; @end example
-;; 
-;; Only errors with a handler are caught. Error can *not* be given as
-;; an early argument.
-(define-macro (catch-multiple thunk . cases)
-  (let catch-recur% ((errs (map car cases)) (cases cases))
-    (let* ((v (car errs))
-           (case other (partition (lambda (case) (eq? v (car case))) cases))
-           (g!rest (gensym "rest")))
-      `(catch (quote ,v)
-         ,(if (null? (cdr errs))
-              thunk
-              `(lambda () ,(catch-recur% (cdr errs) other)))
-         (lambda (err . ,g!rest)
-           (apply (lambda ,(let ((param-list (second (car case))))
-                        (if (not (pair? param-list))
-                            param-list
-                            (multiple-ignore param-list)))
-                    ,@(cddr (car case)))
-                  ,g!rest))))))
-
-
-
-(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 for ~a failed, ~a"
-            (quote ,form)
-            ((@@ (util exceptions) prettify-tree) ,(cons 'list form)))))
-
-
-(define-syntax catch-warnings
-  (syntax-rules ()
-    ((_ default body ...)
-     (parametrize ((warnings-are-errors #t))
-       (catch 'warning
-         (lambda ()
-           body ...)
-         (lambda _ default))))))
diff --git a/module/util/graph.scm b/module/util/graph.scm
deleted file mode 100644
index 999da743..00000000
--- a/module/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 (util graph)
-  :use-module (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/util/hooks.scm b/module/util/hooks.scm
deleted file mode 100644
index d4d44ec9..00000000
--- a/module/util/hooks.scm
+++ /dev/null
@@ -1,6 +0,0 @@
-(define-module (util hooks)
-  :export (shutdown-hook))
-
-;; Run before program terminates
-(define-once shutdown-hook
-  (make-hook 0))
diff --git a/module/util/io.scm b/module/util/io.scm
deleted file mode 100644
index 50f01e12..00000000
--- a/module/util/io.scm
+++ /dev/null
@@ -1,59 +0,0 @@
-(define-module (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 (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/util/options.scm b/module/util/options.scm
deleted file mode 100644
index a4c780bc..00000000
--- a/module/util/options.scm
+++ /dev/null
@@ -1,48 +0,0 @@
-(define-module (util options)
-  :use-module (util)
-  :use-module (srfi srfi-1)
-)
-
-;; option-assoc → getopt-valid option-assoc
-(define-public (getopt-opt options)
-  (map (lambda (optline)
-         (cons (car optline)
-               (map (lambda (opt-field)
-                      (cons (car opt-field)
-                            (cond [(and (eq? 'value (car opt-field))
-                                        (symbol? (cadr opt-field)))
-                                   '(optional)]
-                                  [else (cdr opt-field)])))
-                    (lset-intersection (lambda (a b) (eqv? b (car a)))
-                                       (cdr optline)
-                                       '(single-char required? value predicate)))))
-       options))
-
-
-
-
-;; (name (key value) ...) → sxml
-(define (fmt-help option-line)
-  (let ((name (car option-line))
-        (args (cdr option-line)))
-    (let ((valuefmt (case (and=> (assoc-ref args 'value) car)
-                      [(#t) '(" " (i value))]
-                      [(#f) '()]
-                      [else => (lambda (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)))))))
-
-(use-modules (text markup))
-
-(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/util/time.scm b/module/util/time.scm
deleted file mode 100644
index c97d3ee2..00000000
--- a/module/util/time.scm
+++ /dev/null
@@ -1,50 +0,0 @@
-(define-module (util time)
-  :use-module (ice-9 match)
-  :export (report-time! profile!))
-
-
-(define report-time!
-  (let ((last 0))
-   (lambda (fmt . args)
-     (let ((run (get-internal-run-time))
-                                        ; (real (get-internal-real-time))
-           )
-       (format (current-error-port) "~7,4fs (+ ~,4fs) │ ~?~%"
-               (/ run internal-time-units-per-second)
-               (/ (- run last) internal-time-units-per-second)
-               ;; (/ real internal-time-units-per-second)
-               fmt args)
-       (set! last run)))))
-
-(define-macro (profile! proc)
-  (let ((qualified-procedure
-         (match proc
-           [((or '@ '@@) (module ...) symb)
-            `(@@ ,module ,symb)]
-           [symb
-            `(@@ ,(module-name (current-module)) ,symb)]))
-        (og-procedure (gensym "proc")))
-    `(let ((,og-procedure ,qualified-procedure))
-       (set! ,qualified-procedure
-         (let ((accumulated-time 0)
-               (count 0))
-          (lambda args
-            (set! count (1+ count))
-            (let ((start-time (gettimeofday)))
-              (let ((return (apply ,og-procedure args)))
-                (let ((end-time (gettimeofday)))
-                  (let ((runtime (+ (- (car end-time) (car start-time))
-                                    (/ (- (cdr end-time) (cdr start-time))
-                                       1e6))))
-                    (set! accumulated-time (+ accumulated-time runtime))
-                    (when (> accumulated-time 1)
-                      (display (format #f "~8,4fs │ ~a  (~a)~%"
-                                       accumulated-time
-                                       (or (procedure-name ,qualified-procedure)
-                                           (quote ,qualified-procedure))
-                                       count)
-                               (current-error-port))
-                      (set! count 0)
-                      (set! accumulated-time 0)))
-                  return))))))
-       ,og-procedure)))
diff --git a/module/util/tree.scm b/module/util/tree.scm
deleted file mode 100644
index 474dc272..00000000
--- a/module/util/tree.scm
+++ /dev/null
@@ -1,40 +0,0 @@
-(define-module (util tree)
-  #:use-module (srfi srfi-1)
-  #:use-module (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)))))