www

commit d5435eb71bcab39d3b48aa6b12d8e37f4d5f5631
parent e9290629daff4d3e1846cda8b9aae0866807df83
Author: Stephen Chang <stchang@ccs.neu.edu>
Date:   Wed, 30 Mar 2016 23:25:24 -0400

fix match2 bug with nested user-defined datatypes

Diffstat:
M
tapl/mlish.rkt
 | 
8
++++----
M
tapl/tests/mlish/bg/monad.mlish
 | 
10
++++++++++

2 files changed, 14 insertions(+), 4 deletions(-)
diff --git a/tapl/mlish.rkt b/tapl/mlish.rkt
@@ -335,8 +335,9 @@
        #:with ((~literal #%plain-lambda) (RecName) 
                ((~literal let-values) ()
                 ((~literal let-values) ()
-                 . info-body)))
+                 . (((~literal #%plain-app) ((~literal quote) C) . rst) ...))))
               (get-extra-info #'ty)
+       #:when (member (syntax->datum #'A) (syntax->datum #'(C ...)))
        #'()]
       [(x:id ty)  #'((x ty))]
       [((p1 (unq p) ...) ty) ; comma tup stx
@@ -403,8 +404,9 @@
       #:with ((~literal #%plain-lambda) (RecName) 
               ((~literal let-values) ()
                ((~literal let-values) ()
-                . info-body)))
+                . (((~literal #%plain-app) ((~literal quote) C) . rst) ...))))
               (get-extra-info ty)
+       #:when (member (syntax->datum #'A) (syntax->datum #'(C ...)))
       (compile-pat #'(A) ty)]
      [x:id p]
      [(p1 (unq p) ...) ; comma tup stx
@@ -680,12 +682,10 @@
                    (stx-map 
                       (lambda (tyin) 
                         (define old-orig (get-orig tyin))
-                        (displayln old-orig)
                         (define new-orig
                           (and old-orig
                                (substs (stx-map get-orig #'(τ_solved ...)) #'Xs old-orig
                                            (lambda (x y) (equal? (syntax->datum x) (syntax->datum y))))))
-                        (displayln new-orig)
                         (syntax-property tyin 'orig (list new-orig)))
                      #'(τ_in ...)))
    (⊢ (#%app e_fn- e_arg- ...) : τ_out)])
diff --git a/tapl/tests/mlish/bg/monad.mlish b/tapl/tests/mlish/bg/monad.mlish
@@ -110,3 +110,13 @@
   ⇒ (Some (BQ (∷ 4 (∷ 5 (∷ 6 (∷ 7 (∷ 8 (∷ 9 Nil)))))) Nil)))
 
 (check-type (>> (inst bq-head Int) bq-tails-result) : (Option Int) -> (Some 4))
+
+;; check match2 nested datatype bug
+(check-type
+    (match bq-tails-result with
+     [None -> (None {Int})]
+     [Some bq -> (bq-head bq)]) : (Option Int) -> (Some 4))
+(check-type
+    (match2 bq-tails-result with
+     [None -> (None {Int})]
+     [Some bq -> (bq-head bq)]) : (Option Int) -> (Some 4))