diff --git a/private/define-expanders.rkt b/private/define-expanders.rkt index 5277e6a..1a31f1c 100644 --- a/private/define-expanders.rkt +++ b/private/define-expanders.rkt @@ -7,6 +7,13 @@ (provide define-expander-type) +(define-for-syntax (remove-use-site-scope stx) + (define bd + (syntax-local-identifier-as-binding (syntax-local-introduce #'here))) + (define delta + (make-syntax-delta-introducer (syntax-local-introduce #'here) bd)) + (delta stx 'remove)) + (define-syntax define-expander-type (syntax-parser [(_ name:id) @@ -14,14 +21,18 @@ [make-?-expander "make-~a-expander"] [?-expander? "~a-expander?"] [define-?-expander "define-~a-expander"] + [define-?-expander-bug "define-~a-expander-bug"] [expand-all-?-expanders "expand-all-~a-expanders"]) - #'(begin + #`(begin (define-for-syntax ?-expander-type (make-expander-type)) (define-for-syntax (make-?-expander transformer) (expander ?-expander-type transformer)) (define-for-syntax (?-expander? v) (expander-of-type? ?-expander-type v)) - (define-syntax-rule (define-?-expander expander-name transformer) - (define-syntax expander-name (make-?-expander transformer))) + (define-syntax (define-?-expander stx) + (syntax-case stx () + [(_ expander-name transformer) + (remove-use-site-scope + #'(define-syntax expander-name (make-?-expander transformer)))])) (define-for-syntax (expand-all-?-expanders stx) (expand-syntax-tree-with-expanders-of-type ?-expander-type stx))))])) diff --git a/test/test-define-x-expander-use-site-scope.rkt b/test/test-define-x-expander-use-site-scope.rkt new file mode 100644 index 0000000..34a1646 --- /dev/null +++ b/test/test-define-x-expander-use-site-scope.rkt @@ -0,0 +1,73 @@ +#lang racket + +(require syntax/parse + syntax/parse/experimental/eh + generic-syntax-expanders + syntax/stx + (for-syntax syntax/parse + racket/syntax) + rackunit) + +(define-expander-type eh-mixin) + +(begin-for-syntax + (define eh-post-accumulate (make-parameter #f))) + +(define-for-syntax (strip-use-site stx) + (define bd + (syntax-local-identifier-as-binding (syntax-local-introduce #'here))) + (define delta + (make-syntax-delta-introducer (syntax-local-introduce #'here) bd)) + (delta stx 'remove)) + +(define-syntax define-eh-alternative-mixin + (syntax-parser + [(_ name ((~literal pattern) pat) ... (~optional (~seq #:post post))) + (let () + #`(define-eh-mixin-expander name + (λ (_) + #,@(if (attribute post) + #`(((eh-post-accumulate) (quote-syntax post))) + #'()) + (quote-syntax (~or . #,(strip-use-site #'(pat ...)))))))])) + +(define-syntax ~no-order + (pattern-expander + (λ (stx) + (syntax-case stx () + [(self pat ...) + (let () + (define acc '()) + (define (add-to-acc p) + (set! acc (cons p acc))) + (define alts + (parameterize ([eh-post-accumulate add-to-acc]) + (expand-all-eh-mixin-expanders + #'(pat ...)))) + #`(~and (~seq (~or . #,alts) (... ...)) + #,@acc))])))) + +;; Test: + +(define-eh-alternative-mixin aa + (pattern (~optional (~and some-pat #:some)))) + +(define-eh-alternative-mixin bb + (pattern (~optional (~and other-pat #:other))) + ;; Without the fix in PR #8, the following line gives the error + ;; attribute: not bound as a pattern variable in: some-pat + #:post (~fail #:when (and (attribute some-pat) + (attribute other-pat)))) + +(check-equal? (syntax-parse #'(#:some) + [((~no-order (aa) (bb))) 'ok]) + 'ok) + +(check-equal? (syntax-parse #'(#:other) + [((~no-order (aa) (bb))) 'ok]) + 'ok) + +(check-equal? (syntax-parse #'(#:some #:other) + [((~no-order (aa) (bb))) 'wrong] + [_ 'ok]) + 'ok) \ No newline at end of file