From 4c719df405e70f6d58c6e351df8bf94a3af6b1fe Mon Sep 17 00:00:00 2001 From: Manuel M T Chakravarty Date: Thu, 2 Jul 2009 07:09:05 +0000 Subject: [PATCH] FIX #3197 --- compiler/rename/RnEnv.lhs | 26 ++++++------- compiler/rename/RnNames.lhs | 88 +++++++++++++++++++++++++++++++++---------- 2 files changed, 79 insertions(+), 35 deletions(-) diff --git a/compiler/rename/RnEnv.lhs b/compiler/rename/RnEnv.lhs index 888ac28..51432bd 100644 --- a/compiler/rename/RnEnv.lhs +++ b/compiler/rename/RnEnv.lhs @@ -328,22 +328,18 @@ lookup_sub_bndr is_good doc rdr_name newIPNameRn :: IPName RdrName -> TcRnIf m n (IPName Name) newIPNameRn ip_rdr = newIPName (mapIPName rdrNameOcc ip_rdr) --- Looking up family names in type instances is a subtle affair. The family --- may be imported, in which case we need to lookup the occurence of a global --- name. Alternatively, the family may be in the same binding group (and in --- fact in a declaration processed later), and we need to create a new top --- source binder. +-- If the family is declared locally, it will not yet be in the main +-- environment; hence, we pass in an extra one here, which we check first. +-- See "Note [Looking up family names in family instances]" in 'RnNames'. -- --- So, also this is strictly speaking an occurence, we cannot raise an error --- message yet for instances without a family declaration. This will happen --- during renaming the type instance declaration in RnSource.rnTyClDecl. --- -lookupFamInstDeclBndr :: Module -> Located RdrName -> RnM Name -lookupFamInstDeclBndr mod lrdr_name@(L _ rdr_name) - = do { mb_gre <- lookupGreRn_maybe rdr_name - ; case mb_gre of - Just gre -> returnM (gre_name gre) - Nothing -> newTopSrcBinder mod lrdr_name } +lookupFamInstDeclBndr :: GlobalRdrEnv -> Located RdrName -> RnM Name +lookupFamInstDeclBndr tyclGroupEnv (L loc rdr_name) + = setSrcSpan loc $ + case lookupGRE_RdrName rdr_name tyclGroupEnv of + (gre:_) -> return $ gre_name gre + -- if there is more than one, an error will be raised elsewhere + [] -> lookupOccRn rdr_name + -------------------------------------------------- -- Occurrences diff --git a/compiler/rename/RnNames.lhs b/compiler/rename/RnNames.lhs index a7b84eb..8aa33a2 100644 --- a/compiler/rename/RnNames.lhs +++ b/compiler/rename/RnNames.lhs @@ -360,14 +360,48 @@ used for source code. Instances of type families ~~~~~~~~~~~~~~~~~~~~~~~~~~ -Indexed data/newtype instances contain data constructors that we need to -collect, too. Moreover, we need to descend into the data/newtypes instances -of associated families. +Family instances contain data constructors that we need to collect and we also +need to descend into the type instances of associated families in class +instances. The type constructor of a family instance is a usage occurence. +Hence, we don't return it as a subname in 'AvailInfo'; otherwise, we would get +a duplicate declaration error. -We need to be careful with the handling of the type constructor of each type -instance as the family constructor is already defined, and we want to avoid -raising a duplicate declaration error. So, we make a new name for it, but -don't return it in the 'AvailInfo'. +Note [Looking up family names in family instances] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider + + module M where + type family T a :: * + type instance M.T Int = Bool + +We might think that we can simply use 'lookupOccRn' when processing the type +instance to look up 'M.T'. Alas, we can't! The type family declaration is in +the *same* HsGroup as the type instance declaration. Hence, as we are +currently collecting the binders declared in that HsGroup, these binders will +not have been added to the global environment yet. + +In the case of type classes, this problem does not arise, as a class instance +does not define any binders of it's own. So, we simply don't attempt to look +up the class names of class instances in 'get_local_binders' below. + +If we don't look up class instances, can't we get away without looking up type +instances, too? No, we can't. Data type instances define data constructors +and we need to + + (1) collect those in 'get_local_binders' and + (2) we need to get their parent name in 'get_local_binders', too, to + produce an appropriate 'AvailTC'. + +This parent name is exactly the family name of the type instance that is so +difficult to look up. + +We solve this problem as follows: + + (a) We process all type declarations other than type instances first. + (b) Then, we compute a 'GlobalRdrEnv' from the result of the first step. + (c) Finally, we process all type instances (both those on the toplevel and + those nested in class instances) and check for the family names in the + 'GlobalRdrEnv' produced in the previous step before using 'lookupOccRn'. \begin{code} getLocalNonValBinders :: HsGroup RdrName -> RnM [AvailInfo] @@ -389,10 +423,25 @@ get_local_binders gbl_env (HsGroup {hs_valds = ValBindsIn _ val_sigs, hs_tyclds = tycl_decls, hs_instds = inst_decls, hs_fords = foreign_decls }) - = do { tc_names_s <- mapM new_tc tycl_decls - ; at_names_s <- mapM inst_ats inst_decls - ; val_names <- mapM new_simple val_bndrs - ; return (val_names ++ tc_names_s ++ concat at_names_s) } + = do { -- separate out the family instance declarations + let (tyinst_decls1, tycl_decls_noinsts) + = partition (isFamInstDecl . unLoc) tycl_decls + tyinst_decls = tyinst_decls1 ++ + concatMap (instDeclATs . unLoc) inst_decls + + -- process all type/class decls except family instances + ; tc_names <- mapM new_tc tycl_decls_noinsts + + -- create a temporary rdr env of the type binders + ; let tc_gres = gresFromAvails LocalDef tc_names + tc_name_env = foldl extendGlobalRdrEnv emptyGlobalRdrEnv tc_gres + + -- process all family instances + ; ti_names <- mapM (new_ti tc_name_env) tyinst_decls + + -- finish off with value binder in case of a hs-boot file + ; val_names <- mapM new_simple val_bndrs + ; return (val_names ++ tc_names ++ ti_names) } where mod = tcg_mod gbl_env is_hs_boot = isHsBoot (tcg_src gbl_env) ; @@ -411,21 +460,20 @@ get_local_binders gbl_env (HsGroup {hs_valds = ValBindsIn _ val_sigs, nm <- newTopSrcBinder mod rdr_name return (Avail nm) - new_tc tc_decl - | isFamInstDecl (unLoc tc_decl) - = do { main_name <- lookupFamInstDeclBndr mod main_rdr - ; sub_names <- mapM (newTopSrcBinder mod) sub_rdrs - ; return (AvailTC main_name sub_names) } - -- main_name is not bound here! - | otherwise + new_tc tc_decl -- NOT for type/data instances = do { main_name <- newTopSrcBinder mod main_rdr ; sub_names <- mapM (newTopSrcBinder mod) sub_rdrs ; return (AvailTC main_name (main_name : sub_names)) } where (main_rdr : sub_rdrs) = tyClDeclNames (unLoc tc_decl) - inst_ats inst_decl - = mapM new_tc (instDeclATs (unLoc inst_decl)) + new_ti tc_name_env ti_decl -- ONLY for type/data instances + = do { main_name <- lookupFamInstDeclBndr tc_name_env main_rdr + ; sub_names <- mapM (newTopSrcBinder mod) sub_rdrs + ; return (AvailTC main_name sub_names) } + -- main_name is not bound here! + where + (main_rdr : sub_rdrs) = tyClDeclNames (unLoc ti_decl) get_local_binders _ g = pprPanic "get_local_binders" (ppr g) \end{code} -- 1.7.10.4