www

commit a7dd0c07593eade7676dce7775b078c442fd02b0
parent 783641abd80f80bf6693243415066e31f5e22056
Author: Georges Dupéron <georges.duperon@gmail.com>
Date:   Tue, 30 Aug 2016 02:06:58 +0200

Allow a whole ~seq's contents in define-syntax/parse+simple and define/syntax-parse+simple, not just a single (splicing) syntax class.

Diffstat:
M
private/define-syntax+simple-api.rkt
 | 
24
++++++++++++++++++++----
M
test/test-extend-structure-options.rkt
 | 
17
+++++++++--------

2 files changed, 29 insertions(+), 12 deletions(-)
diff --git a/private/define-syntax+simple-api.rkt b/private/define-syntax+simple-api.rkt
@@ -16,17 +16,33 @@
                    phc-toolkit/untyped
                    (prefix-in syntax/parse: syntax/parse/private/residual-ct)))
 
-(define-simple-macro (define-syntax/parse+simple [name stxclass] . body)
+(define-simple-macro (define-syntax/parse+simple [name . args] . body)
   #:with name-forward (format-id #'name "~a-forward-attributes" #'name)
   #:with tmp-forward (format-id #'tmp "~a-forward-attributes" #'tmp)
   (begin
     (begin-for-syntax
-      (define/syntax-parse+simple [tmp stxclass] . body)
+      (define/syntax-parse+simple [tmp . args] . body)
       (define-syntax name-forward (make-rename-transformer #'tmp-forward)))
     (define-syntax name tmp)))
 
 (begin-for-syntax
-  (define-syntax define/syntax-parse+simple
+  (define-syntax (define/syntax-parse+simple stx)
+    (syntax-case stx ()
+      [(_ [name . args] . body)
+       (let ()
+         (define introducer (make-syntax-introducer))
+         (define/with-syntax args-stxclass
+           (introducer (datum->syntax #'args 'args-stxclass) 'add))
+         (define/with-syntax body-introduced
+           (introducer #'body 'add))
+         #'(begin
+             (define-syntax-class args-stxclass
+               #:auto-nested-attributes
+               (pattern args))
+             (define/syntax-parse+simple/stxclass [name args-stxclass]
+               . body-introduced)))]))
+  
+  (define-syntax define/syntax-parse+simple/stxclass
     (syntax-parser
       [(_ [name (~var cls (static syntax/parse:stxclass? "a syntax class"))]
           . body)
@@ -47,7 +63,7 @@
               (define (name stx2)
                 (syntax-parameterize ([stx (make-rename-transformer #'stx2)])
                   (syntax-parse stx2
-                    [(name colon-stxclass) . body])))
+                    [(name . colon-stxclass) . body])))
               (define (private-simple-api stx/arg attr-name/arg …)
                 (syntax-parameterize ([stx (make-rename-transformer #'stx/arg)])
                   (syntax-parse #'nothing
diff --git a/test/test-extend-structure-options.rkt b/test/test-extend-structure-options.rkt
@@ -6,20 +6,21 @@
                      "test-structure-options.rkt"
                      syntax/parse))
 
-(define-syntax/parse+simple [foo structure-kws]
-  #''(field ...))
+(define-syntax/parse+simple [foo foo-a :structure-kws]
+  #''(foo-a field ...))
 
-(check-equal? (foo [f tf] [g tg])
-              '(f g))
+(check-equal? (foo #:first-case  [f tf] [g tg])
+              '(#:first-case f g))
 
 (begin-for-syntax
   (define-splicing-syntax-class structure-xyz-kws
     (pattern {~seq-no-order {~optional {~seq #:xyz xyz:id}}
                             {structure-kw-all-mixin}})))
 
-(define-syntax/parse [bar :structure-xyz-kws]
-  #`'[(xyz field ...)
+(define-syntax/parse [bar foo-a :structure-xyz-kws]
+  #`'[(xyz foo-a field ...)
       #,(foo-forward-attributes)])
 
-(check-equal? (bar #:xyz zyx [f tf] [g tg])
-              '((zyx f g) (quote (f g))))
+(check-equal? (bar #:second-case #:xyz zyx [f tf] [g tg])
+              '((zyx #:second-case f g)
+                (quote (#:second-case f g))))