[commit: ghc] ghc-8.0: Fix kind generalisation for pattern synonyms (6fd8cf4)

[git at git.haskell.org]

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

On branch  : ghc-8.0
Link       : http://ghc.haskell.org/trac/ghc/changeset/6fd8cf4c9f597af907b2fbb5721e1c16204f1a28/ghc

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

commit 6fd8cf4c9f597af907b2fbb5721e1c16204f1a28
Author: Simon Peyton Jones <simonpj at microsoft.com>
Date:   Fri Feb 26 09:20:12 2016 +0000

    Fix kind generalisation for pattern synonyms
    
    We were failing to zonk, after quantifyTyVars, and that left
    un-zonked type variables in the final PatSyn.
    
    This fixes the patsyn/ problems in Trac #11648, but not
    the polykinds/ ones.
    
    (cherry picked from commit b4dfe04aa77bb2d0ce2c7d82cab5e4425e0b738c)


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

6fd8cf4c9f597af907b2fbb5721e1c16204f1a28
 compiler/typecheck/TcPatSyn.hs | 35 ++++++++++++++++++++++-------------
 1 file changed, 22 insertions(+), 13 deletions(-)

diff --git a/compiler/typecheck/TcPatSyn.hs b/compiler/typecheck/TcPatSyn.hs
index 41470f2..ad49a62 100644
--- a/compiler/typecheck/TcPatSyn.hs
+++ b/compiler/typecheck/TcPatSyn.hs
@@ -122,9 +122,17 @@ tcPatSynSig name sig_ty
                  ; return ( (univ_tvs, req, ex_tvs, prov, arg_tys, body_ty)
                           , bound_tvs) }
 
+       -- Kind generalisation; c.f. kindGeneralise
+       ; let free_kvs = tyCoVarsOfTelescope (implicit_tvs ++ univ_tvs ++ ex_tvs) $
+                        tyCoVarsOfTypes (body_ty : req ++ prov ++ arg_tys)
+
+       ; kvs <- quantifyTyVars emptyVarSet (Pair free_kvs emptyVarSet)
+
        -- These are /signatures/ so we zonk to squeeze out any kind
-       -- unification variables.
+       -- unification variables.  Do this after quantifyTyVars which may
+       -- default kind variables to *.
        -- ToDo: checkValidType?
+       ; traceTc "about zonk" empty
        ; implicit_tvs <- mapM zonkTcTyCoVarBndr implicit_tvs
        ; univ_tvs     <- mapM zonkTcTyCoVarBndr univ_tvs
        ; ex_tvs       <- mapM zonkTcTyCoVarBndr ex_tvs
@@ -133,12 +141,6 @@ tcPatSynSig name sig_ty
        ; arg_tys      <- zonkTcTypes arg_tys
        ; body_ty      <- zonkTcType  body_ty
 
-       -- Kind generalisation; c.f. kindGeneralise
-       ; let free_kvs = tyCoVarsOfTelescope (implicit_tvs ++ univ_tvs ++ ex_tvs) $
-                        tyCoVarsOfTypes (body_ty : req ++ prov ++ arg_tys)
-
-       ; kvs <- quantifyTyVars emptyVarSet (Pair free_kvs emptyVarSet)
-
        -- Complain about:  pattern P :: () => forall x. x -> P x
        -- The renamer thought it was fine, but the existential 'x'
        -- should not appear in the result type
@@ -154,13 +156,13 @@ tcPatSynSig name sig_ty
              (extra_univ, extra_ex) = partition (`elemVarSet` univ_fvs) $
                                       kvs ++ implicit_tvs
        ; traceTc "tcTySig }" $
-         vcat [ text "implicit_tvs" <+> ppr implicit_tvs
-              , text "kvs" <+> ppr kvs
-              , text "extra_univ" <+> ppr extra_univ
-              , text "univ_tvs" <+> ppr univ_tvs
+         vcat [ text "implicit_tvs" <+> ppr_tvs implicit_tvs
+              , text "kvs" <+> ppr_tvs kvs
+              , text "extra_univ" <+> ppr_tvs extra_univ
+              , text "univ_tvs" <+> ppr_tvs univ_tvs
               , text "req" <+> ppr req
-              , text "extra_ex" <+> ppr extra_ex
-              , text "ex_tvs" <+> ppr ex_tvs
+              , text "extra_ex" <+> ppr_tvs extra_ex
+              , text "ex_tvs" <+> ppr_tvs ex_tvs
               , text "prov" <+> ppr prov
               , text "arg_tys" <+> ppr arg_tys
               , text "body_ty" <+> ppr body_ty ]
@@ -171,6 +173,11 @@ tcPatSynSig name sig_ty
                       , patsig_prov     = prov
                       , patsig_arg_tys  = arg_tys
                       , patsig_body_ty  = body_ty }) }
+  where
+
+ppr_tvs :: [TyVar] -> SDoc
+ppr_tvs tvs = braces (vcat [ ppr tv <+> dcolon <+> ppr (tyVarKind tv)
+                           | tv <- tvs])
 
 
 {-
@@ -254,6 +261,8 @@ tcCheckPatSynDecl PSB{ psb_id = lname@(L _ name), psb_args = details
                                     else newMetaSigTyVars ex_tvs
                     -- See the "Existential type variables" part of
                     -- Note [Checking against a pattern signature]
+              ; traceTc "tcpatsyn1" (vcat [ ppr v <+> dcolon <+> ppr (tyVarKind v) | v <- ex_tvs])
+              ; traceTc "tcpatsyn2" (vcat [ ppr v <+> dcolon <+> ppr (tyVarKind v) | v <- ex_tvs'])
               ; prov_dicts <- mapM (emitWanted origin)
                   (substTheta (extendTCvInScopeList subst univ_tvs) prov_theta)
                   -- Add the free vars of 'prov_theta' to the in_scope set to