X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2Frename%2FRnNames.lhs;h=71890dba2406a476389058ce0709d8ba49f49764;hp=b1f3795378303101fc770116f514acbf4ccaf311;hb=9da4639011348fb6c318e3cba4b08622f811d9c4;hpb=a31e156abe004186a959d04167be062969034f54 diff --git a/compiler/rename/RnNames.lhs b/compiler/rename/RnNames.lhs index b1f3795..71890db 100644 --- a/compiler/rename/RnNames.lhs +++ b/compiler/rename/RnNames.lhs @@ -17,6 +17,7 @@ import DynFlags ( DynFlag(..), GhcMode(..), DynFlags(..) ) import HsSyn ( IE(..), ieName, ImportDecl(..), LImportDecl, ForeignDecl(..), HsGroup(..), HsValBinds(..), Sig(..), collectHsBindLocatedBinders, tyClDeclNames, + instDeclATs, isIdxTyDecl, LIE ) import RnEnv import IfaceEnv ( ifaceExportNames ) @@ -28,7 +29,7 @@ import PrelNames import Module import Name ( Name, nameSrcLoc, nameOccName, nameModule, isWiredInName, nameParent, nameParent_maybe, isExternalName, - isBuiltInSyntax ) + isBuiltInSyntax, isTyConName ) import NameSet import NameEnv import OccName ( srcDataName, isTcOcc, pprNonVarNameSpace, @@ -57,6 +58,7 @@ import DriverPhases ( isHsBoot ) import Util ( notNull ) import List ( partition ) import IO ( openFile, IOMode(..) ) +import Monad ( liftM, when ) \end{code} @@ -151,10 +153,9 @@ rnImportDecl' iface decl_spec (ImportDecl mod_name want_boot qual_only as_mod (J return $ ImportDecl mod_name want_boot qual_only as_mod (Just (want_hiding,rn_import_items)) where srcSpanWrapper (L span ieRdr) - = setSrcSpan span $ - case get_item ieRdr of + = case get_item ieRdr of Nothing - -> do addErr (badImportItemErr iface decl_spec ieRdr) + -> do addErrAt span (badImportItemErr iface decl_spec ieRdr) return Nothing Just ieNames -> return (Just [L span ie | ie <- ieNames]) @@ -410,14 +411,27 @@ used for source code. *** See "THE NAMING STORY" in HsDecls **** +Instances of indexed types +~~~~~~~~~~~~~~~~~~~~~~~~~~ +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. + +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'. + \begin{code} getLocalDeclBinders :: TcGblEnv -> HsGroup RdrName -> RnM [Name] -getLocalDeclBinders gbl_env (HsGroup {hs_valds = ValBindsIn val_decls val_sigs, +getLocalDeclBinders gbl_env (HsGroup {hs_valds = ValBindsIn val_decls val_sigs, hs_tyclds = tycl_decls, + hs_instds = inst_decls, hs_fords = foreign_decls }) = do { tc_names_s <- mappM new_tc tycl_decls + ; at_names_s <- mappM inst_ats inst_decls ; val_names <- mappM new_simple val_bndrs - ; return (foldr (++) val_names tc_names_s) } + ; return (foldr (++) val_names (tc_names_s ++ concat at_names_s)) } where mod = tcg_mod gbl_env is_hs_boot = isHsBoot (tcg_src gbl_env) ; @@ -433,11 +447,21 @@ getLocalDeclBinders gbl_env (HsGroup {hs_valds = ValBindsIn val_decls val_sigs, for_hs_bndrs = [nm | L _ (ForeignImport nm _ _) <- foreign_decls] new_tc tc_decl + | isIdxTyDecl (unLoc tc_decl) + = do { main_name <- lookupFamInstDeclBndr mod main_rdr + ; sub_names <- + mappM (newTopSrcBinder mod (Just main_name)) sub_rdrs + ; return sub_names } -- main_name is not declared here! + | otherwise = do { main_name <- newTopSrcBinder mod Nothing main_rdr - ; sub_names <- mappM (newTopSrcBinder mod (Just main_name)) sub_rdrs + ; sub_names <- + mappM (newTopSrcBinder mod (Just main_name)) sub_rdrs ; return (main_name : sub_names) } - where - (main_rdr : sub_rdrs) = tyClDeclNames (unLoc tc_decl) + where + (main_rdr : sub_rdrs) = tyClDeclNames (unLoc tc_decl) + + inst_ats inst_decl + = mappM new_tc (instDeclATs (unLoc inst_decl)) \end{code} @@ -516,7 +540,11 @@ filterImports iface decl_spec (Just (want_hiding, import_items)) all_names = succeed_with True [name] get_item (IEThingWith name names) - = succeed_with True (name:names) + = do { optIdxTypes <- doptM Opt_IndexedTypes + ; when (not optIdxTypes && any isTyConName names) $ + addErr (typeItemErr (head . filter isTyConName $ names ) + (text "in import list")) + ; succeed_with True (name:names) } get_item (IEVar name) = succeed_with True [name] @@ -559,33 +587,40 @@ rnExports :: Maybe [LIE RdrName] -> RnM (Maybe [LIE Name]) rnExports Nothing = return Nothing rnExports (Just exports) - = do TcGblEnv { tcg_imports = ImportAvails { imp_env = imp_env } } <- getGblEnv - let sub_env :: NameEnv [Name] -- Classify each name by its parent - sub_env = mkSubNameEnv (foldUFM unionNameSets emptyNameSet imp_env) - rnExport (IEVar rdrName) - = do name <- lookupGlobalOccRn rdrName - return (IEVar name) - rnExport (IEThingAbs rdrName) - = do name <- lookupGlobalOccRn rdrName - return (IEThingAbs name) - rnExport (IEThingAll rdrName) - = do name <- lookupGlobalOccRn rdrName - return (IEThingAll name) - rnExport ie@(IEThingWith rdrName rdrNames) - = do name <- lookupGlobalOccRn rdrName - if isUnboundName name - then return (IEThingWith name []) - else do - let env = mkOccEnv [(nameOccName s, s) | s <- subNames sub_env name] - mb_names = map (lookupOccEnv env . rdrNameOcc) rdrNames - if any isNothing mb_names - then do addErr (exportItemErr ie) - return (IEThingWith name []) - else return (IEThingWith name (catMaybes mb_names)) - rnExport (IEModuleContents mod) - = return (IEModuleContents mod) - rn_exports <- mapM (wrapLocM rnExport) exports - return (Just rn_exports) + = do TcGblEnv { tcg_imports = ImportAvails { imp_env = imp_env } } <- getGblEnv + let sub_env :: NameEnv [Name] -- Classify each name by its parent + sub_env = mkSubNameEnv (foldUFM unionNameSets emptyNameSet imp_env) + rnExport (IEVar rdrName) + = do name <- lookupGlobalOccRn rdrName + return (IEVar name) + rnExport (IEThingAbs rdrName) + = do name <- lookupGlobalOccRn rdrName + return (IEThingAbs name) + rnExport (IEThingAll rdrName) + = do name <- lookupGlobalOccRn rdrName + return (IEThingAll name) + rnExport ie@(IEThingWith rdrName rdrNames) + = do name <- lookupGlobalOccRn rdrName + if isUnboundName name + then return (IEThingWith name []) + else do + let env = mkOccEnv [(nameOccName s, s) | s <- subNames sub_env name] + mb_names = map (lookupOccEnv env . rdrNameOcc) rdrNames + if any isNothing mb_names + then do addErr (exportItemErr ie) + return (IEThingWith name []) + else do let names = catMaybes mb_names + optIdxTypes <- doptM Opt_IndexedTypes + when (not optIdxTypes && any isTyConName names) $ + addErr (typeItemErr ( head + . filter isTyConName + $ names ) + (text "in export list")) + return (IEThingWith name names) + rnExport (IEModuleContents mod) + = return (IEModuleContents mod) + rn_exports <- mapM (wrapLocM rnExport) exports + return (Just rn_exports) mkExportNameSet :: Bool -- False => no 'module M(..) where' header at all -> Maybe ([LIE Name], [LIE RdrName]) -- Nothing => no explicit export list @@ -753,8 +788,8 @@ reportDeprecations dflags tcg_env check hpt pit (GRE {gre_name = name, gre_prov = Imported (imp_spec:_)}) | name `elemNameSet` used_names , Just deprec_txt <- lookupDeprec dflags hpt pit name - = setSrcSpan (importSpecLoc imp_spec) $ - addWarn (sep [ptext SLIT("Deprecated use of") <+> + = addWarnAt (importSpecLoc imp_spec) + (sep [ptext SLIT("Deprecated use of") <+> pprNonVarNameSpace (occNameSpace (nameOccName name)) <+> quotes (ppr name), (parens imp_msg) <> colon, @@ -1098,6 +1133,10 @@ exportItemErr export_item = sep [ ptext SLIT("The export item") <+> quotes (ppr export_item), ptext SLIT("attempts to export constructors or class methods that are not visible here") ] +typeItemErr name wherestr + = sep [ ptext SLIT("Using 'type' tag on") <+> quotes (ppr name) <+> wherestr, + ptext SLIT("Use -findexed-types to enable this extension") ] + exportClashErr global_env name1 name2 ie1 ie2 = vcat [ ptext SLIT("Conflicting exports for") <+> quotes (ppr occ) <> colon , ppr_export ie1 name1