X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2Frename%2FRnNames.lhs;h=4bca4fcaf48fd8b68dcd9356b47468fbc7327b14;hb=3932b76369acda843a6c998449bf953a7cb2f5fc;hp=d16e3d60f71c2c6dbc79436dc201eaa51f391f93;hpb=39fd94e2727715556805a85a7e803c337df950a9;p=ghc-hetmet.git diff --git a/compiler/rename/RnNames.lhs b/compiler/rename/RnNames.lhs index d16e3d6..4bca4fc 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 ( when ) \end{code} @@ -409,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) ; @@ -432,11 +448,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} @@ -515,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} @@ -558,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 @@ -614,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 @@ -1097,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