diff --git a/private/define-syntax+simple-api.rkt b/private/define-syntax+simple-api.rkt index 8fc6433..c4f9d8e 100644 --- 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 index a0c2bd7..896afdd 100644 --- 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))))