From: Eric Bavier <bav...@member.fsf.org>
* guix/utils.scm (substitute-keyword-arguments): Allow default value
declarations.
* tests/utils.scm (substitute-keyword-arguments): New test.
---
guix/utils.scm | 34 ++++++++++++++++++++--------------
tests/utils.scm | 20 ++++++++++++++++++++
2 files changed, 40 insertions(+), 14 deletions(-)
diff --git a/guix/utils.scm b/guix/utils.scm
index ded3114..1fd6725 100644
--- a/guix/utils.scm
+++ b/guix/utils.scm
@@ -376,21 +376,27 @@ keywords not already present in ARGS."
args))))
(define-syntax substitute-keyword-arguments
- (syntax-rules ()
+ (lambda (x)
"Return a new list of arguments where the value for keyword arg KW is
-replaced by EXP. EXP is evaluated in a context where VAR is boud to the
-previous value of the keyword argument."
- ((_ original-args ((kw var) exp) ...)
- (let loop ((args original-args)
- (before '()))
- (match args
- ((kw var rest (... ...))
- (loop rest (cons* exp kw before)))
- ...
- ((x rest (... ...))
- (loop rest (cons x before)))
- (()
- (reverse before)))))))
+replaced by EXP. EXP is evaluated in a context where VAR is bound to the
+previous value of the keyword argument, or DFLT if given."
+ (syntax-case x ()
+ ((_ original-args ((kw var dflt ...) exp) ...)
+ #`(let loop ((args (default-keyword-arguments
+ original-args
+ (list #,@(append-map (match-lambda
+ ((k) '())
+ (x x))
+ #'((kw dflt ...) ...)))))
+ (before '()))
+ (match args
+ ((kw var rest (... ...))
+ (loop rest (cons* exp kw before)))
+ ...
+ ((x rest (... ...))
+ (loop rest (cons x before)))
+ (()
+ (reverse before))))))))
(define (delkw kw lst)
"Remove KW and its associated value from LST, a keyword/value list such
diff --git a/tests/utils.scm b/tests/utils.scm
index 960928c..bcfaa14 100644
--- a/tests/utils.scm
+++ b/tests/utils.scm
@@ -123,6 +123,26 @@
(default-keyword-arguments '(#:bar 3) '(#:foo 2))
(default-keyword-arguments '(#:foo 2 #:bar 3) '(#:bar 6))))
+(test-equal "substitute-keyword-arguments"
+ '((#:foo 3)
+ (#:foo 3)
+ (#:foo 3 #:bar (1 2))
+ (#:bar (1 2) #:foo 3)
+ (#:foo 3))
+ (list (substitute-keyword-arguments '(#:foo 2)
+ ((#:foo f) (1+ f)))
+ (substitute-keyword-arguments '()
+ ((#:foo f 2) (1+ f)))
+ (substitute-keyword-arguments '(#:foo 2 #:bar (2))
+ ((#:foo f) (1+ f))
+ ((#:bar b) (cons 1 b)))
+ (substitute-keyword-arguments '(#:foo 2)
+ ((#:foo _) 3)
+ ((#:bar b '(2)) (cons 1 b)))
+ (substitute-keyword-arguments '(#:foo 2)
+ ((#:foo f 1) (1+ f))
+ ((#:bar b) (cons 42 b)))))
+
(test-assert "filtered-port, file"
(let* ((file (search-path %load-path "guix.scm"))
(input (open-file file "r0b")))
--
2.9.3
