From c9c12e0e396475533ef987e3969b2ec847a8af9f Mon Sep 17 00:00:00 2001
From: Arun Isaac
Date: Tue, 27 Jul 2021 15:27:25 +0530
Subject: ccwl: Make syntax-lambda** more like lambda**.

I have tripped up several times on the differences between lambda**
and syntax-lambda**. No longer! Making syntax-lambda** as close as
possible to lambda** makes the code much more readable and align
better with common sense.

* ccwl/utils.scm (syntax-lambda**): Do not ignore the first
identifier. Accept multiple values as arguments, not a single syntax
object.
* ccwl/ccwl.scm (command): Update use of syntax-lambda**.
* tests/utils.scm ("syntax-lambda**", "syntax-lambda** with default
values"): Update tests.
---
 ccwl/ccwl.scm   | 130 ++++++++++++++++++++++++++++----------------------------
 ccwl/utils.scm  |  18 +++-----
 tests/utils.scm |   7 ++-
 3 files changed, 77 insertions(+), 78 deletions(-)

diff --git a/ccwl/ccwl.scm b/ccwl/ccwl.scm
index 37f8177..09c590c 100644
--- a/ccwl/ccwl.scm
+++ b/ccwl/ccwl.scm
@@ -101,73 +101,75 @@ association list."
 ;; TODO: Add fine-grained syntax checking.
 (define-syntax command
   (lambda (x)
-    ((syntax-lambda** (#:key stdin #:key* inputs outputs run other)
-       (let ((inputs
-              ;; Canonicalize inputs.
-              (map (lambda (x)
-                     (syntax-case x ()
-                       ((id args ...) (identifier? #'id)
-                        #'(id args ...))
-                       (id (identifier? #'id) #'(id))
-                       (_ (error "Invalid input:" (syntax->datum x)))))
-                   inputs)))
-         (unless run
-           (error "#:run key required in command definition" (syntax->datum x)))
-         #`(make-command
-            (list #,@(map (lambda (x)
-                            (syntax-case x ()
-                              ((id args ...)
-                               ;; Instantiate <input> object with
-                               ;; position and prefix.
-                               #`(input 'id
-                                        #:position #,(list-index (lambda (x)
+    (syntax-case x ()
+      ((_ args ...)
+       (apply (syntax-lambda** (#:key stdin #:key* inputs outputs run other)
+                (let ((inputs
+                       ;; Canonicalize inputs.
+                       (map (lambda (x)
+                              (syntax-case x ()
+                                ((id args ...) (identifier? #'id)
+                                 #'(id args ...))
+                                (id (identifier? #'id) #'(id))
+                                (_ (error "Invalid input:" (syntax->datum x)))))
+                            inputs)))
+                  (unless run
+                    (error "#:run key required in command definition" (syntax->datum x)))
+                  #`(make-command
+                     (list #,@(map (lambda (x)
+                                     (syntax-case x ()
+                                       ((id args ...)
+                                        ;; Instantiate <input> object with
+                                        ;; position and prefix.
+                                        #`(input 'id
+                                                 #:position #,(list-index (lambda (x)
+                                                                            (syntax-case x ()
+                                                                              (input (identifier? #'input)
+                                                                               (eq? (syntax->datum #'id)
+                                                                                    (syntax->datum #'input)))
+                                                                              ((_ input)
+                                                                               (eq? (syntax->datum #'id)
+                                                                                    (syntax->datum #'input)))
+                                                                              (_ #f)))
+                                                                          run)
+                                                 #:prefix #,(any (lambda (x)
                                                                    (syntax-case x ()
-                                                                     (input (identifier? #'input)
-                                                                      (eq? (syntax->datum #'id)
-                                                                           (syntax->datum #'input)))
-                                                                     ((_ input)
-                                                                      (eq? (syntax->datum #'id)
-                                                                           (syntax->datum #'input)))
+                                                                     ((prefix input)
+                                                                      (and (eq? (syntax->datum #'id)
+                                                                                (syntax->datum #'input))
+                                                                           #'prefix))
                                                                      (_ #f)))
                                                                  run)
-                                        #:prefix #,(any (lambda (x)
-                                                          (syntax-case x ()
-                                                            ((prefix input)
-                                                             (and (eq? (syntax->datum #'id)
-                                                                       (syntax->datum #'input))
-                                                                  #'prefix))
-                                                            (_ #f)))
-                                                        run)
-                                        args ...))))
-                          inputs))
-            (list #,@(map (lambda (x)
-                            ;; Instantiate <output> object.
-                            (syntax-case x ()
-                              ((id args ...) (identifier? #'id)
-                               #'(output 'id args ...))
-                              (id (identifier? #'id) #'(output 'id))
-                              (_ (error "Invalid output:"
-                                        (syntax->datum x)))))
-                          outputs))
-            (list #,@(map (lambda (x)
-                            (syntax-case x ()
-                              ;; Replace input symbol with quoted symbol.
-                              (input (identifier? #'input)
-                               #''input)
-                              ;; Leave string as is.
-                              (string-arg (string? (syntax->datum #'string-arg))
-                               #'string-arg)
-                              ;; Replace prefixed input symbol with
-                              ;; quoted symbol.
-                              ((prefix input) (and (string? (syntax->datum #'prefix))
-                                                   (identifier? #'input))
-                               #''input)
-                              (_ (error "Invalid command element:"
-                                        (syntax->datum x)))))
-                          run))
-            #,(and stdin #`'#,stdin)
-            (list #,@other))))
-     x)))
+                                                 args ...))))
+                                   inputs))
+                     (list #,@(map (lambda (x)
+                                     ;; Instantiate <output> object.
+                                     (syntax-case x ()
+                                       ((id args ...) (identifier? #'id)
+                                        #'(output 'id args ...))
+                                       (id (identifier? #'id) #'(output 'id))
+                                       (_ (error "Invalid output:"
+                                                 (syntax->datum x)))))
+                                   outputs))
+                     (list #,@(map (lambda (x)
+                                     (syntax-case x ()
+                                       ;; Replace input symbol with quoted symbol.
+                                       (input (identifier? #'input)
+                                        #''input)
+                                       ;; Leave string as is.
+                                       (string-arg (string? (syntax->datum #'string-arg))
+                                        #'string-arg)
+                                       ;; Replace prefixed input symbol with
+                                       ;; quoted symbol.
+                                       ((prefix input) (and (string? (syntax->datum #'prefix))
+                                                            (identifier? #'input))
+                                        #''input)
+                                       (_ (error "Invalid command element:"
+                                                 (syntax->datum x)))))
+                                   run))
+                     #,(and stdin #`'#,stdin)
+                     (list #,@other))))
+              #'(args ...))))))
 
 (define (input=? input1 input2)
   (eq? (input-id input1)
diff --git a/ccwl/utils.scm b/ccwl/utils.scm
index 14a3c4d..d6ca964 100644
--- a/ccwl/utils.scm
+++ b/ccwl/utils.scm
@@ -176,29 +176,23 @@ while that for n-ary arguments is the empty list. For example,
                                                       unary-arguments))))))))))))
 
 (define-syntax-rule (syntax-lambda** formal-args body ...)
-  "Like lambda**, but for syntax objects. syntax-lambda** varies
-slightly from lambda** in that the first identifier (or argument)
-passed to the resulting function is ignored. This is useful for
-writing macros that accept keyword arguments. For example,
+  "Like lambda**, but for syntax objects. For example,
 
 ((syntax-lambda** (a b #:key foo #:key* bar)
    (list a b foo bar))
- #'(foo 1 2 #:foo 123 #:bar 1 2 3))
+ #'1 #'2 #'#:foo #'123 #'#:bar #'1 #'2 #'3)
 => (#'1 #'2 #'123 (#'1 #'2 #'3))
 
 Just like lambda**, syntax-lambda** also supports default values for
 arguments. For example,
 
 ((syntax-lambda** (foo aal #:key vale (pal 9) #:key* naal (irandu 7) (sol 3 2 1))
-             (list foo aal vale pal naal irandu sol))
- #'(bar 1 2 #:vale 123 #:naal 321 456))
+   (list foo aal vale pal naal irandu sol))
+ #'1 #'2 #'#:vale #'123 #'#:naal #'321 #'456)
 => (#'1 #'2 #'123 9 (#'321 #'456) (7) (3 2 1))"
-  (lambda (x)
+  (lambda args
     (apply (lambda** formal-args body ...)
-           (with-ellipsis :::
-             (syntax-case x ()
-               ((_ args :::)
-                (unsyntax-keywords #'(args :::))))))))
+           (unsyntax-keywords args))))
 
 (define (filter-mapi proc lst)
   "Indexed filter-map. Like filter-map, but PROC calls are (proc item
diff --git a/tests/utils.scm b/tests/utils.scm
index bc9315d..be0e87f 100644
--- a/tests/utils.scm
+++ b/tests/utils.scm
@@ -84,13 +84,16 @@
   (equal? (list #'1 #'2 #'123 (list #'1 #'2 #'3))
           ((syntax-lambda** (a b #:key foo #:key* bar)
              (list a b foo bar))
-           #'(foo 1 2 #:foo 123 #:bar 1 2 3))))
+           #'1 #'2 #'#:foo #'123 #'#:bar #'1 #'2 #'3)))
 
+((syntax-lambda** (a b #:key foo #:key* bar)
+             (list a b foo bar))
+           #'1 #'2 #'#:foo #'123 #'#:bar #'1 #'2 #'3)
 (test-assert "syntax-lambda** with default values"
   (equal? (list #'1 #'2 #'123 9 #'(321 456) '(7) '(3 2 1))
           ((syntax-lambda** (foo aal #:key vale (pal 9) #:key* naal (irandu 7) (sol 3 2 1))
              (list foo aal vale pal naal irandu sol))
-           #'(bar 1 2 #:vale 123 #:naal 321 456))))
+           #'1 #'2 #'#:vale #'123 #'#:naal #'321 #'456)))
 
 (test-equal "filter-mapi"
   '(1 3 5 7 9)
-- 
cgit v1.2.3