Commit 154af13a authored by Simon Peyton Jones's avatar Simon Peyton Jones
Browse files

Tidy up kind generalisation a bit

parent d31e9d6a
......@@ -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 }
......
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment