Remove old util-kwargs, replace with Racket-compatible define*/lambda* forms.

doc/utils.md

@@ -229,20 +229,6 @@ Executes given command ```cmd``` with given argument list ```args```
 writing all ```lines``` to its standard input and then reads all the
 process output.
 
-### Keyword Arguments
-
-    (import util-kwargs)
-
-A simple module providing convenient syntax for defining procedures
-with keyword arguments with default values.
-
-    (define-kwproc (name arg ... (#:kw binding [default]) ...) body ...)
-
-Defines new procedure ```name``` with positional arguments ```arg
-...``` and optional keyword arguments with implicit default value
-```#f``` or any specific value given in the keyword argument
-specification.
-
 ### List
 
     (import util-list)

src/Makefile

@@ -52,7 +52,7 @@ HACKERBASE-OBJS=hackerbase.o testing.o listing.o cal-month.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-kwargs.o util-dict-bst.o
+	 util-dict-bst.o
 
 .PHONY: imports
 imports: $(HACKERBASE-DEPS)
@@ -97,7 +97,7 @@ testing.o: testing.import.scm
 testing.import.scm: $(TESTING-SOURCES)
 
 LISTING-SOURCES=listing.scm testing.import.scm ansi.import.scm	\
-	util-kwargs.import.scm table.import.scm
+	racket-kwargs.import.scm table.import.scm
 
 listing.o: listing.import.scm
 listing.import.scm: $(LISTING-SOURCES)
@@ -125,7 +125,7 @@ MBASE-SOURCES=mbase.scm testing.import.scm util-dict-list.import.scm	\
 	 cal-period.import.scm cal-month.import.scm			\
 	 configuration.import.scm progress.import.scm			\
 	 table.import.scm mbase-dir.import.scm util-list.import.scm	\
-	 util-tag.import.scm util-kwargs.import.scm			\
+	 util-tag.import.scm racket-kwargs.import.scm			\
 	 util-dict-bst.import.scm
 
 mbase.o: mbase.import.scm
@@ -162,7 +162,7 @@ progress.import.scm: $(PROGRESS-SOURCES)
 
 TABLE-SOURCES=table.scm ansi.import.scm testing.import.scm	\
 	 util-string.import.scm util-list.import.scm		\
-	 util-kwargs.import.scm
+	 racket-kwargs.import.scm
 
 table.o: table.import.scm
 table.import.scm: $(TABLE-SOURCES)
@@ -391,13 +391,12 @@ 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)
-
 UTIL-DICT-BST-SOURCES=util-dict-bst.scm util-tag.import.scm	\
 	testing.import.scm
 
 util-dict-bst.o: util-dict-bst.import.scm
 util-dict-bst.import.scm: $(UTIL-DICT-BST-SOURCES)
+
+RACKET-KWARGS-SOURCES=racket-kwargs.scm
+
+racket-kwargs.import.scm: $(RACKET-KWARGS-SOURCES)

src/listing.scm

@@ -39,7 +39,7 @@
 	 (chicken format)
 	 testing
 	 ansi
-	 util-kwargs
+	 racket-kwargs
 	 util-dict-list
 	 table)
 
@@ -127,21 +127,21 @@
 
  ;; Prints and highlights a selection of source listing lines and
  ;; their optional context.
- (define-kwproc (print-source-listing
+ (define* (print-source-listing
-		 lines
+	   lines
-		 highlights
+	   highlights
-		 (#:highlight-rules highlight-rules
+	   #:highlight-rules (highlight-rules
-				    `((error ,(ansi #:bold #:red) ,(ansi #:default))
+			      `((error ,(ansi #:bold #:red) ,(ansi #:default))
-				      (warning ,(ansi #:yellow) ,(ansi #:default))
+				(warning ,(ansi #:yellow) ,(ansi #:default))
-				      (info ,(ansi #:cyan) ,(ansi #:default))
+				(info ,(ansi #:cyan) ,(ansi #:default))
-				      ))
+				))
-		 (#:ellipsis ellipsis "...")
+	   #:ellipsis (ellipsis "...")
-		 (#:context-pre ctx-pre "")
+	   #:context-pre (ctx-pre "")
-		 (#:context-post ctx-post "")
+	   #:context-post (ctx-post "")
-		 (#:highlight-pre hl-pre a:error)
+	   #:highlight-pre (hl-pre a:error)
-		 (#:highlight-post hl-post a:default)
+	   #:highlight-post (hl-post a:default)
-		 (#:context context 3)
+	   #:context (context 3)
-		 (#:keys keys '(number line comment)))
+	   #:keys (keys '(number line comment)))
    (let loop ((lines lines)
 	      (number 1)
 	      (printed-something #f)

src/mbase.scm

@@ -77,7 +77,7 @@
 	 progress
 	 mbase-dir
 	 util-tag
-	 util-kwargs
+	 racket-kwargs
 	 util-dict-bst)
 
  ;; Constant unique tag
@@ -256,9 +256,9 @@
 
  ;; Returns the list of emails of all active members sorted
  ;; alphabetically
- (define-kwproc (mbase-active-emails mb
+ (define* (mbase-active-emails mb
-				     (#:active active #t)
+			       #:active (active #t)
-				     (#:suspended suspended #f))
+			       #:suspended (suspended #f))
    (sort
     (filter
      string?

src/racket-kwargs.scm

@@ -0,0 +1,362 @@
+;;
+;; racket-kwargs.scm
+;;
+;; CHICKEN Scheme version of Racket define/lambda for procedures with
+;; mandatory and optional keyword arguments as well as positional and
+;; optional arguments anywhere in the argument list. The only
+;; limiation being that mandatory positional argument must not be
+;; specified after any optional positional argument.
+;;
+;; 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 racket-kwargs))
+
+(module
+ racket-kwargs
+ (
+  lambda*
+  define*
+  )
+
+ (import scheme
+	 (chicken base)
+	 (chicken keyword)
+	 (chicken syntax)
+	 (chicken format))
+
+ (begin-for-syntax
+  (import (chicken keyword)))
+
+ ;; Splits arguments into two lists: the kw-args and non-kw-args. This
+ ;; procedure is used during run-time to parse the procedure arguments
+ ;; and supply values to the argument bindings. The keyword arguments
+ ;; are returned in reverse order, the positional arguments are
+ ;; returned in the same order as given.
+ (define-syntax split-kwargs
+   (syntax-rules ()
+     ((_ name 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 'name
+			   "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))))))))
+
+ ;; Conditional expansion if given term is an identifier - taken from
+ ;; SRFI-57 sample implementation:
+ ;; https://srfi.schemers.org/srfi-57/srfi-57-1.2.html
+ (define-syntax if-id?
+   (syntax-rules ()
+     ((_ (x . y)  sk fk) fk)
+     ((_ #(x ...) sk fk) fk)
+     ((_ x sk fk)
+      (let-syntax ((test (syntax-rules ()
+                           ((test x sk* fk*)     sk*)
+                           ((test non-x sk* fk*) fk*))))
+	(test foo sk fk)))))
+
+ ;; Conditional expansion for quoted symbols.
+ (define-syntax if-symbol?
+   (syntax-rules (quote)
+     ((_ (quote (x . y)) sk fk) fk)
+     ((_ (quote x) sk fk)
+      (let-syntax ((test (syntax-rules ()
+                           ((test x sk* fk*)     sk*)
+                           ((test non-x sk* fk*) fk*))))
+	(test x sk fk)))
+     ((_ x sk fk) fk)))
+
+ ;; Conditional expansion if keyword is given.
+ (define-syntax if-keyword?
+  (ir-macro-transformer
+   (lambda (e i c)
+     (if (keyword? (cadr e))
+	 (caddr e)
+	 (cadddr e)))))
+
+ ;; Conditional expansion for list expressions
+ (define-syntax if-list?
+   (syntax-rules ()
+     ((_ (w x ...) t f)
+      (if-symbol? (w x ...) f t))
+     ((_ x t f) f)))
+
+ ;; Expansion-time conditional expansion based on boolean constant.
+ (define-syntax if-true?
+   (syntax-rules ()
+     ((_ #f t f) f)
+     ((_ #t t f) t)))
+
+ ;; Allows extracting file:line information from within syntax-rules
+ ;; templates.
+ (define-syntax expansion-line
+   (er-macro-transformer
+    (lambda (e i c)
+      (get-line-number e))))
+
+ ;; Creates one binding without default value from non-kw-args list
+ ;; and resumes argument processing.
+ (define-syntax let-id-arg*
+   (syntax-rules ()
+     ((_ name
+	 seen-opt?
+	 (kws nkws)
+	 (id . rest)
+	 all-kws
+	 body ...)
+      (if-true? seen-opt?
+		(begin-for-syntax
+		 (syntax-error
+		  (let ((el (expansion-line id)))
+		    (format "~A~A~A - positional argument after optional: ~A"
+			    (or el "")
+			    (if el " " "")
+			    'name 'id))))
+		(if (null? nkws)
+		    (error "not enough arguments given" 'name)
+		    (let ((id (car nkws)))
+		      (let-args** name
+				  seen-opt?
+				  (kws (cdr nkws))
+				  rest
+				  all-kws
+				  body ...)))))))
+
+ ;; Creates one binding with default value.
+ (define-syntax let-idd-arg*
+   (syntax-rules ()
+     ((_ name
+	 seen-opt?
+	 (kws nkws)
+	 ((id def) . rest)
+	 all-kws
+	 body ...)
+      (let ((id (if (null? nkws)
+		    def
+		    (car nkws))))
+	(let-args** name
+		    #t
+		    (kws (if (null? nkws)
+			     nkws
+			     (cdr nkws)))
+		    rest
+		    all-kws
+		    body ...)))))
+
+ ;; Create bindings for mandatory and optional keyword arguments.
+ (define-syntax let-kw-arg*
+   (syntax-rules ()
+     ((_ name
+	 seen-opt?
+	 (kws nkws)
+	 (kw (id def) . rest)
+	 (all-kws ...)
+	 body ...)
+      (let ((id (get-keyword kw kws (lambda () def))))
+	(let-args** name
+		    seen-opt?
+		    (kws nkws)
+		    rest
+		    (kw all-kws ...)
+		    body ...)))
+     ((_ name
+	 seen-opt?
+	 (kws nkws)
+	 (kw (id . restd) . rest)
+	 (all-kws ...)
+	 body ...)
+      (begin-for-syntax
+       (syntax-error
+	(let ((el (expansion-line name)))
+	  (format "~A~A~A - wrong keyword argument syntax: ~A ~A"
+		  (or el "")
+		  (if el " " "")
+		  'name kw '(id . restd))))))
+     ((_ name
+	 seen-opt?
+	 (kws nkws)
+	 (kw id . rest)
+	 (all-kws ...)
+	 body ...)
+      (let ((id (get-keyword kw kws (lambda ()
+				      (error 'name "missing kw argument"
+					     kw)))))
+	(let-args** name
+		    seen-opt?
+		    (kws nkws)
+		    rest
+		    (kw all-kws ...)
+		    body ...)))
+     ((_ name
+	 seen-opt?
+	 (kws nkws)
+	 (kw)
+	 (all-kws ...)
+	 body ...)
+      (begin-for-syntax
+       (syntax-error
+	(let ((el (expansion-line name)))
+	  (format "~A~A~A - missing keyword argument syntax: ~A"
+		  (or el "")
+		  (if el " " "")
+		  'name kw)))))))
+
+ ;; Checks whether only defined keywords are used.
+ (define-syntax check-kws
+   (syntax-rules ()
+     ((_ name (all-kws ...) kw-args)
+      (let ((kws-list (list all-kws ...)))
+	(let loop ((kws (let kloop ((kw-args kw-args)
+				    (res '()))
+			  (if (null? kw-args)
+			      res
+			      (kloop (cddr kw-args)
+				     (cons (car kw-args) res))))))
+	  (when (not (null? kws))
+	    (if (not (memq (car kws) kws-list))
+		(error 'name "unknown keyword argument" (car kws))
+		(loop (cdr kws)))))))))
+
+ ;; Converts argument specifications into set of nested let bindings.
+ (define-syntax let-args**
+   (syntax-rules ()
+     ;; End, without rest
+     ((_ name
+	 seen-opt?
+	 (kw-args non-kw-args)
+	 ()
+	 all-kws
+	 body ...)
+      (if (null? non-kw-args)
+	  (let ()
+	    (check-kws name all-kws kw-args)
+	    body ...)
+	  (error 'name "too many arguments" non-kw-args)))
+     ;; Dispatch to appropriate sub-syntax
+     ((_ name
+	 seen-opt?
+	 (kw-args non-kw-args)
+	 (expr . rest)
+	 all-kws
+	 body ...)
+      (if-list? expr
+		(let-idd-arg* name
+			      seen-opt?
+			      (kw-args non-kw-args)
+			      (expr . rest)
+			      all-kws
+			      body ...)
+		(if-id? expr
+			(let-id-arg* name
+				     seen-opt?
+				     (kw-args non-kw-args)
+				     (expr . rest)
+				     all-kws
+				     body ...)
+			(if-keyword? expr
+				     (let-kw-arg* name
+						  seen-opt?
+						  (kw-args non-kw-args)
+						  (expr . rest)
+						  all-kws
+						  body ...)
+				     (begin-for-syntax
+				      (syntax-error
+				       (let ((el (expansion-line name)))
+					 (format
+					  "~A~A~A - keyword, identifier or list required: ~A~A"
+					  (or el "")
+					  (if el " " "")
+					  'name
+					  (if-symbol? expr
+						      "'"
+						      "")
+					  expr))))))))
+     ;; End of the argspec with rest binding
+     ((_ name
+	 seen-opt?
+	 (kw-args non-kw-args)
+	 rest
+	 all-kws
+	 body ...)
+      (let ((rest non-kw-args))
+	(check-kws name all-kws kw-args)
+	body ...))))
+
+ ;; The outermost expression of the lambda* syntax that uses split
+ ;; keyword/non-keyword argument lists as source for keyword argument
+ ;; values lookup and positional arguments consumption.
+ (define-syntax let-args*
+   (syntax-rules ()
+     ((_ name
+	 (argspecs args)
+	 body ...)
+      (let-values (((kw-args non-kw-args) (split-kwargs name args)))
+	(let-args** name
+		    #f
+		    (kw-args non-kw-args)
+		    argspecs
+		    ()
+		    body ...)))))
+
+ ;; Named lambda-like syntax that creates a procedure that handles
+ ;; positional and keyword arguments separately, creating the
+ ;; procedure in a way that introduces appropriate bindings for the
+ ;; body ... expressions.
+ (define-syntax lambda**
+   (syntax-rules ()
+     ((_ (name . argspecs) body ...)
+      (lambda args
+	(let-args* name
+		   (argspecs args)
+		   body ...)))))
+
+ ;; This is a wrapper around lambda** that omits
+ ;; actual name for error reporting.
+ (define-syntax lambda*
+   (syntax-rules ()
+     ((_ argspecs body ...)
+      (lambda** (lambda* . argspecs) body ...))))
+
+ ;; Simple wrapper that behaves like define syntax but for lambda form
+ ;; it uses lambda* syntax.
+ (define-syntax define*
+   (syntax-rules ()
+     ((_ (name . argspecs) body ...)
+      (define name
+	(lambda** (name . argspecs)
+		  body ...)))
+     ((_ i v)
+      (define i v))))
+
+ )

src/table.scm

@@ -44,7 +44,7 @@
 	 testing
 	 util-list
 	 util-string
-	 util-kwargs)
+	 racket-kwargs)
 
  ;; Default table border style to use if not explicitly specified.
  (define *table-border-style* (make-parameter 'unicode))
@@ -273,14 +273,14 @@
 			(if tb (sref 3) "")))
 
  ;; Converts given table to a list of strings suitable for printing.
- (define-kwproc (table->list tbl
+ (define* (table->list tbl
-			     (#:table-border table-border)
+		       #:table-border (table-border #f)
-			     (#:row-border row-border)
+		       #:row-border (row-border #f)
-			     (#:col-border column-border)
+		       #:col-border (column-border #f)
-			     (#:row0-border row0-border)
+		       #:row0-border (row0-border #f)
-			     (#:col0-border col0-border)
+		       #:col0-border (col0-border #f)
-			     (#:border-style border-style (*table-border-style*))
+		       #:border-style (border-style (*table-border-style*))
-			     (#:ansi ansi?))
+		       #:ansi (ansi? #f))
    (let ((table (table-prepare tbl)))
      (if (or (null? tbl)
 	     (null? (car tbl)))