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 <g...@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@TySynonym {}) } -- "newtype instance" and "data instance" -tcFamInstDecl1 fam_tc (decl@TyData { tcdND = new_or_data +tcFamInstDecl1 fam_tc (decl@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@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 _______________________________________________ Cvs-ghc mailing list Cvs-ghc@haskell.org http://www.haskell.org/mailman/listinfo/cvs-ghc
