[commit: ghc] master: Zonk the existential type variables in tcPatSynDecl (4dc9f98)

[git at git.haskell.org]

Repository : ssh://git@git.haskell.org/ghc

On branch  : master
Link       : http://ghc.haskell.org/trac/ghc/changeset/4dc9f9869bfc82fdb8bd61864859007873ebcc27/ghc

>---------------------------------------------------------------

commit 4dc9f9869bfc82fdb8bd61864859007873ebcc27
Author: Simon Peyton Jones <simonpj at microsoft.com>
Date:   Tue Apr 8 09:42:51 2014 +0100

    Zonk the existential type variables in tcPatSynDecl
    
    This was just an omission, which showed up as Trac #8966


>---------------------------------------------------------------

4dc9f9869bfc82fdb8bd61864859007873ebcc27
 compiler/typecheck/TcPatSyn.lhs                |   30 ++++++++++++------------
 testsuite/tests/patsyn/should_compile/T8966.hs |    8 +++++++
 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 94ee199..1464980 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 0000000..895ff1b
--- /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 71b0b71..ecc4701 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, [''])