X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2Frename%2FRnNames.lhs;h=bc7146b0624429ef7ffdd8551ee37aaff1aac829;hp=738a0c4f4f9aec206ec6b59e5e74b6b3fff9af11;hb=6a05ec5ef5373f61b7f9f5bdc344483417fa801b;hpb=5ad61e1470db6dbc8279569c5ad1cc093f753ac0 diff --git a/compiler/rename/RnNames.lhs b/compiler/rename/RnNames.lhs index 738a0c4..bc7146b 100644 --- a/compiler/rename/RnNames.lhs +++ b/compiler/rename/RnNames.lhs @@ -4,60 +4,53 @@ \section[RnNames]{Extracting imported and top-level names in scope} \begin{code} +{-# OPTIONS -w #-} +-- The above warning supression flag is a temporary kludge. +-- While working on this module you are encouraged to remove it and fix +-- any warnings in the module. See +-- http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#Warnings +-- for details + module RnNames ( rnImports, importsFromLocalDecls, rnExports, getLocalDeclBinders, extendRdrEnvRn, - reportUnusedNames, reportDeprecations + reportUnusedNames, finishDeprecations, ) where #include "HsVersions.h" -import DynFlags ( DynFlag(..), GhcMode(..), DynFlags(..) ) +import DynFlags import HsSyn ( IE(..), ieName, ImportDecl(..), LImportDecl, - ForeignDecl(..), HsGroup(..), HsValBinds(..), + ForeignDecl(..), HsGroup(..), HsValBindsLR(..), Sig(..), collectHsBindLocatedBinders, tyClDeclNames, - instDeclATs, isIdxTyDecl, + instDeclATs, isFamInstDecl, LIE ) import RnEnv import RnHsDoc ( rnHsDoc ) import IfaceEnv ( ifaceExportNames ) -import LoadIface ( loadSrcInterface ) +import LoadIface ( loadSrcInterface, loadSysInterface ) import TcRnMonad hiding (LIE) import PrelNames import Module import Name import NameEnv +import UniqFM import NameSet -import OccName ( srcDataName, pprNonVarNameSpace, - occNameSpace, - OccEnv, mkOccEnv, lookupOccEnv, emptyOccEnv, - extendOccEnv ) -import HscTypes ( GenAvailInfo(..), AvailInfo, availNames, availName, - HomePackageTable, PackageIfaceTable, - mkPrintUnqualified, availsToNameSet, - Deprecs(..), ModIface(..), Dependencies(..), - lookupIfaceByModule, ExternalPackageState(..) - ) -import RdrName ( RdrName, rdrNameOcc, setRdrNameSpace, Parent(..), - GlobalRdrEnv, mkGlobalRdrEnv, GlobalRdrElt(..), - emptyGlobalRdrEnv, plusGlobalRdrEnv, globalRdrEnvElts, - extendGlobalRdrEnv, lookupGlobalRdrEnv, lookupGRE_Name, - Provenance(..), ImportSpec(..), ImpDeclSpec(..), ImpItemSpec(..), - importSpecLoc, importSpecModule, isLocalGRE, pprNameProvenance, - unQualSpecOK, qualSpecOK ) +import OccName +import HscTypes +import RdrName import Outputable import Maybes -import SrcLoc ( Located(..), mkGeneralSrcSpan, getLoc, - unLoc, noLoc, srcLocSpan, SrcSpan ) +import SrcLoc import FiniteMap import ErrUtils -import BasicTypes ( DeprecTxt ) +import BasicTypes ( DeprecTxt, Fixity ) import DriverPhases ( isHsBoot ) import Util import ListSetOps -import Data.List ( partition, concatMap ) +import Data.List ( partition, concatMap, (\\), delete ) import IO ( openFile, IOMode(..) ) import Monad ( when ) \end{code} @@ -72,7 +65,7 @@ import Monad ( when ) \begin{code} rnImports :: [LImportDecl RdrName] - -> RnM ([LImportDecl Name], GlobalRdrEnv, ImportAvails) + -> RnM ([LImportDecl Name], GlobalRdrEnv, ImportAvails,AnyHpcUsage) rnImports imports -- PROCESS IMPORT DECLS @@ -80,54 +73,62 @@ rnImports imports -- 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 + let prel_imports = mkPrelImports this_mod implicit_prelude imports + (source, ordinary) = partition is_source_import imports is_source_import (L _ (ImportDecl _ is_boot _ _ _)) = is_boot - stuff1 <- mapM (rnImportDecl this_mod) ordinary + ifOptM Opt_WarnImplicitPrelude ( + 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) = combine (stuff1 ++ stuff2) - return (decls, rdr_env, imp_avails) + let (decls, rdr_env, imp_avails,hpc_usage) = combine (stuff1 ++ stuff2) + return (decls, rdr_env, imp_avails,hpc_usage) where + combine :: [(LImportDecl Name, GlobalRdrEnv, ImportAvails,AnyHpcUsage)] + -> ([LImportDecl Name], GlobalRdrEnv, ImportAvails,AnyHpcUsage) + combine = foldr plus ([], emptyGlobalRdrEnv, emptyImportAvails,False) + where plus (decl, gbl_env1, imp_avails1,hpc_usage1) + (decls, gbl_env2, imp_avails2,hpc_usage2) + = (decl:decls, + gbl_env1 `plusGlobalRdrEnv` gbl_env2, + imp_avails1 `plusImportAvails` imp_avails2, + hpc_usage1 || hpc_usage2) + +mkPrelImports :: Module -> Bool -> [LImportDecl RdrName] -> [LImportDecl RdrName] +-- Consruct the implicit declaration "import Prelude" (or not) +-- -- 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, +mkPrelImports this_mod implicit_prelude import_decls + | this_mod == pRELUDE + || explicit_prelude_import + || not implicit_prelude + = [] + | otherwise = [preludeImportDecl] + where + explicit_prelude_import + = notNull [ () | L _ (ImportDecl mod _ _ _ _) <- import_decls, unLoc mod == pRELUDE_NAME ] - combine :: [(LImportDecl Name, GlobalRdrEnv, ImportAvails)] - -> ([LImportDecl Name], GlobalRdrEnv, ImportAvails) - combine = foldr plus ([], emptyGlobalRdrEnv, emptyImportAvails) - where plus (decl, gbl_env1, imp_avails1) - (decls, gbl_env2, imp_avails2) - = (decl:decls, - gbl_env1 `plusGlobalRdrEnv` gbl_env2, - imp_avails1 `plusImportAvails` imp_avails2) - -preludeImportDecl :: LImportDecl RdrName -preludeImportDecl - = L loc $ - ImportDecl (L loc pRELUDE_NAME) + preludeImportDecl :: LImportDecl RdrName + preludeImportDecl + = L loc $ + ImportDecl (L loc pRELUDE_NAME) False {- Not a boot interface -} False {- Not qualified -} Nothing {- No "as" -} Nothing {- No import list -} - where - loc = mkGeneralSrcSpan FSLIT("Implicit import declaration") - + loc = mkGeneralSrcSpan FSLIT("Implicit import declaration") + rnImportDecl :: Module -> LImportDecl RdrName - -> RnM (LImportDecl Name, GlobalRdrEnv, ImportAvails) + -> RnM (LImportDecl Name, GlobalRdrEnv, ImportAvails,AnyHpcUsage) rnImportDecl this_mod (L loc (ImportDecl loc_imp_mod_name want_boot qual_only as_mod imp_details)) @@ -155,7 +156,7 @@ rnImportDecl this_mod (L loc (ImportDecl loc_imp_mod_name want_boot let imp_mod = mi_module iface deprecs = mi_deprecs iface - is_orph = mi_orphan iface + orph_iface = mi_orphan iface has_finsts = mi_finsts iface deps = mi_deps iface @@ -198,9 +199,9 @@ rnImportDecl this_mod (L loc (ImportDecl loc_imp_mod_name want_boot let -- Compute new transitive dependencies - orphans | is_orph = ASSERT( not (imp_mod `elem` dep_orphs deps) ) - imp_mod : dep_orphs deps - | otherwise = dep_orphs deps + orphans | orph_iface = ASSERT( not (imp_mod `elem` dep_orphs deps) ) + imp_mod : dep_orphs deps + | otherwise = dep_orphs deps finsts | has_finsts = ASSERT( not (imp_mod `elem` dep_finsts deps) ) imp_mod : dep_finsts deps @@ -236,7 +237,7 @@ rnImportDecl this_mod (L loc (ImportDecl loc_imp_mod_name want_boot other -> False imports = ImportAvails { - imp_mods = unitModuleEnv imp_mod (imp_mod, import_all, loc), + imp_mods = unitModuleEnv imp_mod (imp_mod, [(qual_mod_name, import_all, loc)]), imp_orphs = orphans, imp_finsts = finsts, imp_dep_mods = mkModDeps dependent_mods, @@ -253,7 +254,7 @@ rnImportDecl this_mod (L loc (ImportDecl loc_imp_mod_name want_boot let new_imp_decl = L loc (ImportDecl loc_imp_mod_name want_boot qual_only as_mod new_imp_details) - returnM (new_imp_decl, gbl_env, imports) + returnM (new_imp_decl, gbl_env, imports, mi_hpc iface) ) warnRedundantSourceImport mod_name @@ -273,36 +274,82 @@ From the top-level declarations of this module produce * the ImportAvails created by its bindings. -Complain about duplicate bindings - \begin{code} -importsFromLocalDecls :: HsGroup RdrName -> RnM TcGblEnv -importsFromLocalDecls group +-- Bool determines shadowing: +-- true: names in the group should shadow other UnQuals +-- with the same OccName (used in Template Haskell) +-- false: duplicates should be reported as an error +-- +-- The UniqFM (OccName -> FixItem) associates a Name's OccName's +-- FastString with a fixity declaration (that needs the actual OccName +-- to be plugged in). This fixity must be brought into scope when such +-- a Name is. +importsFromLocalDecls :: Bool -> HsGroup RdrName -> UniqFM (Located Fixity) -> RnM TcGblEnv +importsFromLocalDecls shadowP group fixities = do { gbl_env <- getGblEnv ; avails <- getLocalDeclBinders gbl_env group - ; rdr_env' <- extendRdrEnvRn (tcg_rdr_env gbl_env) avails + ; (rdr_env', fix_env') <- extendRdrEnvRn shadowP (tcg_rdr_env gbl_env, + tcg_fix_env gbl_env) + avails fixities ; traceRn (text "local avails: " <> ppr avails) - ; returnM (gbl_env { tcg_rdr_env = rdr_env' }) + ; returnM (gbl_env { tcg_rdr_env = rdr_env', + tcg_fix_env = fix_env'}) } -extendRdrEnvRn :: GlobalRdrEnv -> [AvailInfo] -> RnM GlobalRdrEnv +-- Bool determines shadowing as in importsFromLocalDecls. +-- UniqFM FixItem is the same as in importsFromLocalDecls. +-- -- Add the new locally-bound names one by one, checking for duplicates as -- we do so. Remember that in Template Haskell the duplicates --- might *already be* in the GlobalRdrEnv from higher up the module -extendRdrEnvRn rdr_env avails - = foldlM add_local rdr_env (gresFromAvails LocalDef avails) - where - add_local rdr_env gre - | gres <- lookupGlobalRdrEnv rdr_env (nameOccName (gre_name gre)) - , (dup_gre:_) <- filter isLocalGRE gres -- Check for existing *local* defns - = do { addDupDeclErr (gre_name dup_gre) (gre_name gre) - ; return rdr_env } - | otherwise - = return (extendGlobalRdrEnv rdr_env gre) +-- might *already be* in the GlobalRdrEnv from higher up the module. +-- +-- Also update the FixityEnv with the fixities for the names brought into scope. +-- +-- Note that the return values are the extensions of the two inputs, +-- not the extras relative to them. +extendRdrEnvRn :: Bool -> (GlobalRdrEnv, NameEnv FixItem) + -> [AvailInfo] -> UniqFM (Located Fixity) -> RnM (GlobalRdrEnv, NameEnv FixItem) +extendRdrEnvRn shadowP (rdr_env, fix_env) avails fixities = + let -- if there is a fixity decl for the gre, + -- add it to the fixity env + extendFixEnv env gre = + let name = gre_name gre + occ = nameOccName name + curKey = occNameFS occ in + case lookupUFM fixities curKey of + Nothing -> env + Just (L _ fi) -> extendNameEnv env name (FixItem occ fi) + + (rdr_env_to_extend, extender) = + if shadowP + then -- when shadowing is on, + -- (1) we need to remove the existing Unquals for the + -- names we're extending the env with + -- (2) but extending the env is simple + let names = concatMap availNames avails + new_occs = map nameOccName names + trimmed_rdr_env = hideSomeUnquals rdr_env new_occs + in + (trimmed_rdr_env, + \(cur_rdr_env, cur_fix_env) -> \gre -> + return (extendGlobalRdrEnv cur_rdr_env gre, + extendFixEnv cur_fix_env gre)) + else -- when shadowing is off, + -- (1) we don't munge the incoming env + -- (2) but we need to check for dups when extending + (rdr_env, + \(cur_rdr_env, cur_fix_env) -> \gre -> + let gres = lookupGlobalRdrEnv cur_rdr_env (nameOccName (gre_name gre)) + in case filter isLocalGRE gres of -- Check for existing *local* defns + dup_gre:_ -> do { addDupDeclErr (gre_name dup_gre) (gre_name gre) + ; return (cur_rdr_env, cur_fix_env) } + [] -> return (extendGlobalRdrEnv cur_rdr_env gre, + extendFixEnv cur_fix_env gre)) + in foldlM extender (rdr_env_to_extend, fix_env) (gresFromAvails LocalDef avails) \end{code} @getLocalDeclBinders@ returns the names for an @HsDecl@. It's @@ -310,7 +357,7 @@ used for source code. *** See "THE NAMING STORY" in HsDecls **** -Instances of indexed types +Instances of type families ~~~~~~~~~~~~~~~~~~~~~~~~~~ Indexed data/newtype instances contain data constructors that we need to collect, too. Moreover, we need to descend into the data/newtypes instances @@ -322,11 +369,13 @@ raising a duplicate declaration error. So, we make a new name for it, but don't return it in the 'AvailInfo'. \begin{code} +-- Note: this function does NOT get the binders of the ValBinds that +-- will be bound during renaming getLocalDeclBinders :: TcGblEnv -> HsGroup RdrName -> RnM [AvailInfo] getLocalDeclBinders gbl_env (HsGroup {hs_valds = ValBindsIn val_decls val_sigs, - hs_tyclds = tycl_decls, - hs_instds = inst_decls, - hs_fords = foreign_decls }) + 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 @@ -334,21 +383,20 @@ getLocalDeclBinders gbl_env (HsGroup {hs_valds = ValBindsIn val_decls val_sigs, where mod = tcg_mod gbl_env is_hs_boot = isHsBoot (tcg_src gbl_env) ; - val_bndrs | is_hs_boot = sig_hs_bndrs - | otherwise = for_hs_bndrs ++ val_hs_bndrs - -- In a hs-boot file, the value binders come from the - -- *signatures*, and there should be no foreign binders + + for_hs_bndrs = [nm | L _ (ForeignImport nm _ _) <- foreign_decls] + + -- In a hs-boot file, the value binders come from the + -- *signatures*, and there should be no foreign binders + val_bndrs | is_hs_boot = [nm | L _ (TypeSig nm _) <- val_sigs] + | otherwise = for_hs_bndrs new_simple rdr_name = do nm <- newTopSrcBinder mod rdr_name return (Avail nm) - sig_hs_bndrs = [nm | L _ (TypeSig nm _) <- val_sigs] - val_hs_bndrs = collectHsBindLocatedBinders val_decls - for_hs_bndrs = [nm | L _ (ForeignImport nm _ _) <- foreign_decls] - new_tc tc_decl - | isIdxTyDecl (unLoc tc_decl) + | isFamInstDecl (unLoc tc_decl) = do { main_name <- lookupFamInstDeclBndr mod main_rdr ; sub_names <- mappM (newTopSrcBinder mod) sub_rdrs ; return (AvailTC main_name sub_names) } @@ -392,8 +440,8 @@ filterImports iface decl_spec Nothing all_avails filterImports iface decl_spec (Just (want_hiding, import_items)) all_avails = do -- check for errors, convert RdrNames to Names - opt_indexedtypes <- doptM Opt_IndexedTypes - items1 <- mapM (lookup_lie opt_indexedtypes) import_items + opt_typeFamilies <- doptM Opt_TypeFamilies + items1 <- mapM (lookup_lie opt_typeFamilies) import_items let items2 :: [(LIE Name, AvailInfo)] items2 = concat items1 @@ -411,21 +459,39 @@ filterImports iface decl_spec (Just (want_hiding, import_items)) all_avails return (Just (want_hiding, map fst items2), mkGlobalRdrEnv gres) where -- This environment is how we map names mentioned in the import - -- list to the actual Name they correspond to, and the family - -- that the Name belongs to (an AvailInfo). + -- list to the actual Name they correspond to, and the name family + -- that the Name belongs to (the AvailInfo). The situation is + -- complicated by associated families, which introduce a three-level + -- hierachy, where class = grand parent, assoc family = parent, and + -- data constructors = children. The occ_env entries for associated + -- families needs to capture all this information; hence, we have the + -- third component of the environment that gives the class name (= + -- grand parent) in case of associated families. -- -- 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. - occ_env :: OccEnv (Name,AvailInfo) - occ_env = mkOccEnv [ (nameOccName n, (n,a)) - | a <- all_avails, n <- availNames a ] + occ_env :: OccEnv (Name, -- the name + AvailInfo, -- the export item providing the name + Maybe Name) -- the parent of associated types + occ_env = mkOccEnv_C combine [ (nameOccName n, (n, a, Nothing)) + | a <- all_avails, n <- availNames a] + where + -- we know that (1) there are at most entries for one name, (2) their + -- first component is identical, (3) they are for tys/cls, and (4) one + -- entry has the name in its parent position (the other doesn't) + combine (name, AvailTC p1 subs1, Nothing) + (_ , AvailTC p2 subs2, Nothing) + = let + (parent, subs) = if p1 == name then (p2, subs1) else (p1, subs2) + in + (name, AvailTC name subs, Just parent) lookup_lie :: Bool -> LIE RdrName -> TcRn [(LIE Name, AvailInfo)] - lookup_lie opt_indexedtypes (L loc ieRdr) + lookup_lie opt_typeFamilies (L loc ieRdr) = do stuff <- setSrcSpan loc $ - case lookup_ie opt_indexedtypes ieRdr of + case lookup_ie opt_typeFamilies ieRdr of Failed err -> addErr err >> return [] Succeeded a -> return a checkDodgyImport stuff @@ -445,9 +511,12 @@ filterImports iface decl_spec (Just (want_hiding, import_items)) all_avails -- Returns Nothing on error. -- We return a list here, because in the case of an import -- item like C, if we are hiding, then C refers to *both* a - -- type/class and a data constructor. + -- type/class and a data constructor. Moreover, when we import + -- data constructors of an associated family, we need separate + -- AvailInfos for the data constructors and the family (as they have + -- different parents). See the discussion at occ_env. lookup_ie :: Bool -> IE RdrName -> MaybeErr Message [(IE Name,AvailInfo)] - lookup_ie opt_indexedtypes ie + lookup_ie opt_typeFamilies ie = let bad_ie = Failed (badImportItemErr iface decl_spec ie) lookup_name rdrName = @@ -457,12 +526,18 @@ filterImports iface decl_spec (Just (want_hiding, import_items)) all_avails in case ie of IEVar n -> do - (name,avail) <- lookup_name n + (name, avail, _) <- lookup_name n return [(IEVar name, trimAvail avail name)] IEThingAll tc -> do - (name,avail) <- lookup_name tc - return [(IEThingAll name, avail)] + (name, avail@(AvailTC name2 subs), mb_parent) <- lookup_name tc + case mb_parent of + -- non-associated ty/cls + Nothing -> return [(IEThingAll name, avail)] + -- associated ty + Just parent -> return [(IEThingAll name, + AvailTC name2 (subs \\ [name])), + (IEThingAll name, AvailTC parent [name])] IEThingAbs tc | want_hiding -- hiding ( C ) @@ -473,36 +548,42 @@ filterImports iface decl_spec (Just (want_hiding, import_items)) all_avails in case catMaybeErr [ tc_name, dc_name ] of [] -> bad_ie - names -> return [ (IEThingAbs n, trimAvail av n) - | (n,av) <- names ] + names -> return [mkIEThingAbs name | name <- names] | otherwise - -> do (name,avail) <- lookup_name tc - return [(IEThingAbs name, AvailTC name [name])] - - IEThingWith n ns -> do - (name,avail) <- lookup_name n - case avail of - AvailTC nm subnames | nm == name -> do - let env = mkOccEnv [ (nameOccName s, s) - | s <- subnames ] - let mb_children = map (lookupOccEnv env . rdrNameOcc) ns - children <- - if any isNothing mb_children - then bad_ie - else return (catMaybes mb_children) - -- check for proper import of indexed types - when (not opt_indexedtypes && any isTyConName children) $ - Failed (typeItemErr (head . filter isTyConName - $ children ) - (text "in import list")) - return [(IEThingWith name children, AvailTC name (name:children))] - - _otherwise -> bad_ie + -> do nameAvail <- lookup_name tc + return [mkIEThingAbs nameAvail] + + IEThingWith tc ns -> do + (name, AvailTC name2 subnames, mb_parent) <- lookup_name tc + let + env = mkOccEnv [(nameOccName s, s) | s <- subnames] + mb_children = map (lookupOccEnv env . rdrNameOcc) ns + children <- if any isNothing mb_children + then bad_ie + else return (catMaybes mb_children) + -- check for proper import of type families + when (not opt_typeFamilies && any isTyConName children) $ + Failed (typeItemErr (head . filter isTyConName $ children) + (text "in import list")) + case mb_parent of + -- non-associated ty/cls + Nothing -> return [(IEThingWith name children, + AvailTC name (name:children))] + -- associated ty + Just parent -> return [(IEThingWith name children, + AvailTC name children), + (IEThingWith name children, + AvailTC parent [name])] _other -> Failed illegalImportItemErr -- could be IEModuleContents, IEGroup, IEDoc, IEDocNamed -- all errors. + where + mkIEThingAbs (n, av, Nothing ) = (IEThingAbs n, trimAvail av n) + mkIEThingAbs (n, av, Just parent) = (IEThingAbs n, AvailTC parent [n]) + + catMaybeErr :: [MaybeErr err a] -> [a] catMaybeErr ms = [ a | Succeeded a <- ms ] \end{code} @@ -618,9 +699,18 @@ mkAvailEnv :: [AvailInfo] -> AvailEnv -- We want to combine these; addAvail does that mkAvailEnv avails = foldl addAvail emptyAvailEnv avails +-- After combining the avails, we need to ensure that the parent name is the +-- first entry in the list of subnames, if it is included at all. (Subsequent +-- functions rely on that.) +normaliseAvail :: AvailInfo -> AvailInfo +normaliseAvail avail@(Avail _) = avail +normaliseAvail (AvailTC name subs) = AvailTC name subs' + where + subs' = if name `elem` subs then name : (delete name subs) else subs + -- | combines 'AvailInfo's from the same family nubAvails :: [AvailInfo] -> [AvailInfo] -nubAvails avails = nameEnvElts (mkAvailEnv avails) +nubAvails avails = map normaliseAvail . nameEnvElts . mkAvailEnv $ avails \end{code} @@ -658,41 +748,44 @@ type ExportOccMap = OccEnv (Name, IE RdrName) -- 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 +rnExports :: Bool -- False => no 'module M(..) where' header at all -> Maybe [LIE RdrName] -- Nothing => no explicit export list - -> RnM (Maybe [LIE Name], [AvailInfo]) + -> TcGblEnv + -> RnM TcGblEnv -- 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_mod = this_mod, - tcg_rdr_env = rdr_env, - tcg_imports = imports } <- getGblEnv - +rnExports explicit_mod exports + tcg_env@(TcGblEnv { tcg_mod = this_mod, + tcg_rdr_env = rdr_env, + tcg_imports = imports }) + = do { -- If the module header is omitted altogether, then behave -- as if the user had written "module Main(main) where..." -- EXCEPT in interactive mode, when we behave as if he had -- written "module Main where ..." -- Reason: don't want to complain about 'main' not in scope -- in interactive mode - ghc_mode <- getGhcMode - real_exports <- - case () of - () | explicit_mod - -> return exports - | ghc_mode == Interactive - -> return Nothing - | otherwise - -> do mainName <- lookupGlobalOccRn main_RDR_Unqual - return (Just ([noLoc (IEVar main_RDR_Unqual)])) - -- ToDo: the 'noLoc' here is unhelpful if 'main' turns - -- out to be out of scope - - (exp_spec, avails) <- exports_from_avail real_exports rdr_env imports this_mod - - return (exp_spec, nubAvails avails) -- Combine families + ; dflags <- getDOpts + ; let real_exports + | explicit_mod = exports + | ghcLink dflags == LinkInMemory = Nothing + | otherwise = Just ([noLoc (IEVar main_RDR_Unqual)]) + -- ToDo: the 'noLoc' here is unhelpful if 'main' + -- turns out to be out of scope + + ; (rn_exports, avails) <- exports_from_avail real_exports rdr_env imports this_mod + ; let final_avails = nubAvails avails -- Combine families + + ; return (tcg_env { tcg_exports = final_avails, + tcg_rn_exports = case tcg_rn_exports tcg_env of + Nothing -> Nothing + Just _ -> rn_exports, + tcg_dus = tcg_dus tcg_env `plusDU` + usesOnly (availsToNameSet final_avails) }) } + exports_from_avail :: Maybe [LIE RdrName] -- Nothing => no explicit export list @@ -712,6 +805,7 @@ exports_from_avail Nothing rdr_env imports this_mod exports_from_avail (Just rdr_items) rdr_env imports this_mod = do (ie_names, _, exports) <- foldlM do_litem emptyExportAccum rdr_items + return (Just ie_names, exports) where do_litem :: ExportAccum -> LIE RdrName -> RnM ExportAccum @@ -720,6 +814,10 @@ exports_from_avail (Just rdr_items) rdr_env imports this_mod kids_env :: NameEnv [Name] -- Maps a parent to its in-scope children kids_env = mkChildEnv (globalRdrEnvElts rdr_env) + imported_modules = [ qual_name + | (_, xs) <- moduleEnvElts $ imp_mods imports, + (qual_name, _, _) <- xs ] + exports_from_item :: ExportAccum -> LIE RdrName -> RnM ExportAccum exports_from_item acc@(ie_names, occs, exports) (L loc ie@(IEModuleContents mod)) @@ -731,10 +829,14 @@ exports_from_avail (Just rdr_items) rdr_env imports this_mod | otherwise = do { implicit_prelude <- doptM Opt_ImplicitPrelude - ; let gres = filter (isModuleExported implicit_prelude mod) - (globalRdrEnvElts rdr_env) + ; let { exportValid = (mod `elem` imported_modules) + || (moduleName this_mod == mod) + ; gres = filter (isModuleExported implicit_prelude mod) + (globalRdrEnvElts rdr_env) + } - ; warnIf (null gres) (nullModuleExport mod) + ; checkErr exportValid (moduleNotImported mod) + ; warnIf (exportValid && null gres) (nullModuleExport mod) ; occs' <- check_occs ie occs (map gre_name gres) -- This check_occs not only finds conflicts @@ -768,8 +870,13 @@ exports_from_avail (Just rdr_items) rdr_env imports this_mod return (IEVar (gre_name gre), greAvail gre) lookup_ie (IEThingAbs rdr) - = do name <- lookupGlobalOccRn rdr - return (IEThingAbs name, AvailTC name [name]) + = do gre <- lookupGreRn rdr + let name = gre_name gre + case gre_par gre of + NoParent -> return (IEThingAbs name, + AvailTC name [name]) + ParentIs p -> return (IEThingAbs name, + AvailTC p [name]) lookup_ie ie@(IEThingAll rdr) = do name <- lookupGlobalOccRn rdr @@ -794,8 +901,8 @@ exports_from_avail (Just rdr_items) rdr_env imports this_mod then do addErr (exportItemErr ie) return (IEThingWith name [], AvailTC name [name]) else do let names = catMaybes mb_names - optIdxTypes <- doptM Opt_IndexedTypes - when (not optIdxTypes && any isTyConName names) $ + optTyFam <- doptM Opt_TypeFamilies + when (not optTyFam && any isTyConName names) $ addErr (typeItemErr ( head . filter isTyConName $ names ) @@ -868,13 +975,23 @@ check_occs ie occs names %********************************************************* \begin{code} -reportDeprecations :: DynFlags -> TcGblEnv -> RnM () -reportDeprecations dflags tcg_env - = ifOptM Opt_WarnDeprecations $ - do { (eps,hpt) <- getEpsAndHpt +finishDeprecations :: DynFlags -> Maybe DeprecTxt + -> TcGblEnv -> RnM TcGblEnv +-- (a) Report usasge of deprecated imports +-- (b) If the whole module is deprecated, update tcg_deprecs +-- All this happens only once per module +finishDeprecations dflags mod_deprec tcg_env + = do { (eps,hpt) <- getEpsAndHpt + ; ifOptM Opt_WarnDeprecations $ + mapM_ (check hpt (eps_PIT eps)) all_gres -- By this time, typechecking is complete, -- so the PIT is fully populated - ; mapM_ (check hpt (eps_PIT eps)) all_gres } + + -- Deal with a module deprecation; it overrides all existing deprecs + ; let new_deprecs = case mod_deprec of + Just txt -> DeprecAll txt + Nothing -> tcg_deprecs tcg_env + ; return (tcg_env { tcg_deprecs = new_deprecs }) } where used_names = allUses (tcg_dus tcg_env) -- Report on all deprecated uses; hence allUses @@ -882,7 +999,7 @@ reportDeprecations dflags tcg_env check hpt pit gre@(GRE {gre_name = name, gre_prov = Imported (imp_spec:_)}) | name `elemNameSet` used_names - , Just deprec_txt <- lookupDeprec dflags hpt pit gre + , Just deprec_txt <- lookupImpDeprec dflags hpt pit gre = addWarnAt (importSpecLoc imp_spec) (sep [ptext SLIT("Deprecated use of") <+> pprNonVarNameSpace (occNameSpace (nameOccName name)) <+> @@ -904,26 +1021,43 @@ reportDeprecations dflags tcg_env -- the defn of a non-deprecated thing, when changing a module's -- interface -lookupDeprec :: DynFlags -> HomePackageTable -> PackageIfaceTable - -> GlobalRdrElt -> Maybe DeprecTxt -lookupDeprec dflags hpt pit gre +lookupImpDeprec :: DynFlags -> HomePackageTable -> PackageIfaceTable + -> GlobalRdrElt -> Maybe DeprecTxt +-- The name is definitely imported, so look in HPT, PIT +lookupImpDeprec dflags hpt pit gre = case lookupIfaceByModule dflags hpt pit (nameModule name) of Just iface -> mi_dep_fn iface name `seqMaybe` -- Bleat if the thing, *or case gre_par gre of ParentIs p -> mi_dep_fn iface p -- its parent*, is deprec'd NoParent -> Nothing - Nothing - | isWiredInName name -> Nothing - -- We have not necessarily loaded the .hi file for a - -- wired-in name (yet), although we *could*. - -- And we never deprecate them - - | otherwise -> pprPanic "lookupDeprec" (ppr name) - -- By now all the interfaces should have been loaded + + Nothing -> Nothing -- See Note [Used names with interface not loaded] where name = gre_name gre \end{code} +Note [Used names with interface not loaded] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +By now all the interfaces should have been loaded, +because reportDeprecations happens after typechecking. +However, it's still (just) possible to to find a used +Name whose interface hasn't been loaded: + +a) It might be a WiredInName; in that case we may not load + its interface (although we could). + +b) It might be GHC.Real.fromRational, or GHC.Num.fromInteger + These are seen as "used" by the renamer (if -fno-implicit-prelude) + is on), but the typechecker may discard their uses + if in fact the in-scope fromRational is GHC.Read.fromRational, + (see tcPat.tcOverloadedLit), and the typechecker sees that the type + is fixed, say, to GHC.Base.Float (see Inst.lookupSimpleInst). + In that obscure case it won't force the interface in. + +In both cases we simply don't permit deprecations; +this is, after all, wired-in stuff. + + %********************************************************* %* * Unused names @@ -976,14 +1110,15 @@ reportUnusedNames export_decls gbl_env is_unused_local :: GlobalRdrElt -> Bool is_unused_local gre = isLocalGRE gre && isExternalName (gre_name gre) - unused_imports :: [GlobalRdrElt] - unused_imports = filter unused_imp defined_but_not_used - unused_imp (GRE {gre_prov = Imported imp_specs}) - = not (all (module_unused . importSpecModule) imp_specs) - && or [exp | ImpSpec { is_item = ImpSome { is_explicit = exp } } <- imp_specs] - -- Don't complain about unused imports if we've already said the - -- entire import is unused - unused_imp other = False + unused_imports :: [GlobalRdrElt] + unused_imports = mapCatMaybes unused_imp defined_but_not_used + unused_imp :: GlobalRdrElt -> Maybe GlobalRdrElt -- Result has trimmed Imported provenances + unused_imp gre@(GRE {gre_prov = LocalDef}) = Nothing + unused_imp gre@(GRE {gre_prov = Imported imp_specs}) + | null trimmed_specs = Nothing + | otherwise = Just (gre {gre_prov = Imported trimmed_specs}) + where + trimmed_specs = filter report_if_unused imp_specs -- To figure out the minimal set of imports, start with the things -- that are in scope (i.e. in gbl_env). Then just combine them @@ -1038,7 +1173,7 @@ reportUnusedNames export_decls gbl_env -- qualified imports into account. But it's an improvement. add_expall mod acc = addToFM_C plusAvailEnv acc mod emptyAvailEnv - add_inst_mod (mod,_,_) acc + add_inst_mod (mod, _) acc | mod_name `elemFM` acc = acc -- We import something already | otherwise = addToFM acc mod_name emptyAvailEnv where @@ -1048,7 +1183,7 @@ reportUnusedNames export_decls gbl_env imports = tcg_imports gbl_env - direct_import_mods :: [(Module, Bool, SrcSpan)] + direct_import_mods :: [(Module, [(ModuleName, Bool, SrcSpan)])] -- See the type of the imp_mods for this triple direct_import_mods = moduleEnvElts (imp_mods imports) @@ -1057,9 +1192,11 @@ reportUnusedNames export_decls gbl_env -- [Note: not 'minimal_imports', because that includes directly-imported -- modules even if we use nothing from them; see notes above] -- - -- BUG WARNING: does not deal correctly with multiple imports of the same module - -- becuase direct_import_mods has only one entry per module - unused_imp_mods = [(mod_name,loc) | (mod,no_imp,loc) <- direct_import_mods, + -- BUG WARNING: this code is generally buggy + unused_imp_mods :: [(ModuleName, SrcSpan)] + unused_imp_mods = [(mod_name,loc) + | (mod, xs) <- direct_import_mods, + (_, no_imp, loc) <- xs, let mod_name = moduleName mod, not (mod_name `elemFM` minimal_imports1), mod /= pRELUDE, @@ -1071,6 +1208,12 @@ reportUnusedNames export_decls gbl_env module_unused :: ModuleName -> Bool module_unused mod = any (((==) mod) . fst) unused_imp_mods + report_if_unused :: ImportSpec -> Bool + -- Do we want to report this as an unused import? + report_if_unused (ImpSpec {is_decl = d, is_item = i}) + = not (module_unused (is_mod d)) -- Not if we've already said entire import is unused + && isExplicitItem i -- Only if the import was explicit + --------------------- warnDuplicateImports :: [GlobalRdrElt] -> RnM () -- Given the GREs for names that are used, figure out which imports @@ -1089,8 +1232,6 @@ warnDuplicateImports :: [GlobalRdrElt] -> RnM () warnDuplicateImports gres = ifOptM Opt_WarnUnusedImports $ sequenceM_ [ warn name pr - -- The 'head' picks the first offending group - -- for this particular name | GRE { gre_name = name, gre_prov = Imported imps } <- gres , pr <- redundants imps ] where @@ -1109,7 +1250,12 @@ warnDuplicateImports gres redundants imps = [ (red_imp, cov_imp) | red_imp <- imps + , isExplicitItem (is_item red_imp) + -- Complain only about redundant imports + -- mentioned explicitly by the user , cov_imp <- take 1 (filter (covers red_imp) imps) ] + -- The 'take 1' picks the first offending group + -- for this particular name -- "red_imp" is a putative redundant import -- "cov_imp" potentially covers it @@ -1130,6 +1276,10 @@ warnDuplicateImports gres = False -- They bring into scope different qualified names | not (is_qual red_decl) && is_qual cov_decl = False -- Covering one doesn't bring unqualified name into scope + | otherwise + = not (isExplicitItem cov_item) -- Redundant one is selective and covering one isn't + || red_later -- or both are explicit; tie-break using red_later +{- | red_selective = not cov_selective -- Redundant one is selective and covering one isn't || red_later -- Both are explicit; tie-break using red_later @@ -1137,16 +1287,11 @@ warnDuplicateImports gres = not cov_selective -- Neither import is selective && (is_mod red_decl == is_mod cov_decl) -- They import the same module && red_later -- Tie-break +-} where red_loc = importSpecLoc red_imp cov_loc = importSpecLoc cov_imp red_later = red_loc > cov_loc - cov_selective = selectiveImpItem cov_item - red_selective = selectiveImpItem red_item - -selectiveImpItem :: ImpItemSpec -> Bool -selectiveImpItem ImpAll = False -selectiveImpItem (ImpSome {}) = True -- ToDo: deal with original imports with 'qualified' and 'as M' clauses printMinimalImports :: FiniteMap ModuleName AvailEnv -- Minimal imports @@ -1154,11 +1299,12 @@ printMinimalImports :: FiniteMap ModuleName AvailEnv -- Minimal imports printMinimalImports imps = ifOptM Opt_D_dump_minimal_imports $ do { - mod_ies <- mappM to_ies (fmToList imps) ; + mod_ies <- initIfaceTcRn $ mappM to_ies (fmToList imps) ; this_mod <- getModule ; rdr_env <- getGlobalRdrEnv ; + dflags <- getDOpts ; ioToTcRn (do { h <- openFile (mkFilename this_mod) WriteMode ; - printForUser h (mkPrintUnqualified rdr_env) + printForUser h (mkPrintUnqualified dflags rdr_env) (vcat (map ppr_mod_ie mod_ies)) }) } where @@ -1175,7 +1321,7 @@ printMinimalImports imps to_ies (mod, avail_env) = do ies <- mapM to_ie (availEnvElts avail_env) returnM (mod, ies) - to_ie :: AvailInfo -> RnM (IE Name) + to_ie :: AvailInfo -> IfG (IE Name) -- The main trick here is that if we're importing all the constructors -- we want to say "T(..)", but if we're importing only a subset we want -- to say "T(A,B,C)". So we have to find out what the module exports. @@ -1183,9 +1329,9 @@ printMinimalImports imps to_ie (AvailTC n [m]) = ASSERT( n==m ) returnM (IEThingAbs n) to_ie (AvailTC n ns) - = loadSrcInterface doc n_mod False `thenM` \ iface -> + = loadSysInterface doc n_mod `thenM` \ iface -> case [xs | (m,as) <- mi_exports iface, - moduleName m == n_mod, + m == n_mod, AvailTC x xs <- as, x == nameOccName n] of [xs] | all_used xs -> returnM (IEThingAll n) @@ -1195,7 +1341,7 @@ printMinimalImports imps where all_used avail_occs = all (`elem` map nameOccName ns) avail_occs doc = text "Compute minimal imports from" <+> ppr n - n_mod = moduleName (nameModule n) + n_mod = nameModule n \end{code} @@ -1220,8 +1366,8 @@ dodgyExportWarn item = dodgyMsg (ptext SLIT("export")) item dodgyMsg kind tc = sep [ ptext SLIT("The") <+> kind <+> ptext SLIT("item") <+> quotes (ppr (IEThingAll tc)), - ptext SLIT("suggests that") <+> quotes (ppr tc) <+> ptext SLIT("has constructor or class methods"), - ptext SLIT("but it has none; it is a type synonym or abstract type or class") ] + ptext SLIT("suggests that") <+> quotes (ppr tc) <+> ptext SLIT("has constructors or class methods,"), + ptext SLIT("but it has none") ] exportItemErr export_item = sep [ ptext SLIT("The export item") <+> quotes (ppr export_item), @@ -1229,12 +1375,14 @@ exportItemErr export_item typeItemErr name wherestr = sep [ ptext SLIT("Using 'type' tag on") <+> quotes (ppr name) <+> wherestr, - ptext SLIT("Use -findexed-types to enable this extension") ] + ptext SLIT("Use -ftype-families to enable this extension") ] +exportClashErr :: GlobalRdrEnv -> Name -> Name -> IE RdrName -> IE RdrName + -> Message exportClashErr global_env name1 name2 ie1 ie2 = vcat [ ptext SLIT("Conflicting exports for") <+> quotes (ppr occ) <> colon - , ppr_export ie1 name1 - , ppr_export ie2 name2 ] + , ppr_export ie1' name1' + , ppr_export ie2' name2' ] where occ = nameOccName name1 ppr_export ie name = nest 2 (quotes (ppr ie) <+> ptext SLIT("exports") <+> @@ -1245,6 +1393,10 @@ exportClashErr global_env name1 name2 ie1 ie2 = case lookupGRE_Name global_env name of (gre:_) -> gre [] -> pprPanic "exportClashErr" (ppr name) + get_loc name = nameSrcLoc $ gre_name $ get_gre name + (name1', ie1', name2', ie2') = if get_loc name1 < get_loc name2 + then (name1, ie1, name2, ie2) + else (name2, ie2, name1, ie1) addDupDeclErr :: Name -> Name -> TcRn () addDupDeclErr name_a name_b @@ -1267,10 +1419,18 @@ dupModuleExport mod quotes (ptext SLIT("Module") <+> ppr mod), ptext SLIT("in export list")] +moduleNotImported :: ModuleName -> SDoc +moduleNotImported mod + = ptext SLIT("The export item `module") <+> ppr mod <> + ptext SLIT("' is not imported") + nullModuleExport mod = ptext SLIT("The export item `module") <+> ppr mod <> ptext SLIT("' exports nothing") moduleDeprec mod txt = sep [ ptext SLIT("Module") <+> quotes (ppr mod) <+> ptext SLIT("is deprecated:"), nest 4 (ppr txt) ] + +implicitPreludeWarn + = ptext SLIT("Module `Prelude' implicitly imported") \end{code}