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