diff options
Diffstat (limited to 'module/calp')
33 files changed, 43 insertions, 975 deletions
diff --git a/module/calp/benchmark/parse.scm b/module/calp/benchmark/parse.scm index 2d7c7b18..f1ddf17d 100644 --- a/module/calp/benchmark/parse.scm +++ b/module/calp/benchmark/parse.scm @@ -1,5 +1,5 @@ (define-module (calp benchmark parse) - :use-module (calp util) + :use-module (hnh util) :use-module (glob) :use-module (statprof) diff --git a/module/calp/entry-points/benchmark.scm b/module/calp/entry-points/benchmark.scm index 152a398c..5db9b9df 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 (calp util) + :use-module (hnh util) :use-module (ice-9 getopt-long) - :use-module (calp util options) + :use-module (hnh util options) :use-module ((srfi srfi-41) :select (stream->list)) :use-module ((vcomponent util instance methods) :select (get-event-set)) diff --git a/module/calp/entry-points/convert.scm b/module/calp/entry-points/convert.scm index f05b1e7b..3f602b07 100644 --- a/module/calp/entry-points/convert.scm +++ b/module/calp/entry-points/convert.scm @@ -1,7 +1,7 @@ (define-module (calp entry-points convert) :export (main) - :use-module (calp util) - :use-module (calp util options) + :use-module (hnh util) + :use-module (hnh util options) :use-module (ice-9 getopt-long) :use-module (sxml simple) ) diff --git a/module/calp/entry-points/html.scm b/module/calp/entry-points/html.scm index 45e71947..adac302f 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 (calp util) + :use-module (hnh util) :use-module (calp util time) - :use-module (calp util options) + :use-module (hnh util options) :use-module (datetime) :use-module (ice-9 getopt-long) :use-module ((ice-9 regex) :select (string-match regexp-substitute)) diff --git a/module/calp/entry-points/ical.scm b/module/calp/entry-points/ical.scm index 0ac01b17..938b0b35 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 (calp util) - :use-module (calp util options) + :use-module (hnh util) + :use-module (hnh util options) :use-module (vcomponent formats 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 69c5b687..441ff527 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 (calp util) - :use-module (calp util options) + :use-module (hnh util) + :use-module (hnh 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 8885f38d..c9ff339a 100644 --- a/module/calp/entry-points/server.scm +++ b/module/calp/entry-points/server.scm @@ -1,6 +1,6 @@ (define-module (calp entry-points server) - :use-module (calp util) - :use-module (calp util options) + :use-module (hnh util) + :use-module (hnh util options) :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 5aaa1f2d..b0be318c 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 (calp util options) + :use-module (hnh util options) ) (define options diff --git a/module/calp/entry-points/text.scm b/module/calp/entry-points/text.scm index 6da524ae..0a5744b3 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 (calp util io) - :use-module (calp util options) + :use-module (hnh util io) + :use-module (hnh util options) ) diff --git a/module/calp/entry-points/tidsrapport.scm b/module/calp/entry-points/tidsrapport.scm index abdd7aa2..5ff43cf7 100644 --- a/module/calp/entry-points/tidsrapport.scm +++ b/module/calp/entry-points/tidsrapport.scm @@ -39,8 +39,8 @@ (define-module (calp entry-points tidsrapport) :export (main) - :use-module (calp util) - :use-module (calp util options) + :use-module (hnh util) + :use-module (hnh util options) :use-module (ice-9 getopt-long) :use-module (datetime) ) @@ -52,7 +52,7 @@ (datetime) (vcomponent util instance) (vcomponent util instance methods) - (calp util) + (hnh util) (ice-9 regex) (ice-9 popen) ) diff --git a/module/calp/html/caltable.scm b/module/calp/html/caltable.scm index 2f5a6d31..dd2d4b03 100644 --- a/module/calp/html/caltable.scm +++ b/module/calp/html/caltable.scm @@ -1,5 +1,5 @@ (define-module (calp html caltable) - :use-module (calp util) + :use-module (hnh 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 36ec5166..2f8c85ec 100644 --- a/module/calp/html/components.scm +++ b/module/calp/html/components.scm @@ -1,5 +1,5 @@ (define-module (calp html components) - :use-module (calp util) + :use-module (hnh util) :use-module (ice-9 curried-definitions) :use-module (ice-9 match) :export (xhtml-doc) diff --git a/module/calp/html/config.scm b/module/calp/html/config.scm index 081777ac..6bd1e0ec 100644 --- a/module/calp/html/config.scm +++ b/module/calp/html/config.scm @@ -1,5 +1,5 @@ (define-module (calp html config) - :use-module (calp util) + :use-module (hnh util) :use-module (calp util config) ) diff --git a/module/calp/html/util.scm b/module/calp/html/util.scm index 40852279..ecb54198 100644 --- a/module/calp/html/util.scm +++ b/module/calp/html/util.scm @@ -1,5 +1,5 @@ (define-module (calp html util) - :use-module (calp util)) + :use-module (hnh util)) (define-public (date-link date) diff --git a/module/calp/html/vcomponent.scm b/module/calp/html/vcomponent.scm index 2abf370d..34aeca66 100644 --- a/module/calp/html/vcomponent.scm +++ b/module/calp/html/vcomponent.scm @@ -1,5 +1,5 @@ (define-module (calp html vcomponent) - :use-module (calp util) + :use-module (hnh util) :use-module (srfi srfi-1) :use-module (srfi srfi-41) :use-module ((rnrs io ports) :select (put-bytevector)) @@ -10,7 +10,7 @@ :use-module (calp html util) :use-module ((calp html config) :select (edit-mode debug)) :use-module ((calp html components) :select (btn tabset form with-label)) - :use-module ((calp util color) :select (calculate-fg-color)) + :use-module ((hnh util color) :select (calculate-fg-color)) :use-module ((crypto) :select (sha256 checksum->string)) :use-module ((xdg basedir) :prefix xdg-) :use-module ((vcomponent recurrence) :select (repeating?)) diff --git a/module/calp/html/view/calendar.scm b/module/calp/html/view/calendar.scm index 64fafb3d..ecdce291 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 (calp util) + :use-module (hnh util) :use-module (vcomponent) :use-module ((vcomponent datetime) :select (events-between)) diff --git a/module/calp/html/view/calendar/month.scm b/module/calp/html/view/calendar/month.scm index 6506b0ea..2b4c888a 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 (calp util) + :use-module (hnh 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 badea7b9..de09e00a 100644 --- a/module/calp/html/view/calendar/shared.scm +++ b/module/calp/html/view/calendar/shared.scm @@ -1,6 +1,6 @@ (define-module (calp html view calendar shared) - :use-module (calp util) - :use-module ((calp util exceptions) :select (assert)) + :use-module (hnh util) + :use-module ((hnh util exceptions) :select (assert)) :use-module (srfi srfi-1) :use-module (vcomponent) :use-module ((vcomponent datetime) @@ -9,7 +9,7 @@ event-length/clamped)) :use-module ((vcomponent datetime output) :select (format-summary)) - :use-module (calp util tree) + :use-module (hnh 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 1714c6c4..5b12a351 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 (calp util) + :use-module (hnh util) :use-module (srfi srfi-1) :use-module (srfi srfi-41) :use-module (rnrs records syntactic) diff --git a/module/calp/html/view/search.scm b/module/calp/html/view/search.scm index b939e7a2..b6f36612 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 (calp util) + :use-module (hnh util) :use-module (vcomponent) :use-module (vcomponent util search) :use-module ((ice-9 pretty-print) :select (pretty-print)) diff --git a/module/calp/main.scm b/module/calp/main.scm index 770be556..d1e33d55 100644 --- a/module/calp/main.scm +++ b/module/calp/main.scm @@ -1,16 +1,16 @@ ;; -*- geiser-scheme-implementation: guile -*- (define-module (calp main) - :use-module (calp util) + :use-module (hnh util) :use-module (srfi srfi-1) :use-module (srfi srfi-88) ; keyword syntax :use-module ((calp util config) :select (set-config! get-config get-configuration-documentation)) - :use-module (calp util options) + :use-module (hnh util options) :use-module ((calp util hooks) :select (shutdown-hook)) :use-module ((text markup) :select (sxml->ansi-text)) - :use-module ((calp util exceptions) :select (filter-stack)) + :use-module ((hnh util exceptions) :select (filter-stack)) :use-module (ice-9 getopt-long) :use-module (ice-9 regex) @@ -215,7 +215,7 @@ ;; (define path (read-line pipe)) (define line ((@ (ice-9 rdelim) read-line) pipe)) (define names (string-split line #\space)) - ((@ (calp util io) with-atomic-output-to-file) + ((@ (hnh util io) with-atomic-output-to-file) (path-append (xdg-data-home) "/calp/zoneinfo.scm") (lambda () (write `(set-config! 'tz-list ',names)) (newline) diff --git a/module/calp/repl.scm b/module/calp/repl.scm index 0765b65c..e25c2649 100644 --- a/module/calp/repl.scm +++ b/module/calp/repl.scm @@ -6,7 +6,7 @@ :use-module (system repl server) :use-module (ice-9 regex) :use-module ((calp util hooks) :select (shutdown-hook)) - :use-module ((calp util exceptions) :select (warning)) + :use-module ((hnh util exceptions) :select (warning)) ) (define-public (repl-start address) diff --git a/module/calp/server/routes.scm b/module/calp/server/routes.scm index a435bbc0..b53e1cad 100644 --- a/module/calp/server/routes.scm +++ b/module/calp/server/routes.scm @@ -1,7 +1,7 @@ (define-module (calp server routes) - :use-module (calp util) - :use-module (calp util options) - :use-module (calp util exceptions) + :use-module (hnh util) + :use-module (hnh util options) + :use-module (hnh util exceptions) :use-module (srfi srfi-1) diff --git a/module/calp/server/server.scm b/module/calp/server/server.scm index ae2117ab..fc185033 100644 --- a/module/calp/server/server.scm +++ b/module/calp/server/server.scm @@ -1,5 +1,5 @@ (define-module (calp server server) - :use-module (calp util) + :use-module (hnh 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 1014b94c..cd1d0c9d 100644 --- a/module/calp/terminal.scm +++ b/module/calp/terminal.scm @@ -4,7 +4,7 @@ #:use-module (srfi srfi-17) #:use-module (srfi srfi-26) #:use-module ((srfi srfi-41) :select (stream-car)) - #:use-module (calp util) + #:use-module (hnh util) #:use-module (vulgar) #:use-module (vulgar info) #:use-module (vulgar color) diff --git a/module/calp/util.scm b/module/calp/util.scm deleted file mode 100644 index e1e2131a..00000000 --- a/module/calp/util.scm +++ /dev/null @@ -1,616 +0,0 @@ -(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? - -> ->> set set-> aif awhen - let-lazy let-env - case* define-many - and=>> label - print-and-return - begin1 - ) - #: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-syntax-rule (begin1 first rest ...) - (let ((return first)) - rest ... - return)) - - - - - -(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) - (error "Can't find extreme in an empty list") - (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)) - -;; 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)))))) - -;; 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))) - -;; (split-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))]))) - - - -;; Simar to span from srfi-1, but never takes more than -;; @var{count} items. Can however still take less. -;; @example -;; (span-upto 2 char-numeric? (string->list "123456")) -;; ⇒ (#\1 #\2) -;; ⇒ (#\3 #\4 #\5 #\6) -;; (span-upto 2 char-numeric? (string->list "H123456")) -;; ⇒ () -;; ⇒ (#\H #\1 #\2 #\3 #\4 #\5 #\6) -;; @end example -(define-public (span-upto count predicate list) - (let loop ((remaining count) - (taken '()) - (list list)) - (if (or (zero? remaining) (null? list)) - (values (reverse! taken) list) - (if (predicate (car list)) - (loop (1- remaining) - (cons (car list) taken) - (cdr list)) - (loop (1- remaining) - taken list))))) - - -;; 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 (intersperse 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 (ass%-ref-all alist key =) - (map cdr (filter (lambda (pair) (= key (car pair))) - alist))) - -;; Equivalent to assoc-ref (and family), but works on association lists with -;; non-unique keys, returning all mathing records (instead of just the first). -;; @begin lisp -;; (assoc-ref-all '((a . 1) (b . 2) (a . 3)) 'a) -;; ⇒ (1 3) -;; @end -(define-public (assoc-ref-all alist key) (ass%-ref-all alist key equal?)) -(define-public (assq-ref-all alist key) (ass%-ref-all alist key eq?)) -(define-public (assv-ref-all alist key) (ass%-ref-all alist key eqv?)) - - - - -(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 (->quoted-string any) - (with-output-to-string (lambda () (write any)))) - - - - -;; TODO shouldn't this use `file-name-separator-string'? -(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 #f)) - (dynamic-wind - (lambda () - (set! 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)) - (lambda () body ...) - (lambda () - (for-each (lambda (pair) (setenv (car pair) (caddr pair))) - env-pairs))))])) - - -(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 deleted file mode 100644 index 161e6707..00000000 --- a/module/calp/util/color.scm +++ /dev/null @@ -1,22 +0,0 @@ -(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 index fbe35d59..2fe2b9b0 100644 --- a/module/calp/util/config.scm +++ b/module/calp/util/config.scm @@ -5,7 +5,7 @@ ;;; Code: (define-module (calp util config) - :use-module (calp util) + :use-module (hnh util) :use-module (srfi srfi-1) :use-module (ice-9 format) ; for format-procedure :use-module (ice-9 curried-definitions) ; for ensure diff --git a/module/calp/util/exceptions.scm b/module/calp/util/exceptions.scm deleted file mode 100644 index d9df30ed..00000000 --- a/module/calp/util/exceptions.scm +++ /dev/null @@ -1,57 +0,0 @@ -(define-module (calp util exceptions) - #:use-module (srfi srfi-1) - #:use-module (calp util) - #:use-module (calp util config) - #:use-module (ice-9 format) - - #:use-module ((system vm frame) - :select (frame-bindings binding-ref)) - - #:export (assert)) - - -(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 failed. ~a expected, ~a got" - (quote ,form) - ((@@ (calp util exceptions) prettify-tree) (list ,form))))) - - -(define-public (filter-stack pred? stk) - (concatenate - (for i in (iota (stack-length stk)) - (filter pred? (map binding-ref (frame-bindings (stack-ref stk i))))))) diff --git a/module/calp/util/graph.scm b/module/calp/util/graph.scm deleted file mode 100644 index 6a01a9ee..00000000 --- a/module/calp/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 (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/io.scm b/module/calp/util/io.scm deleted file mode 100644 index 7db1eee2..00000000 --- a/module/calp/util/io.scm +++ /dev/null @@ -1,59 +0,0 @@ -(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 deleted file mode 100644 index 20263c45..00000000 --- a/module/calp/util/options.scm +++ /dev/null @@ -1,45 +0,0 @@ -(define-module (calp util options) - :use-module (calp util) - :use-module (ice-9 match) - :use-module (srfi srfi-1) - :use-module (text markup) - ) - -;; option-assoc → getopt-valid option-assoc -(define-public (getopt-opt options) - (define ice-9-names '(single-char required? value predicate)) - (for (option-name flags ...) in options - (cons option-name - (map (match-lambda - (('value (_ ...)) `(value #t)) - (('value (? symbol? _)) `(value optional)) - ((key v) `(,key ,v))) - (filter (match-lambda ((key _ ...) (memv key ice-9-names))) - flags))))) - - -;; (name (key value) ...) → sxml -(define (fmt-help option-line) - (match option-line - ((name args ...) - (let ((valuefmt (match (assoc-ref args 'value) - [(#t) '(" " (i value))] - [(or #f (#f)) '()] - [(('options options ...)) - `(" {" ,(string-join options "|") "}")] - [(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)))))))) - -(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/tree.scm b/module/calp/util/tree.scm deleted file mode 100644 index b7856aa9..00000000 --- a/module/calp/util/tree.scm +++ /dev/null @@ -1,40 +0,0 @@ -(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))))) |