134 lines
3.4 KiB
Scheme
134 lines
3.4 KiB
Scheme
;;
|
|
;; 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 ...)))))
|
|
|
|
)
|