suzanne.soy/generic-syntax-expanders
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

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

Browse Source
This commit is contained in:
Georges Dupéron 2016-08-24 13:37:22 +02:00
parent 4df442f59f
commit c45b0c3c3a
2 changed files with 87 additions and 3 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

17
private/define-expanders.rkt
View File

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

73
test/test-define-x-expander-use-site-scope.rkt Normal file
View File

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