diff --git a/tapl/mlish.rkt b/tapl/mlish.rkt index be96e63..251aaa5 100644 --- a/tapl/mlish.rkt +++ b/tapl/mlish.rkt @@ -549,6 +549,7 @@ [(_ e with . clauses) #:fail-when (null? (syntax->list #'clauses)) "no clauses" #:with [e- τ_e] (infer+erase #'e) + #:with t_expect (syntax-property stx 'expected-type) ; propagate inferred type (cond [(×? #'τ_e) ;; e is tuple (syntax-parse #'clauses #:datum-literals (->) @@ -556,7 +557,8 @@ #:with (~× ty ...) #'τ_e #:fail-unless (stx-length=? #'(ty ...) #'(x ...)) "match clause pattern not compatible with given tuple" - #:with [(x- ...) e_body- ty_body] (infer/ctx+erase #'([x ty] ...) #'e_body) + #:with [(x- ...) e_body- ty_body] (infer/ctx+erase #'([x ty] ...) + #'(add-expected e_body t_expect)) #:with (acc ...) (for/list ([(a i) (in-indexed (syntax->list #'(x ...)))]) #`(lambda (s) (list-ref s #,(datum->syntax #'here i)))) #:with z (generate-temporary) @@ -576,7 +578,7 @@ #:with (~List ty) #'τ_e #:with ([(x- ... rst-) e_body- ty_body] ...) (stx-map (lambda (ctx e) (infer/ctx+erase ctx e)) - #'(([x ty] ... [rst (List ty)]) ...) #'(e_body ...)) + #'(([x ty] ... [rst (List ty)]) ...) #'((add-expected e_body t_expect) ...)) #:with τ_out (stx-car #'(ty_body ...)) #:with (len ...) (stx-map (lambda (p) #`#,(stx-length p)) #'((x ...) ...)) #:with (lenop ...) (stx-map (lambda (p) (if (brack? p) #'= #'>=)) #'(xs ...)) @@ -633,7 +635,6 @@ ;; (for/list ([(a i) (in-indexed (syntax->list accs))]) ;; #`(lambda (s) (unsafe-struct*-ref s #,(datum->syntax #'here i))))) ;; #'((acc-fn ...) ...)) - #:with t_expect (syntax-property stx 'expected-type) ; propagate inferred type #:with (e_c ...) (stx-map (lambda (ec) (add-expected-ty ec #'t_expect)) #'(e_c_un ...)) #:with (((x- ...) (e_guard- e_c-) (τ_guard τ_ec)) ...) (stx-map diff --git a/tapl/tests/mlish-tests.rkt b/tapl/tests/mlish-tests.rkt index fec23c2..a834980 100644 --- a/tapl/tests/mlish-tests.rkt +++ b/tapl/tests/mlish-tests.rkt @@ -172,7 +172,6 @@ [Nil -> lst2] [Cons x xs -> (Cons x (append xs lst2))])) - ;; end infer.rkt tests -------------------------------------------------- ;; algebraic data types @@ -257,6 +256,27 @@ [Nil -> 3]) : Int ⇒ 6) +;; check expected-type propagation for other match paterns + +(define-type (Option A) + (None) + (Some A)) + +(check-type (match (tup 1 2) with [a b -> None]) : (Option Int) -> None) +(check-type + (match (list 1 2) with + [[] -> None] + [[x y] -> None]) + : (Option Int) -> None) + +(check-type + (match (list 1 2) with + [[] -> None] + [x :: xs -> None]) + : (Option Int) -> None) + +(define-type (Pairof A B) (C A B)) +(check-type (match (C 1 2) with [C a b -> None]) : (Option Int) -> None) ; ext-stlc tests -------------------------------------------------- diff --git a/tapl/tests/run-mlish-tests1.rkt b/tapl/tests/run-mlish-tests1.rkt index 6506f3a..c768ab2 100644 --- a/tapl/tests/run-mlish-tests1.rkt +++ b/tapl/tests/run-mlish-tests1.rkt @@ -1,6 +1,6 @@ #lang racket (require "mlish-tests.rkt") -;(require "mlish/queens.mlish") +(require "mlish/queens.mlish") (require "mlish/listpats.mlish") (require "mlish/match2.mlish") diff --git a/tapl/tests/run-mlish-tests1b.rkt b/tapl/tests/run-mlish-tests1b.rkt index 2350d5b..de8333f 100644 --- a/tapl/tests/run-mlish-tests1b.rkt +++ b/tapl/tests/run-mlish-tests1b.rkt @@ -1,6 +1,6 @@ #lang racket ;; (require "mlish-tests.rkt") -(require "mlish/queens.mlish") +;(require "mlish/queens.mlish") (require "mlish/trees-tests.mlish") (require "mlish/chameneos.mlish") (require "mlish/ack.mlish")