From d3afa54144748685d12c159407194e03538e98de Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Hugo=20H=C3=B6rnquist?= Date: Mon, 24 Aug 2020 20:34:11 +0200 Subject: Move util modules into calp module.. --- config.scm | 2 +- module/c/cpp.scm | 6 +- module/c/parse.scm | 2 +- module/calp/benchmark/parse.scm | 2 +- module/calp/entry-points/benchmark.scm | 4 +- module/calp/entry-points/html.scm | 10 +- module/calp/entry-points/ical.scm | 4 +- module/calp/entry-points/import.scm | 4 +- module/calp/entry-points/server.scm | 8 +- module/calp/entry-points/terminal.scm | 2 +- module/calp/entry-points/text.scm | 4 +- module/calp/html/caltable.scm | 2 +- module/calp/html/components.scm | 4 +- module/calp/html/config.scm | 4 +- module/calp/html/util.scm | 2 +- module/calp/html/vcomponent.scm | 4 +- module/calp/html/view/calendar.scm | 4 +- module/calp/html/view/calendar/month.scm | 2 +- module/calp/html/view/calendar/shared.scm | 4 +- module/calp/html/view/calendar/week.scm | 2 +- module/calp/html/view/search.scm | 2 +- module/calp/main.scm | 12 +- module/calp/repl.scm | 4 +- module/calp/server/routes.scm | 6 +- module/calp/server/server.scm | 2 +- module/calp/terminal.scm | 2 +- module/calp/util.scm | 574 ++++++++++++++++++++++++++++++ module/calp/util/color.scm | 22 ++ module/calp/util/config.scm | 136 +++++++ module/calp/util/exceptions.scm | 95 +++++ module/calp/util/graph.scm | 93 +++++ module/calp/util/hooks.scm | 6 + module/calp/util/io.scm | 59 +++ module/calp/util/options.scm | 48 +++ module/calp/util/time.scm | 50 +++ module/calp/util/tree.scm | 40 +++ module/datetime.scm | 4 +- module/datetime/instance.scm | 6 +- module/datetime/timespec.scm | 4 +- module/datetime/zic.scm | 4 +- module/srfi/srfi-41/util.scm | 2 +- module/sxml/namespace.scm | 2 +- module/sxml/transformations.scm | 2 +- module/text/flow.scm | 2 +- module/text/markup.scm | 2 +- module/text/numbers.scm | 2 +- module/text/util.scm | 2 +- module/util.scm | 574 ------------------------------ module/util/color.scm | 22 -- module/util/config.scm | 136 ------- module/util/exceptions.scm | 95 ----- module/util/graph.scm | 93 ----- module/util/hooks.scm | 6 - module/util/io.scm | 59 --- module/util/options.scm | 48 --- module/util/time.scm | 50 --- module/util/tree.scm | 40 --- module/vcomponent.scm | 4 +- module/vcomponent/base.scm | 2 +- module/vcomponent/build.scm | 2 +- module/vcomponent/control.scm | 2 +- module/vcomponent/datetime.scm | 2 +- module/vcomponent/datetime/output.scm | 6 +- module/vcomponent/describe.scm | 2 +- module/vcomponent/duration.scm | 4 +- module/vcomponent/geo.scm | 2 +- module/vcomponent/ical/output.scm | 4 +- module/vcomponent/ical/parse.scm | 4 +- module/vcomponent/ical/types.scm | 4 +- module/vcomponent/instance.scm | 4 +- module/vcomponent/instance/methods.scm | 2 +- module/vcomponent/parse.scm | 4 +- module/vcomponent/parse/types.scm | 4 +- module/vcomponent/recurrence/display.scm | 2 +- module/vcomponent/recurrence/generate.scm | 4 +- module/vcomponent/recurrence/internal.scm | 2 +- module/vcomponent/recurrence/parse.scm | 4 +- module/vcomponent/search.scm | 2 +- module/vcomponent/vdir/parse.scm | 4 +- module/vcomponent/vdir/save-delete.scm | 6 +- module/vcomponent/xcal/output.scm | 4 +- module/vcomponent/xcal/parse.scm | 4 +- module/vcomponent/xcal/types.scm | 2 +- module/vulgar.scm | 2 +- module/vulgar/components.scm | 2 +- module/vulgar/info.scm | 2 +- module/vulgar/termios.scm | 2 +- module/web/http/make-routes.scm | 2 +- module/web/query.scm | 2 +- scripts/benchmark.scm | 6 +- scripts/get-config.scm | 2 +- system/config.scm | 2 +- tests/datetime.scm | 2 +- tests/let.scm | 2 +- tests/param.scm | 2 +- tests/recurrence.scm | 2 +- tests/rrule-parse.scm | 2 +- tests/run-tests.scm | 2 +- tests/termios.scm | 2 +- tests/tz.scm | 2 +- tests/util.scm | 2 +- tests/web-server.scm | 2 +- tests/xcal.scm | 2 +- 103 files changed, 1256 insertions(+), 1256 deletions(-) create mode 100644 module/calp/util.scm create mode 100644 module/calp/util/color.scm create mode 100644 module/calp/util/config.scm create mode 100644 module/calp/util/exceptions.scm create mode 100644 module/calp/util/graph.scm create mode 100644 module/calp/util/hooks.scm create mode 100644 module/calp/util/io.scm create mode 100644 module/calp/util/options.scm create mode 100644 module/calp/util/time.scm create mode 100644 module/calp/util/tree.scm delete mode 100644 module/util.scm delete mode 100644 module/util/color.scm delete mode 100644 module/util/config.scm delete mode 100644 module/util/exceptions.scm delete mode 100644 module/util/graph.scm delete mode 100644 module/util/hooks.scm delete mode 100644 module/util/io.scm delete mode 100644 module/util/options.scm delete mode 100644 module/util/time.scm delete mode 100644 module/util/tree.scm diff --git a/config.scm b/config.scm index ac20024e..4092ecb3 100644 --- a/config.scm +++ b/config.scm @@ -10,7 +10,7 @@ (sxml simple) (glob) - (util config) + (calp util config) (datetime) diff --git a/module/c/cpp.scm b/module/c/cpp.scm index 062e50f5..070ea4f6 100644 --- a/module/c/cpp.scm +++ b/module/c/cpp.scm @@ -1,13 +1,13 @@ (define-module (c cpp) - :use-module (util) + :use-module (calp util) :use-module (srfi srfi-1) :use-module (ice-9 popen) :use-module (ice-9 match) :use-module (ice-9 regex) :use-module ((rnrs io ports) :select (call-with-port)) :use-module (ice-9 pretty-print) ; used by one error handler - :use-module ((util io) :select (read-lines)) - :use-module (util graph) + :use-module ((calp util io) :select (read-lines)) + :use-module (calp util graph) :use-module (c lex) :use-module (c parse) :use-module (c operators) diff --git a/module/c/parse.scm b/module/c/parse.scm index 42f2c13a..bef7e66d 100644 --- a/module/c/parse.scm +++ b/module/c/parse.scm @@ -1,5 +1,5 @@ (define-module (c parse) - :use-module (util) + :use-module (calp util) :use-module (srfi srfi-1) :use-module (ice-9 match) :export (parse-lexeme-tree)) 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 ( ...) in b1 body ...) + (map ((@ (ice-9 match) match-lambda) [( ...) b1 body ...]) + )) + ((for in b1 body ...) + (map (lambda () b1 body ...) + )))) + + + +;; 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 + (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 # 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))))) diff --git a/module/datetime.scm b/module/datetime.scm index 5a821afb..d004b2a5 100644 --- a/module/datetime.scm +++ b/module/datetime.scm @@ -9,13 +9,13 @@ :use-module (srfi srfi-9) :use-module (srfi srfi-9 gnu) - :use-module (util) + :use-module (calp util) :use-module (srfi srfi-41) :use-module (srfi srfi-41 util) :use-module (ice-9 i18n) :use-module (ice-9 format) - :use-module (util config) + :use-module (calp util config) :re-export (locale-month) ) diff --git a/module/datetime/instance.scm b/module/datetime/instance.scm index 5b5a6604..6cce17f4 100644 --- a/module/datetime/instance.scm +++ b/module/datetime/instance.scm @@ -1,7 +1,7 @@ (define-module (datetime instance) - :use-module (util) - :use-module (util config) - :use-module (util exceptions) + :use-module (calp util) + :use-module (calp util config) + :use-module (calp util exceptions) :use-module (datetime zic) :use-module ((xdg basedir) :prefix xdg-) :export (zoneinfo)) diff --git a/module/datetime/timespec.scm b/module/datetime/timespec.scm index ddd8a164..dd75ff7c 100644 --- a/module/datetime/timespec.scm +++ b/module/datetime/timespec.scm @@ -4,8 +4,8 @@ ;;; Code: (define-module (datetime timespec) - :use-module (util) - :use-module (util exceptions) + :use-module (calp util) + :use-module (calp util exceptions) :use-module (datetime) :use-module (srfi srfi-1) :use-module (srfi srfi-9 gnu) diff --git a/module/datetime/zic.scm b/module/datetime/zic.scm index ac4b2f9b..080a8ad0 100644 --- a/module/datetime/zic.scm +++ b/module/datetime/zic.scm @@ -11,8 +11,8 @@ ;; See zic(8) for data format ;;; Code: (define-module (datetime zic) - :use-module (util) - :use-module (util exceptions) + :use-module (calp util) + :use-module (calp util exceptions) :use-module (datetime) :use-module (datetime timespec) :use-module (ice-9 rdelim) diff --git a/module/srfi/srfi-41/util.scm b/module/srfi/srfi-41/util.scm index eda379a7..aa28b852 100644 --- a/module/srfi/srfi-41/util.scm +++ b/module/srfi/srfi-41/util.scm @@ -2,7 +2,7 @@ #:use-module (srfi srfi-1) #:use-module (srfi srfi-41) #:use-module ((ice-9 sandbox) :select (call-with-time-limit)) - #:use-module (util) ; let*, find-min + #:use-module (calp util) ; let*, find-min #:export (stream-car+cdr interleave-streams with-streams stream-timeslice-limit)) diff --git a/module/sxml/namespace.scm b/module/sxml/namespace.scm index 5a274098..57250b93 100644 --- a/module/sxml/namespace.scm +++ b/module/sxml/namespace.scm @@ -1,5 +1,5 @@ (define-module (sxml namespace) - :use-module (util) + :use-module (calp util) :use-module (sxml transform)) (define* (symbol-split symbol key: (sep #\:)) diff --git a/module/sxml/transformations.scm b/module/sxml/transformations.scm index 037dc00f..5d82ee9c 100644 --- a/module/sxml/transformations.scm +++ b/module/sxml/transformations.scm @@ -6,7 +6,7 @@ ;;; Code: (define-module (sxml transformations) - :use-module (util) + :use-module (calp util) :use-module ((srfi srfi-1) :select (concatenate)) :use-module ((sxml transform) :select (pre-post-order)) ) diff --git a/module/text/flow.scm b/module/text/flow.scm index 75ef5ccf..b9f0e387 100644 --- a/module/text/flow.scm +++ b/module/text/flow.scm @@ -1,5 +1,5 @@ (define-module (text flow) - :use-module (util) + :use-module (calp util) :use-module (text util) :use-module (srfi srfi-1) ) diff --git a/module/text/markup.scm b/module/text/markup.scm index 84bf7f61..7e625725 100644 --- a/module/text/markup.scm +++ b/module/text/markup.scm @@ -1,5 +1,5 @@ (define-module (text markup) - :use-module (util) + :use-module (calp util) :use-module (srfi srfi-1) :use-module (ice-9 match) :use-module (ice-9 pretty-print) diff --git a/module/text/numbers.scm b/module/text/numbers.scm index 3e302c69..883d7b2a 100644 --- a/module/text/numbers.scm +++ b/module/text/numbers.scm @@ -1,5 +1,5 @@ (define-module (text numbers) - :use-module (util)) + :use-module (calp util)) ;; only used in number->string-cardinal (define (large-prefix e) diff --git a/module/text/util.scm b/module/text/util.scm index eda2df98..b2560bf4 100644 --- a/module/text/util.scm +++ b/module/text/util.scm @@ -1,5 +1,5 @@ (define-module (text util) - :use-module (util)) + :use-module (calp util)) (define-public (words str) (string-split str #\space)) (define-public (unwords list) (string-join list " " 'infix)) diff --git a/module/util.scm b/module/util.scm deleted file mode 100644 index c1eaf6bf..00000000 --- a/module/util.scm +++ /dev/null @@ -1,574 +0,0 @@ -(define-module (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 ( ...) in b1 body ...) - (map ((@ (ice-9 match) match-lambda) [( ...) b1 body ...]) - )) - ((for in b1 body ...) - (map (lambda () b1 body ...) - )))) - - - -;; 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/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 - (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 # 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))))) diff --git a/module/vcomponent.scm b/module/vcomponent.scm index b4a30c83..a53523c0 100644 --- a/module/vcomponent.scm +++ b/module/vcomponent.scm @@ -1,6 +1,6 @@ (define-module (vcomponent) - :use-module (util) - :use-module (util config) + :use-module (calp util) + :use-module (calp util config) :use-module (vcomponent base) :use-module (vcomponent parse) :use-module (vcomponent instance methods) diff --git a/module/vcomponent/base.scm b/module/vcomponent/base.scm index 47815a0e..ae10fe01 100644 --- a/module/vcomponent/base.scm +++ b/module/vcomponent/base.scm @@ -1,5 +1,5 @@ (define-module (vcomponent base) - :use-module (util) + :use-module (calp util) :use-module (srfi srfi-1) :use-module (srfi srfi-9) :use-module (srfi srfi-9 gnu) diff --git a/module/vcomponent/build.scm b/module/vcomponent/build.scm index a4512819..d49844cc 100644 --- a/module/vcomponent/build.scm +++ b/module/vcomponent/build.scm @@ -9,7 +9,7 @@ ;;; Code: (define-module (vcomponent build) - :use-module (util) + :use-module (calp util) :use-module (vcomponent base) :use-module (srfi srfi-26) :use-module ((srfi srfi-88) :select (keyword->string))) diff --git a/module/vcomponent/control.scm b/module/vcomponent/control.scm index 6003c7ca..add48c28 100644 --- a/module/vcomponent/control.scm +++ b/module/vcomponent/control.scm @@ -1,5 +1,5 @@ (define-module (vcomponent control) - #:use-module (util) + #:use-module (calp util) #:use-module (vcomponent) #:export (with-replaced-properties)) diff --git a/module/vcomponent/datetime.scm b/module/vcomponent/datetime.scm index faeae70a..887ae48b 100644 --- a/module/vcomponent/datetime.scm +++ b/module/vcomponent/datetime.scm @@ -4,7 +4,7 @@ #:use-module (datetime) #:use-module (datetime timespec) #:use-module (datetime zic) - #:use-module (util) + #:use-module (calp util) :use-module (ice-9 curried-definitions) diff --git a/module/vcomponent/datetime/output.scm b/module/vcomponent/datetime/output.scm index c76f010f..1b377a7c 100644 --- a/module/vcomponent/datetime/output.scm +++ b/module/vcomponent/datetime/output.scm @@ -1,7 +1,7 @@ (define-module (vcomponent datetime output) - :use-module (util) - :use-module (util config) - :use-module (util exceptions) + :use-module (calp util) + :use-module (calp util config) + :use-module (calp util exceptions) :use-module (datetime) :use-module (vcomponent base) :use-module (text util) diff --git a/module/vcomponent/describe.scm b/module/vcomponent/describe.scm index a579c245..063efa9c 100644 --- a/module/vcomponent/describe.scm +++ b/module/vcomponent/describe.scm @@ -1,5 +1,5 @@ (define-module (vcomponent describe) - :use-module (util) + :use-module (calp util) :use-module (vcomponent base) :use-module (text util)) diff --git a/module/vcomponent/duration.scm b/module/vcomponent/duration.scm index f8ef1d70..7591a880 100644 --- a/module/vcomponent/duration.scm +++ b/module/vcomponent/duration.scm @@ -1,6 +1,6 @@ (define-module (vcomponent duration) - :use-module (util) - :use-module (util exceptions) + :use-module (calp util) + :use-module (calp util exceptions) :use-module (datetime) :use-module (ice-9 peg) :use-module (ice-9 match) diff --git a/module/vcomponent/geo.scm b/module/vcomponent/geo.scm index 2a343ed9..ac370a6c 100644 --- a/module/vcomponent/geo.scm +++ b/module/vcomponent/geo.scm @@ -1,5 +1,5 @@ (define-module (vcomponent geo) - :use-module (util) + :use-module (calp util) :use-module (srfi srfi-9 gnu)) (define-immutable-record-type diff --git a/module/vcomponent/ical/output.scm b/module/vcomponent/ical/output.scm index 75e579b8..a0816679 100644 --- a/module/vcomponent/ical/output.scm +++ b/module/vcomponent/ical/output.scm @@ -1,8 +1,8 @@ (define-module (vcomponent ical output) :use-module (ice-9 format) :use-module (ice-9 match) - :use-module (util) - :use-module (util exceptions) + :use-module (calp util) + :use-module (calp util exceptions) :use-module (vcomponent) :use-module (vcomponent datetime) :use-module (srfi srfi-1) diff --git a/module/vcomponent/ical/parse.scm b/module/vcomponent/ical/parse.scm index 96c18952..9c555bca 100644 --- a/module/vcomponent/ical/parse.scm +++ b/module/vcomponent/ical/parse.scm @@ -1,6 +1,6 @@ (define-module (vcomponent ical parse) - :use-module (util) - :use-module (util exceptions) + :use-module (calp util) + :use-module (calp util exceptions) :use-module ((ice-9 rdelim) :select (read-line)) :use-module (vcomponent base) :use-module (datetime) diff --git a/module/vcomponent/ical/types.scm b/module/vcomponent/ical/types.scm index b46bb236..1ec9d0bd 100644 --- a/module/vcomponent/ical/types.scm +++ b/module/vcomponent/ical/types.scm @@ -1,7 +1,7 @@ ;; see (vcomponent parse types) (define-module (vcomponent ical types) - :use-module (util) - :use-module (util exceptions) + :use-module (calp util) + :use-module (calp util exceptions) :use-module (base64) :use-module (datetime)) diff --git a/module/vcomponent/instance.scm b/module/vcomponent/instance.scm index 88858709..206d7f19 100644 --- a/module/vcomponent/instance.scm +++ b/module/vcomponent/instance.scm @@ -1,6 +1,6 @@ (define-module (vcomponent instance) - :use-module (util) - :use-module ((util config) :select (get-config)) + :use-module (calp util) + :use-module ((calp util config) :select (get-config)) :use-module ((oop goops) :select (make)) :export (global-event-object) ) diff --git a/module/vcomponent/instance/methods.scm b/module/vcomponent/instance/methods.scm index ea3522f9..7a193b8a 100644 --- a/module/vcomponent/instance/methods.scm +++ b/module/vcomponent/instance/methods.scm @@ -1,5 +1,5 @@ (define-module (vcomponent instance methods) - :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/vcomponent/parse.scm b/module/vcomponent/parse.scm index 290a8d3e..9790d1eb 100644 --- a/module/vcomponent/parse.scm +++ b/module/vcomponent/parse.scm @@ -1,8 +1,8 @@ (define-module (vcomponent parse) - :use-module (util) + :use-module (calp util) :use-module (vcomponent base) :use-module ((vcomponent vdir parse) :select (parse-vdir)) - :use-module ((util time) :select (report-time!)) + :use-module ((calp util time) :select (report-time!)) :use-module (vcomponent ical parse) :re-export (parse-calendar) diff --git a/module/vcomponent/parse/types.scm b/module/vcomponent/parse/types.scm index c12da750..ba4b2b47 100644 --- a/module/vcomponent/parse/types.scm +++ b/module/vcomponent/parse/types.scm @@ -1,6 +1,6 @@ (define-module (vcomponent parse types) - :use-module (util) - :use-module (util exceptions) + :use-module (calp util) + :use-module (calp util exceptions) :use-module (base64) :use-module (datetime) :use-module (srfi srfi-9 gnu) diff --git a/module/vcomponent/recurrence/display.scm b/module/vcomponent/recurrence/display.scm index 1df95d0b..f9c6f1c4 100644 --- a/module/vcomponent/recurrence/display.scm +++ b/module/vcomponent/recurrence/display.scm @@ -6,7 +6,7 @@ ;;; Code: (define-module (vcomponent recurrence display) - :use-module (util) + :use-module (calp util) :use-module (vcomponent recurrence internal) :use-module (text util) :use-module (text numbers) diff --git a/module/vcomponent/recurrence/generate.scm b/module/vcomponent/recurrence/generate.scm index 2d9d3960..c272e907 100644 --- a/module/vcomponent/recurrence/generate.scm +++ b/module/vcomponent/recurrence/generate.scm @@ -1,6 +1,6 @@ (define-module (vcomponent recurrence generate) - :use-module (util) - :use-module (util exceptions) + :use-module (calp util) + :use-module (calp util exceptions) :use-module (srfi srfi-1) :use-module (srfi srfi-26) :use-module (srfi srfi-41) diff --git a/module/vcomponent/recurrence/internal.scm b/module/vcomponent/recurrence/internal.scm index 502f588f..0c119bb6 100644 --- a/module/vcomponent/recurrence/internal.scm +++ b/module/vcomponent/recurrence/internal.scm @@ -5,7 +5,7 @@ #:use-module ((vcomponent base) :select (prop)) #:use-module (srfi srfi-9) #:use-module (srfi srfi-9 gnu) - #:use-module (util) + #:use-module (calp util) ) ;; EXDATE is also a property linked to recurense rules diff --git a/module/vcomponent/recurrence/parse.scm b/module/vcomponent/recurrence/parse.scm index 9019ae7e..b48e88e5 100644 --- a/module/vcomponent/recurrence/parse.scm +++ b/module/vcomponent/recurrence/parse.scm @@ -7,8 +7,8 @@ #:use-module (datetime) #:use-module (srfi srfi-26) #:use-module (vcomponent recurrence internal) - #:use-module (util) - #:use-module (util exceptions) + #:use-module (calp util) + #:use-module (calp util exceptions) #:use-module (ice-9 match)) diff --git a/module/vcomponent/search.scm b/module/vcomponent/search.scm index 15ff0720..7d039a24 100644 --- a/module/vcomponent/search.scm +++ b/module/vcomponent/search.scm @@ -25,7 +25,7 @@ ;;; Code: (define-module (vcomponent search) - :use-module (util) + :use-module (calp util) :use-module (srfi srfi-1) :use-module (srfi srfi-9) :use-module (srfi srfi-41) diff --git a/module/vcomponent/vdir/parse.scm b/module/vcomponent/vdir/parse.scm index e2fc37a1..d251e60a 100644 --- a/module/vcomponent/vdir/parse.scm +++ b/module/vcomponent/vdir/parse.scm @@ -11,8 +11,8 @@ :use-module ((ice-9 rdelim) :select (read-line)) :use-module ((ice-9 ftw) :select (scandir ftw)) - :use-module (util) - :use-module (util exceptions) + :use-module (calp util) + :use-module (calp util exceptions) :use-module (vcomponent base) :use-module (vcomponent ical parse) diff --git a/module/vcomponent/vdir/save-delete.scm b/module/vcomponent/vdir/save-delete.scm index 2cbe96bf..d17b595e 100644 --- a/module/vcomponent/vdir/save-delete.scm +++ b/module/vcomponent/vdir/save-delete.scm @@ -10,11 +10,11 @@ ;;; Code: (define-module (vcomponent vdir save-delete) - :use-module (util) - :use-module ((util exceptions) :select (assert)) + :use-module (calp util) + :use-module ((calp util exceptions) :select (assert)) :use-module (vcomponent ical output) :use-module (vcomponent) - :use-module ((util io) :select (with-atomic-output-to-file)) + :use-module ((calp util io) :select (with-atomic-output-to-file)) ) diff --git a/module/vcomponent/xcal/output.scm b/module/vcomponent/xcal/output.scm index ec162ec0..692b3ec2 100644 --- a/module/vcomponent/xcal/output.scm +++ b/module/vcomponent/xcal/output.scm @@ -1,6 +1,6 @@ (define-module (vcomponent xcal output) - :use-module (util) - :use-module (util exceptions) + :use-module (calp util) + :use-module (calp util exceptions) :use-module (vcomponent) :use-module (vcomponent geo) :use-module (vcomponent xcal types) diff --git a/module/vcomponent/xcal/parse.scm b/module/vcomponent/xcal/parse.scm index a4b51b5b..26f25caa 100644 --- a/module/vcomponent/xcal/parse.scm +++ b/module/vcomponent/xcal/parse.scm @@ -1,6 +1,6 @@ (define-module (vcomponent xcal parse) - :use-module (util) - :use-module (util exceptions) + :use-module (calp util) + :use-module (calp util exceptions) :use-module (base64) :use-module (ice-9 match) :use-module (sxml match) diff --git a/module/vcomponent/xcal/types.scm b/module/vcomponent/xcal/types.scm index 30916a35..468400f4 100644 --- a/module/vcomponent/xcal/types.scm +++ b/module/vcomponent/xcal/types.scm @@ -1,5 +1,5 @@ (define-module (vcomponent xcal types) - :use-module (util) + :use-module (calp util) :use-module (vcomponent ical types) :use-module (datetime) ) diff --git a/module/vulgar.scm b/module/vulgar.scm index 722ccb51..eabd11f8 100644 --- a/module/vulgar.scm +++ b/module/vulgar.scm @@ -7,7 +7,7 @@ (define-module (vulgar) #:use-module (srfi srfi-60) #:use-module (vulgar termios) - #:use-module (util) + #:use-module (calp util) #:export (with-vulgar)) (define-public (cls) diff --git a/module/vulgar/components.scm b/module/vulgar/components.scm index 83c702b6..3909d63f 100644 --- a/module/vulgar/components.scm +++ b/module/vulgar/components.scm @@ -1,6 +1,6 @@ (define-module (vulgar components) #:use-module (datetime) - #:use-module (util) + #:use-module (calp util) #:export ()) (define-public (display-calendar-header! date) diff --git a/module/vulgar/info.scm b/module/vulgar/info.scm index 86abf0a0..66901ff8 100644 --- a/module/vulgar/info.scm +++ b/module/vulgar/info.scm @@ -1,5 +1,5 @@ (define-module (vulgar info) - :use-module (util)) + :use-module (calp util)) (define-public (get-terminal-size) (let* (((rpipe . wpipe) (pipe))) diff --git a/module/vulgar/termios.scm b/module/vulgar/termios.scm index 2e260e21..75181ff3 100644 --- a/module/vulgar/termios.scm +++ b/module/vulgar/termios.scm @@ -7,7 +7,7 @@ :use-module (ice-9 rdelim) :use-module (srfi srfi-9) ; records :use-module (c cpp) - :use-module (util) + :use-module (calp util) :export (make-termios copy-termios tcsetattr! tcgetattr! cfmakeraw!)) diff --git a/module/web/http/make-routes.scm b/module/web/http/make-routes.scm index c725513d..ab5f88a7 100644 --- a/module/web/http/make-routes.scm +++ b/module/web/http/make-routes.scm @@ -1,6 +1,6 @@ (define-module (web http make-routes) :export (make-routes) - :use-module (util) + :use-module (calp util) :use-module (ice-9 regex) :use-module (srfi srfi-1) :use-module (web response) diff --git a/module/web/query.scm b/module/web/query.scm index cb96824d..55b3f564 100644 --- a/module/web/query.scm +++ b/module/web/query.scm @@ -1,5 +1,5 @@ (define-module (web query) - :use-module (util) + :use-module (calp util) :use-module (srfi srfi-1) :use-module (web uri)) diff --git a/scripts/benchmark.scm b/scripts/benchmark.scm index f0e2cbcf..362ccccd 100644 --- a/scripts/benchmark.scm +++ b/scripts/benchmark.scm @@ -1,7 +1,7 @@ (add-to-load-path "module") -(use-modules (util) - (util app) - (util config) +(use-modules (calp util) + (calp util app) + (calp util config) (vcomponent) (vcomponent group) (vcomponent datetime) diff --git a/scripts/get-config.scm b/scripts/get-config.scm index 6d9c3290..4ab2c2c9 100755 --- a/scripts/get-config.scm +++ b/scripts/get-config.scm @@ -11,7 +11,7 @@ (add-to-load-path "module") (use-modules - (util) + (calp util) (ice-9 ftw) (ice-9 match) (srfi srfi-1) diff --git a/system/config.scm b/system/config.scm index fef7c9b5..6e765fcb 100644 --- a/system/config.scm +++ b/system/config.scm @@ -1,4 +1,4 @@ -(use-modules (util config) +(use-modules (calp util config) (ice-9 regex) ((datetime) :select (mon)) (glob)) diff --git a/tests/datetime.scm b/tests/datetime.scm index 73b7ce65..83750472 100644 --- a/tests/datetime.scm +++ b/tests/datetime.scm @@ -10,7 +10,7 @@ leap-year? ) ((ice-9 format) format) - ((util) let*) + ((calp util) let*) ) (test-equal "empty time" diff --git a/tests/let.scm b/tests/let.scm index 14a246d2..82919b49 100644 --- a/tests/let.scm +++ b/tests/let.scm @@ -1,4 +1,4 @@ -(((util) let*) +(((calp util) let*) ((guile) set!)) (test-assert (let* ((a #t)) a)) diff --git a/tests/param.scm b/tests/param.scm index ad690e61..0c4190dd 100644 --- a/tests/param.scm +++ b/tests/param.scm @@ -1,6 +1,6 @@ (((vcomponent base) param prop* parameters) ((vcomponent parse) parse-calendar) - ((util) sort*)) + ((calp util) sort*)) (define v (call-with-input-string "BEGIN:DUMMY diff --git a/tests/recurrence.scm b/tests/recurrence.scm index e73aa836..6ced6af0 100644 --- a/tests/recurrence.scm +++ b/tests/recurrence.scm @@ -12,7 +12,7 @@ ((vcomponent base) make-vcomponent prop prop* extract) ((datetime) parse-ics-datetime datetime time date datetime->string) - ((util) -> set!) + ((calp util) -> set!) ((srfi srfi-41) stream->list) ((srfi srfi-88) keyword->string)) diff --git a/tests/rrule-parse.scm b/tests/rrule-parse.scm index f1d02d27..b7a851a0 100644 --- a/tests/rrule-parse.scm +++ b/tests/rrule-parse.scm @@ -2,7 +2,7 @@ parse-recurrence-rule) ((vcomponent recurrence) make-recur-rule) ((datetime) mon) - ((util exceptions) warnings-are-errors warning-handler) + ((calp util exceptions) warnings-are-errors warning-handler) ) (test-equal (make-recur-rule freq: 'HOURLY wkst: mon interval: 1) diff --git a/tests/run-tests.scm b/tests/run-tests.scm index b162522d..670a1784 100755 --- a/tests/run-tests.scm +++ b/tests/run-tests.scm @@ -17,7 +17,7 @@ (ice-9 getopt-long) (srfi srfi-64) ; test suite (srfi srfi-88) ; suffix keywords - ((util) :select (for awhen)) + ((calp util) :select (for awhen)) ;; datetime introduces the reader extensions for datetimes, ;; which leaks into the sandboxes below. (datetime)) diff --git a/tests/termios.scm b/tests/termios.scm index 3fed5da3..214a12a0 100755 --- a/tests/termios.scm +++ b/tests/termios.scm @@ -7,7 +7,7 @@ ;;; Code: -(((util) set!) +(((calp util) set!) ((vulgar termios) make-termios copy-termios lflag diff --git a/tests/tz.scm b/tests/tz.scm index 321bb960..8ccd636d 100644 --- a/tests/tz.scm +++ b/tests/tz.scm @@ -4,7 +4,7 @@ datetime->unix-time unix-time->datetime get-datetime) - ((util) let-env)) + ((calp util) let-env)) ;; London alternates between +0000 and +0100 (let-env ((TZ "Europe/London")) diff --git a/tests/util.scm b/tests/util.scm index 6ad58a24..f917b5ce 100644 --- a/tests/util.scm +++ b/tests/util.scm @@ -1,4 +1,4 @@ -(((util) filter-sorted set/r!)) +(((calp util) filter-sorted set/r!)) (test-equal "Filter sorted" '(3 4 5) diff --git a/tests/web-server.scm b/tests/web-server.scm index 49092607..6b315319 100644 --- a/tests/web-server.scm +++ b/tests/web-server.scm @@ -2,7 +2,7 @@ ((web server) run-server) ((ice-9 threads) call-with-new-thread cancel-thread) ((web client) http-get) - ((util) let*) + ((calp util) let*) ((web response) response-code response-location) ((web uri) build-uri uri-path) ((guile) AF_INET)) diff --git a/tests/xcal.scm b/tests/xcal.scm index 0d4985df..1748cba3 100644 --- a/tests/xcal.scm +++ b/tests/xcal.scm @@ -1,7 +1,7 @@ (((vcomponent xcal parse) sxcal->vcomponent) ((vcomponent xcal output) vcomponent->sxcal) ((vcomponent ical parse) parse-calendar) - ((util) ->) + ((calp util) ->) ((vcomponent base) parameters prop* children) ) -- cgit v1.2.3