From ae3ba7ec40abde9719c98bd4d54832f9ea910e8b Mon Sep 17 00:00:00 2001 From: Lemmih Date: Fri, 24 Feb 2006 15:47:04 +0000 Subject: [PATCH] Rather large refactoring of RnNames. This restructoring makes the renamed export and import lists available in IDE mode. --- ghc/compiler/main/GHC.hs | 2 +- ghc/compiler/main/HscMain.lhs | 17 +- ghc/compiler/rename/RnNames.lhs | 455 +++++++++++++++++++++------------ ghc/compiler/typecheck/TcRnDriver.lhs | 20 +- ghc/compiler/typecheck/TcRnMonad.lhs | 2 + ghc/compiler/typecheck/TcRnTypes.lhs | 8 +- 6 files changed, 321 insertions(+), 183 deletions(-) diff --git a/ghc/compiler/main/GHC.hs b/ghc/compiler/main/GHC.hs index 85f62f3..e8e093b 100644 --- a/ghc/compiler/main/GHC.hs +++ b/ghc/compiler/main/GHC.hs @@ -730,7 +730,7 @@ data CheckedModule = -- fields within CheckedModule. type ParsedSource = Located (HsModule RdrName) -type RenamedSource = HsGroup Name +type RenamedSource = (HsGroup Name, [LImportDecl Name], Maybe [LIE Name]) type TypecheckedSource = LHsBinds Id -- NOTE: diff --git a/ghc/compiler/main/HscMain.lhs b/ghc/compiler/main/HscMain.lhs index 2b9ae6c..43a140b 100644 --- a/ghc/compiler/main/HscMain.lhs +++ b/ghc/compiler/main/HscMain.lhs @@ -40,7 +40,7 @@ import VarEnv ( emptyTidyEnv ) import Var ( Id ) import Module ( emptyModuleEnv, ModLocation(..) ) import RdrName ( GlobalRdrEnv, RdrName ) -import HsSyn ( HsModule, LHsBinds, HsGroup ) +import HsSyn ( HsModule, LHsBinds, HsGroup, LIE, LImportDecl ) import SrcLoc ( Located(..) ) import StringBuffer ( hGetStringBuffer, stringToStringBuffer ) import Parser @@ -133,9 +133,12 @@ data HscResult -- In IDE mode: we just do the static/dynamic checks | HscChecked - (Located (HsModule RdrName)) -- parsed - (Maybe (HsGroup Name)) -- renamed - (Maybe (LHsBinds Id, GlobalRdrEnv, ModDetails)) -- typechecked + -- parsed + (Located (HsModule RdrName)) + -- renamed + (Maybe (HsGroup Name,[LImportDecl Name],Maybe [LIE Name])) + -- typechecked + (Maybe (LHsBinds Id, GlobalRdrEnv, ModDetails)) -- Concluded that it wasn't necessary | HscNoRecomp ModDetails -- new details (HomeSymbolTable additions) @@ -339,8 +342,12 @@ hscFileCheck hsc_env mod_summary = do { md_rules = [panic "no rules"] } -- Rules are CoreRules, not the -- RuleDecls we get out of the typechecker + rnInfo = do decl <- tcg_rn_decls tc_result + imports <- tcg_rn_imports tc_result + let exports = tcg_rn_exports tc_result + return (decl,imports,exports) return (HscChecked rdr_module - (tcg_rn_decls tc_result) + rnInfo (Just (tcg_binds tc_result, tcg_rdr_env tc_result, md))) diff --git a/ghc/compiler/rename/RnNames.lhs b/ghc/compiler/rename/RnNames.lhs index 4cdb241..6e2bb6f 100644 --- a/ghc/compiler/rename/RnNames.lhs +++ b/ghc/compiler/rename/RnNames.lhs @@ -5,10 +5,10 @@ \begin{code} module RnNames ( - rnImports, importsFromLocalDecls, - rnExports, + rnImports, mkRdrEnvAndImports, importsFromLocalDecls, + rnExports, mkExportNameSet, getLocalDeclBinders, extendRdrEnvRn, - reportUnusedNames, reportDeprecations, + reportUnusedNames, reportDeprecations, mkModDeps ) where @@ -17,12 +17,12 @@ module RnNames ( import DynFlags ( DynFlag(..), GhcMode(..) ) import HsSyn ( IE(..), ieName, ImportDecl(..), LImportDecl, ForeignDecl(..), HsGroup(..), HsValBinds(..), - Sig(..), collectHsBindLocatedBinders, tyClDeclNames - ) + Sig(..), collectHsBindLocatedBinders, tyClDeclNames, + LIE ) import RnEnv import IfaceEnv ( ifaceExportNames ) import LoadIface ( loadSrcInterface ) -import TcRnMonad +import TcRnMonad hiding (LIE) import FiniteMap import PrelNames ( pRELUDE, isUnboundName, main_RDR_Unqual ) @@ -70,52 +70,36 @@ import IO ( openFile, IOMode(..) ) %************************************************************************ \begin{code} -rnImports :: [LImportDecl RdrName] - -> RnM (GlobalRdrEnv, ImportAvails) - +rnImports :: [LImportDecl RdrName] -> RnM [LImportDecl Name] rnImports imports - = do { -- PROCESS IMPORT DECLS - -- Do the non {- SOURCE -} ones first, so that we get a helpful - -- warning for {- SOURCE -} ones that are unnecessary - this_mod <- getModule - ; implicit_prelude <- doptM Opt_ImplicitPrelude - ; let - all_imports = mk_prel_imports this_mod implicit_prelude ++ imports - (source, ordinary) = partition is_source_import all_imports - is_source_import (L _ (ImportDecl _ is_boot _ _ _)) = is_boot - - get_imports = importsFromImportDecl this_mod - - ; stuff1 <- mappM get_imports ordinary - ; stuff2 <- mappM get_imports source - - -- COMBINE RESULTS - ; let - (imp_gbl_envs, imp_avails) = unzip (stuff1 ++ stuff2) - gbl_env :: GlobalRdrEnv - gbl_env = foldr plusGlobalRdrEnv emptyGlobalRdrEnv imp_gbl_envs - - all_avails :: ImportAvails - all_avails = foldr plusImportAvails emptyImportAvails imp_avails - - -- ALL DONE - ; return (gbl_env, all_avails) } - where - -- NB: opt_NoImplicitPrelude is slightly different to import Prelude (); - -- because the former doesn't even look at Prelude.hi for instance - -- declarations, whereas the latter does. - mk_prel_imports this_mod implicit_prelude - | this_mod == pRELUDE - || explicit_prelude_import - || not implicit_prelude - = [] - - | otherwise = [preludeImportDecl] - - explicit_prelude_import - = notNull [ () | L _ (ImportDecl mod _ _ _ _) <- imports, - unLoc mod == pRELUDE ] - + -- PROCESS IMPORT DECLS + -- Do the non {- SOURCE -} ones first, so that we get a helpful + -- warning for {- SOURCE -} ones that are unnecessary + = do this_mod <- getModule + implicit_prelude <- doptM Opt_ImplicitPrelude + let all_imports = mk_prel_imports this_mod implicit_prelude ++ imports + (source, ordinary) = partition is_source_import all_imports + is_source_import (L _ (ImportDecl _ is_boot _ _ _)) = is_boot + get_imports = importsFromImportDeclDirect this_mod + + stuff1 <- mapM get_imports ordinary + stuff2 <- mapM get_imports source + return (stuff1 ++ stuff2) + where +-- NB: opt_NoImplicitPrelude is slightly different to import Prelude (); +-- because the former doesn't even look at Prelude.hi for instance +-- declarations, whereas the latter does. + mk_prel_imports this_mod implicit_prelude + | this_mod == pRELUDE + || explicit_prelude_import + || not implicit_prelude + = [] + | otherwise = [preludeImportDecl] + explicit_prelude_import + = notNull [ () | L _ (ImportDecl mod _ _ _ _) <- imports, + unLoc mod == pRELUDE ] + +preludeImportDecl :: LImportDecl RdrName preludeImportDecl = L loc $ ImportDecl (L loc pRELUDE) @@ -124,12 +108,152 @@ preludeImportDecl Nothing {- No "as" -} Nothing {- No import list -} where - loc = mkGeneralSrcSpan FSLIT("Implicit import declaration") + loc = mkGeneralSrcSpan FSLIT("Implicit import declaration") + +mkRdrEnvAndImports :: [LImportDecl Name] -> RnM (GlobalRdrEnv, ImportAvails) +mkRdrEnvAndImports imports + = do this_mod <- getModule + let get_imports = importsFromImportDecl this_mod + stuff <- mapM get_imports imports + let (imp_gbl_envs, imp_avails) = unzip stuff + gbl_env :: GlobalRdrEnv + gbl_env = foldr plusGlobalRdrEnv emptyGlobalRdrEnv imp_gbl_envs + + all_avails :: ImportAvails + all_avails = foldr plusImportAvails emptyImportAvails imp_avails + -- ALL DONE + return (gbl_env, all_avails) + \end{code} \begin{code} +rnImportDecl :: ModIface -> ImpDeclSpec -> ImportDecl RdrName -> NameSet -> RnM (ImportDecl Name) +rnImportDecl iface decl_spec (ImportDecl loc_imp_mod_name want_boot qual_only as_mod Nothing) all_names + = return $ ImportDecl loc_imp_mod_name want_boot qual_only as_mod Nothing +rnImportDecl iface decl_spec (ImportDecl loc_imp_mod_name want_boot qual_only as_mod (Just (want_hiding,import_items))) all_names + = do import_items_mbs <- mapM (srcSpanWrapper) import_items + let rn_import_items = concat . catMaybes $ import_items_mbs + return $ ImportDecl loc_imp_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 + Nothing + -> do addErr (badImportItemErr iface decl_spec ieRdr) + return Nothing + Just ieNames + -> return (Just [L span ie | ie <- ieNames]) + occ_env :: OccEnv Name -- Maps OccName to corresponding Name + occ_env = mkOccEnv [(nameOccName n, n) | n <- nameSetToList all_names] + -- This env will have entries for data constructors too, + -- they won't make any difference because naked entities like T + -- in an import list map to TcOccs, not VarOccs. + + sub_env :: NameEnv [Name] + sub_env = mkSubNameEnv all_names + + get_item :: IE RdrName -> Maybe [IE Name] + -- Empty result for a bad item. + -- Singleton result is typical case. + -- Can have two when we are hiding, and mention C which might be + -- both a class and a data constructor. + get_item item@(IEModuleContents _) + = Nothing + + get_item (IEThingAll tc) + = do name <- check_name tc + return [IEThingAll name] +{- + -> -- This occurs when you import T(..), but + -- only export T abstractly. The single [n] + -- in the AvailTC is the type or class itself + ifOptM Opt_WarnDodgyImports (addWarn (dodgyImportWarn tc)) `thenM_` + return [ IEThingAll n ] + + names -> return [ IEThingAll n | n <- names ] +-} + + get_item (IEThingAbs tc) + | want_hiding -- hiding ( C ) + -- Here the 'C' can be a data constructor + -- *or* a type/class, or even both + = case catMaybes [check_name tc, check_name (setRdrNameSpace tc srcDataName)] of + [] -> Nothing + names -> return [ IEThingAbs n | n <- names ] + | otherwise + = do name <- check_name tc + return [IEThingAbs name] + get_item (IEThingWith n ns) -- import (C (A,B)) + = do name <- check_name n + let env = mkOccEnv [(nameOccName s, s) | s <- subNames sub_env name] + mb_names = map (lookupOccEnv env . rdrNameOcc) ns + names <- sequence mb_names + return [IEThingWith name names] + + get_item (IEVar n) + = do name <- check_name n + return [IEVar name] + + check_name :: RdrName -> Maybe Name + check_name rdrName + = lookupOccEnv occ_env (rdrNameOcc rdrName) + + +importsFromImportDeclDirect :: Module + -> LImportDecl RdrName + -> RnM (LImportDecl Name) +importsFromImportDeclDirect this_mod + (L loc importDecl@(ImportDecl loc_imp_mod_name want_boot qual_only as_mod imp_details)) + = setSrcSpan loc $ + do iface <- loadSrcInterface doc imp_mod_name want_boot + -- Compiler sanity check: if the import didn't say + -- {-# SOURCE #-} we should not get a hi-boot file + WARN( not want_boot && mi_boot iface, ppr imp_mod_name ) $ do + -- Issue a user warning for a redundant {- SOURCE -} import + -- NB that we arrange to read all the ordinary imports before + -- any of the {- SOURCE -} imports + warnIf (want_boot && not (mi_boot iface)) + (warnRedundantSourceImport imp_mod_name) + + let deprecs = mi_deprecs iface + is_orph = mi_orphan iface + deps = mi_deps iface + filtered_exports = filter not_this_mod (mi_exports iface) + not_this_mod (mod,_) = mod /= this_mod + imp_mod = mi_module iface + + -- If the module exports anything defined in this module, just ignore it. + -- Reason: otherwise it looks as if there are two local definition sites + -- for the thing, and an error gets reported. Easiest thing is just to + -- filter them out up front. This situation only arises if a module + -- imports itself, or another module that imported it. (Necessarily, + -- this invoves a loop.) + -- + -- Tiresome consequence: if you say + -- module A where + -- import B( AType ) + -- type AType = ... + -- + -- module B( AType ) where + -- import {-# SOURCE #-} A( AType ) + -- + -- then you'll get a 'B does not export AType' message. Oh well. + + qual_mod_name = case as_mod of + Nothing -> imp_mod_name + Just another_name -> another_name + imp_spec = ImpDeclSpec { is_mod = imp_mod_name, is_qual = qual_only, + is_dloc = loc, is_as = qual_mod_name } + + -- Get the total imports, and filter them according to the import list + total_avails <- ifaceExportNames filtered_exports + importDecl' <- rnImportDecl iface imp_spec importDecl total_avails + return (L loc importDecl') + where imp_mod_name = unLoc loc_imp_mod_name + doc = ppr imp_mod_name <+> ptext SLIT("is directly imported") + importsFromImportDecl :: Module - -> LImportDecl RdrName + -> LImportDecl Name -> RnM (GlobalRdrEnv, ImportAvails) importsFromImportDecl this_mod @@ -378,7 +502,7 @@ available, and filters it through the import spec (if any). \begin{code} filterImports :: ModIface -> ImpDeclSpec -- The span for the entire import decl - -> Maybe (Bool, [Located (IE RdrName)]) -- Import spec; True => hiding + -> Maybe (Bool, [LIE Name]) -- Import spec; True => hiding -> NameSet -- What's available -> RnM (NameSet, -- What's imported (qualified or unqualified) GlobalRdrEnv) -- Same again, but in GRE form @@ -393,36 +517,21 @@ mkGenericRdrEnv decl_spec names imp_spec = ImpSpec { is_decl = decl_spec, is_item = ImpAll } filterImports iface decl_spec Nothing all_names - = returnM (all_names, mkGenericRdrEnv decl_spec all_names) + = return (all_names, mkGenericRdrEnv decl_spec all_names) filterImports iface decl_spec (Just (want_hiding, import_items)) all_names - = mappM (addLocM get_item) import_items `thenM` \ gres_s -> - let - gres = concat gres_s - specified_names = mkNameSet (map gre_name gres) - in - if not want_hiding then - return (specified_names, mkGlobalRdrEnv gres) - else - let - keep n = not (n `elemNameSet` specified_names) - pruned_avails = filterNameSet keep all_names - in - return (pruned_avails, mkGenericRdrEnv decl_spec pruned_avails) - + = mapM (addLocM get_item) import_items >>= \gres_s -> + let gres = concat gres_s + specified_names = mkNameSet (map gre_name gres) + in if not want_hiding then + return (specified_names, mkGlobalRdrEnv gres) + else let keep n = not (n `elemNameSet` specified_names) + pruned_avails = filterNameSet keep all_names + in return (pruned_avails, mkGenericRdrEnv decl_spec pruned_avails) where - occ_env :: OccEnv Name -- Maps OccName to corresponding Name - occ_env = mkOccEnv [(nameOccName n, n) | n <- nameSetToList all_names] - -- This env will have entries for data constructors too, - -- they won't make any difference because naked entities like T - -- in an import list map to TcOccs, not VarOccs. - - sub_env :: NameEnv [Name] + sub_env :: NameEnv [Name] -- Classify each name by its parent sub_env = mkSubNameEnv all_names - bale_out item = addErr (badImportItemErr iface decl_spec item) `thenM_` - returnM [] - succeed_with :: Bool -> [Name] -> RnM [GlobalRdrElt] succeed_with all_explicit names = do { loc <- getSrcSpanM @@ -435,46 +544,29 @@ filterImports iface decl_spec (Just (want_hiding, import_items)) all_names item_spec = ImpSome { is_explicit = explicit, is_iloc = loc } explicit = all_explicit || isNothing (nameParent_maybe name) - get_item :: IE RdrName -> RnM [GlobalRdrElt] + get_item :: IE Name -> RnM [GlobalRdrElt] -- Empty result for a bad item. -- Singleton result is typical case. -- Can have two when we are hiding, and mention C which might be -- both a class and a data constructor. get_item item@(IEModuleContents _) - = bale_out item + -- This case should be filtered out by 'rnImports'. + = panic "filterImports: IEModuleContents?" - get_item item@(IEThingAll tc) - = case check_item item of - [] -> bale_out item + get_item (IEThingAll name) + = case subNames sub_env name of + [] -> do ifOptM Opt_WarnDodgyImports (addWarn (dodgyImportWarn name)) + succeed_with False [name] + names -> succeed_with False (name:names) - [n] -> -- This occurs when you import T(..), but - -- only export T abstractly. The single [n] - -- in the AvailTC is the type or class itself - ifOptM Opt_WarnDodgyImports (addWarn (dodgyImportWarn tc)) `thenM_` - succeed_with False [n] + get_item (IEThingAbs name) + = succeed_with True [name] - names -> succeed_with False names + get_item (IEThingWith name names) + = succeed_with True (name:names) + get_item (IEVar name) + = succeed_with True [name] - get_item item@(IEThingAbs n) - | want_hiding -- hiding( C ) - -- Here the 'C' can be a data constructor - -- *or* a type/class, or even both - = case concat [check_item item, check_item (IEVar data_n)] of - [] -> bale_out item - names -> succeed_with True names - where - data_n = setRdrNameSpace n srcDataName - - get_item item - = case check_item item of - [] -> bale_out item - names -> succeed_with True names - - check_item :: IE RdrName -> [Name] - check_item item - = case lookupOccEnv occ_env (rdrNameOcc (ieName item)) of - Nothing -> [] - Just name -> filterAvail item name sub_env \end{code} @@ -504,23 +596,54 @@ type ExportAccum -- The type of the accumulating parameter of NameSet) -- The accumulated exported stuff emptyExportAccum = ([], emptyOccEnv, emptyNameSet) -type ExportOccMap = OccEnv (Name, IE RdrName) +type ExportOccMap = OccEnv (Name, IE Name) -- Tracks what a particular exported OccName -- in an export list refers to, and which item -- it came from. It's illegal to export two distinct things -- that have the same occurrence name - -rnExports :: Bool -- False => no 'module M(..) where' header at all - -> Maybe [Located (IE RdrName)] -- Nothing => no explicit export list - -> RnM NameSet +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 (foldModuleEnv unionNameSets emptyNameSet imp_env) + inLoc fn (L span x) + = do x' <- fn x + return (L span x') + 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 (IEThingWith rdrName rdrNames) + = do name <- lookupGlobalOccRn rdrName + let env = mkOccEnv [(nameOccName s, s) | s <- subNames sub_env name] + mb_names = map (lookupOccEnv env . rdrNameOcc) rdrNames + if any isNothing mb_names + then -- The export error will be reporting in 'mkExportNameSet' + return (IEThingWith name []) + else return (IEThingWith name (catMaybes mb_names)) + rnExport (IEModuleContents mod) + = return (IEModuleContents mod) + rn_exports <- mapM (inLoc rnExport) exports + return (Just rn_exports) + +mkExportNameSet :: Bool -- False => no 'module M(..) where' header at all + -> Maybe [LIE Name] -- Nothing => no explicit export list + -> RnM NameSet -- Complains if two distinct exports have same OccName -- Warns about identical exports. -- Complains about exports items not in scope -rnExports explicit_mod exports - = do { TcGblEnv { tcg_rdr_env = rdr_env, - tcg_imports = imports } <- getGblEnv ; +mkExportNameSet explicit_mod exports + = do TcGblEnv { tcg_rdr_env = rdr_env, + tcg_imports = imports } <- getGblEnv -- If the module header is omitted altogether, then behave -- as if the user had written "module Main(main) where..." @@ -528,13 +651,17 @@ rnExports explicit_mod exports -- written "module Main where ..." -- Reason: don't want to complain about 'main' not in scope -- in interactive mode - ghci_mode <- getGhciMode ; - let { real_exports - | explicit_mod = exports - | ghci_mode == Interactive = Nothing - | otherwise = Just [noLoc (IEVar main_RDR_Unqual)] } ; + ghci_mode <- getGhciMode + real_exports <- case () of + () | explicit_mod + -> return exports + | ghci_mode == Interactive + -> return Nothing + | otherwise + -> do mainName <- lookupGlobalOccRn main_RDR_Unqual + return (Just [noLoc (IEVar mainName)]) -- ToDo: the 'noLoc' here is unhelpful if 'main' turns out to be out of scope - exports_from_avail real_exports rdr_env imports } + exports_from_avail real_exports rdr_env imports exports_from_avail Nothing rdr_env imports @@ -546,16 +673,16 @@ exports_from_avail Nothing rdr_env imports isLocalGRE gre ]) exports_from_avail (Just items) rdr_env (ImportAvails { imp_env = imp_env }) - = foldlM do_litem emptyExportAccum items `thenM` \ (_, _, exports) -> - returnM exports + = do (_, _, exports) <- foldlM do_litem emptyExportAccum items + return exports where sub_env :: NameEnv [Name] -- Classify each name by its parent sub_env = mkSubNameEnv (foldModuleEnv unionNameSets emptyNameSet imp_env) - do_litem :: ExportAccum -> Located (IE RdrName) -> RnM ExportAccum + do_litem :: ExportAccum -> LIE Name -> RnM ExportAccum do_litem acc = addLocM (exports_from_item acc) - exports_from_item :: ExportAccum -> IE RdrName -> RnM ExportAccum + exports_from_item :: ExportAccum -> IE Name -> RnM ExportAccum exports_from_item acc@(mods, occs, exports) ie@(IEModuleContents mod) | mod `elem` mods -- Duplicate export of M = do { warn_dup_exports <- doptM Opt_WarnDuplicateExports ; @@ -564,48 +691,36 @@ exports_from_avail (Just items) rdr_env (ImportAvails { imp_env = imp_env }) | otherwise = case lookupModuleEnv imp_env mod of - Nothing -> addErr (modExportErr mod) `thenM_` - returnM acc - Just names - -> let - new_exports = filterNameSet (inScopeUnqual rdr_env) names - in - - -- This check_occs not only finds conflicts between this item - -- and others, but also internally within this item. That is, - -- if 'M.x' is in scope in several ways, we'll have several - -- members of mod_avails with the same OccName. - check_occs ie occs (nameSetToList new_exports) `thenM` \ occs' -> - returnM (mod:mods, occs', exports `unionNameSets` new_exports) + Nothing -> do addErr (modExportErr mod) + return acc + Just names + -> do let new_exports = filterNameSet (inScopeUnqual rdr_env) names + -- This check_occs not only finds conflicts between this item + -- and others, but also internally within this item. That is, + -- if 'M.x' is in scope in several ways, we'll have several + -- members of mod_avails with the same OccName. + occs' <- check_occs ie occs (nameSetToList new_exports) + return (mod:mods, occs', exports `unionNameSets` new_exports) exports_from_item acc@(mods, occs, exports) ie - = lookupGlobalOccRn (ieName ie) `thenM` \ name -> - if isUnboundName name then - returnM acc -- Avoid error cascade - else let - new_exports = filterAvail ie name sub_env - in - checkErr (not (null new_exports)) (exportItemErr ie) `thenM_` - checkForDodgyExport ie new_exports `thenM_` - check_occs ie occs new_exports `thenM` \ occs' -> - returnM (mods, occs', addListToNameSet exports new_exports) + = if isUnboundName (ieName ie) + then return acc -- Avoid error cascade + else let new_exports = filterAvail ie sub_env in + do checkErr (not (null new_exports)) (exportItemErr ie) + checkForDodgyExport ie new_exports + occs' <- check_occs ie occs new_exports + return (mods, occs', addListToNameSet exports new_exports) ------------------------------- -filterAvail :: IE RdrName -- Wanted - -> Name -- The Name of the ieName of the item +filterAvail :: IE Name -- Wanted -> NameEnv [Name] -- Maps type/class names to their sub-names - -> [Name] -- Empty if even one thing reqd is missing - -filterAvail (IEVar _) n subs = [n] -filterAvail (IEThingAbs _) n subs = [n] -filterAvail (IEThingAll _) n subs = n : subNames subs n -filterAvail (IEThingWith _ rdrs) n subs - | any isNothing mb_names = [] - | otherwise = n : catMaybes mb_names - where - env = mkOccEnv [(nameOccName s, s) | s <- subNames subs n] - mb_names = map (lookupOccEnv env . rdrNameOcc) rdrs -filterAvail (IEModuleContents _) _ _ = panic "filterAvail" + -> [Name] + +filterAvail (IEVar n) subs = [n] +filterAvail (IEThingAbs n) subs = [n] +filterAvail (IEThingAll n) subs = n : subNames subs n +filterAvail (IEThingWith n ns) subs = n : ns +filterAvail (IEModuleContents _) _ = panic "filterAvail" subNames :: NameEnv [Name] -> Name -> [Name] subNames env n = lookupNameEnv env n `orElse` [] @@ -628,7 +743,7 @@ inScopeUnqual :: GlobalRdrEnv -> Name -> Bool inScopeUnqual env n = any unQualOK (lookupGRE_Name env n) ------------------------------- -checkForDodgyExport :: IE RdrName -> [Name] -> RnM () +checkForDodgyExport :: IE Name -> [Name] -> RnM () checkForDodgyExport ie@(IEThingAll tc) [n] | isTcOcc (nameOccName n) = addWarn (dodgyExportWarn tc) -- This occurs when you export T(..), but @@ -639,7 +754,7 @@ checkForDodgyExport ie@(IEThingAll tc) [n] checkForDodgyExport _ _ = return () ------------------------------- -check_occs :: IE RdrName -> ExportOccMap -> [Name] -> RnM ExportOccMap +check_occs :: IE Name -> ExportOccMap -> [Name] -> RnM ExportOccMap check_occs ie occs names = foldlM check occs names where @@ -730,7 +845,7 @@ gre_is_used used_names gre = gre_name gre `elemNameSet` used_names %********************************************************* \begin{code} -reportUnusedNames :: Maybe [Located (IE RdrName)] -- Export list +reportUnusedNames :: Maybe [LIE RdrName] -- Export list -> TcGblEnv -> RnM () reportUnusedNames export_decls gbl_env = do { traceRn ((text "RUN") <+> (ppr (tcg_dus gbl_env))) @@ -970,8 +1085,8 @@ printMinimalImports imps = ptext SLIT("import") <+> ppr mod_name <> parens (fsep (punctuate comma (map ppr ies))) - to_ies (mod, avail_env) = mappM to_ie (availEnvElts avail_env) `thenM` \ ies -> - returnM (mod, ies) + to_ies (mod, avail_env) = do ies <- mapM to_ie (availEnvElts avail_env) + returnM (mod, ies) to_ie :: AvailInfo -> RnM (IE Name) -- The main trick here is that if we're importing all the constructors diff --git a/ghc/compiler/typecheck/TcRnDriver.lhs b/ghc/compiler/typecheck/TcRnDriver.lhs index dcf1636..ee0663e 100644 --- a/ghc/compiler/typecheck/TcRnDriver.lhs +++ b/ghc/compiler/typecheck/TcRnDriver.lhs @@ -53,6 +53,7 @@ import TcSimplify ( tcSimplifyTop ) import TcTyClsDecls ( tcTyAndClassDecls ) import LoadIface ( loadOrphanModules ) import RnNames ( importsFromLocalDecls, rnImports, rnExports, + mkRdrEnvAndImports, mkExportNameSet, reportUnusedNames, reportDeprecations ) import RnEnv ( lookupSrcOcc_maybe ) import RnSource ( rnSrcDecls, rnTyClDecls, checkModDeprec ) @@ -149,7 +150,7 @@ tcRnModule :: HscEnv -> Located (HsModule RdrName) -> IO (Messages, Maybe TcGblEnv) -tcRnModule hsc_env hsc_src save_rn_decls +tcRnModule hsc_env hsc_src save_rn_syntax (L loc (HsModule maybe_mod export_ies import_decls local_decls mod_deprec)) = do { showPass (hsc_dflags hsc_env) "Renamer/typechecker" ; @@ -161,8 +162,9 @@ tcRnModule hsc_env hsc_src save_rn_decls initTc hsc_env hsc_src this_mod $ setSrcSpan loc $ do { - -- Deal with imports; sets tcg_rdr_env, tcg_imports - (rdr_env, imports) <- rnImports import_decls ; + -- Deal with imports; + rn_imports <- rnImports import_decls ; + (rdr_env, imports) <- mkRdrEnvAndImports rn_imports ; let { dep_mods :: ModuleEnv (Module, IsBootInterface) ; dep_mods = imp_dep_mods imports @@ -189,7 +191,11 @@ tcRnModule hsc_env hsc_src save_rn_decls gbl { tcg_rdr_env = rdr_env, tcg_inst_env = extendInstEnvList (tcg_inst_env gbl) home_insts, tcg_imports = tcg_imports gbl `plusImportAvails` imports, - tcg_rn_decls = if save_rn_decls then + tcg_rn_imports = if save_rn_syntax then + Just rn_imports + else + Nothing, + tcg_rn_decls = if save_rn_syntax then Just emptyRnGroup else Nothing }) @@ -223,7 +229,8 @@ tcRnModule hsc_env hsc_src save_rn_decls reportDeprecations tcg_env ; -- Process the export list - exports <- rnExports (isJust maybe_mod) export_ies ; + rn_exports <- rnExports export_ies ; + exports <- mkExportNameSet (isJust maybe_mod) rn_exports ; -- Check whether the entire module is deprecated -- This happens only once per module @@ -231,6 +238,9 @@ tcRnModule hsc_env hsc_src save_rn_decls -- Add exports and deprecations to envt let { final_env = tcg_env { tcg_exports = exports, + tcg_rn_exports = if save_rn_syntax then + rn_exports + else Nothing, tcg_dus = tcg_dus tcg_env `plusDU` usesOnly exports, tcg_deprecs = tcg_deprecs tcg_env `plusDeprecs` mod_deprecs } diff --git a/ghc/compiler/typecheck/TcRnMonad.lhs b/ghc/compiler/typecheck/TcRnMonad.lhs index b334a51..3c5de73 100644 --- a/ghc/compiler/typecheck/TcRnMonad.lhs +++ b/ghc/compiler/typecheck/TcRnMonad.lhs @@ -98,6 +98,8 @@ initTc hsc_env hsc_src mod do_this tcg_imports = init_imports, tcg_home_mods = home_mods, tcg_dus = emptyDUs, + tcg_rn_imports = Nothing, + tcg_rn_exports = Nothing, tcg_rn_decls = Nothing, tcg_binds = emptyLHsBinds, tcg_deprecs = NoDeprecs, diff --git a/ghc/compiler/typecheck/TcRnTypes.lhs b/ghc/compiler/typecheck/TcRnTypes.lhs index 966eff1..62281b5 100644 --- a/ghc/compiler/typecheck/TcRnTypes.lhs +++ b/ghc/compiler/typecheck/TcRnTypes.lhs @@ -43,7 +43,8 @@ module TcRnTypes( #include "HsVersions.h" import HsSyn ( PendingSplice, HsOverLit, LRuleDecl, LForeignDecl, - ArithSeqInfo, DictBinds, LHsBinds, HsGroup ) + ArithSeqInfo, DictBinds, LHsBinds, LImportDecl, HsGroup, + IE ) import HscTypes ( FixityEnv, HscEnv, TypeEnv, TyThing, GenAvailInfo(..), AvailInfo, HscSource(..), @@ -62,7 +63,7 @@ import OccName ( OccEnv ) import Var ( Id, TyVar ) import VarEnv ( TidyEnv ) import Module -import SrcLoc ( SrcSpan, SrcLoc, srcSpanStart ) +import SrcLoc ( SrcSpan, SrcLoc, Located, srcSpanStart ) import VarSet ( IdSet ) import ErrUtils ( Messages, Message ) import UniqSupply ( UniqSupply ) @@ -217,6 +218,8 @@ data TcGblEnv -- collected initially in un-zonked form and are -- finally zonked in tcRnSrcDecls + tcg_rn_imports :: Maybe [LImportDecl Name], + tcg_rn_exports :: Maybe [Located (IE Name)], tcg_rn_decls :: Maybe (HsGroup Name), -- renamed decls, maybe -- Nothing <=> Don't retain renamed decls @@ -726,6 +729,7 @@ cmpInst (LitInst _ lit1 ty1 _) (LitInst _ lit2 ty2 _) = (lit1 `compare` lit2) ` %************************************************************************ \begin{code} +-- FIXME: Rename this. It clashes with (Located (IE ...)) type LIE = Bag Inst isEmptyLIE = isEmptyBag -- 1.7.10.4