Import util-kwargs from lvision.

src/Makefile

@@ -51,7 +51,8 @@ HACKERBASE-OBJS=hackerbase.o testing.o listing.o cal-month.o		\
 	 util-string.o util-io.o util-list.o util-parser.o texts.o	\
 	 tests.o util-proc.o util-mail.o notifications.o		\
 	 util-format.o brmember-format.o logging.o specification.o	\
-	 util-git.o cal-day.o util-stdout.o cal-format.o
+	 util-git.o cal-day.o util-stdout.o cal-format.o		\
+	 util-kwargs.o
 
 .PHONY: imports
 imports: $(HACKERBASE-DEPS)
@@ -385,3 +386,8 @@ CAL-FORMAT-SOURCES=cal-format.scm cal-day.import.scm cal-month.import.scm
 
 cal-format.o: cal-format.import.scm
 cal-format.import.scm: $(CAL-FORMAT-SOURCES)
+
+UTIL-KWARGS-SOURCES=util-kwargs.scm
+
+util-kwargs.o: util-kwargs.import.scm
+util-kwargs.import.scm: $(UTIL-KWARGS-SOURCES)

src/util-kwargs.scm

@@ -0,0 +1,134 @@
+;;
+;; util-kwargs.scm
+;;
+;; Syntax infrastructure for kwargs procedure definitions.
+;;
+;; ISC License
+;;
+;; Copyright 2023 Dominik Pantůček <dominik.pantucek@trustica.cz>
+;;
+;; Permission to use, copy, modify, and/or distribute this software
+;; for any purpose with or without fee is hereby granted, provided
+;; that the above copyright notice and this permission notice appear
+;; in all copies.
+;; 
+;; THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL
+;; WARRANTIES WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED
+;; WARRANTIES OF MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE
+;; AUTHOR BE LIABLE FOR ANY SPECIAL, DIRECT, INDIRECT, OR
+;; CONSEQUENTIAL DAMAGES OR ANY DAMAGES WHATSOEVER RESULTING FROM LOSS
+;; OF USE, DATA OR PROFITS, WHETHER IN AN ACTION OF CONTRACT,
+;; NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF OR IN
+;; CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE.
+;;
+
+(declare (unit util-kwargs))
+
+(module
+ util-kwargs
+ (
+  define-kwproc
+  let-kwargs*
+  let-kwargs**
+  split-kwargs
+  )
+ (import scheme
+	 (chicken base)
+	 (chicken keyword))
+
+ ;; Splits arguments into two lists: the kw-args and non-kw-args
+ (define (split-kwargs args)
+   (let loop ((args args)
+	      (kw-args '())
+	      (non-kw-args '()))
+     (if (null? args)
+	 (values kw-args
+		 (reverse non-kw-args))
+	 (if (keyword? (car args))
+	     (if (null? (cdr args))
+		 (error 'split-kwargs "missing keyword pair" (car args))
+		 (loop (cddr args)
+		       (cons (car args)
+			     (cons (cadr args)
+				   kw-args))
+		       non-kw-args))
+	     (loop (cdr args)
+		   kw-args
+		   (cons (car args) non-kw-args))))))
+
+ ;; Parses all the variants of keyword and positional arguments in the
+ ;; list.
+ (define-syntax let-kwargs**
+   (syntax-rules ()
+     ;; End, without rest
+     ((_ name
+	 (kw-args non-kw-args)
+	 ()
+	 expr ...)
+      (if (null? non-kw-args)
+	  (let ()
+	    expr ...)
+	  (error 'name "too many arguments" non-kw-args)))
+     ;; Explicit default for kw-arg
+     ((_ name
+	 (kw-args non-kw-args)
+	 ((kw binding) . rest)
+	 expr ...)
+      (let-kwargs** name
+		    (kw-args non-kw-args)
+		    ((kw binding #f) . rest)
+		    expr ...))
+     ;; A kw-args with default
+     ((_ name
+	 (kw-args non-kw-args)
+	 ((kw binding default) . rest)
+	 expr ...)
+      (let ((binding (get-keyword kw kw-args (lambda () default))))
+	(let-kwargs** name
+		      (kw-args non-kw-args)
+		      rest
+		      expr ...)))
+     ;; Positional argument
+     ((_ name
+	 (kw-args non-kw-args)
+	 (binding . rest)
+	 expr ...)
+      (let ((binding (if (null? non-kw-args)
+			 (error 'name "not enough arguments" non-kw-args)
+			 (car non-kw-args)))
+	    (cdr-non-kw-args (cdr non-kw-args)))
+	(let-kwargs** name
+		      (kw-args cdr-non-kw-args)
+		      rest
+		      expr ...)))
+     ;; Rest argument
+     ((_ name
+	 (kw-args non-kw-args)
+	 rest
+	 expr ...)
+      (let ((rest non-kw-args))
+	expr ...))))
+
+ ;; Simple wrapper to separate the kw/non-kw lists and pass it on to
+ ;; further parsing
+ (define-syntax let-kwargs*
+   (syntax-rules ()
+     ((_ name
+	 ((binding . rest) args)
+	 expr ...)
+      (let-values (((kw-args non-kw-args) (split-kwargs args)))
+	(let-kwargs** name
+		      (kw-args non-kw-args)
+		      (binding . rest)
+		      expr ...)))))
+
+ ;; Convenience syntax for defining kwargs functions
+ (define-syntax define-kwproc
+   (syntax-rules ()
+     ((_ (name . argspec) expr ...)
+      (define (name . args)
+	(let-kwargs* name
+		     (argspec args)
+		     expr ...)))))
+
+ )