diff --git a/racket/typed/roles.rkt b/racket/typed/roles.rkt index 4a66bed..e598a6a 100644 --- a/racket/typed/roles.rkt +++ b/racket/typed/roles.rkt @@ -686,16 +686,16 @@ [(on (a/r:asserted-or-retracted p) s) ≫ [⊢ p ≫ p-- (⇒ : τp)] #:fail-unless (pure? #'p--) "pattern not allowed to have effects" - #:with p- (compile-syndicate-pattern #'p) #:with ([x:id τ:type] ...) (pat-bindings #'p) [[x ≫ x- : τ] ... ⊢ s ≫ s- (⇒ a (~effs)) (⇒ r (~effs)) (⇒ f (~effs τ-f ...)) (⇒ s (~effs τ-s ...))] + #:with p- (substs #'(x- ...) #'(x ...) (compile-syndicate-pattern #'p)) #:with τ-r #'(Reacts (a/r.react-con τp) τ-f ...) ----------------------------------- [⊢ (syndicate:on (a/r.syndicate-kw p-) - (let- ([x- x] ...) s-)) + s-) (⇒ : ★/t) (⇒ r (τ-r)) (⇒ f ()) @@ -720,22 +720,25 @@ #'()])) (define-for-syntax (compile-pattern pat bind-id-transformer exp-transformer) - (let loop ([pat pat]) - (syntax-parse pat - #:datum-literals (tuple discard bind) - [(tuple p ...) - #`(list 'tuple #,@(stx-map loop #'(p ...)))] - [(k:kons1 p) - #`(#,(kons1->constructor #'k) #,(loop #'p))] - [(bind x:id τ:type) - (bind-id-transformer #'x)] - [discard - #'_] - [(~constructor-exp ctor p ...) - (define/with-syntax uctor (untyped-ctor #'ctor)) - #`(uctor #,@(stx-map loop #'(p ...)))] - [_ - (exp-transformer pat)]))) + (define (l-e stx) (local-expand stx 'expression '())) + (let loop ([pat pat]) + (syntax-parse pat + #:datum-literals (tuple discard bind) + [(tuple p ...) + #`(list- 'tuple #,@(stx-map loop #'(p ...)))] + [(k:kons1 p) + #`(#,(kons1->constructor #'k) #,(loop #'p))] + [(bind x:id τ:type) + (bind-id-transformer #'x)] + [discard + #'_] + [(~constructor-exp ctor p ...) + (define/with-syntax uctor (untyped-ctor #'ctor)) + #`(uctor #,@(stx-map loop #'(p ...)))] + [_ + ;; local expanding "expression-y" syntax allows variable references to transform + ;; according to the mappings set up by turnstile. + (exp-transformer (l-e pat))]))) (define-for-syntax (compile-syndicate-pattern pat) (compile-pattern pat @@ -1052,9 +1055,12 @@ [⊢ p ≫ p-- ⇒ τ-p] ... #:fail-unless (project-safe? #'τ-e (type-eval #'(U τ-p ...))) "possibly unsafe pattern match" #:fail-unless (stx-andmap pure? #'(p-- ...)) "patterns must be pure" - #:with (p- ...) (stx-map compile-match-pattern #'(p ...)) + #:with (p- ...) (stx-map (lambda (p x-s xs) (substs x-s xs (compile-match-pattern p))) + #'(p ...) + #'((x- ...) ...) + #'((x ...) ...)) -------------------------------------------------------------- - [⊢ (match- e- [p- (let- ([x- x] ...) s-)] ... + [⊢ (match- e- [p- s-] ... [_ (error "incomplete pattern match")]) (⇒ : (U τ-s ...)) (⇒ a (as ... ...))