From 807409d41f8b1a4435ee1cf7ddc3d1a1b9116799 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Hugo=20H=C3=B6rnquist?= Date: Mon, 31 Jan 2022 20:24:18 +0100 Subject: Move stuff from calp/util to hnh/util. This is the first (major) step in splitting the generally useful items into its own library. --- calp-gnome.scm | 2 +- doc/ref/guile/util.texi | 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/convert.scm | 4 +- module/calp/entry-points/html.scm | 4 +- module/calp/entry-points/ical.scm | 4 +- module/calp/entry-points/import.scm | 4 +- module/calp/entry-points/server.scm | 4 +- module/calp/entry-points/terminal.scm | 2 +- module/calp/entry-points/text.scm | 4 +- module/calp/entry-points/tidsrapport.scm | 6 +- module/calp/html/caltable.scm | 2 +- module/calp/html/components.scm | 2 +- module/calp/html/config.scm | 2 +- module/calp/html/util.scm | 2 +- module/calp/html/vcomponent.scm | 4 +- module/calp/html/view/calendar.scm | 2 +- module/calp/html/view/calendar/month.scm | 2 +- module/calp/html/view/calendar/shared.scm | 6 +- module/calp/html/view/calendar/week.scm | 2 +- module/calp/html/view/search.scm | 2 +- module/calp/main.scm | 8 +- module/calp/repl.scm | 2 +- module/calp/server/routes.scm | 6 +- module/calp/server/server.scm | 2 +- module/calp/terminal.scm | 2 +- module/calp/util.scm | 616 ------------------------- module/calp/util/color.scm | 22 - module/calp/util/config.scm | 2 +- module/calp/util/exceptions.scm | 57 --- module/calp/util/graph.scm | 93 ---- module/calp/util/io.scm | 59 --- module/calp/util/options.scm | 45 -- module/calp/util/tree.scm | 40 -- module/datetime.scm | 6 +- module/datetime/instance.scm | 4 +- module/datetime/timespec.scm | 4 +- module/datetime/zic.scm | 4 +- module/hnh/util.scm | 616 +++++++++++++++++++++++++ module/hnh/util/color.scm | 22 + module/hnh/util/exceptions.scm | 57 +++ module/hnh/util/graph.scm | 93 ++++ module/hnh/util/io.scm | 59 +++ module/hnh/util/options.scm | 45 ++ module/hnh/util/tree.scm | 40 ++ 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/sv.scm | 2 +- module/text/util.scm | 2 +- module/vcomponent.scm | 2 +- module/vcomponent/base.scm | 2 +- module/vcomponent/control.scm | 2 +- module/vcomponent/datetime.scm | 2 +- module/vcomponent/datetime/output.scm | 4 +- module/vcomponent/duration.scm | 4 +- module/vcomponent/formats/common/types.scm | 4 +- module/vcomponent/formats/ical/output.scm | 4 +- module/vcomponent/formats/ical/parse.scm | 4 +- module/vcomponent/formats/ical/types.scm | 4 +- module/vcomponent/formats/vdir/parse.scm | 4 +- module/vcomponent/formats/vdir/save-delete.scm | 6 +- module/vcomponent/formats/xcal/output.scm | 4 +- module/vcomponent/formats/xcal/parse.scm | 4 +- module/vcomponent/formats/xcal/types.scm | 2 +- module/vcomponent/geo.scm | 2 +- 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/util/control.scm | 2 +- module/vcomponent/util/describe.scm | 2 +- module/vcomponent/util/instance.scm | 2 +- module/vcomponent/util/instance/methods.scm | 2 +- module/vcomponent/util/parse-cal-path.scm | 2 +- module/vcomponent/util/search.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 +- module/web/uri-query.scm | 2 +- scripts/all-symbols.scm | 2 +- scripts/benchmark.scm | 2 +- scripts/get-config.scm | 2 +- scripts/use2dot/gen-use.scm | 2 +- tests/annoying-events.scm | 2 +- tests/datetime.scm | 2 +- tests/let-env.scm | 2 +- tests/let.scm | 2 +- tests/param.scm | 2 +- tests/recurrence-advanced.scm | 2 +- tests/recurrence-simple.scm | 2 +- tests/run-tests.scm | 4 +- tests/server.scm | 2 +- tests/termios.scm | 2 +- tests/tz.scm | 2 +- tests/util.scm | 4 +- tests/web-server.scm | 2 +- tests/xcal.scm | 2 +- 106 files changed, 1063 insertions(+), 1063 deletions(-) delete mode 100644 module/calp/util.scm delete mode 100644 module/calp/util/color.scm delete mode 100644 module/calp/util/exceptions.scm delete mode 100644 module/calp/util/graph.scm delete mode 100644 module/calp/util/io.scm delete mode 100644 module/calp/util/options.scm delete mode 100644 module/calp/util/tree.scm create mode 100644 module/hnh/util.scm create mode 100644 module/hnh/util/color.scm create mode 100644 module/hnh/util/exceptions.scm create mode 100644 module/hnh/util/graph.scm create mode 100644 module/hnh/util/io.scm create mode 100644 module/hnh/util/options.scm create mode 100644 module/hnh/util/tree.scm diff --git a/calp-gnome.scm b/calp-gnome.scm index cd10406b..61ef41a4 100644 --- a/calp-gnome.scm +++ b/calp-gnome.scm @@ -8,7 +8,7 @@ (begin (use-modules - (calp util) + (hnh util) ((srfi srfi-1) :select (partition)) (srfi srfi-41) (vcomponent datetime) diff --git a/doc/ref/guile/util.texi b/doc/ref/guile/util.texi index aae4dc6e..4a22b6c5 100644 --- a/doc/ref/guile/util.texi +++ b/doc/ref/guile/util.texi @@ -1,5 +1,5 @@ @node Calp Util -@section (calp util) +@section (hnh util) @defmac define-syntax [stx] Extends the default syntax from the default diff --git a/module/c/cpp.scm b/module/c/cpp.scm index 070ea4f6..c782e468 100644 --- a/module/c/cpp.scm +++ b/module/c/cpp.scm @@ -1,13 +1,13 @@ (define-module (c cpp) - :use-module (calp util) + :use-module (hnh 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 ((calp util io) :select (read-lines)) - :use-module (calp util graph) + :use-module ((hnh util io) :select (read-lines)) + :use-module (hnh 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 bef7e66d..3e3d8024 100644 --- a/module/c/parse.scm +++ b/module/c/parse.scm @@ -1,5 +1,5 @@ (define-module (c parse) - :use-module (calp util) + :use-module (hnh 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 2d7c7b18..f1ddf17d 100644 --- a/module/calp/benchmark/parse.scm +++ b/module/calp/benchmark/parse.scm @@ -1,5 +1,5 @@ (define-module (calp benchmark parse) - :use-module (calp util) + :use-module (hnh util) :use-module (glob) :use-module (statprof) diff --git a/module/calp/entry-points/benchmark.scm b/module/calp/entry-points/benchmark.scm index 152a398c..5db9b9df 100644 --- a/module/calp/entry-points/benchmark.scm +++ b/module/calp/entry-points/benchmark.scm @@ -1,8 +1,8 @@ (define-module (calp entry-points benchmark) - :use-module (calp util) + :use-module (hnh util) :use-module (ice-9 getopt-long) - :use-module (calp util options) + :use-module (hnh util options) :use-module ((srfi srfi-41) :select (stream->list)) :use-module ((vcomponent util instance methods) :select (get-event-set)) diff --git a/module/calp/entry-points/convert.scm b/module/calp/entry-points/convert.scm index f05b1e7b..3f602b07 100644 --- a/module/calp/entry-points/convert.scm +++ b/module/calp/entry-points/convert.scm @@ -1,7 +1,7 @@ (define-module (calp entry-points convert) :export (main) - :use-module (calp util) - :use-module (calp util options) + :use-module (hnh util) + :use-module (hnh util options) :use-module (ice-9 getopt-long) :use-module (sxml simple) ) diff --git a/module/calp/entry-points/html.scm b/module/calp/entry-points/html.scm index 45e71947..adac302f 100644 --- a/module/calp/entry-points/html.scm +++ b/module/calp/entry-points/html.scm @@ -1,8 +1,8 @@ (define-module (calp entry-points html) :export (main) - :use-module (calp util) + :use-module (hnh util) :use-module (calp util time) - :use-module (calp util options) + :use-module (hnh util options) :use-module (datetime) :use-module (ice-9 getopt-long) :use-module ((ice-9 regex) :select (string-match regexp-substitute)) diff --git a/module/calp/entry-points/ical.scm b/module/calp/entry-points/ical.scm index 0ac01b17..938b0b35 100644 --- a/module/calp/entry-points/ical.scm +++ b/module/calp/entry-points/ical.scm @@ -1,7 +1,7 @@ (define-module (calp entry-points ical) :export (main) - :use-module (calp util) - :use-module (calp util options) + :use-module (hnh util) + :use-module (hnh util options) :use-module (vcomponent formats ical output) :use-module (ice-9 getopt-long) :use-module (datetime) diff --git a/module/calp/entry-points/import.scm b/module/calp/entry-points/import.scm index 69c5b687..441ff527 100644 --- a/module/calp/entry-points/import.scm +++ b/module/calp/entry-points/import.scm @@ -1,7 +1,7 @@ (define-module (calp entry-points import) :export (main) - :use-module (calp util) - :use-module (calp util options) + :use-module (hnh util) + :use-module (hnh util options) :use-module (ice-9 getopt-long) :use-module (ice-9 rdelim) :use-module (srfi srfi-1) diff --git a/module/calp/entry-points/server.scm b/module/calp/entry-points/server.scm index 8885f38d..c9ff339a 100644 --- a/module/calp/entry-points/server.scm +++ b/module/calp/entry-points/server.scm @@ -1,6 +1,6 @@ (define-module (calp entry-points server) - :use-module (calp util) - :use-module (calp util options) + :use-module (hnh util) + :use-module (hnh util options) :use-module (calp util config) :use-module (srfi srfi-1) diff --git a/module/calp/entry-points/terminal.scm b/module/calp/entry-points/terminal.scm index 5aaa1f2d..b0be318c 100644 --- a/module/calp/entry-points/terminal.scm +++ b/module/calp/entry-points/terminal.scm @@ -5,7 +5,7 @@ :use-module (ice-9 getopt-long) :use-module (datetime) :use-module (vulgar) - :use-module (calp util options) + :use-module (hnh util options) ) (define options diff --git a/module/calp/entry-points/text.scm b/module/calp/entry-points/text.scm index 6da524ae..0a5744b3 100644 --- a/module/calp/entry-points/text.scm +++ b/module/calp/entry-points/text.scm @@ -2,8 +2,8 @@ :export (main) :use-module (text flow) :use-module (ice-9 getopt-long) - :use-module (calp util io) - :use-module (calp util options) + :use-module (hnh util io) + :use-module (hnh util options) ) diff --git a/module/calp/entry-points/tidsrapport.scm b/module/calp/entry-points/tidsrapport.scm index abdd7aa2..5ff43cf7 100644 --- a/module/calp/entry-points/tidsrapport.scm +++ b/module/calp/entry-points/tidsrapport.scm @@ -39,8 +39,8 @@ (define-module (calp entry-points tidsrapport) :export (main) - :use-module (calp util) - :use-module (calp util options) + :use-module (hnh util) + :use-module (hnh util options) :use-module (ice-9 getopt-long) :use-module (datetime) ) @@ -52,7 +52,7 @@ (datetime) (vcomponent util instance) (vcomponent util instance methods) - (calp util) + (hnh util) (ice-9 regex) (ice-9 popen) ) diff --git a/module/calp/html/caltable.scm b/module/calp/html/caltable.scm index 2f5a6d31..dd2d4b03 100644 --- a/module/calp/html/caltable.scm +++ b/module/calp/html/caltable.scm @@ -1,5 +1,5 @@ (define-module (calp html caltable) - :use-module (calp util) + :use-module (hnh util) :use-module (calp html util) :use-module (datetime) :use-module (srfi srfi-41) diff --git a/module/calp/html/components.scm b/module/calp/html/components.scm index 36ec5166..2f8c85ec 100644 --- a/module/calp/html/components.scm +++ b/module/calp/html/components.scm @@ -1,5 +1,5 @@ (define-module (calp html components) - :use-module (calp util) + :use-module (hnh util) :use-module (ice-9 curried-definitions) :use-module (ice-9 match) :export (xhtml-doc) diff --git a/module/calp/html/config.scm b/module/calp/html/config.scm index 081777ac..6bd1e0ec 100644 --- a/module/calp/html/config.scm +++ b/module/calp/html/config.scm @@ -1,5 +1,5 @@ (define-module (calp html config) - :use-module (calp util) + :use-module (hnh util) :use-module (calp util config) ) diff --git a/module/calp/html/util.scm b/module/calp/html/util.scm index 40852279..ecb54198 100644 --- a/module/calp/html/util.scm +++ b/module/calp/html/util.scm @@ -1,5 +1,5 @@ (define-module (calp html util) - :use-module (calp util)) + :use-module (hnh util)) (define-public (date-link date) diff --git a/module/calp/html/vcomponent.scm b/module/calp/html/vcomponent.scm index 2abf370d..34aeca66 100644 --- a/module/calp/html/vcomponent.scm +++ b/module/calp/html/vcomponent.scm @@ -1,5 +1,5 @@ (define-module (calp html vcomponent) - :use-module (calp util) + :use-module (hnh util) :use-module (srfi srfi-1) :use-module (srfi srfi-41) :use-module ((rnrs io ports) :select (put-bytevector)) @@ -10,7 +10,7 @@ :use-module (calp html util) :use-module ((calp html config) :select (edit-mode debug)) :use-module ((calp html components) :select (btn tabset form with-label)) - :use-module ((calp util color) :select (calculate-fg-color)) + :use-module ((hnh util color) :select (calculate-fg-color)) :use-module ((crypto) :select (sha256 checksum->string)) :use-module ((xdg basedir) :prefix xdg-) :use-module ((vcomponent recurrence) :select (repeating?)) diff --git a/module/calp/html/view/calendar.scm b/module/calp/html/view/calendar.scm index 64fafb3d..ecdce291 100644 --- a/module/calp/html/view/calendar.scm +++ b/module/calp/html/view/calendar.scm @@ -1,5 +1,5 @@ (define-module (calp html view calendar) - :use-module (calp util) + :use-module (hnh util) :use-module (vcomponent) :use-module ((vcomponent datetime) :select (events-between)) diff --git a/module/calp/html/view/calendar/month.scm b/module/calp/html/view/calendar/month.scm index 6506b0ea..2b4c888a 100644 --- a/module/calp/html/view/calendar/month.scm +++ b/module/calp/html/view/calendar/month.scm @@ -1,5 +1,5 @@ (define-module (calp html view calendar month) - :use-module (calp util) + :use-module (hnh util) :use-module (srfi srfi-1) :use-module (srfi srfi-41) :use-module (srfi srfi-41 util) diff --git a/module/calp/html/view/calendar/shared.scm b/module/calp/html/view/calendar/shared.scm index badea7b9..de09e00a 100644 --- a/module/calp/html/view/calendar/shared.scm +++ b/module/calp/html/view/calendar/shared.scm @@ -1,6 +1,6 @@ (define-module (calp html view calendar shared) - :use-module (calp util) - :use-module ((calp util exceptions) :select (assert)) + :use-module (hnh util) + :use-module ((hnh util exceptions) :select (assert)) :use-module (srfi srfi-1) :use-module (vcomponent) :use-module ((vcomponent datetime) @@ -9,7 +9,7 @@ event-length/clamped)) :use-module ((vcomponent datetime output) :select (format-summary)) - :use-module (calp util tree) + :use-module (hnh util tree) :use-module (datetime) :use-module (calp html config) :use-module ((calp html components) diff --git a/module/calp/html/view/calendar/week.scm b/module/calp/html/view/calendar/week.scm index 1714c6c4..5b12a351 100644 --- a/module/calp/html/view/calendar/week.scm +++ b/module/calp/html/view/calendar/week.scm @@ -1,5 +1,5 @@ (define-module (calp html view calendar week) - :use-module (calp util) + :use-module (hnh util) :use-module (srfi srfi-1) :use-module (srfi srfi-41) :use-module (rnrs records syntactic) diff --git a/module/calp/html/view/search.scm b/module/calp/html/view/search.scm index b939e7a2..b6f36612 100644 --- a/module/calp/html/view/search.scm +++ b/module/calp/html/view/search.scm @@ -1,5 +1,5 @@ (define-module (calp html view search) - :use-module (calp util) + :use-module (hnh util) :use-module (vcomponent) :use-module (vcomponent util search) :use-module ((ice-9 pretty-print) :select (pretty-print)) diff --git a/module/calp/main.scm b/module/calp/main.scm index 770be556..d1e33d55 100644 --- a/module/calp/main.scm +++ b/module/calp/main.scm @@ -1,16 +1,16 @@ ;; -*- geiser-scheme-implementation: guile -*- (define-module (calp main) - :use-module (calp util) + :use-module (hnh util) :use-module (srfi srfi-1) :use-module (srfi srfi-88) ; keyword syntax :use-module ((calp util config) :select (set-config! get-config get-configuration-documentation)) - :use-module (calp util options) + :use-module (hnh util options) :use-module ((calp util hooks) :select (shutdown-hook)) :use-module ((text markup) :select (sxml->ansi-text)) - :use-module ((calp util exceptions) :select (filter-stack)) + :use-module ((hnh util exceptions) :select (filter-stack)) :use-module (ice-9 getopt-long) :use-module (ice-9 regex) @@ -215,7 +215,7 @@ ;; (define path (read-line pipe)) (define line ((@ (ice-9 rdelim) read-line) pipe)) (define names (string-split line #\space)) - ((@ (calp util io) with-atomic-output-to-file) + ((@ (hnh util io) with-atomic-output-to-file) (path-append (xdg-data-home) "/calp/zoneinfo.scm") (lambda () (write `(set-config! 'tz-list ',names)) (newline) diff --git a/module/calp/repl.scm b/module/calp/repl.scm index 0765b65c..e25c2649 100644 --- a/module/calp/repl.scm +++ b/module/calp/repl.scm @@ -6,7 +6,7 @@ :use-module (system repl server) :use-module (ice-9 regex) :use-module ((calp util hooks) :select (shutdown-hook)) - :use-module ((calp util exceptions) :select (warning)) + :use-module ((hnh util exceptions) :select (warning)) ) (define-public (repl-start address) diff --git a/module/calp/server/routes.scm b/module/calp/server/routes.scm index a435bbc0..b53e1cad 100644 --- a/module/calp/server/routes.scm +++ b/module/calp/server/routes.scm @@ -1,7 +1,7 @@ (define-module (calp server routes) - :use-module (calp util) - :use-module (calp util options) - :use-module (calp util exceptions) + :use-module (hnh util) + :use-module (hnh util options) + :use-module (hnh util exceptions) :use-module (srfi srfi-1) diff --git a/module/calp/server/server.scm b/module/calp/server/server.scm index ae2117ab..fc185033 100644 --- a/module/calp/server/server.scm +++ b/module/calp/server/server.scm @@ -1,5 +1,5 @@ (define-module (calp server server) - :use-module (calp util) + :use-module (hnh util) :use-module (web server) :use-module ((calp server routes) :select (make-make-routes)) :use-module (ice-9 threads)) diff --git a/module/calp/terminal.scm b/module/calp/terminal.scm index 1014b94c..cd1d0c9d 100644 --- a/module/calp/terminal.scm +++ b/module/calp/terminal.scm @@ -4,7 +4,7 @@ #:use-module (srfi srfi-17) #:use-module (srfi srfi-26) #:use-module ((srfi srfi-41) :select (stream-car)) - #:use-module (calp util) + #:use-module (hnh util) #:use-module (vulgar) #:use-module (vulgar info) #:use-module (vulgar color) diff --git a/module/calp/util.scm b/module/calp/util.scm deleted file mode 100644 index e1e2131a..00000000 --- a/module/calp/util.scm +++ /dev/null @@ -1,616 +0,0 @@ -(define-module (calp util) - #:use-module (srfi srfi-1) - #:use-module (srfi srfi-88) ; postfix keywords - #:use-module ((ice-9 optargs) #:select (define*-public)) - #:use-module ((sxml fold) #:select (fold-values)) - #:use-module ((srfi srfi-9 gnu) #:select (set-fields)) - #:re-export (define*-public fold-values) - #:export (for sort* sort*! - set/r! - catch-multiple - quote? - -> ->> set set-> aif awhen - let-lazy let-env - case* define-many - and=>> label - print-and-return - begin1 - ) - #:replace (let* set! define-syntax - when unless)) - -((@ (guile) define-syntax) define-syntax - (syntax-rules () - ((_ (name args ...) body ...) - ((@ (guile) define-syntax) name - (lambda (args ...) - body ...))) - ((_ otherwise ...) - ((@ (guile) define-syntax) otherwise ...)))) - - - -;; NOTE -;; Instead of returning the empty list a better default value -;; for when and unless would be the identity element for the -;; current context. -;; So (string-append (when #f ...)) would expand into -;; (string-append (if #f ... "")). -;; This however requires type interferance, which i don't -;; *currently* have. - -(define-syntax-rule (when pred body ...) - (if pred (begin body ...) '())) - -(define-syntax-rule (unless pred body ...) - (if pred '() (begin body ...))) - - -(define-syntax (aif stx) - (syntax-case stx () - [(_ condition true-clause false-clause) - (with-syntax ((it (datum->syntax stx 'it))) - #'(let ((it condition)) - (if it true-clause false-clause)))])) - -(define-syntax (awhen stx) - (syntax-case stx () - [(_ condition body ...) - (with-syntax ((it (datum->syntax stx 'it))) - #'(let ((it condition)) - (when it body ...)))])) - -#; -(define-macro (awhen pred . body) - `(let ((it ,pred)) - (when it - ,@body))) - - - -(define-syntax for - (syntax-rules (in) - ((for ( ...) 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-syntax-rule (begin1 first rest ...) - (let ((return first)) - rest ... - return)) - - - - - -(define-macro (print-and-return expr) - (let ((str (gensym "str")) - (result (gensym "result"))) - `(let* ((,result ,expr) - (,str (format #f "~a [~a]~%" ,result (quote ,expr)))) - (display ,str (current-error-port)) - ,result))) - - - -(define-public (swap f) - (lambda args (apply f (reverse args)))) - - -(define-syntax case*% - (syntax-rules (else) - [(_ _ else) - #t] - [(_ invalue (value ...)) - (memv invalue (list value ...))] - #; - [(_ invalue target) - (eq? invalue target)])) - -;; Like `case', but evals the case parameters -(define-syntax case* - (syntax-rules (else) - [(_ invalue (cases body ...) ...) - (cond ((case*% invalue cases) - body ...) - ...)])) - -;; Allow set to work on multiple values at once, -;; similar to Common Lisp's @var{setf} -;; @example -;; (set! x 10 -;; y 20) -;; @end example -;; Still requires all variables to be defined beforehand. -(define-syntax set! - (syntax-rules (=) - ((_ field = (op args ...) rest ...) - (set! field (op field args ...) - rest ...)) - ((_ field = proc rest ...) - (set! field (proc field) - rest ...)) - ((_ field val) - ((@ (guile) set!) field val)) - ((_ field val rest ...) - (begin ((@ (guile) set!) field val) - (set! rest ...))))) - -;; only evaluates the final form once -(define-syntax set/r! - (syntax-rules (=) - ((_ args ... v = something) - (begin - (set! args ... v = something) - v)) - ((_ args ... final) - (let ((val final)) - (set! args ... val) - val)))) - - -(define-syntax define-many - (syntax-rules () - [(_) (begin)] - [(_ def) (begin)] - [(_ (symbols ...) value rest ...) - (begin (define symbols value) ... - (define-many rest ...))] - [(_ def (symbols ...) value rest ...) - (begin (def symbols value) ... - (define-many def rest ...))])) - -;; Attach a label to a function, allowing it to call itself -;; without actually giving it a name (can also be thought -;; of as letrec-1). -;; @example -;; ((label fact -;; (match-lambda -;; [0 1] -;; [x (* x (fact (1- x)))])) -;; 5) -;; @end example -(define-syntax label - (syntax-rules () - [(_ self proc) - (letrec ((self proc)) - proc)])) - - -;; This function borrowed from web-ics (calendar util) -(define* (sort* items comperator #:optional (get identity)) - "A sort function more in line with how python's sorted works" - (sort items (lambda (a b) - (comperator (get a) - (get b))))) - -;; Sorts the list @var{items}. @emph{May} destroy the input list in the process -(define* (sort*! items comperator #:optional (get identity)) - "A sort function more in line with how python's sorted works" - (sort! items (lambda (a b) - (comperator (get a) - (get b))))) - -;; Given {items, <} finds the most extreme value. -;; Returns 2 values. The extremest item in @var{items}, -;; and the other items in some order. -;; Ord b => (list a) [, (b, b -> bool), (a -> b)] -> a, (list a) -(define*-public (find-extreme items optional: (< <) (access identity)) - (if (null? items) - (error "Can't find extreme in an empty list") - (fold-values - (lambda (c min other) - (if (< (access c) (access min)) - ;; Current stream head is smaller that previous min - (values c (cons min other)) - ;; Previous min is still smallest - (values min (cons c other)))) - (cdr items) - ;; seeds: - (car items) '()))) - -(define*-public (find-min list optional: (access identity)) - (find-extreme list < access)) - -(define*-public (find-max list optional: (access identity)) - (find-extreme list > access)) - -(define-public (filter-sorted proc list) - (take-while - proc (drop-while - (negate proc) list))) - -;; (define (!= a b) (not (= a b))) -(define-public != (negate =)) - -(define-public (take-to lst i) - "Like @var{take}, but might lists shorter than length." - (if (> i (length lst)) - lst (take lst i))) - -(define-public (string-take-to str i) - (if (> i (string-length str)) - str (string-take str i))) - -(define-public (string-first str) - (string-ref str 0)) - -(define-public (string-last str) - (string-ref str (1- (string-length str)))) - -(define-public (as-symb s) - (if (string? s) (string->symbol s) s)) - -(define-public (enumerate lst) - (zip (iota (length lst)) - lst)) - -;; Takes a procedure returning multiple values, and returns a function which -;; takes the same arguments as the original procedure, but only returns one of -;; the procedures. Which procedure can be sent as an additional parameter. -(define*-public (unval proc #:optional (n 0)) - (lambda args - (call-with-values (lambda () (apply proc args)) - (lambda args (list-ref args n))))) - -(define-public (flatten lst) - (fold (lambda (subl done) - (append done ((if (list? subl) flatten list) subl))) - '() lst)) - -(define-syntax let-lazy - (syntax-rules () - [(_ ((field value) ...) - body ...) - (let ((field (delay value)) ...) - (let-syntax ((field (identifier-syntax (force field))) ...) - body ...))])) - -(define-public (map/dotted proc dotted-list) - (cond ((null? dotted-list) '()) - ((not-pair? dotted-list) (proc dotted-list)) - (else - (cons (proc (car dotted-list)) - (map/dotted proc (cdr dotted-list)))))) - -;; Merges two association lists, comparing with eq. -;; The cdrs in all pairs in both lists should be lists, -;; If a key is present in both then the contents of b is -;; put @emph{before} the contents in a. -;; @example -;; (assq-merge '((k 1)) '((k 2))) -;; => ((k 2 1)) -;; @end example -(define-public (assq-merge a b) - (fold (lambda (entry alist) - (let* (((k . v) entry) - (o (assq-ref alist k))) - (assq-set! alist k (append v (or o '()))))) - (copy-tree a) b)) - -(define-public (kvlist->assq kvlist) - (map (lambda (pair) - (cons (keyword->symbol (car pair)) (cdr pair))) - (group kvlist 2))) - -(define*-public (assq-limit alist optional: (number 1)) - (map (lambda (pair) - (take-to pair (1+ number))) - alist)) - -(define-public (group-by proc lst) - (let ((h (make-hash-table))) - (for value in lst - (let ((key (proc value))) - (hash-set! h key (cons value (hash-ref h key '()))))) - ;; NOTE changing this list to cons allows the output to work with assq-merge. - (hash-map->list list h))) - -;; (split-by '(0 1 2 3 4 2 5 6) 2) -;; ⇒ ((0 1) (3 4) (5 6)) -(define-public (split-by list item) - (let loop ((done '()) - (current '()) - (rem list)) - (cond [(null? rem) - (reverse (cons (reverse current) done))] - [(eqv? item (car rem)) - (loop (cons (reverse current) done) - '() - (cdr rem))] - [else - (loop done - (cons (car rem) current) - (cdr rem))]))) - - - -;; Simar to span from srfi-1, but never takes more than -;; @var{count} items. Can however still take less. -;; @example -;; (span-upto 2 char-numeric? (string->list "123456")) -;; ⇒ (#\1 #\2) -;; ⇒ (#\3 #\4 #\5 #\6) -;; (span-upto 2 char-numeric? (string->list "H123456")) -;; ⇒ () -;; ⇒ (#\H #\1 #\2 #\3 #\4 #\5 #\6) -;; @end example -(define-public (span-upto count predicate list) - (let loop ((remaining count) - (taken '()) - (list list)) - (if (or (zero? remaining) (null? list)) - (values (reverse! taken) list) - (if (predicate (car list)) - (loop (1- remaining) - (cons (car list) taken) - (cdr list)) - (loop (1- remaining) - taken list))))) - - -;; Returns the cross product between l1 and l2. -;; each element is a cons cell. -(define (cross-product% l1 l2) - (concatenate - (map (lambda (a) - (map (lambda (b) (cons a b)) - l2)) - l1))) - -(define-public (cross-product . args) - (if (null? args) - '() - (let* ((last rest (car+cdr (reverse args)))) - (reduce-right cross-product% '() - (reverse (cons (map list last) rest )))))) - -;; Given an arbitary tree, do a pre-order traversal, appending all strings. -;; non-strings allso allowed, converted to strings and also appended. -(define-public (string-flatten tree) - (cond [(string? tree) tree] - [(list? tree) (string-concatenate (map string-flatten tree))] - [else (format #f "~a" tree)])) - -(define-public (intersperse item list) - (let loop ((flipflop #f) - (rem list)) - (if (null? rem) - '() - (if flipflop - (cons item (loop (not flipflop) rem)) - (cons (car rem) (loop (not flipflop) (cdr rem))) - )))) - -;; @example -;; (insert-ordered 5 (iota 10)) -;; ⇒ (0 1 2 3 4 5 5 6 7 8 9) -;; @end example -(define*-public (insert-ordered item collection optional: (< <)) - (cond [(null? collection) - (list item)] - [(< item (car collection)) - (cons item collection)] - [else - (cons (car collection) - (insert-ordered item (cdr collection) <))])) - - - -(define-syntax -> - (syntax-rules () - [(-> obj) obj] - [(-> obj (func args ...) rest ...) - (-> (func obj args ...) rest ...)] - [(-> obj func rest ...) - (-> (func obj) rest ...)])) - -(define-syntax ->> - (syntax-rules () - ((->> obj) - obj) - ((->> obj (func args ...) rest ...) - (->> (func args ... obj) rest ...)) - ((->> obj func rest ...) - (->> (func obj) rest ...)))) - -;; Non-destructive set, syntax extension from set-fields from (srfi -;; srfi-9 gnu). -(define-syntax set - (syntax-rules (=) - [(set (acc obj) value) - (set-fields - obj ((acc) value))] - [(set (acc obj) = (op rest ...)) - (set-fields - obj ((acc) (op (acc obj) rest ...)))])) - -(define-syntax set-> - (syntax-rules (=) - [(_ obj) obj] - [(_ obj (func = (op args ...)) rest ...) - (set-> (set (func obj) (op (func obj) args ...)) rest ...)] - [(_ obj (func args ...) rest ...) - (set-> (set (func obj) args ...) rest ...)])) - -(define-syntax and=>> - (syntax-rules () - [(_ value) value] - [(_ value proc rest ...) - (and=>> (and=> value proc) - rest ...)])) - -(define-public (downcase-symbol symb) - (-> symb - symbol->string - string-downcase - string->symbol)) - - -;; @example -;; (group (iota 10) 2) -;; ⇒ ((0 1) (2 3) (4 5) (6 7) (8 9)) -;; @end example -;; Requires that width|(length list) -(define-public (group list width) - (unless (null? list) - (let* ((row rest (split-at list width))) - (cons row (group rest width))))) - -;; repeatedly apply @var{proc} to @var{base} -;; unitl @var{until} is satisfied. -;; (a → a), (a → bool), a → a -(define-public (iterate proc until base) - (let loop ((o base)) - (if (until o) - o - (loop (proc o))))) - -;; (a → values a), list ... → values a -(define-public (valued-map proc . lists) - (apply values - (apply append-map - (lambda args - (call-with-values (lambda () (apply proc args)) list)) - lists))) - -(define (ass%-ref-all alist key =) - (map cdr (filter (lambda (pair) (= key (car pair))) - alist))) - -;; Equivalent to assoc-ref (and family), but works on association lists with -;; non-unique keys, returning all mathing records (instead of just the first). -;; @begin lisp -;; (assoc-ref-all '((a . 1) (b . 2) (a . 3)) 'a) -;; ⇒ (1 3) -;; @end -(define-public (assoc-ref-all alist key) (ass%-ref-all alist key equal?)) -(define-public (assq-ref-all alist key) (ass%-ref-all alist key eq?)) -(define-public (assv-ref-all alist key) (ass%-ref-all alist key eqv?)) - - - - -(define-public (vector-last v) - (vector-ref v (1- (vector-length v)))) - -(define-public (->str any) - (with-output-to-string (lambda () (display any)))) - -(define-public ->string ->str) - -(define-public (->quoted-string any) - (with-output-to-string (lambda () (write any)))) - - - - -;; TODO shouldn't this use `file-name-separator-string'? -(define-public (path-append . strings) - (fold (lambda (s done) - (string-append - done - (if (string-null? s) - (string-append s "/") - (if (char=? #\/ (string-last done)) - (if (char=? #\/ (string-first s)) - (string-drop s 1) s) - (if (char=? #\/ (string-first s)) - s (string-append "/" s)))))) - (let ((s (car strings))) - (if (string-null? s) - "/" s)) - (cdr strings))) - - - - -(define-syntax let-env - (syntax-rules () - [(_ ((name value) ...) - body ...) - - (let ((env-pairs #f)) - (dynamic-wind - (lambda () - (set! env-pairs - (map (lambda (n new-value) - (list n new-value (getenv n))) - (list (symbol->string (quote name)) ...) - (list value ...))) - (for-each (lambda (pair) (setenv (car pair) (cadr pair))) - env-pairs)) - (lambda () body ...) - (lambda () - (for-each (lambda (pair) (setenv (car pair) (caddr pair))) - env-pairs))))])) - - -(define-public (uuidgen) - ((@ (rnrs io ports) call-with-port) - ((@ (ice-9 popen) open-input-pipe) "uuidgen") - (@ (ice-9 rdelim) read-line))) diff --git a/module/calp/util/color.scm b/module/calp/util/color.scm deleted file mode 100644 index 161e6707..00000000 --- a/module/calp/util/color.scm +++ /dev/null @@ -1,22 +0,0 @@ -(define-module (calp util color) - ) - -;; Returns a color with good contrast to the given background color. -;; https://stackoverflow.com/questions/1855884/determine-font-color-based-on-background-color/1855903#1855903 -(define-public (calculate-fg-color c) - (catch #t - (lambda () - (define (str->num c n) (string->number (substring/shared c n (+ n 2)) 16)) - ;; (format (current-error-port) "COLOR = ~s~%" c) - (let ((r (str->num c 1)) - (g (str->num c 3)) - (b (str->num c 5))) - (if (< 1/2 (/ (+ (* 0.299 r) - (* 0.587 g) - (* 0.114 b)) - #xFF)) - "#000000" "#FFFFFF"))) - (lambda args - (format (current-error-port) "Error calculating foreground color?~%~s~%" args) - "#FF0000" - ))) diff --git a/module/calp/util/config.scm b/module/calp/util/config.scm index fbe35d59..2fe2b9b0 100644 --- a/module/calp/util/config.scm +++ b/module/calp/util/config.scm @@ -5,7 +5,7 @@ ;;; Code: (define-module (calp util config) - :use-module (calp util) + :use-module (hnh util) :use-module (srfi srfi-1) :use-module (ice-9 format) ; for format-procedure :use-module (ice-9 curried-definitions) ; for ensure diff --git a/module/calp/util/exceptions.scm b/module/calp/util/exceptions.scm deleted file mode 100644 index d9df30ed..00000000 --- a/module/calp/util/exceptions.scm +++ /dev/null @@ -1,57 +0,0 @@ -(define-module (calp util exceptions) - #:use-module (srfi srfi-1) - #:use-module (calp util) - #:use-module (calp util config) - #:use-module (ice-9 format) - - #:use-module ((system vm frame) - :select (frame-bindings binding-ref)) - - #:export (assert)) - - -(define-public warning-handler - (make-parameter - (lambda (fmt . args) - (format #f "WARNING: ~?~%" fmt args)))) - -(define-public warnings-are-errors - (make-parameter #f)) - -(define-config warnings-are-errors #f - description: "Crash on warnings." - post: warnings-are-errors) - -;; forwards return from warning-hander. By default returns an unspecified value, -;; but instances are free to provide a proper return value and use it. -(define-public (warning fmt . args) - (display (apply (warning-handler) fmt (or args '())) - (current-error-port)) - (when (warnings-are-errors) - (throw 'warning fmt args))) - -(define-public (fatal fmt . args) - (display (format #f "FATAL: ~?~%" fmt (or args '())) - (current-error-port)) - (raise 2) - ) - -(define (prettify-tree tree) - (cond [(pair? tree) (cons (prettify-tree (car tree)) - (prettify-tree (cdr tree)))] - [(and (procedure? tree) (procedure-name tree)) - => identity] - [else tree])) - - -(define-macro (assert form) - `(unless ,form - (throw 'assertion-error "Assertion failed. ~a expected, ~a got" - (quote ,form) - ((@@ (calp util exceptions) prettify-tree) (list ,form))))) - - -(define-public (filter-stack pred? stk) - (concatenate - (for i in (iota (stack-length stk)) - (filter pred? (map binding-ref (frame-bindings (stack-ref stk i))))))) diff --git a/module/calp/util/graph.scm b/module/calp/util/graph.scm deleted file mode 100644 index 6a01a9ee..00000000 --- a/module/calp/util/graph.scm +++ /dev/null @@ -1,93 +0,0 @@ -;;; Commentary: -;; An immutable directed graph. -;; Most operations are O(n), since there is no total -;; order on symbols in scheme. -;;; Code: - -(define-module (calp util graph) - :use-module (calp util) - :use-module (srfi srfi-1) - :use-module (srfi srfi-9 gnu)) - -;; Immutable directed graph -(define-immutable-record-type - (make-graph% nodes edges node-key-proc node-equal?) - graph? - (nodes graph-nodes) - (edges graph-edges) ; (list (symb . symb)) - (node-key-proc node-key-proc) ; node → symb - (node-equal? node-equal?) ; node, node -> symb - ) - -(define*-public (make-graph optional: - (node-key-proc identity) - (node-equal? eq?)) - (make-graph% '() '() node-key-proc node-equal?)) - -(define*-public (rebuild-graph optional: old-graph - (nodes '()) (edges '())) - (make-graph% nodes edges - (if old-graph (node-key-proc old-graph) identity) - (if old-graph (node-equal? old-graph) eq?))) - -(define-public (graph-empty? graph) - (null? (graph-nodes graph))) - -;; Add node to graph. Adds directed edges from node to neighbours -;; graph, node, (list node-key) → graph -(define-public (add-node graph node edge-neighbours) - (rebuild-graph - graph - (lset-adjoin (node-equal? graph) (graph-nodes graph) - node) - (lset-union equal? (graph-edges graph) - (map (lambda (o) (cons ((node-key-proc graph) node) o)) - edge-neighbours)))) - -;; get node by key -(define-public (get-node graph key) - (find (lambda (node) (eq? key ((node-key-proc graph) node))) - (graph-nodes graph))) - -;; Remove node by @var{node-equal?} -(define-public (remove-node graph node) - (rebuild-graph - graph - (remove (lambda (other) ((node-equal? graph) node other)) - (graph-nodes graph)) - (let ((key ((node-key-proc graph) node))) - (remove (lambda (edge) (or (eq? key (car edge)) - (eq? key (cdr edge)))) - (graph-edges graph))))) - -;; NOTE this is O(n^2) (maybe, sort of?) -;; Getting it faster would require building an index, which -;; is hard since there isn't a total order on symbols. -(define-public (find-node-without-dependencies graph) - (find (lambda (node) - (let ((key ((node-key-proc graph) node))) - (not (find (lambda (edge) (eq? key (car edge))) (graph-edges graph))))) - (graph-nodes graph))) - -;; graph → node x graph -(define-public (find-and-remove-node-without-dependencies graph) - (let ((node (find-node-without-dependencies graph))) - (unless node - (throw 'graph-error 'find-and-remove-node-without-dependencies - "No node without dependencies in graph" '() graph)) - (values node (remove-node graph node)))) - -;; Assumes that the edges of the graph are dependencies. -;; Returns a list of all nodes so that each node is before its dependants. -;; A missing dependency (and probably a loop) is an error, and currently -;; leads to some weird error messages. -(define-public (resolve-dependency-graph graph) - (catch 'graph-error - (lambda () - (let loop ((graph graph)) - (if (graph-empty? graph) - '() - (let* ((node graph* (find-and-remove-node-without-dependencies graph))) - (cons node (loop graph*)))))) - (lambda (err caller fmt args graph . data) - graph))) diff --git a/module/calp/util/io.scm b/module/calp/util/io.scm deleted file mode 100644 index 7db1eee2..00000000 --- a/module/calp/util/io.scm +++ /dev/null @@ -1,59 +0,0 @@ -(define-module (calp util io) - :use-module ((ice-9 rdelim) :select (read-line))) - -(define-public (open-input-port str) - (if (string=? "-" str) - (current-input-port) - (open-input-file str))) - -(define-public (open-output-port str) - (if (string=? "-" str) - (current-output-port) - (open-output-file str))) - - - -(define-public (read-lines port) - (with-input-from-port port - (lambda () - (let loop ((line (read-line))) - (if (eof-object? line) - '() (cons line (loop (read-line)))))))) - -;; Same functionality as the regular @var{with-output-to-file}, but -;; with the difference that either everything is written, or nothing -;; is written, and if anything is written it's all written atomicaly at -;; once (the original file will never contain an intermidiate state). -;; Does NOT handle race conditions between threads. -;; Return #f on failure, something truthy otherwise -(define-public (with-atomic-output-to-file filename thunk) - ;; copy to enusre writable string - (define tmpfile (string-copy (string-append - (dirname filename) - file-name-separator-string - "." (basename filename) - "XXXXXX"))) - (define port #f) - (dynamic-wind - (lambda () (set! port (mkstemp! tmpfile))) - (lambda () - (with-output-to-port port thunk) - ;; Closing a port forces a write, due to buffering - ;; some of the errors that logically would come - ;; from write calls are first raised here. But since - ;; crashing is acceptable here, that's fine. - (close-port port) - (rename-file tmpfile filename)) - (lambda () - (when (access? tmpfile F_OK) - ;; I'm a bit unclear on how to trash our write buffer. - ;; hopefully first removing the file, followed by closing - ;; the port is enough for the kernel to do the sensible - ;; thing. - (delete-file tmpfile) - (close-port port) - ;; `when' defaults to the truthy `()', see (calp util) - ;; (note that # is thruthy, but shouldn't be - ;; counted on, since anything with an unspecified return - ;; value might as well return #f) - #f)))) diff --git a/module/calp/util/options.scm b/module/calp/util/options.scm deleted file mode 100644 index 20263c45..00000000 --- a/module/calp/util/options.scm +++ /dev/null @@ -1,45 +0,0 @@ -(define-module (calp util options) - :use-module (calp util) - :use-module (ice-9 match) - :use-module (srfi srfi-1) - :use-module (text markup) - ) - -;; option-assoc → getopt-valid option-assoc -(define-public (getopt-opt options) - (define ice-9-names '(single-char required? value predicate)) - (for (option-name flags ...) in options - (cons option-name - (map (match-lambda - (('value (_ ...)) `(value #t)) - (('value (? symbol? _)) `(value optional)) - ((key v) `(,key ,v))) - (filter (match-lambda ((key _ ...) (memv key ice-9-names))) - flags))))) - - -;; (name (key value) ...) → sxml -(define (fmt-help option-line) - (match option-line - ((name args ...) - (let ((valuefmt (match (assoc-ref args 'value) - [(#t) '(" " (i value))] - [(or #f (#f)) '()] - [(('options options ...)) - `(" {" ,(string-join options "|") "}")] - [(s) `(" [" (i ,s) "]")]))) - `(*TOP* (b "--" ,name) ,@valuefmt - ,@(awhen (assoc-ref args 'single-char) - `("," (ws) - (b "-" ,(car it)) - ,@valuefmt)) - (br) - ,@(awhen (assoc-ref args 'description) - `((blockquote ,@it) - (br)))))))) - -(define-public (format-arg-help options) - (sxml->ansi-text (cons '*TOP* (map sxml->ansi-text (map fmt-help options))))) - -(define*-public (print-arg-help options optional: (port (current-error-port))) - (display (format-arg-help options) port)) diff --git a/module/calp/util/tree.scm b/module/calp/util/tree.scm deleted file mode 100644 index b7856aa9..00000000 --- a/module/calp/util/tree.scm +++ /dev/null @@ -1,40 +0,0 @@ -(define-module (calp util tree) - #:use-module (srfi srfi-1) - #:use-module (calp util) - #:export (make-tree left-subtree - right-subtree - length-of-longst-branch - tree-map)) - -;; Constructs a binary tree where each node's children is partitioned -;; into a left and right branch using @var{pred?}. -;; Has thee form @var{(node left-subtree right-subtree)}. A leaf has -;; both it's children equal to @var{null}. -(define (make-tree pred? lst) - (unless (null? lst) - (let* ((head tail (partition (lambda (el) (pred? (car lst) el)) - (cdr lst)))) - (list (car lst) - (make-tree pred? head) - (make-tree pred? tail))))) - -(define (left-subtree tree) - (list-ref tree 1)) - -(define (right-subtree tree) - (list-ref tree 2)) - -;; Length includes current node, so the length of a leaf is 1. -(define (length-of-longst-branch tree) - (if (null? tree) - ;; Having the @var{1+} outside the @var{max} also works, - ;; but leads to events overlapping many other to be thinner. - ;; Having it inside makes all events as evenly wide as possible. - 0 (max (1+ (length-of-longst-branch (left-subtree tree))) - (length-of-longst-branch (right-subtree tree))))) - -(define (tree-map proc tree) - (unless (null? tree) - (list (proc (car tree)) - (tree-map proc (left-subtree tree)) - (tree-map proc (right-subtree tree))))) diff --git a/module/datetime.scm b/module/datetime.scm index e4a17779..0af8ca03 100644 --- a/module/datetime.scm +++ b/module/datetime.scm @@ -9,7 +9,7 @@ :use-module (srfi srfi-9) :use-module (srfi srfi-9 gnu) - :use-module (calp util) + :use-module (hnh util) :use-module (srfi srfi-41) :use-module (srfi srfi-41 util) @@ -694,12 +694,12 @@ Returns -1 on failure" [else dt])) (cond [(null? str) - ;; ((@ (calp util exceptions) warning) + ;; ((@ (hnh util exceptions) warning) ;; "Premature end of string, still got fmt = ~s" ;; fmt) (ampm dt)] [(null? fmt) - ;; ((@ (calp util exceptions) warning) + ;; ((@ (hnh util exceptions) warning) ;; "Unsparsed characters at end of string") (ampm dt)] [(eq? #\~ (car fmt)) diff --git a/module/datetime/instance.scm b/module/datetime/instance.scm index a03916d9..294aee27 100644 --- a/module/datetime/instance.scm +++ b/module/datetime/instance.scm @@ -1,7 +1,7 @@ (define-module (datetime instance) - :use-module (calp util) + :use-module (hnh util) :use-module (calp util config) - :use-module (calp util exceptions) + :use-module (hnh 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 dd75ff7c..9b236e2d 100644 --- a/module/datetime/timespec.scm +++ b/module/datetime/timespec.scm @@ -4,8 +4,8 @@ ;;; Code: (define-module (datetime timespec) - :use-module (calp util) - :use-module (calp util exceptions) + :use-module (hnh util) + :use-module (hnh 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 080a8ad0..6343dce3 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 (calp util) - :use-module (calp util exceptions) + :use-module (hnh util) + :use-module (hnh util exceptions) :use-module (datetime) :use-module (datetime timespec) :use-module (ice-9 rdelim) diff --git a/module/hnh/util.scm b/module/hnh/util.scm new file mode 100644 index 00000000..0b22555b --- /dev/null +++ b/module/hnh/util.scm @@ -0,0 +1,616 @@ +(define-module (hnh util) + #:use-module (srfi srfi-1) + #:use-module (srfi srfi-88) ; postfix keywords + #:use-module ((ice-9 optargs) #:select (define*-public)) + #:use-module ((sxml fold) #:select (fold-values)) + #:use-module ((srfi srfi-9 gnu) #:select (set-fields)) + #:re-export (define*-public fold-values) + #:export (for sort* sort*! + set/r! + catch-multiple + quote? + -> ->> set set-> aif awhen + let-lazy let-env + case* define-many + and=>> label + print-and-return + begin1 + ) + #:replace (let* set! define-syntax + when unless)) + +((@ (guile) define-syntax) define-syntax + (syntax-rules () + ((_ (name args ...) body ...) + ((@ (guile) define-syntax) name + (lambda (args ...) + body ...))) + ((_ otherwise ...) + ((@ (guile) define-syntax) otherwise ...)))) + + + +;; NOTE +;; Instead of returning the empty list a better default value +;; for when and unless would be the identity element for the +;; current context. +;; So (string-append (when #f ...)) would expand into +;; (string-append (if #f ... "")). +;; This however requires type interferance, which i don't +;; *currently* have. + +(define-syntax-rule (when pred body ...) + (if pred (begin body ...) '())) + +(define-syntax-rule (unless pred body ...) + (if pred '() (begin body ...))) + + +(define-syntax (aif stx) + (syntax-case stx () + [(_ condition true-clause false-clause) + (with-syntax ((it (datum->syntax stx 'it))) + #'(let ((it condition)) + (if it true-clause false-clause)))])) + +(define-syntax (awhen stx) + (syntax-case stx () + [(_ condition body ...) + (with-syntax ((it (datum->syntax stx 'it))) + #'(let ((it condition)) + (when it body ...)))])) + +#; +(define-macro (awhen pred . body) + `(let ((it ,pred)) + (when it + ,@body))) + + + +(define-syntax for + (syntax-rules (in) + ((for ( ...) 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-syntax-rule (begin1 first rest ...) + (let ((return first)) + rest ... + return)) + + + + + +(define-macro (print-and-return expr) + (let ((str (gensym "str")) + (result (gensym "result"))) + `(let* ((,result ,expr) + (,str (format #f "~a [~a]~%" ,result (quote ,expr)))) + (display ,str (current-error-port)) + ,result))) + + + +(define-public (swap f) + (lambda args (apply f (reverse args)))) + + +(define-syntax case*% + (syntax-rules (else) + [(_ _ else) + #t] + [(_ invalue (value ...)) + (memv invalue (list value ...))] + #; + [(_ invalue target) + (eq? invalue target)])) + +;; Like `case', but evals the case parameters +(define-syntax case* + (syntax-rules (else) + [(_ invalue (cases body ...) ...) + (cond ((case*% invalue cases) + body ...) + ...)])) + +;; Allow set to work on multiple values at once, +;; similar to Common Lisp's @var{setf} +;; @example +;; (set! x 10 +;; y 20) +;; @end example +;; Still requires all variables to be defined beforehand. +(define-syntax set! + (syntax-rules (=) + ((_ field = (op args ...) rest ...) + (set! field (op field args ...) + rest ...)) + ((_ field = proc rest ...) + (set! field (proc field) + rest ...)) + ((_ field val) + ((@ (guile) set!) field val)) + ((_ field val rest ...) + (begin ((@ (guile) set!) field val) + (set! rest ...))))) + +;; only evaluates the final form once +(define-syntax set/r! + (syntax-rules (=) + ((_ args ... v = something) + (begin + (set! args ... v = something) + v)) + ((_ args ... final) + (let ((val final)) + (set! args ... val) + val)))) + + +(define-syntax define-many + (syntax-rules () + [(_) (begin)] + [(_ def) (begin)] + [(_ (symbols ...) value rest ...) + (begin (define symbols value) ... + (define-many rest ...))] + [(_ def (symbols ...) value rest ...) + (begin (def symbols value) ... + (define-many def rest ...))])) + +;; Attach a label to a function, allowing it to call itself +;; without actually giving it a name (can also be thought +;; of as letrec-1). +;; @example +;; ((label fact +;; (match-lambda +;; [0 1] +;; [x (* x (fact (1- x)))])) +;; 5) +;; @end example +(define-syntax label + (syntax-rules () + [(_ self proc) + (letrec ((self proc)) + proc)])) + + +;; This function borrowed from web-ics (calendar util) +(define* (sort* items comperator #:optional (get identity)) + "A sort function more in line with how python's sorted works" + (sort items (lambda (a b) + (comperator (get a) + (get b))))) + +;; Sorts the list @var{items}. @emph{May} destroy the input list in the process +(define* (sort*! items comperator #:optional (get identity)) + "A sort function more in line with how python's sorted works" + (sort! items (lambda (a b) + (comperator (get a) + (get b))))) + +;; Given {items, <} finds the most extreme value. +;; Returns 2 values. The extremest item in @var{items}, +;; and the other items in some order. +;; Ord b => (list a) [, (b, b -> bool), (a -> b)] -> a, (list a) +(define*-public (find-extreme items optional: (< <) (access identity)) + (if (null? items) + (error "Can't find extreme in an empty list") + (fold-values + (lambda (c min other) + (if (< (access c) (access min)) + ;; Current stream head is smaller that previous min + (values c (cons min other)) + ;; Previous min is still smallest + (values min (cons c other)))) + (cdr items) + ;; seeds: + (car items) '()))) + +(define*-public (find-min list optional: (access identity)) + (find-extreme list < access)) + +(define*-public (find-max list optional: (access identity)) + (find-extreme list > access)) + +(define-public (filter-sorted proc list) + (take-while + proc (drop-while + (negate proc) list))) + +;; (define (!= a b) (not (= a b))) +(define-public != (negate =)) + +(define-public (take-to lst i) + "Like @var{take}, but might lists shorter than length." + (if (> i (length lst)) + lst (take lst i))) + +(define-public (string-take-to str i) + (if (> i (string-length str)) + str (string-take str i))) + +(define-public (string-first str) + (string-ref str 0)) + +(define-public (string-last str) + (string-ref str (1- (string-length str)))) + +(define-public (as-symb s) + (if (string? s) (string->symbol s) s)) + +(define-public (enumerate lst) + (zip (iota (length lst)) + lst)) + +;; Takes a procedure returning multiple values, and returns a function which +;; takes the same arguments as the original procedure, but only returns one of +;; the procedures. Which procedure can be sent as an additional parameter. +(define*-public (unval proc #:optional (n 0)) + (lambda args + (call-with-values (lambda () (apply proc args)) + (lambda args (list-ref args n))))) + +(define-public (flatten lst) + (fold (lambda (subl done) + (append done ((if (list? subl) flatten list) subl))) + '() lst)) + +(define-syntax let-lazy + (syntax-rules () + [(_ ((field value) ...) + body ...) + (let ((field (delay value)) ...) + (let-syntax ((field (identifier-syntax (force field))) ...) + body ...))])) + +(define-public (map/dotted proc dotted-list) + (cond ((null? dotted-list) '()) + ((not-pair? dotted-list) (proc dotted-list)) + (else + (cons (proc (car dotted-list)) + (map/dotted proc (cdr dotted-list)))))) + +;; Merges two association lists, comparing with eq. +;; The cdrs in all pairs in both lists should be lists, +;; If a key is present in both then the contents of b is +;; put @emph{before} the contents in a. +;; @example +;; (assq-merge '((k 1)) '((k 2))) +;; => ((k 2 1)) +;; @end example +(define-public (assq-merge a b) + (fold (lambda (entry alist) + (let* (((k . v) entry) + (o (assq-ref alist k))) + (assq-set! alist k (append v (or o '()))))) + (copy-tree a) b)) + +(define-public (kvlist->assq kvlist) + (map (lambda (pair) + (cons (keyword->symbol (car pair)) (cdr pair))) + (group kvlist 2))) + +(define*-public (assq-limit alist optional: (number 1)) + (map (lambda (pair) + (take-to pair (1+ number))) + alist)) + +(define-public (group-by proc lst) + (let ((h (make-hash-table))) + (for value in lst + (let ((key (proc value))) + (hash-set! h key (cons value (hash-ref h key '()))))) + ;; NOTE changing this list to cons allows the output to work with assq-merge. + (hash-map->list list h))) + +;; (split-by '(0 1 2 3 4 2 5 6) 2) +;; ⇒ ((0 1) (3 4) (5 6)) +(define-public (split-by list item) + (let loop ((done '()) + (current '()) + (rem list)) + (cond [(null? rem) + (reverse (cons (reverse current) done))] + [(eqv? item (car rem)) + (loop (cons (reverse current) done) + '() + (cdr rem))] + [else + (loop done + (cons (car rem) current) + (cdr rem))]))) + + + +;; Simar to span from srfi-1, but never takes more than +;; @var{count} items. Can however still take less. +;; @example +;; (span-upto 2 char-numeric? (string->list "123456")) +;; ⇒ (#\1 #\2) +;; ⇒ (#\3 #\4 #\5 #\6) +;; (span-upto 2 char-numeric? (string->list "H123456")) +;; ⇒ () +;; ⇒ (#\H #\1 #\2 #\3 #\4 #\5 #\6) +;; @end example +(define-public (span-upto count predicate list) + (let loop ((remaining count) + (taken '()) + (list list)) + (if (or (zero? remaining) (null? list)) + (values (reverse! taken) list) + (if (predicate (car list)) + (loop (1- remaining) + (cons (car list) taken) + (cdr list)) + (loop (1- remaining) + taken list))))) + + +;; Returns the cross product between l1 and l2. +;; each element is a cons cell. +(define (cross-product% l1 l2) + (concatenate + (map (lambda (a) + (map (lambda (b) (cons a b)) + l2)) + l1))) + +(define-public (cross-product . args) + (if (null? args) + '() + (let* ((last rest (car+cdr (reverse args)))) + (reduce-right cross-product% '() + (reverse (cons (map list last) rest )))))) + +;; Given an arbitary tree, do a pre-order traversal, appending all strings. +;; non-strings allso allowed, converted to strings and also appended. +(define-public (string-flatten tree) + (cond [(string? tree) tree] + [(list? tree) (string-concatenate (map string-flatten tree))] + [else (format #f "~a" tree)])) + +(define-public (intersperse item list) + (let loop ((flipflop #f) + (rem list)) + (if (null? rem) + '() + (if flipflop + (cons item (loop (not flipflop) rem)) + (cons (car rem) (loop (not flipflop) (cdr rem))) + )))) + +;; @example +;; (insert-ordered 5 (iota 10)) +;; ⇒ (0 1 2 3 4 5 5 6 7 8 9) +;; @end example +(define*-public (insert-ordered item collection optional: (< <)) + (cond [(null? collection) + (list item)] + [(< item (car collection)) + (cons item collection)] + [else + (cons (car collection) + (insert-ordered item (cdr collection) <))])) + + + +(define-syntax -> + (syntax-rules () + [(-> obj) obj] + [(-> obj (func args ...) rest ...) + (-> (func obj args ...) rest ...)] + [(-> obj func rest ...) + (-> (func obj) rest ...)])) + +(define-syntax ->> + (syntax-rules () + ((->> obj) + obj) + ((->> obj (func args ...) rest ...) + (->> (func args ... obj) rest ...)) + ((->> obj func rest ...) + (->> (func obj) rest ...)))) + +;; Non-destructive set, syntax extension from set-fields from (srfi +;; srfi-9 gnu). +(define-syntax set + (syntax-rules (=) + [(set (acc obj) value) + (set-fields + obj ((acc) value))] + [(set (acc obj) = (op rest ...)) + (set-fields + obj ((acc) (op (acc obj) rest ...)))])) + +(define-syntax set-> + (syntax-rules (=) + [(_ obj) obj] + [(_ obj (func = (op args ...)) rest ...) + (set-> (set (func obj) (op (func obj) args ...)) rest ...)] + [(_ obj (func args ...) rest ...) + (set-> (set (func obj) args ...) rest ...)])) + +(define-syntax and=>> + (syntax-rules () + [(_ value) value] + [(_ value proc rest ...) + (and=>> (and=> value proc) + rest ...)])) + +(define-public (downcase-symbol symb) + (-> symb + symbol->string + string-downcase + string->symbol)) + + +;; @example +;; (group (iota 10) 2) +;; ⇒ ((0 1) (2 3) (4 5) (6 7) (8 9)) +;; @end example +;; Requires that width|(length list) +(define-public (group list width) + (unless (null? list) + (let* ((row rest (split-at list width))) + (cons row (group rest width))))) + +;; repeatedly apply @var{proc} to @var{base} +;; unitl @var{until} is satisfied. +;; (a → a), (a → bool), a → a +(define-public (iterate proc until base) + (let loop ((o base)) + (if (until o) + o + (loop (proc o))))) + +;; (a → values a), list ... → values a +(define-public (valued-map proc . lists) + (apply values + (apply append-map + (lambda args + (call-with-values (lambda () (apply proc args)) list)) + lists))) + +(define (ass%-ref-all alist key =) + (map cdr (filter (lambda (pair) (= key (car pair))) + alist))) + +;; Equivalent to assoc-ref (and family), but works on association lists with +;; non-unique keys, returning all mathing records (instead of just the first). +;; @begin lisp +;; (assoc-ref-all '((a . 1) (b . 2) (a . 3)) 'a) +;; ⇒ (1 3) +;; @end +(define-public (assoc-ref-all alist key) (ass%-ref-all alist key equal?)) +(define-public (assq-ref-all alist key) (ass%-ref-all alist key eq?)) +(define-public (assv-ref-all alist key) (ass%-ref-all alist key eqv?)) + + + + +(define-public (vector-last v) + (vector-ref v (1- (vector-length v)))) + +(define-public (->str any) + (with-output-to-string (lambda () (display any)))) + +(define-public ->string ->str) + +(define-public (->quoted-string any) + (with-output-to-string (lambda () (write any)))) + + + + +;; TODO shouldn't this use `file-name-separator-string'? +(define-public (path-append . strings) + (fold (lambda (s done) + (string-append + done + (if (string-null? s) + (string-append s "/") + (if (char=? #\/ (string-last done)) + (if (char=? #\/ (string-first s)) + (string-drop s 1) s) + (if (char=? #\/ (string-first s)) + s (string-append "/" s)))))) + (let ((s (car strings))) + (if (string-null? s) + "/" s)) + (cdr strings))) + + + + +(define-syntax let-env + (syntax-rules () + [(_ ((name value) ...) + body ...) + + (let ((env-pairs #f)) + (dynamic-wind + (lambda () + (set! env-pairs + (map (lambda (n new-value) + (list n new-value (getenv n))) + (list (symbol->string (quote name)) ...) + (list value ...))) + (for-each (lambda (pair) (setenv (car pair) (cadr pair))) + env-pairs)) + (lambda () body ...) + (lambda () + (for-each (lambda (pair) (setenv (car pair) (caddr pair))) + env-pairs))))])) + + +(define-public (uuidgen) + ((@ (rnrs io ports) call-with-port) + ((@ (ice-9 popen) open-input-pipe) "uuidgen") + (@ (ice-9 rdelim) read-line))) diff --git a/module/hnh/util/color.scm b/module/hnh/util/color.scm new file mode 100644 index 00000000..b626316d --- /dev/null +++ b/module/hnh/util/color.scm @@ -0,0 +1,22 @@ +(define-module (hnh 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/hnh/util/exceptions.scm b/module/hnh/util/exceptions.scm new file mode 100644 index 00000000..fef0f1b5 --- /dev/null +++ b/module/hnh/util/exceptions.scm @@ -0,0 +1,57 @@ +(define-module (hnh util exceptions) + #:use-module (srfi srfi-1) + #:use-module (hnh util) + #:use-module (calp util config) + #:use-module (ice-9 format) + + #:use-module ((system vm frame) + :select (frame-bindings binding-ref)) + + #:export (assert)) + + +(define-public warning-handler + (make-parameter + (lambda (fmt . args) + (format #f "WARNING: ~?~%" fmt args)))) + +(define-public warnings-are-errors + (make-parameter #f)) + +(define-config warnings-are-errors #f + description: "Crash on warnings." + post: warnings-are-errors) + +;; forwards return from warning-hander. By default returns an unspecified value, +;; but instances are free to provide a proper return value and use it. +(define-public (warning fmt . args) + (display (apply (warning-handler) fmt (or args '())) + (current-error-port)) + (when (warnings-are-errors) + (throw 'warning fmt args))) + +(define-public (fatal fmt . args) + (display (format #f "FATAL: ~?~%" fmt (or args '())) + (current-error-port)) + (raise 2) + ) + +(define (prettify-tree tree) + (cond [(pair? tree) (cons (prettify-tree (car tree)) + (prettify-tree (cdr tree)))] + [(and (procedure? tree) (procedure-name tree)) + => identity] + [else tree])) + + +(define-macro (assert form) + `(unless ,form + (throw 'assertion-error "Assertion failed. ~a expected, ~a got" + (quote ,form) + ((@@ (calp util exceptions) prettify-tree) (list ,form))))) + + +(define-public (filter-stack pred? stk) + (concatenate + (for i in (iota (stack-length stk)) + (filter pred? (map binding-ref (frame-bindings (stack-ref stk i))))))) diff --git a/module/hnh/util/graph.scm b/module/hnh/util/graph.scm new file mode 100644 index 00000000..912f9612 --- /dev/null +++ b/module/hnh/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 (hnh util graph) + :use-module (hnh 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/hnh/util/io.scm b/module/hnh/util/io.scm new file mode 100644 index 00000000..04e54a9e --- /dev/null +++ b/module/hnh/util/io.scm @@ -0,0 +1,59 @@ +(define-module (hnh 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/hnh/util/options.scm b/module/hnh/util/options.scm new file mode 100644 index 00000000..57473816 --- /dev/null +++ b/module/hnh/util/options.scm @@ -0,0 +1,45 @@ +(define-module (hnh util options) + :use-module (hnh util) + :use-module (ice-9 match) + :use-module (srfi srfi-1) + :use-module (text markup) + ) + +;; option-assoc → getopt-valid option-assoc +(define-public (getopt-opt options) + (define ice-9-names '(single-char required? value predicate)) + (for (option-name flags ...) in options + (cons option-name + (map (match-lambda + (('value (_ ...)) `(value #t)) + (('value (? symbol? _)) `(value optional)) + ((key v) `(,key ,v))) + (filter (match-lambda ((key _ ...) (memv key ice-9-names))) + flags))))) + + +;; (name (key value) ...) → sxml +(define (fmt-help option-line) + (match option-line + ((name args ...) + (let ((valuefmt (match (assoc-ref args 'value) + [(#t) '(" " (i value))] + [(or #f (#f)) '()] + [(('options options ...)) + `(" {" ,(string-join options "|") "}")] + [(s) `(" [" (i ,s) "]")]))) + `(*TOP* (b "--" ,name) ,@valuefmt + ,@(awhen (assoc-ref args 'single-char) + `("," (ws) + (b "-" ,(car it)) + ,@valuefmt)) + (br) + ,@(awhen (assoc-ref args 'description) + `((blockquote ,@it) + (br)))))))) + +(define-public (format-arg-help options) + (sxml->ansi-text (cons '*TOP* (map sxml->ansi-text (map fmt-help options))))) + +(define*-public (print-arg-help options optional: (port (current-error-port))) + (display (format-arg-help options) port)) diff --git a/module/hnh/util/tree.scm b/module/hnh/util/tree.scm new file mode 100644 index 00000000..6c4f765d --- /dev/null +++ b/module/hnh/util/tree.scm @@ -0,0 +1,40 @@ +(define-module (hnh util tree) + #:use-module (srfi srfi-1) + #:use-module (hnh 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/srfi/srfi-41/util.scm b/module/srfi/srfi-41/util.scm index aa28b852..7c062003 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 (calp util) ; let*, find-min + #:use-module (hnh 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 19211227..af770f7a 100644 --- a/module/sxml/namespace.scm +++ b/module/sxml/namespace.scm @@ -1,5 +1,5 @@ (define-module (sxml namespace) - :use-module (calp util) + :use-module (hnh util) :use-module (sxml transform)) (define* (symbol-split symbol key: (sep #\:)) diff --git a/module/sxml/transformations.scm b/module/sxml/transformations.scm index 5d82ee9c..0978d71c 100644 --- a/module/sxml/transformations.scm +++ b/module/sxml/transformations.scm @@ -6,7 +6,7 @@ ;;; Code: (define-module (sxml transformations) - :use-module (calp util) + :use-module (hnh 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 528650a5..f7e08e1b 100644 --- a/module/text/flow.scm +++ b/module/text/flow.scm @@ -4,7 +4,7 @@ ;;; Code: (define-module (text flow) - :use-module (calp util) + :use-module (hnh util) :use-module (text util) :use-module (srfi srfi-1) ) diff --git a/module/text/markup.scm b/module/text/markup.scm index b74fd169..295ca198 100644 --- a/module/text/markup.scm +++ b/module/text/markup.scm @@ -1,5 +1,5 @@ (define-module (text markup) - :use-module (calp util) + :use-module (hnh util) :use-module (srfi srfi-1) :use-module (ice-9 match) :use-module (ice-9 pretty-print) diff --git a/module/text/numbers/sv.scm b/module/text/numbers/sv.scm index ca59254b..2a032525 100644 --- a/module/text/numbers/sv.scm +++ b/module/text/numbers/sv.scm @@ -1,5 +1,5 @@ (define-module (text numbers sv) - :use-module (calp util)) + :use-module (hnh util)) ;; only used in number->string-cardinal (define (large-prefix e) diff --git a/module/text/util.scm b/module/text/util.scm index ce39ad10..7144b032 100644 --- a/module/text/util.scm +++ b/module/text/util.scm @@ -3,7 +3,7 @@ ;;; Code: (define-module (text util) - :use-module ((calp util) :select (define*-public intersperse) ) + :use-module ((hnh util) :select (define*-public intersperse) ) ) (define-public (words str) (string-split str #\space)) diff --git a/module/vcomponent.scm b/module/vcomponent.scm index c1983977..7618084c 100644 --- a/module/vcomponent.scm +++ b/module/vcomponent.scm @@ -1,5 +1,5 @@ (define-module (vcomponent) - :use-module (calp util) + :use-module (hnh util) :use-module (calp util config) :use-module (vcomponent base) ;; :use-module ((vcomponent util instance methods) diff --git a/module/vcomponent/base.scm b/module/vcomponent/base.scm index 66e6534f..579382ae 100644 --- a/module/vcomponent/base.scm +++ b/module/vcomponent/base.scm @@ -1,5 +1,5 @@ (define-module (vcomponent base) - :use-module (calp util) + :use-module (hnh util) :use-module (srfi srfi-1) :use-module (srfi srfi-9) :use-module (srfi srfi-9 gnu) diff --git a/module/vcomponent/control.scm b/module/vcomponent/control.scm index 4cb6c708..586dd4a3 100644 --- a/module/vcomponent/control.scm +++ b/module/vcomponent/control.scm @@ -1,5 +1,5 @@ (define-module (vcomponent util control) - #:use-module (calp util) + #:use-module (hnh util) #:use-module (vcomponent) #:export (with-replaced-properties)) diff --git a/module/vcomponent/datetime.scm b/module/vcomponent/datetime.scm index ca4f90e9..bb4fe50e 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 (calp util) + #:use-module (hnh util) :use-module (ice-9 curried-definitions) diff --git a/module/vcomponent/datetime/output.scm b/module/vcomponent/datetime/output.scm index 1b377a7c..fa662286 100644 --- a/module/vcomponent/datetime/output.scm +++ b/module/vcomponent/datetime/output.scm @@ -1,7 +1,7 @@ (define-module (vcomponent datetime output) - :use-module (calp util) + :use-module (hnh util) :use-module (calp util config) - :use-module (calp util exceptions) + :use-module (hnh util exceptions) :use-module (datetime) :use-module (vcomponent base) :use-module (text util) diff --git a/module/vcomponent/duration.scm b/module/vcomponent/duration.scm index 7591a880..786675b8 100644 --- a/module/vcomponent/duration.scm +++ b/module/vcomponent/duration.scm @@ -1,6 +1,6 @@ (define-module (vcomponent duration) - :use-module (calp util) - :use-module (calp util exceptions) + :use-module (hnh util) + :use-module (hnh util exceptions) :use-module (datetime) :use-module (ice-9 peg) :use-module (ice-9 match) diff --git a/module/vcomponent/formats/common/types.scm b/module/vcomponent/formats/common/types.scm index 87425c01..efe17f36 100644 --- a/module/vcomponent/formats/common/types.scm +++ b/module/vcomponent/formats/common/types.scm @@ -1,6 +1,6 @@ (define-module (vcomponent formats common types) - :use-module (calp util) - :use-module (calp util exceptions) + :use-module (hnh util) + :use-module (hnh util exceptions) :use-module (base64) :use-module (datetime) :use-module (srfi srfi-9 gnu) diff --git a/module/vcomponent/formats/ical/output.scm b/module/vcomponent/formats/ical/output.scm index 9efac3c4..fba8bffc 100644 --- a/module/vcomponent/formats/ical/output.scm +++ b/module/vcomponent/formats/ical/output.scm @@ -1,6 +1,6 @@ (define-module (vcomponent formats ical output) - :use-module (calp util exceptions) - :use-module (calp util) + :use-module (hnh util exceptions) + :use-module (hnh util) :use-module (datetime) :use-module (datetime zic) :use-module ((datetime instance) :select (zoneinfo)) diff --git a/module/vcomponent/formats/ical/parse.scm b/module/vcomponent/formats/ical/parse.scm index d76044a3..34812a2c 100644 --- a/module/vcomponent/formats/ical/parse.scm +++ b/module/vcomponent/formats/ical/parse.scm @@ -1,7 +1,7 @@ (define-module (vcomponent formats ical parse) :use-module ((ice-9 rdelim) :select (read-line)) - :use-module (calp util exceptions) - :use-module (calp util) + :use-module (hnh util exceptions) + :use-module (hnh util) :use-module (datetime) :use-module (srfi srfi-1) :use-module (srfi srfi-26) diff --git a/module/vcomponent/formats/ical/types.scm b/module/vcomponent/formats/ical/types.scm index d063ca8f..39b3b1e3 100644 --- a/module/vcomponent/formats/ical/types.scm +++ b/module/vcomponent/formats/ical/types.scm @@ -1,7 +1,7 @@ ;; see (vcomponent parse types) (define-module (vcomponent formats ical types) - :use-module (calp util) - :use-module (calp util exceptions) + :use-module (hnh util) + :use-module (hnh util exceptions) :use-module (base64) :use-module (datetime) :use-module (datetime timespec)) diff --git a/module/vcomponent/formats/vdir/parse.scm b/module/vcomponent/formats/vdir/parse.scm index f3810887..20b89026 100644 --- a/module/vcomponent/formats/vdir/parse.scm +++ b/module/vcomponent/formats/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 (calp util) - :use-module (calp util exceptions) + :use-module (hnh util) + :use-module (hnh util exceptions) :use-module (vcomponent base) :use-module (vcomponent formats ical parse) diff --git a/module/vcomponent/formats/vdir/save-delete.scm b/module/vcomponent/formats/vdir/save-delete.scm index 1c70dabf..73725b2c 100644 --- a/module/vcomponent/formats/vdir/save-delete.scm +++ b/module/vcomponent/formats/vdir/save-delete.scm @@ -10,11 +10,11 @@ ;;; Code: (define-module (vcomponent formats vdir save-delete) - :use-module (calp util) - :use-module ((calp util exceptions) :select (assert)) + :use-module (hnh util) + :use-module ((hnh util exceptions) :select (assert)) :use-module (vcomponent formats ical output) :use-module (vcomponent) - :use-module ((calp util io) :select (with-atomic-output-to-file)) + :use-module ((hnh util io) :select (with-atomic-output-to-file)) ) diff --git a/module/vcomponent/formats/xcal/output.scm b/module/vcomponent/formats/xcal/output.scm index e2cada83..81fab41c 100644 --- a/module/vcomponent/formats/xcal/output.scm +++ b/module/vcomponent/formats/xcal/output.scm @@ -1,6 +1,6 @@ (define-module (vcomponent formats xcal output) - :use-module (calp util) - :use-module (calp util exceptions) + :use-module (hnh util) + :use-module (hnh util exceptions) :use-module (vcomponent) :use-module (vcomponent geo) :use-module (vcomponent formats xcal types) diff --git a/module/vcomponent/formats/xcal/parse.scm b/module/vcomponent/formats/xcal/parse.scm index e84f380e..7dee8d67 100644 --- a/module/vcomponent/formats/xcal/parse.scm +++ b/module/vcomponent/formats/xcal/parse.scm @@ -1,6 +1,6 @@ (define-module (vcomponent formats xcal parse) - :use-module (calp util) - :use-module (calp util exceptions) + :use-module (hnh util) + :use-module (hnh util exceptions) :use-module (base64) :use-module (ice-9 match) :use-module (sxml match) diff --git a/module/vcomponent/formats/xcal/types.scm b/module/vcomponent/formats/xcal/types.scm index 34c7c40d..05fbc8c6 100644 --- a/module/vcomponent/formats/xcal/types.scm +++ b/module/vcomponent/formats/xcal/types.scm @@ -1,5 +1,5 @@ (define-module (vcomponent formats xcal types) - :use-module (calp util) + :use-module (hnh util) :use-module (vcomponent formats ical types) :use-module (datetime) ) diff --git a/module/vcomponent/geo.scm b/module/vcomponent/geo.scm index ac370a6c..27b2cbae 100644 --- a/module/vcomponent/geo.scm +++ b/module/vcomponent/geo.scm @@ -1,5 +1,5 @@ (define-module (vcomponent geo) - :use-module (calp util) + :use-module (hnh util) :use-module (srfi srfi-9 gnu)) (define-immutable-record-type diff --git a/module/vcomponent/recurrence/display.scm b/module/vcomponent/recurrence/display.scm index b13e955e..f5ce1c57 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 (calp util) + :use-module (hnh util) :use-module (vcomponent recurrence internal) :use-module (text util) :use-module (text numbers sv) diff --git a/module/vcomponent/recurrence/generate.scm b/module/vcomponent/recurrence/generate.scm index 1d262202..b498e033 100644 --- a/module/vcomponent/recurrence/generate.scm +++ b/module/vcomponent/recurrence/generate.scm @@ -1,6 +1,6 @@ (define-module (vcomponent recurrence generate) - :use-module (calp util) - :use-module (calp util exceptions) + :use-module (hnh util) + :use-module (hnh 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 a57dfd65..b4f09d92 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 (calp util) + #:use-module (hnh 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 a1bf3eaa..3477f6d4 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 (calp util) - #:use-module (calp util exceptions) + #:use-module (hnh util) + #:use-module (hnh util exceptions) #:use-module (ice-9 match)) diff --git a/module/vcomponent/util/control.scm b/module/vcomponent/util/control.scm index 4cb6c708..586dd4a3 100644 --- a/module/vcomponent/util/control.scm +++ b/module/vcomponent/util/control.scm @@ -1,5 +1,5 @@ (define-module (vcomponent util control) - #:use-module (calp util) + #:use-module (hnh util) #:use-module (vcomponent) #:export (with-replaced-properties)) diff --git a/module/vcomponent/util/describe.scm b/module/vcomponent/util/describe.scm index 5c3afd30..0c3ab27c 100644 --- a/module/vcomponent/util/describe.scm +++ b/module/vcomponent/util/describe.scm @@ -1,5 +1,5 @@ (define-module (vcomponent util describe) - :use-module (calp util) + :use-module (hnh util) :use-module (vcomponent base) :use-module (text util)) diff --git a/module/vcomponent/util/instance.scm b/module/vcomponent/util/instance.scm index 15c020b1..6e1e765f 100644 --- a/module/vcomponent/util/instance.scm +++ b/module/vcomponent/util/instance.scm @@ -1,5 +1,5 @@ (define-module (vcomponent util instance) - :use-module (calp util) + :use-module (hnh util) :use-module ((calp util config) :select (get-config)) :use-module ((oop goops) :select (make)) :export (global-event-object) diff --git a/module/vcomponent/util/instance/methods.scm b/module/vcomponent/util/instance/methods.scm index 37aef3bc..120ab2fe 100644 --- a/module/vcomponent/util/instance/methods.scm +++ b/module/vcomponent/util/instance/methods.scm @@ -1,5 +1,5 @@ (define-module (vcomponent util instance methods) - :use-module (calp util) + :use-module (hnh util) :use-module (srfi srfi-1) :use-module (srfi srfi-41) :use-module (srfi srfi-41 util) diff --git a/module/vcomponent/util/parse-cal-path.scm b/module/vcomponent/util/parse-cal-path.scm index 94c0c6ed..11a32064 100644 --- a/module/vcomponent/util/parse-cal-path.scm +++ b/module/vcomponent/util/parse-cal-path.scm @@ -1,5 +1,5 @@ (define-module (vcomponent util parse-cal-path) - :use-module (calp util) + :use-module (hnh util) :use-module ((calp util time) :select (report-time!)) :use-module (vcomponent base) :use-module ((vcomponent formats ical parse) diff --git a/module/vcomponent/util/search.scm b/module/vcomponent/util/search.scm index fb395022..61e81eb5 100644 --- a/module/vcomponent/util/search.scm +++ b/module/vcomponent/util/search.scm @@ -25,7 +25,7 @@ ;;; Code: (define-module (vcomponent util search) - :use-module (calp util) + :use-module (hnh util) :use-module (srfi srfi-1) :use-module (srfi srfi-9) :use-module (srfi srfi-41) diff --git a/module/vulgar.scm b/module/vulgar.scm index eabd11f8..5ddea738 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 (calp util) + #:use-module (hnh util) #:export (with-vulgar)) (define-public (cls) diff --git a/module/vulgar/components.scm b/module/vulgar/components.scm index 2b018e4e..882da849 100644 --- a/module/vulgar/components.scm +++ b/module/vulgar/components.scm @@ -1,6 +1,6 @@ (define-module (vulgar components) #:use-module (datetime) - #:use-module (calp util) + #:use-module (hnh util) #:export ()) (define-public (display-calendar-header! date) diff --git a/module/vulgar/info.scm b/module/vulgar/info.scm index 66901ff8..79e555da 100644 --- a/module/vulgar/info.scm +++ b/module/vulgar/info.scm @@ -1,5 +1,5 @@ (define-module (vulgar info) - :use-module (calp util)) + :use-module (hnh util)) (define-public (get-terminal-size) (let* (((rpipe . wpipe) (pipe))) diff --git a/module/vulgar/termios.scm b/module/vulgar/termios.scm index f88882c9..532fc07e 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 (calp util) + :use-module (hnh 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 4fb5397a..7254fcb5 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 (calp util) + :use-module (hnh 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 55b3f564..e5057a24 100644 --- a/module/web/query.scm +++ b/module/web/query.scm @@ -1,5 +1,5 @@ (define-module (web query) - :use-module (calp util) + :use-module (hnh util) :use-module (srfi srfi-1) :use-module (web uri)) diff --git a/module/web/uri-query.scm b/module/web/uri-query.scm index 9eff203f..40d89b11 100644 --- a/module/web/uri-query.scm +++ b/module/web/uri-query.scm @@ -1,5 +1,5 @@ (define-module (web uri-query) - :use-module ((calp util) :select (->quoted-string)) + :use-module ((hnh util) :select (->quoted-string)) :use-module ((web uri) :select (uri-encode)) ) diff --git a/scripts/all-symbols.scm b/scripts/all-symbols.scm index a200fb6c..5ac1f215 100755 --- a/scripts/all-symbols.scm +++ b/scripts/all-symbols.scm @@ -13,7 +13,7 @@ (add-to-load-path (string-append (dirname (dirname (current-filename))) "/module")) -(use-modules (calp util) +(use-modules (hnh util) (srfi srfi-1)) diff --git a/scripts/benchmark.scm b/scripts/benchmark.scm index 362ccccd..462d578c 100644 --- a/scripts/benchmark.scm +++ b/scripts/benchmark.scm @@ -1,5 +1,5 @@ (add-to-load-path "module") -(use-modules (calp util) +(use-modules (hnh util) (calp util app) (calp util config) (vcomponent) diff --git a/scripts/get-config.scm b/scripts/get-config.scm index 4ab2c2c9..0351b768 100755 --- a/scripts/get-config.scm +++ b/scripts/get-config.scm @@ -11,7 +11,7 @@ (add-to-load-path "module") (use-modules - (calp util) + (hnh util) (ice-9 ftw) (ice-9 match) (srfi srfi-1) diff --git a/scripts/use2dot/gen-use.scm b/scripts/use2dot/gen-use.scm index 8475d71e..02785088 100755 --- a/scripts/use2dot/gen-use.scm +++ b/scripts/use2dot/gen-use.scm @@ -154,7 +154,7 @@ (datetime) (vcomponent) - (calp util) + (hnh util) ) ((scan files) 'edges))) diff --git a/tests/annoying-events.scm b/tests/annoying-events.scm index ba93b9c9..90e6a184 100644 --- a/tests/annoying-events.scm +++ b/tests/annoying-events.scm @@ -3,7 +3,7 @@ ((vcomponent base) extract prop make-vcomponent) ((vcomponent datetime) event-overlaps?) ((datetime) date date+ date<) - ((calp util) set!)) + ((hnh util) set!)) (define* (event key: summary dtstart dtend) (define ev (make-vcomponent 'VEVENT)) diff --git a/tests/datetime.scm b/tests/datetime.scm index f9cf94e1..d1ebd238 100644 --- a/tests/datetime.scm +++ b/tests/datetime.scm @@ -16,7 +16,7 @@ string->date string->time string->datetime ) ((ice-9 format) format) - ((calp util) let*) + ((hnh util) let*) ((ice-9 i18n) make-locale) ((guile) LC_TIME) ) diff --git a/tests/let-env.scm b/tests/let-env.scm index 0fe77539..17cfb817 100644 --- a/tests/let-env.scm +++ b/tests/let-env.scm @@ -1,5 +1,5 @@ (((guile) setenv getenv) - ((calp util) let-env)) + ((hnh util) let-env)) (setenv "CALP_TEST_ENV" "1") (test-equal "Ensure we have set value beforehand" diff --git a/tests/let.scm b/tests/let.scm index 81a34131..3f1b52a7 100644 --- a/tests/let.scm +++ b/tests/let.scm @@ -2,7 +2,7 @@ ;; Tests my custom let*. ;;; Code: -(((calp util) let*) +(((hnh util) let*) ((guile) set!)) (test-assert (let* ((a #t)) a)) diff --git a/tests/param.scm b/tests/param.scm index c5a23cbe..cf8c9458 100644 --- a/tests/param.scm +++ b/tests/param.scm @@ -6,7 +6,7 @@ (((vcomponent base) param prop* parameters prop) ((vcomponent formats ical parse) parse-calendar) ((vcomponent) make-vcomponent) - ((calp util) sort* set!)) + ((hnh util) sort* set!)) (define v (call-with-input-string "BEGIN:DUMMY diff --git a/tests/recurrence-advanced.scm b/tests/recurrence-advanced.scm index c2242c19..4f26f2c7 100644 --- a/tests/recurrence-advanced.scm +++ b/tests/recurrence-advanced.scm @@ -23,7 +23,7 @@ ((vcomponent base) make-vcomponent prop prop* extract) ((datetime) parse-ics-datetime datetime time date datetime->string) - ((calp util) -> set!) + ((hnh util) -> set!) ((srfi srfi-41) stream->list) ((srfi srfi-88) keyword->string)) diff --git a/tests/recurrence-simple.scm b/tests/recurrence-simple.scm index cd170976..d5a35802 100644 --- a/tests/recurrence-simple.scm +++ b/tests/recurrence-simple.scm @@ -8,7 +8,7 @@ ((datetime) day-stream mon) ((vcomponent base) extract prop) - ((calp util exceptions) warnings-are-errors warning-handler) + ((hnh util exceptions) warnings-are-errors warning-handler) ((guile) format @@) ((vcomponent formats ical parse) parse-calendar) diff --git a/tests/run-tests.scm b/tests/run-tests.scm index 6ec8dea7..9271fc55 100755 --- a/tests/run-tests.scm +++ b/tests/run-tests.scm @@ -47,7 +47,7 @@ (srfi srfi-64) ; test suite (srfi srfi-88) ; suffix keywords (system vm coverage) - ((calp util) :select (for awhen)) + ((hnh util) :select (for awhen)) ;; datetime introduces the reader extensions for datetimes, ;; which leaks into the sandboxes below. (datetime)) @@ -92,7 +92,7 @@ (test-begin "tests") ;; Forces all warnings to be explicitly handled by tests -((@ (calp util exceptions) warnings-are-errors) #t) +((@ (hnh util exceptions) warnings-are-errors) #t) (define (run-with-coverage) (with-code-coverage diff --git a/tests/server.scm b/tests/server.scm index d21c11da..a2b3ea9d 100644 --- a/tests/server.scm +++ b/tests/server.scm @@ -3,7 +3,7 @@ ;;; Code: (((web http make-routes) parse-endpoint-string) - ((calp util) let*)) + ((hnh util) let*)) (test-assert "Check that parsing doesn't crash" (parse-endpoint-string "/static/:dir/:file")) diff --git a/tests/termios.scm b/tests/termios.scm index c0cb4323..e54ddc9c 100644 --- a/tests/termios.scm +++ b/tests/termios.scm @@ -5,7 +5,7 @@ ;; It might also leave the terminal in a broken state if exited prematurely. ;;; Code: -(((calp util) set!) +(((hnh util) set!) ((vulgar termios) make-termios copy-termios lflag diff --git a/tests/tz.scm b/tests/tz.scm index 147f0807..1cbb1842 100644 --- a/tests/tz.scm +++ b/tests/tz.scm @@ -12,7 +12,7 @@ datetime->unix-time unix-time->datetime get-datetime) - ((calp util) let-env)) + ((hnh 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 aa47a44f..45e69dd6 100644 --- a/tests/util.scm +++ b/tests/util.scm @@ -1,8 +1,8 @@ ;;; Commentary: -;; Checks some prodecuders from (calp util) +;; Checks some prodecuders from (hnh util) ;;; Code: -(((calp util) filter-sorted set/r! +(((hnh util) filter-sorted set/r! find-min find-max span-upto iterate ->string ->quoted-string path-append begin1) diff --git a/tests/web-server.scm b/tests/web-server.scm index bce05d0e..73d34317 100644 --- a/tests/web-server.scm +++ b/tests/web-server.scm @@ -7,7 +7,7 @@ ((web server) run-server) ((ice-9 threads) call-with-new-thread cancel-thread) ((web client) http-get) - ((calp util) let*) + ((hnh 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 df8a5135..6e80405b 100644 --- a/tests/xcal.scm +++ b/tests/xcal.scm @@ -6,7 +6,7 @@ (((vcomponent formats xcal parse) sxcal->vcomponent) ((vcomponent formats xcal output) vcomponent->sxcal) ((vcomponent formats ical parse) parse-calendar) - ((calp util) ->) + ((hnh util) ->) ((vcomponent base) parameters prop* children) ) -- cgit v1.2.3