Added tests for ~syntax-case, fixed stat-pattern in ~syntax-case: it should not escape the behaviour of _
This commit is contained in:
parent
8bf9e48c02
commit
30bf1aaa2d
|
@ -1,6 +1,6 @@
|
||||||
#lang racket/base
|
#lang racket/base
|
||||||
(provide ~syntax-case ~syntax-case-stat)
|
(provide ~syntax-case ~syntax-case-stat)
|
||||||
(require syntax/parse
|
(require stxparse-info/parse
|
||||||
(for-syntax racket/base))
|
(for-syntax racket/base))
|
||||||
(define-for-syntax (~syntax-case-impl not-stat? stx)
|
(define-for-syntax (~syntax-case-impl not-stat? stx)
|
||||||
(with-syntax ([(_ stx1) stx])
|
(with-syntax ([(_ stx1) stx])
|
||||||
|
@ -22,7 +22,7 @@
|
||||||
[()
|
[()
|
||||||
stx2]))
|
stx2]))
|
||||||
(syntax-case #'stx1 ()
|
(syntax-case #'stx1 ()
|
||||||
[underscore (and (id=? #'underscore #'_) not-stat?)
|
[underscore (id=? #'underscore #'_)
|
||||||
#'underscore]
|
#'underscore]
|
||||||
[id (identifier? #'id)
|
[id (identifier? #'id)
|
||||||
(ds `{,{ds2 '~var #'id} ,#'id})]
|
(ds `{,{ds2 '~var #'id} ,#'id})]
|
||||||
|
@ -49,17 +49,7 @@
|
||||||
[other
|
[other
|
||||||
(ds `{,(ds2 '~datum #'other) ,#'other})])))
|
(ds `{,(ds2 '~datum #'other) ,#'other})])))
|
||||||
|
|
||||||
#;(syntax-case (quote-syntax #s(a b c d)) ()
|
|
||||||
[#s(a ... bb) #'bb]
|
|
||||||
[(... #s(a ... b)) 'y])
|
|
||||||
|
|
||||||
(define-syntax ~syntax-case
|
(define-syntax ~syntax-case
|
||||||
(pattern-expander (λ (stx) (~syntax-case-impl #t stx))))
|
(pattern-expander (λ (stx) (~syntax-case-impl #t stx))))
|
||||||
(define-syntax ~syntax-case-stat
|
(define-syntax ~syntax-case-stat
|
||||||
(pattern-expander (λ (stx) (~syntax-case-impl #f stx))))
|
(pattern-expander (λ (stx) (~syntax-case-impl #f stx))))
|
||||||
|
|
||||||
#;(syntax-parse #'(1 2 3)
|
|
||||||
[{~syntax-case (~var ... ~and)}
|
|
||||||
(displayln (attribute ~var))
|
|
||||||
(displayln (attribute ~and))
|
|
||||||
])
|
|
18
test/test-syntax-case-as-syntax-parse.rkt
Normal file
18
test/test-syntax-case-as-syntax-parse.rkt
Normal file
|
@ -0,0 +1,18 @@
|
||||||
|
#lang racket/base
|
||||||
|
(require rackunit
|
||||||
|
subtemplate/private/syntax-case-as-syntax-parse
|
||||||
|
stxparse-info/parse)
|
||||||
|
(check-equal?
|
||||||
|
(syntax-parse #'(1 2 3)
|
||||||
|
[{~syntax-case (~var ... ~and)}
|
||||||
|
(list (map syntax->datum (attribute ~var))
|
||||||
|
(syntax->datum (attribute ~and)))
|
||||||
|
])
|
||||||
|
'((1 2) 3))
|
||||||
|
|
||||||
|
(check-equal?
|
||||||
|
(syntax-parse #'(1 2 3)
|
||||||
|
[{~syntax-case (... (_ _ _))}
|
||||||
|
;; underscores are not escaped by (... pat)
|
||||||
|
(syntax->datum #'_)])
|
||||||
|
'_)
|
Loading…
Reference in New Issue
Block a user