diff --git a/doc/utils.md b/doc/utils.md index 1a41f52..7f5127a 100644 --- a/doc/utils.md +++ b/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) diff --git a/src/Makefile b/src/Makefile index 2d9ba05..ce31881 100644 --- a/src/Makefile +++ b/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) diff --git a/src/listing.scm b/src/listing.scm index a6dfcba..c98e9d4 100644 --- a/src/listing.scm +++ b/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 - lines - highlights - (#:highlight-rules highlight-rules - `((error ,(ansi #:bold #:red) ,(ansi #:default)) - (warning ,(ansi #:yellow) ,(ansi #:default)) - (info ,(ansi #:cyan) ,(ansi #:default)) - )) - (#:ellipsis ellipsis "...") - (#:context-pre ctx-pre "") - (#:context-post ctx-post "") - (#:highlight-pre hl-pre a:error) - (#:highlight-post hl-post a:default) - (#:context context 3) - (#:keys keys '(number line comment))) + (define* (print-source-listing + lines + highlights + #:highlight-rules (highlight-rules + `((error ,(ansi #:bold #:red) ,(ansi #:default)) + (warning ,(ansi #:yellow) ,(ansi #:default)) + (info ,(ansi #:cyan) ,(ansi #:default)) + )) + #:ellipsis (ellipsis "...") + #:context-pre (ctx-pre "") + #:context-post (ctx-post "") + #:highlight-pre (hl-pre a:error) + #:highlight-post (hl-post a:default) + #:context (context 3) + #:keys (keys '(number line comment))) (let loop ((lines lines) (number 1) (printed-something #f) diff --git a/src/mbase.scm b/src/mbase.scm index a834820..bc01bc5 100644 --- a/src/mbase.scm +++ b/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 - (#:active active #t) - (#:suspended suspended #f)) + (define* (mbase-active-emails mb + #:active (active #t) + #:suspended (suspended #f)) (sort (filter string? diff --git a/src/racket-kwargs.scm b/src/racket-kwargs.scm new file mode 100644 index 0000000..36e3ef4 --- /dev/null +++ b/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 +;; +;; 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)))) + + ) diff --git a/src/table.scm b/src/table.scm index 8d01a90..c9e3b28 100644 --- a/src/table.scm +++ b/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 - (#:table-border table-border) - (#:row-border row-border) - (#:col-border column-border) - (#:row0-border row0-border) - (#:col0-border col0-border) - (#:border-style border-style (*table-border-style*)) - (#:ansi ansi?)) + (define* (table->list tbl + #:table-border (table-border #f) + #:row-border (row-border #f) + #:col-border (column-border #f) + #:row0-border (row0-border #f) + #:col0-border (col0-border #f) + #:border-style (border-style (*table-border-style*)) + #:ansi (ansi? #f)) (let ((table (table-prepare tbl))) (if (or (null? tbl) (null? (car tbl)))