diff options
author | Simon Peyton Jones <simonpj@microsoft.com> | 2012-02-16 13:48:25 +0000 |
---|---|---|
committer | Simon Peyton Jones <simonpj@microsoft.com> | 2012-02-16 13:48:25 +0000 |
commit | 154af13a71a2711793a4d78a1b0782a9501f233c (patch) | |
tree | fb9426e0e808fafa894ec31001dfa767306384db | |
parent | d31e9d6a44842206f341bac8d692aae5a6d6ed00 (diff) | |
download | haskell-154af13a71a2711793a4d78a1b0782a9501f233c.tar.gz |
Tidy up kind generalisation a bit
-rw-r--r-- | compiler/typecheck/TcTyClsDecls.lhs | 21 |
1 files changed, 12 insertions, 9 deletions
diff --git a/compiler/typecheck/TcTyClsDecls.lhs b/compiler/typecheck/TcTyClsDecls.lhs index 95d7d236a7..322506ff3f 100644 --- a/compiler/typecheck/TcTyClsDecls.lhs +++ b/compiler/typecheck/TcTyClsDecls.lhs @@ -281,7 +281,10 @@ kcTyClGroup decls -- Step 4: generalisation -- Kind checking done for this group -- Now we have to kind generalize the flexis - ; mapM generalise (tyClsBinders decls) }}} + ; res <- mapM generalise (tyClsBinders decls) + + ; traceTc "kcTyClGroup result" (ppr res) + ; return res }}} where generalise :: Name -> TcM (Name, Kind) @@ -474,7 +477,9 @@ kcFamilyDecl classTvs decl@(TyFamily {tcdKind = kind}) unifyClassParmKinds (L _ tv) | (n,k) <- hsTyVarNameKind tv , Just classParmKind <- lookup n classTyKinds - = let ctxt = ptext ( sLit "When kind checking family declaration") + = traceTc "kcFam" (ppr k $$ ppr classParmKind $$ ppr classTyKinds) + >> + let ctxt = ptext ( sLit "When kind checking family declaration") <+> ppr (tcdLName decl) in addErrCtxt ctxt $ unifyKind k classParmKind >> return () | otherwise = return () @@ -630,7 +635,7 @@ tcTyClDecl1 _parent calc_isrec ; fds' <- mapM (addLocM tc_fundep) fundeps ; (sig_stuff, gen_dm_env) <- tcClassSigs class_name sigs meths ; return (tvs', ctxt', fds', sig_stuff, gen_dm_env) } - ; clas <- fixM $ \ clas -> do + ; clas <- fixM $ \ clas -> do { let -- This little knot is just so we can get -- hold of the name of the class TyCon, which we -- need to look up its recursiveness @@ -709,7 +714,8 @@ tcClassATs class_name parent ats at_defs at_defs_map :: NameEnv [LTyClDecl Name] -- Maps an AT in 'ats' to a list of all its default defs in 'at_defs' - at_defs_map = foldr (\at_def nenv -> extendNameEnv_C (++) nenv (tcdName (unLoc at_def)) [at_def]) + at_defs_map = foldr (\at_def nenv -> extendNameEnv_C (++) nenv + (tcdName (unLoc at_def)) [at_def]) emptyNameEnv at_defs tc_at at = do { [ATyCon fam_tc] <- addLocM (tcTyClDecl1 parent @@ -921,18 +927,15 @@ tcConDecl new_or_data existential_ok rep_tycon res_tmpl -- Data types , con_details = details, con_res = res_ty } <- kcConDecl new_or_data con ; addErrCtxt (dataConCtxt name) $ - tcTyVarBndrsKindGen tvs $ \ tvs' -> do + tcTyVarBndrsKindGen tvs $ \ tvs' -> do { ctxt' <- tcHsKindedContext ctxt ; checkTc (existential_ok || conRepresentibleWithH98Syntax con) (badExistential name) - ; traceTc "tcConDecl 1" (ppr con) ; (univ_tvs, ex_tvs, eq_preds, res_ty') <- tcResultType res_tmpl tvs' res_ty ; let tc_datacon is_infix field_lbls btys = do { (arg_tys, stricts) <- mapAndUnzipM tcConArg btys - ; traceTc "tcConDecl 3" (ppr name) - - ; buildDataCon (unLoc name) is_infix + ; buildDataCon (unLoc name) is_infix stricts field_lbls univ_tvs ex_tvs eq_preds ctxt' arg_tys res_ty' rep_tycon } |