aboutsummaryrefslogtreecommitdiff
path: root/module/calp
diff options
context:
space:
mode:
Diffstat (limited to 'module/calp')
-rw-r--r--module/calp/benchmark/parse.scm2
-rw-r--r--module/calp/entry-points/benchmark.scm4
-rw-r--r--module/calp/entry-points/html.scm10
-rw-r--r--module/calp/entry-points/ical.scm4
-rw-r--r--module/calp/entry-points/import.scm4
-rw-r--r--module/calp/entry-points/server.scm8
-rw-r--r--module/calp/entry-points/terminal.scm2
-rw-r--r--module/calp/entry-points/text.scm4
-rw-r--r--module/calp/html/caltable.scm2
-rw-r--r--module/calp/html/components.scm4
-rw-r--r--module/calp/html/config.scm4
-rw-r--r--module/calp/html/util.scm2
-rw-r--r--module/calp/html/vcomponent.scm4
-rw-r--r--module/calp/html/view/calendar.scm4
-rw-r--r--module/calp/html/view/calendar/month.scm2
-rw-r--r--module/calp/html/view/calendar/shared.scm4
-rw-r--r--module/calp/html/view/calendar/week.scm2
-rw-r--r--module/calp/html/view/search.scm2
-rw-r--r--module/calp/main.scm12
-rw-r--r--module/calp/repl.scm4
-rw-r--r--module/calp/server/routes.scm6
-rw-r--r--module/calp/server/server.scm2
-rw-r--r--module/calp/terminal.scm2
-rw-r--r--module/calp/util.scm574
-rw-r--r--module/calp/util/color.scm22
-rw-r--r--module/calp/util/config.scm136
-rw-r--r--module/calp/util/exceptions.scm95
-rw-r--r--module/calp/util/graph.scm93
-rw-r--r--module/calp/util/hooks.scm6
-rw-r--r--module/calp/util/io.scm59
-rw-r--r--module/calp/util/options.scm48
-rw-r--r--module/calp/util/time.scm50
-rw-r--r--module/calp/util/tree.scm40
33 files changed, 1170 insertions, 47 deletions
diff --git a/module/calp/benchmark/parse.scm b/module/calp/benchmark/parse.scm
index e9bc509f..f1be66f5 100644
--- a/module/calp/benchmark/parse.scm
+++ b/module/calp/benchmark/parse.scm
@@ -1,5 +1,5 @@
(define-module (calp benchmark parse)
- :use-module (util)
+ :use-module (calp util)
:use-module (glob)
:use-module (statprof)
diff --git a/module/calp/entry-points/benchmark.scm b/module/calp/entry-points/benchmark.scm
index 7706f6f0..851edc59 100644
--- a/module/calp/entry-points/benchmark.scm
+++ b/module/calp/entry-points/benchmark.scm
@@ -1,8 +1,8 @@
(define-module (calp entry-points benchmark)
- :use-module (util)
+ :use-module (calp util)
:use-module (ice-9 getopt-long)
- :use-module (util options)
+ :use-module (calp util options)
:use-module ((srfi srfi-41) :select (stream->list))
:use-module ((vcomponent instance methods) :select (get-event-set))
diff --git a/module/calp/entry-points/html.scm b/module/calp/entry-points/html.scm
index 8c400e1d..39f00979 100644
--- a/module/calp/entry-points/html.scm
+++ b/module/calp/entry-points/html.scm
@@ -1,8 +1,8 @@
(define-module (calp entry-points html)
:export (main)
- :use-module (util)
- :use-module (util time)
- :use-module (util options)
+ :use-module (calp util)
+ :use-module (calp util time)
+ :use-module (calp util options)
:use-module (datetime)
:use-module (ice-9 getopt-long)
:use-module ((ice-9 regex) :select (string-match regexp-substitute))
@@ -91,7 +91,7 @@
(define calendars (get-calendars global-event-object))
(define events (get-event-set global-event-object))
- ((@ (util time) report-time!) "html start")
+ ((@ (calp util time) report-time!) "html start")
(create-files target-directory)
@@ -168,5 +168,5 @@
[else
(error "Unknown html style: ~a" style)])
- ((@ (util time) report-time!) "all done")
+ ((@ (calp util time) report-time!) "all done")
)
diff --git a/module/calp/entry-points/ical.scm b/module/calp/entry-points/ical.scm
index 0b6a0535..15e677b5 100644
--- a/module/calp/entry-points/ical.scm
+++ b/module/calp/entry-points/ical.scm
@@ -1,7 +1,7 @@
(define-module (calp entry-points ical)
:export (main)
- :use-module (util)
- :use-module (util options)
+ :use-module (calp util)
+ :use-module (calp util options)
:use-module (vcomponent ical output)
:use-module (ice-9 getopt-long)
:use-module (datetime)
diff --git a/module/calp/entry-points/import.scm b/module/calp/entry-points/import.scm
index e8c46ea8..f25e642f 100644
--- a/module/calp/entry-points/import.scm
+++ b/module/calp/entry-points/import.scm
@@ -1,7 +1,7 @@
(define-module (calp entry-points import)
:export (main)
- :use-module (util)
- :use-module (util options)
+ :use-module (calp util)
+ :use-module (calp util options)
:use-module (ice-9 getopt-long)
:use-module (ice-9 rdelim)
:use-module (srfi srfi-1)
diff --git a/module/calp/entry-points/server.scm b/module/calp/entry-points/server.scm
index 87eaba1e..55f84c1a 100644
--- a/module/calp/entry-points/server.scm
+++ b/module/calp/entry-points/server.scm
@@ -1,8 +1,8 @@
(define-module (calp entry-points server)
- :use-module (util)
- :use-module (util options)
- :use-module (util exceptions)
- :use-module (util config)
+ :use-module (calp util)
+ :use-module (calp util options)
+ :use-module (calp util exceptions)
+ :use-module (calp util config)
:use-module (srfi srfi-1)
diff --git a/module/calp/entry-points/terminal.scm b/module/calp/entry-points/terminal.scm
index fa035e7a..5aaa1f2d 100644
--- a/module/calp/entry-points/terminal.scm
+++ b/module/calp/entry-points/terminal.scm
@@ -5,7 +5,7 @@
:use-module (ice-9 getopt-long)
:use-module (datetime)
:use-module (vulgar)
- :use-module (util options)
+ :use-module (calp util options)
)
(define options
diff --git a/module/calp/entry-points/text.scm b/module/calp/entry-points/text.scm
index 04f57a31..6da524ae 100644
--- a/module/calp/entry-points/text.scm
+++ b/module/calp/entry-points/text.scm
@@ -2,8 +2,8 @@
:export (main)
:use-module (text flow)
:use-module (ice-9 getopt-long)
- :use-module (util io)
- :use-module (util options)
+ :use-module (calp util io)
+ :use-module (calp util options)
)
diff --git a/module/calp/html/caltable.scm b/module/calp/html/caltable.scm
index 65a70252..2f5a6d31 100644
--- a/module/calp/html/caltable.scm
+++ b/module/calp/html/caltable.scm
@@ -1,5 +1,5 @@
(define-module (calp html caltable)
- :use-module (util)
+ :use-module (calp util)
:use-module (calp html util)
:use-module (datetime)
:use-module (srfi srfi-41)
diff --git a/module/calp/html/components.scm b/module/calp/html/components.scm
index 49f00e52..ebc359b8 100644
--- a/module/calp/html/components.scm
+++ b/module/calp/html/components.scm
@@ -1,6 +1,6 @@
(define-module (calp html components)
- :use-module (util)
- :use-module (util exceptions)
+ :use-module (calp util)
+ :use-module (calp util exceptions)
:export (xhtml-doc)
)
diff --git a/module/calp/html/config.scm b/module/calp/html/config.scm
index 6f156c98..081777ac 100644
--- a/module/calp/html/config.scm
+++ b/module/calp/html/config.scm
@@ -1,6 +1,6 @@
(define-module (calp html config)
- :use-module (util)
- :use-module (util config)
+ :use-module (calp util)
+ :use-module (calp util config)
)
(define-public debug (make-parameter #f))
diff --git a/module/calp/html/util.scm b/module/calp/html/util.scm
index 8410472c..cd5aaeab 100644
--- a/module/calp/html/util.scm
+++ b/module/calp/html/util.scm
@@ -1,6 +1,6 @@
(define-module (calp html util)
:use-module ((base64) :select (base64encode base64decode))
- :use-module (util))
+ :use-module (calp util))
;;; @var{html-attr} & @var{html-unattr} used to just strip any
;;; attributes not valid in css. That allowed a human reader to
diff --git a/module/calp/html/vcomponent.scm b/module/calp/html/vcomponent.scm
index be6b6166..3a2bd3cc 100644
--- a/module/calp/html/vcomponent.scm
+++ b/module/calp/html/vcomponent.scm
@@ -1,5 +1,5 @@
(define-module (calp html vcomponent)
- :use-module (util)
+ :use-module (calp util)
:use-module (vcomponent)
:use-module (srfi srfi-1)
:use-module (srfi srfi-41)
@@ -7,7 +7,7 @@
:use-module (calp html util)
:use-module ((calp html config) :select (edit-mode))
:use-module ((calp html components) :select (btn tabset))
- :use-module ((util color) :select (calculate-fg-color))
+ :use-module ((calp util color) :select (calculate-fg-color))
:use-module ((vcomponent datetime output)
:select (fmt-time-span
format-description
diff --git a/module/calp/html/view/calendar.scm b/module/calp/html/view/calendar.scm
index 67a1a7b5..27edfcb4 100644
--- a/module/calp/html/view/calendar.scm
+++ b/module/calp/html/view/calendar.scm
@@ -1,5 +1,5 @@
(define-module (calp html view calendar)
- :use-module (util)
+ :use-module (calp util)
:use-module (vcomponent)
:use-module ((vcomponent datetime)
:select (events-between))
@@ -18,7 +18,7 @@
:use-module (calp html util)
:use-module ((calp html caltable) :select (cal-table))
- :use-module (util config)
+ :use-module (calp util config)
:use-module (srfi srfi-1)
:use-module (srfi srfi-26)
diff --git a/module/calp/html/view/calendar/month.scm b/module/calp/html/view/calendar/month.scm
index ce8957da..0ac69292 100644
--- a/module/calp/html/view/calendar/month.scm
+++ b/module/calp/html/view/calendar/month.scm
@@ -1,5 +1,5 @@
(define-module (calp html view calendar month)
- :use-module (util)
+ :use-module (calp util)
:use-module (srfi srfi-1)
:use-module (srfi srfi-41)
:use-module (srfi srfi-41 util)
diff --git a/module/calp/html/view/calendar/shared.scm b/module/calp/html/view/calendar/shared.scm
index 73698060..fb5eace5 100644
--- a/module/calp/html/view/calendar/shared.scm
+++ b/module/calp/html/view/calendar/shared.scm
@@ -1,5 +1,5 @@
(define-module (calp html view calendar shared)
- :use-module (util)
+ :use-module (calp util)
:use-module (srfi srfi-1)
:use-module (vcomponent)
:use-module ((vcomponent datetime)
@@ -8,7 +8,7 @@
event-length/clamped))
:use-module ((vcomponent datetime output)
:select (format-summary))
- :use-module (util tree)
+ :use-module (calp util tree)
:use-module (datetime)
:use-module (calp html config)
:use-module ((calp html components)
diff --git a/module/calp/html/view/calendar/week.scm b/module/calp/html/view/calendar/week.scm
index ca6aa9f8..111c8f21 100644
--- a/module/calp/html/view/calendar/week.scm
+++ b/module/calp/html/view/calendar/week.scm
@@ -1,5 +1,5 @@
(define-module (calp html view calendar week)
- :use-module (util)
+ :use-module (calp util)
:use-module (srfi srfi-1)
:use-module (srfi srfi-41)
:use-module (datetime)
diff --git a/module/calp/html/view/search.scm b/module/calp/html/view/search.scm
index faefe6dc..3141fa11 100644
--- a/module/calp/html/view/search.scm
+++ b/module/calp/html/view/search.scm
@@ -1,5 +1,5 @@
(define-module (calp html view search)
- :use-module (util)
+ :use-module (calp util)
:use-module (vcomponent)
:use-module (vcomponent search)
:use-module ((ice-9 pretty-print) :select (pretty-print))
diff --git a/module/calp/main.scm b/module/calp/main.scm
index e336846a..39d8f625 100644
--- a/module/calp/main.scm
+++ b/module/calp/main.scm
@@ -1,13 +1,13 @@
;; -*- geiser-scheme-implementation: guile -*-
(define-module (calp main)
- :use-module (util)
+ :use-module (calp util)
:use-module (srfi srfi-1)
:use-module (srfi srfi-88) ; keyword syntax
- :use-module ((util config) :select (set-config! get-config get-configuration-documentation))
- :use-module (util options)
- :use-module ((util hooks) :select (shutdown-hook))
+ :use-module ((calp util config) :select (set-config! get-config get-configuration-documentation))
+ :use-module (calp util options)
+ :use-module ((calp util hooks) :select (shutdown-hook))
:use-module ((text markup) :select (sxml->ansi-text))
@@ -170,7 +170,7 @@
;; (define path (read-line pipe))
(define line ((@ (ice-9 rdelim) read-line) pipe))
(define names (string-split line #\space))
- ((@ (util io) with-atomic-output-to-file)
+ ((@ (calp util io) with-atomic-output-to-file)
(path-append (xdg-data-home) "/calp/zoneinfo.scm")
(lambda ()
(write `(set-config! 'tz-list ',names)) (newline)
@@ -207,7 +207,7 @@
(string->symbol stprof)))))
(define-public (main args)
- ((@ (util time) report-time!) "Program start")
+ ((@ (calp util time) report-time!) "Program start")
(dynamic-wind (lambda () 'noop)
(lambda () (catch 'return (lambda () (wrapped-main args)) values))
(lambda () (run-hook shutdown-hook))))
diff --git a/module/calp/repl.scm b/module/calp/repl.scm
index f43b8fce..d4f087aa 100644
--- a/module/calp/repl.scm
+++ b/module/calp/repl.scm
@@ -5,8 +5,8 @@
(define-module (calp repl)
:use-module (system repl server)
:use-module (ice-9 regex)
- :use-module ((util hooks) :select (shutdown-hook))
- :use-module (util exceptions)
+ :use-module ((calp util hooks) :select (shutdown-hook))
+ :use-module (calp util exceptions)
)
(define-public (repl-start address)
diff --git a/module/calp/server/routes.scm b/module/calp/server/routes.scm
index 51e5acb2..f647b998 100644
--- a/module/calp/server/routes.scm
+++ b/module/calp/server/routes.scm
@@ -1,7 +1,7 @@
(define-module (calp server routes)
- :use-module (util)
- :use-module (util options)
- :use-module (util exceptions)
+ :use-module (calp util)
+ :use-module (calp util options)
+ :use-module (calp util exceptions)
:use-module (srfi srfi-1)
diff --git a/module/calp/server/server.scm b/module/calp/server/server.scm
index 1ad700f1..ae2117ab 100644
--- a/module/calp/server/server.scm
+++ b/module/calp/server/server.scm
@@ -1,5 +1,5 @@
(define-module (calp server server)
- :use-module (util)
+ :use-module (calp util)
:use-module (web server)
:use-module ((calp server routes) :select (make-make-routes))
:use-module (ice-9 threads))
diff --git a/module/calp/terminal.scm b/module/calp/terminal.scm
index fd513a63..7887df5e 100644
--- a/module/calp/terminal.scm
+++ b/module/calp/terminal.scm
@@ -5,7 +5,7 @@
#:use-module (srfi srfi-26)
#:use-module (srfi srfi-41)
#:use-module (srfi srfi-41 util)
- #:use-module (util)
+ #:use-module (calp util)
#:use-module (vulgar)
#:use-module (vulgar info)
#:use-module (vulgar color)
diff --git a/module/calp/util.scm b/module/calp/util.scm
new file mode 100644
index 00000000..25c753dc
--- /dev/null
+++ b/module/calp/util.scm
@@ -0,0 +1,574 @@
+(define-module (calp 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?
+ re-export-modules
+ -> ->> set set-> aif awhen
+ let-lazy let-env
+ case* define-many
+ and=>> label
+ print-and-return
+ )
+ #: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-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)
+ ;; Vad fan retunerar man här?
+ (values #f '())
+ (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))
+
+;; Map with index
+(define-syntax-rule (map-each proc lst)
+ (map (lambda (x i) (proc x i))
+ lst (iota (length lst))))
+
+(export map-each)
+
+;; 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))))))
+
+(define-syntax re-export-modules
+ (syntax-rules ()
+ ((_ (mod ...) ...)
+ (begin
+ (module-use! (module-public-interface (current-module))
+ (resolve-interface '(mod ...)))
+ ...))))
+
+;; 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)))
+
+;; (group-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))])))
+
+
+;; 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 (intersperce 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-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 (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
+ (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)
+ (let ((return (begin body ...)))
+ (for-each (lambda (pair) (setenv (car pair) (caddr pair)))
+ env-pairs)
+ return))]))
+
+(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/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)))))