X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2Frename%2FRnNames.lhs;h=8f6d158bd659e2c0179ce819968a0dd3f36767fe;hb=0cfba505ee10cf12737077449a6cb4d98e56263c;hp=6b98283afd63f7e92c413d42ae1a215270f097c3;hpb=bd865113a1446bb18fb32b546b8776b846a23116;p=ghc-hetmet.git diff --git a/compiler/rename/RnNames.lhs b/compiler/rename/RnNames.lhs index 6b98283..8f6d158 100644 --- a/compiler/rename/RnNames.lhs +++ b/compiler/rename/RnNames.lhs @@ -29,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, @@ -58,7 +58,7 @@ import DriverPhases ( isHsBoot ) import Util ( notNull ) import List ( partition ) import IO ( openFile, IOMode(..) ) -import Monad ( liftM ) +import Monad ( liftM, when ) \end{code} @@ -411,17 +411,20 @@ used for source code. *** See "THE NAMING STORY" in HsDecls **** -Associated data types: Instances declarations may contain definitions of -associated data types whose data constructors we need to collect, too. -However, we need to be careful with the handling of the data type constructor -of each asscociated type, as it is already defined in the corresponding -class. We make a new name for it, but don't return it in the 'AvailInfo' (to -avoid raising a duplicate declaration error; see the helper -'unavail_main_name'). +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 }) @@ -532,7 +535,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] @@ -575,33 +582,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 @@ -1114,6 +1128,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