[commit: ghc] ghc-kinds: kind generalize data families (3514446)

[Julien Cretin]

Repository : ssh://darcs.haskell.org//srv/darcs/ghc

On branch  : ghc-kinds

http://hackage.haskell.org/trac/ghc/changeset/351444697093a70cea03e86e6a6057119d3e9aa5

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

commit 351444697093a70cea03e86e6a6057119d3e9aa5
Author: Julien Cretin <ghc at ia0.eu>
Date:   Fri Sep 23 12:48:21 2011 +0200

    kind generalize data families

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

 compiler/hsSyn/HsTypes.lhs        |   13 ++++++++-----
 compiler/typecheck/TcHsType.lhs   |    2 +-
 compiler/typecheck/TcInstDcls.lhs |   28 +++++++++++++++-------------
 3 files changed, 24 insertions(+), 19 deletions(-)

diff --git a/compiler/hsSyn/HsTypes.lhs b/compiler/hsSyn/HsTypes.lhs
index 784e1fe..8b44e45 100644
--- a/compiler/hsSyn/HsTypes.lhs
+++ b/compiler/hsSyn/HsTypes.lhs
@@ -524,11 +524,14 @@ ppr_mono_ty _    (HsCoreTy ty)       = ppr ty
 ppr_mono_ty _    (HsExplicitListTy _ tys) = quote $ brackets (interpp'SP tys)
 ppr_mono_ty _    (HsExplicitTupleTy _ tys) = quote $ parens (interpp'SP tys)
 
-ppr_mono_ty ctxt_prec (HsWrapTy (WpKiApps []) ty) = ppr_mono_ty ctxt_prec ty
-ppr_mono_ty ctxt_prec (HsWrapTy (WpKiApps (ki:kis)) ty)
-  = maybeParen ctxt_prec pREC_CON $
-    hsep [ ppr_mono_ty pREC_FUN (HsWrapTy (WpKiApps kis) ty)
-         , ptext (sLit "@") <> pprParendKind ki ]
+ppr_mono_ty ctxt_prec (HsWrapTy (WpKiApps kis) ty)
+  = go ctxt_prec kis ty
+  where
+    go ctxt_prec [] ty = ppr_mono_ty ctxt_prec ty
+    go ctxt_prec (ki:kis) ty
+      = maybeParen ctxt_prec pREC_CON $
+        hsep [ go pREC_FUN kis ty
+             , ptext (sLit "@") <> pprParendKind ki ]
 
 ppr_mono_ty ctxt_prec (HsEqTy ty1 ty2)
   = maybeParen ctxt_prec pREC_OP $
diff --git a/compiler/typecheck/TcHsType.lhs b/compiler/typecheck/TcHsType.lhs
index 21ae7ee..bd127d3 100644
--- a/compiler/typecheck/TcHsType.lhs
+++ b/compiler/typecheck/TcHsType.lhs
@@ -493,7 +493,7 @@ kc_hs_type (HsExplicitTupleTy _ tys) = do
   return ( HsExplicitTupleTy (map snd ty_k_s) (map fst ty_k_s)
          , mkTyConApp (tupleTyCon BoxedTuple (length tys)) (map snd ty_k_s))
 
-kc_hs_type (HsWrapTy {}) = panic "kc_hs_type"
+kc_hs_type (HsWrapTy {}) = panic "kc_hs_type HsWrapTy"  -- it means we kind checked something twice
 
 ---------------------------
 kcApps :: Outputable a
diff --git a/compiler/typecheck/TcInstDcls.lhs b/compiler/typecheck/TcInstDcls.lhs
index e8f5583..c8d4b6b 100644
--- a/compiler/typecheck/TcInstDcls.lhs
+++ b/compiler/typecheck/TcInstDcls.lhs
@@ -563,28 +563,30 @@ tcFamInstDecl1 fam_tc (decl at TySynonym {})
        }
 
   -- "newtype instance" and "data instance"
-tcFamInstDecl1 fam_tc (decl at TyData { tcdND = new_or_data
+tcFamInstDecl1 fam_tc (decl at TyData { tcdND = new_or_data, tcdCtxt = ctxt
                                    , tcdCons = cons})
-  = kcFamTyPats fam_tc decl $ \_ k_tvs k_typats resKind ->
-                           --  ^- IA0_TODO like TcTyClsDecls
+  = kcFamTyPats fam_tc decl $ \k_kipats k_tvs k_typats resKind ->
     do { -- check that the family declaration is for the right kind
          checkTc (isFamilyTyCon fam_tc) (notFamily fam_tc)
        ; checkTc (isAlgTyCon fam_tc) (wrongKindOfFamily fam_tc)
 
        ; -- (1) kind check the data declaration as usual
-       ; k_decl <- kcDataDecl decl k_tvs
-       ; let k_ctxt = tcdCtxt k_decl
-             k_cons = tcdCons k_decl
+       ; _ <- kcDataDecl decl k_tvs
 
          -- result kind must be '*' (otherwise, we have too few patterns)
        ; checkTc (isLiftedTypeKind resKind) $ tooFewParmsErr (tyConArity fam_tc)
 
          -- (2) type check indexed data type declaration
+         -- We kind generalize the kind patterns since they contain
+         -- all the meta kind variables
+       ; (t_kvs, t_kipats) <- kindGeneralizeKinds k_kipats
        ; tcTyVarBndrs k_tvs $ \t_tvs -> do   -- turn kinded into proper tyvars
 
          -- kind check the type indexes and the context
        { t_typats     <- mapM tcHsKindedType k_typats
-       ; stupid_theta <- tcHsKindedContext k_ctxt
+       ; stupid_theta <- tcHsKindedContext =<< kcHsContext ctxt
+       ; let t_ktvs = t_kvs ++ t_tvs
+             t_ktpats = t_kipats ++ t_typats
 
          -- (3) Check that
          --     (a) left-hand side contains no type family applications
@@ -592,22 +594,22 @@ tcFamInstDecl1 fam_tc (decl at TyData { tcdND = new_or_data
          --         foralls earlier)
        ; mapM_ checkTyFamFreeness t_typats
 
-       ; dataDeclChecks (tcdName decl) new_or_data stupid_theta k_cons
+       ; dataDeclChecks (tcdName decl) new_or_data stupid_theta cons
 
          -- (4) construct representation tycon
-       ; rep_tc_name <- newFamInstTyConName (tcdLName decl) t_typats
+       ; rep_tc_name <- newFamInstTyConName (tcdLName decl) t_ktpats
        ; let ex_ok = True       -- Existentials ok for type families!
        ; fixM (\ rep_tycon -> do
-             { let orig_res_ty = mkTyConApp fam_tc t_typats
+             { let orig_res_ty = mkTyConApp fam_tc t_ktpats
              ; data_cons <- tcConDecls new_or_data ex_ok rep_tycon
-                                       (t_tvs, orig_res_ty) k_cons
+                                       (t_ktvs, orig_res_ty) cons
              ; tc_rhs <-
                  case new_or_data of
                    DataType -> return (mkDataTyConRhs data_cons)
                    NewType  -> ASSERT( not (null data_cons) )
                                mkNewTyConRhs rep_tc_name rep_tycon (head data_cons)
-             ; buildAlgTyCon rep_tc_name t_tvs stupid_theta tc_rhs Recursive
-                             h98_syntax NoParentTyCon (Just (fam_tc, t_typats))
+             ; buildAlgTyCon rep_tc_name t_ktvs stupid_theta tc_rhs Recursive
+                             h98_syntax NoParentTyCon (Just (fam_tc, t_ktpats))
                  -- We always assume that indexed types are recursive.  Why?
                  -- (1) Due to their open nature, we can never be sure that a
                  -- further instance might not introduce a new recursive