X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;ds=sidebyside;f=compiler%2Frename%2FRnNames.lhs;h=a6b021df8f375e29c958fea0b3578092b799ba31;hb=190f24892156953d73b55401d0467a6f1a88ce5d;hp=71d5c9b350a036eb86db71aa7f316d495d539151;hpb=61d2625ae2e6a4cdae2ffc92df828905e81c24cc;p=ghc-hetmet.git diff --git a/compiler/rename/RnNames.lhs b/compiler/rename/RnNames.lhs index 71d5c9b..a6b021d 100644 --- a/compiler/rename/RnNames.lhs +++ b/compiler/rename/RnNames.lhs @@ -17,8 +17,10 @@ import DynFlags ( DynFlag(..), GhcMode(..), DynFlags(..) ) import HsSyn ( IE(..), ieName, ImportDecl(..), LImportDecl, ForeignDecl(..), HsGroup(..), HsValBinds(..), Sig(..), collectHsBindLocatedBinders, tyClDeclNames, + instDeclATs, isIdxTyDecl, LIE ) import RnEnv +import RnHsDoc ( rnHsDoc ) import IfaceEnv ( ifaceExportNames ) import LoadIface ( loadSrcInterface ) import TcRnMonad hiding (LIE) @@ -28,7 +30,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 +59,7 @@ import DriverPhases ( isHsBoot ) import Util ( notNull ) import List ( partition ) import IO ( openFile, IOMode(..) ) +import Monad ( liftM, when ) \end{code} @@ -151,10 +154,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 +412,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) ; @@ -430,14 +445,24 @@ getLocalDeclBinders gbl_env (HsGroup {hs_valds = ValBindsIn val_decls val_sigs, sig_hs_bndrs = [nm | L _ (TypeSig nm _) <- val_sigs] val_hs_bndrs = collectHsBindLocatedBinders val_decls - for_hs_bndrs = [nm | L _ (ForeignImport nm _ _ _) <- foreign_decls] + 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,10 +541,19 @@ 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] - + get_item (IEGroup _ _) + = succeed_with False [] + get_item (IEDoc _) + = succeed_with False [] + get_item (IEDocNamed _) + = succeed_with False [] \end{code} @@ -559,33 +593,56 @@ 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) + rnExport (IEGroup lev doc) + = do rn_doc <- rnHsDoc doc + return (IEGroup lev rn_doc) + rnExport (IEDoc doc) + = do rn_doc <- rnHsDoc doc + return (IEDoc rn_doc) + rnExport (IEDocNamed str) + = return (IEDocNamed str) + + rn_exports <- mapM (wrapLocM rnExport) exports + return (Just rn_exports) + +filterOutDocs = filter notDoc + where + notDoc (L _ (IEGroup _ _)) = False + notDoc (L _ (IEDoc _)) = False + notDoc (L _ (IEDocNamed _)) = False + notDoc _ = True mkExportNameSet :: Bool -- False => no 'module M(..) where' header at all -> Maybe ([LIE Name], [LIE RdrName]) -- Nothing => no explicit export list @@ -615,7 +672,11 @@ mkExportNameSet explicit_mod exports return (Just ([noLoc (IEVar mainName)] ,[noLoc (IEVar main_RDR_Unqual)])) -- ToDo: the 'noLoc' here is unhelpful if 'main' turns out to be out of scope - exports_from_avail real_exports rdr_env imports + + -- we don't want to include Haddock comments + let real_exports' = fmap (\(a,b) -> (filterOutDocs a, filterOutDocs b)) real_exports + + exports_from_avail real_exports' rdr_env imports exports_from_avail Nothing rdr_env imports @@ -725,7 +786,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 +814,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 +1159,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