X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2Frename%2FRnNames.lhs;h=84568d97731546139feeff971f8545eda1991839;hp=d82bea968ca46b797f80b876c5eb153bc7f0c463;hb=e95ee1f718c6915c478005aad8af81705357d6ab;hpb=4917397e279b0aa755eb09e1ca62913237132895 diff --git a/compiler/rename/RnNames.lhs b/compiler/rename/RnNames.lhs index d82bea9..84568d9 100644 --- a/compiler/rename/RnNames.lhs +++ b/compiler/rename/RnNames.lhs @@ -6,7 +6,8 @@ \begin{code} module RnNames ( rnImports, getLocalNonValBinders, - rnExports, extendGlobalRdrEnvRn, + rnExports, extendGlobalRdrEnvRn, + gresFromAvails, reportUnusedNames, finishWarnings, ) where @@ -19,7 +20,7 @@ import RnEnv import RnHsDoc ( rnHsDoc ) import IfaceEnv ( ifaceExportNames ) import LoadIface ( loadSrcInterface, loadSysInterface ) -import TcRnMonad hiding (LIE) +import TcRnMonad import HeaderInfo ( mkPrelImports ) import PrelNames @@ -32,7 +33,6 @@ import RdrName import Outputable import Maybes import SrcLoc -import FiniteMap import ErrUtils import Util import FastString @@ -41,6 +41,8 @@ import Data.List ( partition, (\\), delete ) import qualified Data.Set as Set import System.IO import Control.Monad +import Data.Map (Map) +import qualified Data.Map as Map \end{code} @@ -69,10 +71,11 @@ rnImports imports when (notNull prel_imports) $ addWarn (implicitPreludeWarn) ) - stuff1 <- mapM (rnImportDecl this_mod) (prel_imports ++ ordinary) - stuff2 <- mapM (rnImportDecl this_mod) source - let (decls, rdr_env, imp_avails,hpc_usage) = combine (stuff1 ++ stuff2) - return (decls, rdr_env, imp_avails,hpc_usage) + stuff1 <- mapM (rnImportDecl this_mod True) prel_imports + stuff2 <- mapM (rnImportDecl this_mod False) ordinary + stuff3 <- mapM (rnImportDecl this_mod False) source + let (decls, rdr_env, imp_avails, hpc_usage) = combine (stuff1 ++ stuff2 ++ stuff3) + return (decls, rdr_env, imp_avails, hpc_usage) where combine :: [(LImportDecl Name, GlobalRdrEnv, ImportAvails,AnyHpcUsage)] @@ -85,11 +88,11 @@ rnImports imports imp_avails1 `plusImportAvails` imp_avails2, hpc_usage1 || hpc_usage2) -rnImportDecl :: Module +rnImportDecl :: Module -> Bool -> LImportDecl RdrName -> RnM (LImportDecl Name, GlobalRdrEnv, ImportAvails,AnyHpcUsage) -rnImportDecl this_mod (L loc (ImportDecl loc_imp_mod_name mb_pkg want_boot +rnImportDecl this_mod implicit_prelude (L loc (ImportDecl loc_imp_mod_name mb_pkg want_boot qual_only as_mod imp_details)) = setSrcSpan loc $ do @@ -103,6 +106,17 @@ rnImportDecl this_mod (L loc (ImportDecl loc_imp_mod_name mb_pkg want_boot imp_mod_name = unLoc loc_imp_mod_name doc = ppr imp_mod_name <+> ptext (sLit "is directly imported") + let isExplicit lie = case unLoc lie of + IEThingAll _ -> False + _ -> True + case imp_details of + Just (False, lies) + | all isExplicit lies -> + return () + _ -> + unless implicit_prelude $ + ifOptM Opt_WarnMissingImportList (addWarn (missingImportListWarn imp_mod_name)) + iface <- loadSrcInterface doc imp_mod_name want_boot mb_pkg -- Compiler sanity check: if the import didn't say @@ -260,23 +274,34 @@ top level binders specially in two ways 2. We make them *shadow* the outer bindings. If we don't do that, we'll get a complaint when extending the GlobalRdrEnv, saying that - there are two bindings for 'f'. - - This shadowing applies even if the binding for 'f' is in a - where-clause, and hence is in the *local* RdrEnv not the *global* - RdrEnv. - -We find out whether we are inside a [d| ... |] by testing the TH -stage. This is a slight hack, because the stage field was really meant for -the type checker, and here we are not interested in the fields of Brack, -hence the error thunks in thRnBrack. + there are two bindings for 'f'. There are several tricky points: + + * This shadowing applies even if the binding for 'f' is in a + where-clause, and hence is in the *local* RdrEnv not the *global* + RdrEnv. + + * The *qualified* name M.f from the enclosing module must certainly + still be available. So we don't nuke it entirely; we just make + it seem like qualified import. + + * We only shadow *External* names (which come from the main module) + Do not shadow *Inernal* names because in the bracket + [d| class C a where f :: a + f = 4 |] + rnSrcDecls will first call extendGlobalRdrEnvRn with C[f] from the + class decl, and *separately* extend the envt with the value binding. + +3. We find out whether we are inside a [d| ... |] by testing the TH + stage. This is a slight hack, because the stage field was really + meant for the type checker, and here we are not interested in the + fields of Brack, hence the error thunks in thRnBrack. \begin{code} extendGlobalRdrEnvRn :: [AvailInfo] -> MiniFixityEnv -> RnM (TcGblEnv, TcLclEnv) -- Updates both the GlobalRdrEnv and the FixityEnv - -- We return a new TcLclEnv only becuase we might have to + -- We return a new TcLclEnv only because we might have to -- delete some bindings from it; -- see Note [Top-level Names in Template Haskell decl quotes] @@ -292,7 +317,7 @@ extendGlobalRdrEnvRn avails new_fixities -- See Note [Top-level Names in Template Haskell decl quotes] shadowP = isBrackStage stage new_occs = map (nameOccName . gre_name) gres - rdr_env1 = hideSomeUnquals rdr_env new_occs + rdr_env1 = transformGREs qual_gre new_occs rdr_env lcl_env1 = lcl_env { tcl_rdr = delListFromOccEnv (tcl_rdr lcl_env) new_occs } (rdr_env2, lcl_env2) | shadowP = (rdr_env1, lcl_env1) | otherwise = (rdr_env, lcl_env) @@ -319,6 +344,35 @@ extendGlobalRdrEnvRn avails new_fixities where name = gre_name gre occ = nameOccName name + + qual_gre :: GlobalRdrElt -> GlobalRdrElt + -- Transform top-level GREs from the module being compiled + -- so that they are out of the way of new definitions in a Template + -- Haskell bracket + -- See Note [Top-level Names in Template Haskell decl quotes] + -- Seems like 5 times as much work as it deserves! + -- + -- For a LocalDef we make a (fake) qualified imported GRE for a + -- local GRE so that the original *qualified* name is still in scope + -- but the *unqualified* one no longer is. What a hack! + + qual_gre gre@(GRE { gre_prov = LocalDef, gre_name = name }) + | isExternalName name = gre { gre_prov = Imported [imp_spec] } + | otherwise = gre + -- Do not shadow Internal (ie Template Haskell) Names + -- See Note [Top-level Names in Template Haskell decl quotes] + where + mod = ASSERT2( isExternalName name, ppr name) moduleName (nameModule name) + imp_spec = ImpSpec { is_item = ImpAll, is_decl = decl_spec } + decl_spec = ImpDeclSpec { is_mod = mod, is_as = mod, + is_qual = True, -- Qualified only! + is_dloc = srcLocSpan (nameSrcLoc name) } + + qual_gre gre@(GRE { gre_prov = Imported specs }) + = gre { gre_prov = Imported (map qual_spec specs) } + + qual_spec spec@(ImpSpec { is_decl = decl_spec }) + = spec { is_decl = decl_spec { is_qual = True } } \end{code} @getLocalDeclBinders@ returns the names for an @HsDecl@. It's @@ -376,8 +430,8 @@ getLocalNonValBinders :: HsGroup RdrName -> RnM [AvailInfo] -- Get all the top-level binders bound the group *except* -- for value bindings, which are treated separately -- Specificaly we return AvailInfo for --- type decls --- class decls +-- type decls (incl constructors and record selectors) +-- class decls (including class ops) -- associated types -- foreign imports -- (in hs-boot files) value signatures @@ -394,8 +448,7 @@ get_local_binders gbl_env (HsGroup {hs_valds = ValBindsIn _ val_sigs, = do { -- separate out the family instance declarations let (tyinst_decls1, tycl_decls_noinsts) = partition (isFamInstDecl . unLoc) tycl_decls - tyinst_decls = tyinst_decls1 ++ - concatMap (instDeclATs . unLoc) inst_decls + tyinst_decls = tyinst_decls1 ++ instDeclATs inst_decls -- process all type/class decls except family instances ; tc_names <- mapM new_tc tycl_decls_noinsts @@ -411,7 +464,6 @@ get_local_binders gbl_env (HsGroup {hs_valds = ValBindsIn _ val_sigs, ; val_names <- mapM new_simple val_bndrs ; return (val_names ++ tc_names ++ ti_names) } where - mod = tcg_mod gbl_env is_hs_boot = isHsBoot (tcg_src gbl_env) ; for_hs_bndrs :: [Located RdrName] @@ -425,23 +477,23 @@ get_local_binders gbl_env (HsGroup {hs_valds = ValBindsIn _ val_sigs, new_simple :: Located RdrName -> RnM (GenAvailInfo Name) new_simple rdr_name = do - nm <- newTopSrcBinder mod rdr_name + nm <- newTopSrcBinder rdr_name return (Avail nm) new_tc tc_decl -- NOT for type/data instances - = do { main_name <- newTopSrcBinder mod main_rdr - ; sub_names <- mapM (newTopSrcBinder mod) sub_rdrs + = do { main_name <- newTopSrcBinder main_rdr + ; sub_names <- mapM newTopSrcBinder sub_rdrs ; return (AvailTC main_name (main_name : sub_names)) } where - (main_rdr : sub_rdrs) = tyClDeclNames (unLoc tc_decl) + (main_rdr : sub_rdrs) = hsTyClDeclBinders tc_decl new_ti tc_name_env ti_decl -- ONLY for type/data instances = do { main_name <- lookupFamInstDeclBndr tc_name_env main_rdr - ; sub_names <- mapM (newTopSrcBinder mod) sub_rdrs + ; sub_names <- mapM newTopSrcBinder sub_rdrs ; return (AvailTC main_name sub_names) } -- main_name is not bound here! where - (main_rdr : sub_rdrs) = tyClDeclNames (unLoc ti_decl) + (main_rdr : sub_rdrs) = hsTyClDeclBinders ti_decl get_local_binders _ g = pprPanic "get_local_binders" (ppr g) \end{code} @@ -549,7 +601,8 @@ filterImports iface decl_spec (Just (want_hiding, import_items)) all_avails -- different parents). See the discussion at occ_env. lookup_ie :: Bool -> IE RdrName -> MaybeErr Message [(IE Name,AvailInfo)] lookup_ie opt_typeFamilies ie - = let bad_ie = Failed (badImportItemErr iface decl_spec ie) + = let bad_ie :: MaybeErr Message a + bad_ie = Failed (badImportItemErr iface decl_spec ie) lookup_name rdr | isQual rdr = Failed (qualImportItemErr rdr) @@ -1204,7 +1257,7 @@ findImportUsage :: [LImportDecl Name] -> [RdrName] -> [ImportDeclUsage] -type ImportMap = FiniteMap SrcLoc [AvailInfo] +type ImportMap = Map SrcLoc [AvailInfo] -- The intermediate data struture records, for each import -- declaration, what stuff brought into scope by that -- declaration is actually used in the module. @@ -1219,12 +1272,12 @@ findImportUsage imports rdr_env rdrs = map unused_decl imports where import_usage :: ImportMap - import_usage = foldr add_rdr emptyFM rdrs + import_usage = foldr add_rdr Map.empty rdrs unused_decl decl@(L loc (ImportDecl { ideclHiding = imps })) = (decl, nubAvails used_avails, unused_imps) where - used_avails = lookupFM import_usage (srcSpanStart loc) `orElse` [] + used_avails = Map.lookup (srcSpanStart loc) import_usage `orElse` [] used_names = availsToNameSet used_avails unused_imps = case imps of @@ -1244,9 +1297,9 @@ findImportUsage imports rdr_env rdrs add_imp :: GlobalRdrElt -> ImportSpec -> ImportMap -> ImportMap add_imp gre (ImpSpec { is_decl = imp_decl_spec }) iu - = addToFM_C add iu decl_loc [avail] + = Map.insertWith add decl_loc [avail] iu where - add avails _ = avail : avails + add _ avails = avail : avails -- add is really just a specialised (++) decl_loc = srcSpanStart (is_dloc imp_decl_spec) name = gre_name gre avail = case gre_par gre of @@ -1448,6 +1501,10 @@ nullModuleExport :: ModuleName -> SDoc nullModuleExport mod = ptext (sLit "The export item `module") <+> ppr mod <> ptext (sLit "' exports nothing") +missingImportListWarn :: ModuleName -> SDoc +missingImportListWarn mod + = ptext (sLit "The module") <+> quotes (ppr mod) <+> ptext (sLit "does not have an explicit import list") + moduleWarn :: ModuleName -> WarningTxt -> SDoc moduleWarn mod (WarningTxt txt) = sep [ ptext (sLit "Module") <+> quotes (ppr mod) <> ptext (sLit ":"),