commit 26a2699d4897a78a35f5533c53327f030445f7e0
parent 2a9005a31d1c7bf5433db7799fd1dbdb57b6b661
Author: Stephen Chang <stchang@ccs.neu.edu>
Date: Mon, 11 Apr 2016 14:53:45 -0400
fix match expected-type propagation to non-datatype clauses
- closes #8
Diffstat:
4 files changed, 27 insertions(+), 6 deletions(-)
diff --git 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
@@ -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
@@ -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
@@ -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")
