www

commit c45b0c3c3a9db9f372ee546547739ade2ee1348a
parent 4df442f59f12ca7bbb97cbfad22e3635f8dd9e59
Author: Georges Dupéron <georges.duperon@gmail.com>
Date:   Wed, 24 Aug 2016 13:37:22 +0200

Remove the extra use-site scope on the body of define-?-expander.

Diffstat:
M
private/define-expanders.rkt
 | 
17
++++++++++++++---
A
test/test-define-x-expander-use-site-scope.rkt
 | 
74
++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++

2 files changed, 88 insertions(+), 3 deletions(-)
diff --git 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
@@ -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