diff options
Diffstat (limited to 'module/calp/util')
-rw-r--r-- | module/calp/util/color.scm | 22 | ||||
-rw-r--r-- | module/calp/util/config.scm | 136 | ||||
-rw-r--r-- | module/calp/util/exceptions.scm | 95 | ||||
-rw-r--r-- | module/calp/util/graph.scm | 93 | ||||
-rw-r--r-- | module/calp/util/hooks.scm | 6 | ||||
-rw-r--r-- | module/calp/util/io.scm | 59 | ||||
-rw-r--r-- | module/calp/util/options.scm | 48 | ||||
-rw-r--r-- | module/calp/util/time.scm | 50 | ||||
-rw-r--r-- | module/calp/util/tree.scm | 40 |
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))))) |