diff --git a/main.rkt b/main.rkt index 402f5c2..5aa415a 100644 --- a/main.rkt +++ b/main.rkt @@ -5,7 +5,8 @@ "private/no-order.rkt" "private/post.rkt" "private/global.rkt" - "private/optional.rkt") + "private/optional.rkt" + (for-template "private/define-syntax+simple-api.rkt")) (provide #;define-splicing-syntax-class-with-eh-mixins #;define-syntax-class-with-eh-mixins @@ -22,5 +23,6 @@ ~global-counter aggregate-global-or aggregate-global-and - aggregate-global-counter) - + aggregate-global-counter + (for-template define-syntax/parse+simple) + define/syntax-parse+simple) diff --git a/private/define-syntax+simple-api.rkt b/private/define-syntax+simple-api.rkt new file mode 100644 index 0000000..eb1cc03 --- /dev/null +++ b/private/define-syntax+simple-api.rkt @@ -0,0 +1,67 @@ +#lang racket/base + +(provide define-syntax/parse+simple + (for-syntax define/syntax-parse+simple)) + +(require phc-toolkit/untyped + syntax/parse/define + (for-syntax racket/base + syntax/parse + racket/stxparam + racket/syntax) + (for-meta 2 + racket/base + syntax/parse + racket/syntax + phc-toolkit/untyped + (prefix-in syntax/parse: syntax/parse/private/residual-ct))) + +(define-simple-macro (define-syntax/parse+simple [name stxclass] . 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 name-forward (make-rename-transformer #'tmp-forward))) + (define-syntax name tmp))) + +(begin-for-syntax + (define-syntax define/syntax-parse+simple + (syntax-parser + [(_ [name (~var cls (static syntax/parse:stxclass? "a syntax class"))] + . body) + #:with colon-stxclass (format-id #'cls ":~a" #'cls) + #:with name-forward (format-id #'name "~a-forward-attributes" #'name) + (with-disappeared-uses + (define c (syntax-local-value/record #'cls syntax/parse:stxclass?)) + (define attrs (syntax/parse:stxclass-attrs c)) + (define/with-syntax (attr-name …) (map syntax/parse:attr-name attrs)) + (define/with-syntax (attr-name/ctx …) + (stx-map (λ (a) (datum->syntax #'body (syntax-e a))) + #'(attr-name …))) + (define-temp-ids "~a/arg" (attr-name …)) + (define/with-syntax (attr-depth …) (map syntax/parse:attr-depth attrs)) + #'(begin + (define (name stx2) + (syntax-parameterize ([stx (make-rename-transformer #'stx2)]) + (syntax-parse stx2 + [(name colon-stxclass) . body]))) + (define (private-simple-api stx/arg attr-name/arg …) + (syntax-parameterize ([stx (make-rename-transformer #'stx/arg)]) + (syntax-parse #'nothing + [(~bind [(attr-name/ctx attr-depth) attr-name/arg] …) + . body]))) + (define-syntax (name-forward stx3) + (syntax-case stx3 () + [(_) + #`(private-simple-api + stx + (attribute #,(datum->syntax stx3 'attr-name)) + …)] + [(_ forward-args-prefix) + #`(private-simple-api + stx + (attribute #,(format-id stx3 "~a.~a" + #'forward-args-prefix + 'attr-name)) + …)]))))]))) \ No newline at end of file diff --git a/test/test-extend-structure-options.rkt b/test/test-extend-structure-options.rkt new file mode 100644 index 0000000..a0c2bd7 --- /dev/null +++ b/test/test-extend-structure-options.rkt @@ -0,0 +1,25 @@ +#lang racket + +(require rackunit + phc-toolkit/untyped + (for-syntax extensible-parser-specifications + "test-structure-options.rkt" + syntax/parse)) + +(define-syntax/parse+simple [foo structure-kws] + #''(field ...)) + +(check-equal? (foo [f tf] [g tg]) + '(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 ...) + #,(foo-forward-attributes)]) + +(check-equal? (bar #:xyz zyx [f tf] [g tg]) + '((zyx f g) (quote (f g)))) diff --git a/test/test-structure-options.rkt b/test/test-structure-options.rkt index cf0e8fc..ded4e36 100644 --- a/test/test-structure-options.rkt +++ b/test/test-structure-options.rkt @@ -14,7 +14,8 @@ (provide structure-kw-instance-or-builder-mixin structure-kw-predicate-mixin structure-kw-fields-mixin - structure-kw-all-mixin) + structure-kw-all-mixin + structure-kws) (define-eh-alternative-mixin structure-kw-instance-or-builder-mixin (pattern