X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2Frename%2FRnNames.lhs;h=8f6d158bd659e2c0179ce819968a0dd3f36767fe;hb=0cfba505ee10cf12737077449a6cb4d98e56263c;hp=63fd99dde1ae688b645f5f128dbd16bbaf7e814c;hpb=16513d4899e167d20e120c2b3907230b7ff9dd83;p=ghc-hetmet.git diff --git a/compiler/rename/RnNames.lhs b/compiler/rename/RnNames.lhs index 63fd99d..8f6d158 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) ; @@ -435,9 +449,14 @@ getLocalDeclBinders gbl_env (HsGroup {hs_valds = ValBindsIn val_decls val_sigs, new_tc tc_decl = do { main_name <- newTopSrcBinder mod Nothing main_rdr ; sub_names <- mappM (newTopSrcBinder mod (Just main_name)) sub_rdrs - ; return (main_name : sub_names) } + ; if isIdxTyDecl (unLoc tc_decl) -- index type definitions + then return ( sub_names) -- are usage occurences + else return (main_name : sub_names) } where (main_rdr : sub_rdrs) = tyClDeclNames (unLoc tc_decl) + + inst_ats inst_decl + = mappM new_tc (instDeclATs (unLoc inst_decl)) \end{code} @@ -516,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] @@ -559,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 @@ -725,7 +755,7 @@ check_occs ie occs names | otherwise -- Same occ name but different names: an error -> do { global_env <- getGlobalRdrEnv ; - addErr (exportClashErr global_env name name' ie ie') ; + addErr (exportClashErr global_env name' name ie' ie) ; returnM occs } where name_occ = nameOccName name @@ -753,8 +783,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 +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