Move util modules into calp module..

9 files changed, 549 insertions, 0 deletions

diff --git a/module/calp/util/color.scm b/module/calp/util/color.scm
new file mode 100644
index 00000000..161e6707
--- /dev/null
+++ b/module/calp/util/color.scm
@@ -0,0 +1,22 @@
+(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
new file mode 100644
index 00000000..32dabb69
--- /dev/null
+++ b/module/calp/util/config.scm
@@ -0,0 +1,136 @@
+;;; Commentary:
+
+;; Configuration system.
+
+;;; Code:
+
+(define-module (calp util config)
+  :use-module (calp 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/calp/util/exceptions.scm b/module/calp/util/exceptions.scm
new file mode 100644
index 00000000..29e1472c
--- /dev/null
+++ b/module/calp/util/exceptions.scm
@@ -0,0 +1,95 @@
+(define-module (calp util exceptions)
+  #:use-module (srfi srfi-1)
+  #:use-module (calp util)
+  #:use-module (calp 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)
+            ((@@ (calp 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/calp/util/graph.scm b/module/calp/util/graph.scm
new file mode 100644
index 00000000..6a01a9ee
--- /dev/null
+++ b/module/calp/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 (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/hooks.scm b/module/calp/util/hooks.scm
new file mode 100644
index 00000000..7a784085
--- /dev/null
+++ b/module/calp/util/hooks.scm
@@ -0,0 +1,6 @@
+(define-module (calp util hooks)
+  :export (shutdown-hook))
+
+;; Run before program terminates
+(define-once shutdown-hook
+  (make-hook 0))
diff --git a/module/calp/util/io.scm b/module/calp/util/io.scm
new file mode 100644
index 00000000..7db1eee2
--- /dev/null
+++ b/module/calp/util/io.scm
@@ -0,0 +1,59 @@
+(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
new file mode 100644
index 00000000..0e239a78
--- /dev/null
+++ b/module/calp/util/options.scm
@@ -0,0 +1,48 @@
+(define-module (calp util options)
+  :use-module (calp 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/calp/util/time.scm b/module/calp/util/time.scm
new file mode 100644
index 00000000..0a624d30
--- /dev/null
+++ b/module/calp/util/time.scm
@@ -0,0 +1,50 @@
+(define-module (calp 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/calp/util/tree.scm b/module/calp/util/tree.scm
new file mode 100644
index 00000000..b7856aa9
--- /dev/null
+++ b/module/calp/util/tree.scm
@@ -0,0 +1,40 @@
+(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)))))