suzanne.soy/racket
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

syntax/parse: allow pattern expanders to produce EH patterns

Browse Source 
fixes #1427
This commit is contained in:
Ryan Culpepper 2016-08-22 19:47:41 -04:00
parent a5f0e6dcfc
commit 471f37158a
2 changed files with 44 additions and 17 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

17
pkgs/racket-test/tests/stxparse/test.rkt
View File

@ -4,7 +4,7 @@
syntax/parse/debug
syntax/parse/define
"setup.rkt"
(for-syntax syntax/parse))
(for-syntax syntax/parse racket/syntax))
;; Main syntax class and pattern tests
@ -620,6 +620,21 @@
(+ x y z))))
))
(test-case "eh pattern-expander"
(define-syntax ~oncekw
(pattern-expander
(λ (stx)
(syntax-case stx ()
[(_ kw pat ...)
(keyword? (syntax-e #'kw))
(with-syntax ([name (format-id #'kw "~a-kw" (keyword->string (syntax-e #'kw)))])
#'(~once (~seq (~and kw name) pat ...)
#:name (format "the ~a keyword" 'kw)))]))))
(check-equal? (syntax-parse #'(m #:a #:b 1 #:a)
[(_ (~or #:a (~oncekw #:b b)) ...)
(syntax->datum #'(b-kw b))])
'(#:b 1)))
(test-case "this-syntax"
(let ()
(define-syntax-class identity

44
racket/collects/syntax/parse/private/rep.rkt
View File

@ -459,26 +459,14 @@
(and (identifier? #'id)
(not-shadowed? #'id)
(pattern-expander? (syntax-local-value #'id (λ () #f))))
(let* ([proc (pattern-expander-proc (syntax-local-value #'id))]
[introducer (make-syntax-introducer)]
[mstx (introducer (syntax-local-introduce stx))]
[mresult (parameterize ([current-syntax-parse-pattern-introducer introducer])
(proc mstx))]
[result (syntax-local-introduce (introducer mresult))])
(disappeared! #'id)
(recur result))]
(begin (disappeared! #'id)
(recur (expand-pattern (syntax-local-value #'id) stx)))]
[(id . rst)
(and (identifier? #'id)
(not-shadowed? #'id)
(pattern-expander? (syntax-local-value #'id (λ () #f))))
(let* ([proc (pattern-expander-proc (syntax-local-value #'id))]
[introducer (make-syntax-introducer)]
[mstx (introducer (syntax-local-introduce stx))]
[mresult (parameterize ([current-syntax-parse-pattern-introducer introducer])
(proc mstx))]
[result (syntax-local-introduce (introducer mresult))])
(disappeared! #'id)
(recur result))]
(begin (disappeared! #'id)
(recur (expand-pattern (syntax-local-value #'id) stx)))]
[wildcard
(and (wildcard? #'wildcard)
(not-shadowed? #'wildcard))
@ -608,6 +596,16 @@
(let ([lp (parse-single-pattern (datum->syntax #f contents #'s) decls)])
(pat:pstruct key lp)))])))
;; expand-pattern : pattern-expander Syntax -> Syntax
(define (expand-pattern pe stx)
(let* ([proc (pattern-expander-proc pe)]
[introducer (make-syntax-introducer)]
[mstx (introducer (syntax-local-introduce stx))]
[mresult (parameterize ([current-syntax-parse-pattern-introducer introducer])
(proc mstx))]
[result (syntax-local-introduce (introducer mresult))])
result))
;; parse-ellipsis-head-pattern : stx DeclEnv -> (listof EllipsisHeadPattern)
(define (parse-ellipsis-head-pattern stx decls)
(for/list ([ehpat+hstx (in-list (parse*-ellipsis-head-pattern stx decls #t))])
@ -617,8 +615,22 @@
;; -> (listof (list EllipsisHeadPattern stx/eh-alternative))
(define (parse*-ellipsis-head-pattern stx decls allow-or?
#:context [ctx (current-syntax-context)])
(define (recur stx) (parse*-ellipsis-head-pattern stx decls allow-or? #:context ctx))
(define not-shadowed? (make-not-shadowed? decls))
(syntax-case* stx (~eh-var ~or ~between ~optional ~once)
(make-not-shadowed-id=? decls)
[id
(and (identifier? #'id)
(not-shadowed? #'id)
(pattern-expander? (syntax-local-value #'id (lambda () #f))))
(begin (disappeared! #'id)
(recur (expand-pattern (syntax-local-value #'id) stx)))]
[(id . rst)
(and (identifier? #'id)
(not-shadowed? #'id)
(pattern-expander? (syntax-local-value #'id (lambda () #f))))
(begin (disappeared! #'id)
(recur (expand-pattern (syntax-local-value #'id) stx)))]
[(~eh-var name eh-alt-set-id)
(disappeared! stx)
(let ()