diff options
| author | Simon Peyton Jones <simonpj@microsoft.com> | 2014-04-08 09:42:51 +0100 |
|---|---|---|
| committer | Austin Seipp <austin@well-typed.com> | 2014-04-22 01:20:30 -0500 |
| commit | 7dc927d8c3b0bd68cdf2186702309e36dc223ec1 (patch) | |
| tree | 88499ef6212f2ec850b2d8132ca281351719185e | |
| parent | 5944331dfcbd703f6a1a249406a2f4476749a6e1 (diff) | |
| download | haskell-7dc927d8c3b0bd68cdf2186702309e36dc223ec1.tar.gz | |
Zonk the existential type variables in tcPatSynDecl
This was just an omission, which showed up as Trac #8966
(cherry picked from commit 4dc9f9869bfc82fdb8bd61864859007873ebcc27)
| -rw-r--r-- | compiler/typecheck/TcPatSyn.lhs | 30 | ||||
| -rw-r--r-- | testsuite/tests/patsyn/should_compile/T8966.hs | 8 | ||||
| -rw-r--r-- | testsuite/tests/patsyn/should_compile/all.T | 1 |
3 files changed, 24 insertions, 15 deletions
diff --git a/compiler/typecheck/TcPatSyn.lhs b/compiler/typecheck/TcPatSyn.lhs index 94ee199d30..1464980194 100644 --- a/compiler/typecheck/TcPatSyn.lhs +++ b/compiler/typecheck/TcPatSyn.lhs @@ -47,28 +47,28 @@ tcPatSynDecl lname@(L _ name) details lpat dir ; pat_ty <- newFlexiTyVarTy openTypeKind ; let (arg_names, is_infix) = case details of - PrefixPatSyn names -> (map unLoc names, False) + PrefixPatSyn names -> (map unLoc names, False) InfixPatSyn name1 name2 -> (map unLoc [name1, name2], True) - ; ((lpat', args), wanted) <- captureConstraints $ - tcPat PatSyn lpat pat_ty $ mapM tcLookupId arg_names + ; ((lpat', args), wanted) <- captureConstraints $ + tcPat PatSyn lpat pat_ty $ + mapM tcLookupId arg_names ; let named_taus = (name, pat_ty):map (\arg -> (getName arg, varType arg)) args ; traceTc "tcPatSynDecl::wanted" (ppr named_taus $$ ppr wanted) - ; (qtvs, given_dicts, _mr_bites, ev_binds) <- simplifyInfer True False named_taus wanted - ; let req_dicts = given_dicts + ; (qtvs, req_dicts, _mr_bites, ev_binds) <- simplifyInfer True False named_taus wanted ; (ex_vars, prov_dicts) <- tcCollectEx lpat' - ; let univ_tvs = filter (not . (`elemVarSet` ex_vars)) qtvs - ex_tvs = varSetElems ex_vars + ; let univ_tvs = filter (not . (`elemVarSet` ex_vars)) qtvs + ex_tvs = varSetElems ex_vars + prov_theta = map evVarPred prov_dicts + req_theta = map evVarPred req_dicts - ; pat_ty <- zonkTcType pat_ty - ; args <- mapM zonkId args - - ; univ_tvs <- mapM zonkQuantifiedTyVar univ_tvs - ; let prov_theta = map evVarPred prov_dicts - req_theta = map evVarPred req_dicts + ; univ_tvs <- mapM zonkQuantifiedTyVar univ_tvs + ; ex_tvs <- mapM zonkQuantifiedTyVar ex_tvs ; prov_theta <- zonkTcThetaType prov_theta - ; req_theta <- zonkTcThetaType req_theta + ; req_theta <- zonkTcThetaType req_theta + ; pat_ty <- zonkTcType pat_ty + ; args <- mapM zonkId args ; traceTc "tcPatSynDecl: ex" (ppr ex_tvs $$ ppr prov_theta $$ @@ -92,7 +92,7 @@ tcPatSynDecl lname@(L _ name) details lpat dir prov_theta req_theta pat_ty ; m_wrapper <- tcPatSynWrapper lname lpat dir args - univ_tvs ex_tvs theta pat_ty + univ_tvs ex_tvs theta pat_ty ; let binds = matcher_bind `unionBags` maybe emptyBag snd m_wrapper ; traceTc "tcPatSynDecl }" $ ppr name diff --git a/testsuite/tests/patsyn/should_compile/T8966.hs b/testsuite/tests/patsyn/should_compile/T8966.hs new file mode 100644 index 0000000000..895ff1b764 --- /dev/null +++ b/testsuite/tests/patsyn/should_compile/T8966.hs @@ -0,0 +1,8 @@ +{-# LANGUAGE PolyKinds, KindSignatures, PatternSynonyms, DataKinds, GADTs #-} + +module T8966 where + +data NQ :: [k] -> * where + D :: NQ '[a] + +pattern Q = D diff --git a/testsuite/tests/patsyn/should_compile/all.T b/testsuite/tests/patsyn/should_compile/all.T index 71b0b71f3f..ecc4701661 100644 --- a/testsuite/tests/patsyn/should_compile/all.T +++ b/testsuite/tests/patsyn/should_compile/all.T @@ -8,3 +8,4 @@ test('ex-num', normal, compile, ['']) test('num', normal, compile, ['']) test('incomplete', normal, compile, ['']) test('export', normal, compile, ['']) +test('T8966', normal, compile, ['']) |