brmlab/hackerbase
4
0
Fork 0
Code Issues Pull requests Projects Releases Packages Wiki Activity

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

Browse source
This commit is contained in:
Dominik Pantůček 2023-05-25 14:43:01 +02:00
parent d24526b765
commit 963d3069e9
6 changed files with 399 additions and 52 deletions
Download patch file Download diff file Expand all files Collapse all files

14
doc/utils.md
View file

@ -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)

17
src/Makefile
View file

@ -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)

32
src/listing.scm
View file

@ -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)

8
src/mbase.scm
View file

@ -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?

362
src/racket-kwargs.scm Normal file
View file

@ -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))))
)

18
src/table.scm
View file

@ -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)))