diff options
| author | Simon Peyton Jones <simonpj@microsoft.com> | 2015-12-23 10:13:26 +0000 |
|---|---|---|
| committer | Simon Peyton Jones <simonpj@microsoft.com> | 2015-12-23 10:14:02 +0000 |
| commit | 78248702b0b8189d73f08c89d86f5cb7a3c6ae8c (patch) | |
| tree | eecb1544a178afa127f0a3663a1788c77d7b31d4 | |
| parent | b37f2164c08bfc1623ca4d9cab7cc4c2ebbc2e40 (diff) | |
| download | haskell-78248702b0b8189d73f08c89d86f5cb7a3c6ae8c.tar.gz | |
Fix ASSERT in buildPatSyn, and T10897 test
This closes Trac #10897
| -rw-r--r-- | compiler/iface/BuildTyCl.hs | 16 | ||||
| -rw-r--r-- | testsuite/tests/patsyn/should_compile/T10897.hs (renamed from testsuite/tests/patsyn/should_compile/T10897b.hs) | 2 | ||||
| -rw-r--r-- | testsuite/tests/patsyn/should_compile/all.T | 4 |
3 files changed, 13 insertions, 9 deletions
diff --git a/compiler/iface/BuildTyCl.hs b/compiler/iface/BuildTyCl.hs index 7c62bc2be5..d370d3712f 100644 --- a/compiler/iface/BuildTyCl.hs +++ b/compiler/iface/BuildTyCl.hs @@ -182,12 +182,14 @@ buildPatSyn :: Name -> Bool buildPatSyn src_name declared_infix matcher@(matcher_id,_) builder (univ_tvs, req_theta) (ex_tvs, prov_theta) arg_tys pat_ty field_labels - = ASSERT2((and [ univ_tvs == univ_tvs1 - , ex_tvs == ex_tvs1 - , pat_ty `eqType` pat_ty1 - , prov_theta `eqTypes` prov_theta1 - , req_theta `eqTypes` req_theta1 - , arg_tys `eqTypes` arg_tys1 + = -- The assertion checks that the matcher is + -- compatible with the pattern synonym + ASSERT2((and [ univ_tvs `equalLength` univ_tvs1 + , ex_tvs `equalLength` ex_tvs1 + , pat_ty `eqType` substTy subst pat_ty1 + , prov_theta `eqTypes` substTys subst prov_theta1 + , req_theta `eqTypes` substTys subst req_theta1 + , arg_tys `eqTypes` substTys subst arg_tys1 ]) , (vcat [ ppr univ_tvs <+> twiddle <+> ppr univ_tvs1 , ppr ex_tvs <+> twiddle <+> ppr ex_tvs1 @@ -205,6 +207,8 @@ buildPatSyn src_name declared_infix matcher@(matcher_id,_) builder (ex_tvs1, prov_theta1, cont_tau) = tcSplitSigmaTy cont_sigma (arg_tys1, _) = tcSplitFunTys cont_tau twiddle = char '~' + subst = zipTopTCvSubst (univ_tvs1 ++ ex_tvs1) + (mkTyVarTys (univ_tvs ++ ex_tvs)) ------------------------------------------------------ type TcMethInfo = (Name, Type, Maybe (DefMethSpec Type)) diff --git a/testsuite/tests/patsyn/should_compile/T10897b.hs b/testsuite/tests/patsyn/should_compile/T10897.hs index 6b506b8b45..e34f146188 100644 --- a/testsuite/tests/patsyn/should_compile/T10897b.hs +++ b/testsuite/tests/patsyn/should_compile/T10897.hs @@ -1,4 +1,4 @@ -module B where +module T10897 where import T10897a Single y = True diff --git a/testsuite/tests/patsyn/should_compile/all.T b/testsuite/tests/patsyn/should_compile/all.T index dd2bbf4114..e1c8243597 100644 --- a/testsuite/tests/patsyn/should_compile/all.T +++ b/testsuite/tests/patsyn/should_compile/all.T @@ -41,8 +41,8 @@ test('poly-export3', normal, compile, ['']) test('multi-export', normal, compile, ['']) test('export-super-class', normal, compile, ['']) test('export-record-selector', normal, compile, ['']) -test('T10897', expect_broken(10897), multi_compile, ['T10897', [ +test('T10897', normal, multi_compile, ['T10897', [ ('T10897a.hs','-c') - ,('T10897b.hs', '-c')], '']) + ], '-v0']) test('T11224b', normal, compile, ['']) test('MoreEx', normal, compile, ['']) |