Patchwork [2/2] utils: Support defaults in substitute-keyword-arguments.

login
register
mail settings
Submitter Eric Bavier
Date Sept. 20, 2016, 9:29 p.m.
Message ID <20160920212916.18530-2-ericbavier@openmailbox.org>
Download mbox | patch
Permalink /patch/15820/
State New
Headers show

Comments

Eric Bavier - Sept. 20, 2016, 9:29 p.m.
From: Eric Bavier <bavier@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(-)
Ludovic Courtès - Sept. 24, 2016, 2:21 a.m.
Eric Bavier <ericbavier@openmailbox.org> skribis:

> From: Eric Bavier <bavier@member.fsf.org>
>
> * guix/utils.scm (substitute-keyword-arguments): Allow default value
> declarations.
> * tests/utils.scm (substitute-keyword-arguments): New test.

Good idea!


[...]

> +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 '()))

I would prefer to stick to ‘syntax-rules’ when matching the clauses,
with a helper macro:

  (define-syntax expand-default-args
    (syntax-rules ()
      ((_ original args ((kw var) expr) rest ...)
       ...)
      ((_ original args ((kw var default) expr) rest ...)
       ...)))

  …

    (syntax-rules ()
      ((_ original-args ((clause exp) ...)
       (let loop ((args (expand-default-args original-args clause ...)))
         …))))

But this would be a bonus; the patch LGTM.

Thanks!

Ludo’.

Patch

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