diff options
Diffstat (limited to 'module/calp')
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))))) |