From d5435eb71bcab39d3b48aa6b12d8e37f4d5f5631 Mon Sep 17 00:00:00 2001 From: Stephen Chang Date: Wed, 30 Mar 2016 23:25:24 -0400 Subject: [PATCH] fix match2 bug with nested user-defined datatypes --- tapl/mlish.rkt | 8 ++++---- tapl/tests/mlish/bg/monad.mlish | 10 ++++++++++ 2 files changed, 14 insertions(+), 4 deletions(-) diff --git a/tapl/mlish.rkt b/tapl/mlish.rkt index 32ffb5c..dee74df 100644 --- 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 index aed6d48..5d0adde 100644 --- 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))