suzanne.soy/extensible-parser-specifications
1
0
Fork 0
Code Issues 2 Pull Requests Actions Packages Projects Releases Wiki Activity

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

Browse Source
This commit is contained in:
Georges Dupéron 2016-08-30 02:06:58 +02:00
parent 783641abd8
commit a7dd0c0759
2 changed files with 29 additions and 12 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

24
private/define-syntax+simple-api.rkt
View File

@ -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

17
test/test-extend-structure-options.rkt
View File

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