From 839a0880ea32b3ef2f0715957bfeec6e4bb3367b Mon Sep 17 00:00:00 2001 From: Manuel M T Chakravarty Date: Mon, 18 Sep 2006 21:46:52 +0000 Subject: [PATCH] Don't lift ATs out of classes and instances before tc Wed Aug 9 15:31:08 EDT 2006 Manuel M T Chakravarty * Don't lift ATs out of classes and instances before tc --- compiler/rename/RnSource.lhs | 31 ++++++++++++------------------- compiler/typecheck/TcTyClsDecls.lhs | 9 ++------- 2 files changed, 14 insertions(+), 26 deletions(-) diff --git a/compiler/rename/RnSource.lhs b/compiler/rename/RnSource.lhs index 5083044..e29c2fe 100644 --- a/compiler/rename/RnSource.lhs +++ b/compiler/rename/RnSource.lhs @@ -111,10 +111,8 @@ rnSrcDecls (HsGroup { hs_valds = val_decls, <- mapFvRn (wrapLocFstM rnDefaultDecl) default_decls ; let { - rn_at_decls = concat - [ats | L _ (InstDecl _ _ _ ats) <- rn_inst_decls] ; rn_group = HsGroup { hs_valds = rn_val_decls, - hs_tyclds = rn_tycl_decls ++ rn_at_decls, + hs_tyclds = rn_tycl_decls, hs_instds = rn_inst_decls, hs_fixds = rn_fix_decls, hs_depds = [], @@ -284,10 +282,9 @@ rnSrcInstDecl (InstDecl inst_ty mbinds uprags ats) let at_doc = text "In the associated types in an instance declaration" at_names = map (head . tyClDeclNames . unLoc) ats - (_, rdrCtxt, _, _) = splitHsInstDeclTy (unLoc inst_ty) in checkDupNames at_doc at_names `thenM_` - rnATDefs rdrCtxt ats `thenM` \ (ats', at_fvs) -> + rnATInsts ats `thenM` \ (ats', at_fvs) -> -- Rename the bindings -- The typechecker (not the renamer) checks that all @@ -333,30 +330,26 @@ rnSrcInstDecl (InstDecl inst_ty mbinds uprags ats) -- to remove the context). \end{code} -Renaming of the associated type definitions in instances. +Renaming of the associated types in instances. -* In the case of associated data and newtype definitions we add the instance - context. * We raise an error if we encounter a kind signature in an instance. \begin{code} -rnATDefs :: HsContext RdrName -> [LTyClDecl RdrName] - -> RnM ([LTyClDecl Name], FreeVars) -rnATDefs ctxt atDecls = - mapFvRn (wrapLocFstM rnAtDef) atDecls +rnATInsts :: [LTyClDecl RdrName] -> RnM ([LTyClDecl Name], FreeVars) +rnATInsts atDecls = + mapFvRn (wrapLocFstM rnATInst) atDecls where - rnAtDef tydecl@TyFunction {} = + rnATInst tydecl@TyFunction {} = do addErr noKindSig rnTyClDecl tydecl - rnAtDef tydecl@TySynonym {} = rnTyClDecl tydecl - rnAtDef tydecl@TyData {tcdCtxt = L l tyCtxt} = + rnATInst tydecl@TySynonym {} = rnTyClDecl tydecl + rnATInst tydecl@TyData {} = do checkM (not . isKindSigDecl $ tydecl) $ addErr noKindSig - rnTyClDecl (tydecl {tcdCtxt = L l (ctxt ++ tyCtxt)}) - -- The source loc is somewhat half hearted... -=chak - rnAtDef _ = - panic "RnSource.rnATDefs: not a type declaration" + rnTyClDecl tydecl + rnATInst _ = + panic "RnSource.rnATInsts: not a type declaration" noKindSig = text "Instances cannot have kind signatures" \end{code} diff --git a/compiler/typecheck/TcTyClsDecls.lhs b/compiler/typecheck/TcTyClsDecls.lhs index 1e61c39..a41ccbe 100644 --- a/compiler/typecheck/TcTyClsDecls.lhs +++ b/compiler/typecheck/TcTyClsDecls.lhs @@ -127,13 +127,8 @@ tcTyAndClassDecls boot_details decls ; traceTc (text "tcTyAndCl" <+> ppr mod) ; (syn_tycons, alg_tyclss) <- fixM (\ ~(rec_syn_tycons, rec_alg_tyclss) -> do { let { -- Calculate variances and rec-flag - ; (syn_decls, alg_decls_pre) = partition (isSynDecl . unLoc) decls - ; alg_decls = alg_decls_pre ++ - concat [tcdATs decl -- add AT decls - | declLoc <- alg_decls_pre - , let decl = unLoc declLoc - , isClassDecl decl] } - + ; (syn_decls, alg_decls) = partition (isSynDecl . unLoc) + decls } -- Extend the global env with the knot-tied results -- for data types and classes -- -- 1.7.10.4