syndicate-lang
/
syndicate-2017
1
0
Fork 0
Code Issues Pull Requests Projects Releases Wiki Activity

fix pattern compilation

This commit is contained in:
Sam Caldwell 2018-07-31 14:46:24 -04:00 committed by Sam Caldwell
parent 938d3c519d
commit e7e8f5e174
1 changed files with 26 additions and 20 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

46
racket/typed/roles.rkt
View File

@ -686,16 +686,16 @@
[(on (a/r:asserted-or-retracted p) s) ≫ [(on (a/r:asserted-or-retracted p) s) ≫
[⊢ p ≫ p-- (⇒ : τp)] [⊢ p ≫ p-- (⇒ : τp)]
#:fail-unless (pure? #'p--) "pattern not allowed to have effects" #:fail-unless (pure? #'p--) "pattern not allowed to have effects"
#:with p- (compile-syndicate-pattern #'p)
#:with ([x:id τ:type] ...) (pat-bindings #'p) #:with ([x:id τ:type] ...) (pat-bindings #'p)
[[x ≫ x- : τ] ... ⊢ s ≫ s- (⇒ a (~effs)) [[x ≫ x- : τ] ... ⊢ s ≫ s- (⇒ a (~effs))
(⇒ r (~effs)) (⇒ r (~effs))
(⇒ f (~effs τ-f ...)) (⇒ f (~effs τ-f ...))
(⇒ s (~effs τ-s ...))] (⇒ s (~effs τ-s ...))]
#:with p- (substs #'(x- ...) #'(x ...) (compile-syndicate-pattern #'p))
#:with τ-r #'(Reacts (a/r.react-con τp) τ-f ...) #:with τ-r #'(Reacts (a/r.react-con τp) τ-f ...)
----------------------------------- -----------------------------------
[⊢ (syndicate:on (a/r.syndicate-kw p-) [⊢ (syndicate:on (a/r.syndicate-kw p-)
(let- ([x- x] ...) s-)) s-)
(⇒ : ★/t) (⇒ : ★/t)
(⇒ r (τ-r)) (⇒ r (τ-r))
(⇒ f ()) (⇒ f ())
@ -720,22 +720,25 @@
#'()])) #'()]))
(define-for-syntax (compile-pattern pat bind-id-transformer exp-transformer) (define-for-syntax (compile-pattern pat bind-id-transformer exp-transformer)
(let loop ([pat pat]) (define (l-e stx) (local-expand stx 'expression '()))
(syntax-parse pat (let loop ([pat pat])
#:datum-literals (tuple discard bind) (syntax-parse pat
[(tuple p ...) #:datum-literals (tuple discard bind)
#`(list 'tuple #,@(stx-map loop #'(p ...)))] [(tuple p ...)
[(k:kons1 p) #`(list- 'tuple #,@(stx-map loop #'(p ...)))]
#`(#,(kons1->constructor #'k) #,(loop #'p))] [(k:kons1 p)
[(bind x:id τ:type) #`(#,(kons1->constructor #'k) #,(loop #'p))]
(bind-id-transformer #'x)] [(bind x:id τ:type)
[discard (bind-id-transformer #'x)]
#'_] [discard
[(~constructor-exp ctor p ...) #'_]
(define/with-syntax uctor (untyped-ctor #'ctor)) [(~constructor-exp ctor p ...)
#`(uctor #,@(stx-map loop #'(p ...)))] (define/with-syntax uctor (untyped-ctor #'ctor))
[_ #`(uctor #,@(stx-map loop #'(p ...)))]
(exp-transformer pat)]))) [_
;; 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) (define-for-syntax (compile-syndicate-pattern pat)
(compile-pattern pat (compile-pattern pat
@ -1052,9 +1055,12 @@
[⊢ p ≫ p-- ⇒ τ-p] ... [⊢ p ≫ p-- ⇒ τ-p] ...
#:fail-unless (project-safe? #'τ-e (type-eval #'(U τ-p ...))) "possibly unsafe pattern match" #:fail-unless (project-safe? #'τ-e (type-eval #'(U τ-p ...))) "possibly unsafe pattern match"
#:fail-unless (stx-andmap pure? #'(p-- ...)) "patterns must be pure" #: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")]) [_ (error "incomplete pattern match")])
(⇒ : (U τ-s ...)) (⇒ : (U τ-s ...))
(⇒ a (as ... ...)) (⇒ a (as ... ...))