X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2Frename%2FRnNames.lhs;h=bc7146b0624429ef7ffdd8551ee37aaff1aac829;hp=6c35ef11a22aa39c633c53bc8ebd7659b18d77f7;hb=6a05ec5ef5373f61b7f9f5bdc344483417fa801b;hpb=ec0b859902e717c24addff49f9a83efb927fb669 diff --git a/compiler/rename/RnNames.lhs b/compiler/rename/RnNames.lhs index 6c35ef1..bc7146b 100644 --- a/compiler/rename/RnNames.lhs +++ b/compiler/rename/RnNames.lhs @@ -4,18 +4,25 @@ \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, finishDeprecations + 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, isFamInstDecl, LIE ) @@ -29,6 +36,7 @@ import PrelNames import Module import Name import NameEnv +import UniqFM import NameSet import OccName import HscTypes @@ -38,7 +46,7 @@ import Maybes import SrcLoc import FiniteMap import ErrUtils -import BasicTypes ( DeprecTxt ) +import BasicTypes ( DeprecTxt, Fixity ) import DriverPhases ( isHsBoot ) import Util import ListSetOps @@ -57,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 @@ -69,20 +77,25 @@ rnImports imports (source, ordinary) = partition is_source_import imports is_source_import (L _ (ImportDecl _ is_boot _ _ _)) = is_boot + 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)] - -> ([LImportDecl Name], GlobalRdrEnv, ImportAvails) - combine = foldr plus ([], emptyGlobalRdrEnv, emptyImportAvails) - where plus (decl, gbl_env1, imp_avails1) - (decls, gbl_env2, imp_avails2) + 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) + imp_avails1 `plusImportAvails` imp_avails2, + hpc_usage1 || hpc_usage2) mkPrelImports :: Module -> Bool -> [LImportDecl RdrName] -> [LImportDecl RdrName] -- Consruct the implicit declaration "import Prelude" (or not) @@ -115,7 +128,7 @@ mkPrelImports this_mod implicit_prelude import_decls 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)) @@ -224,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, @@ -241,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 @@ -261,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 @@ -298,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 @@ -310,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 @@ -322,19 +383,18 @@ 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 | isFamInstDecl (unLoc tc_decl) = do { main_name <- lookupFamInstDeclBndr mod main_rdr @@ -380,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 @@ -428,10 +488,10 @@ filterImports iface decl_spec (Just (want_hiding, import_items)) all_avails (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 @@ -456,7 +516,7 @@ filterImports iface decl_spec (Just (want_hiding, import_items)) all_avails -- 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 = @@ -501,8 +561,8 @@ filterImports iface decl_spec (Just (want_hiding, import_items)) all_avails 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) $ + -- 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 @@ -708,10 +768,10 @@ rnExports explicit_mod exports -- written "module Main where ..." -- Reason: don't want to complain about 'main' not in scope -- in interactive mode - ; ghc_mode <- getGhcMode + ; dflags <- getDOpts ; let real_exports - | explicit_mod = exports - | ghc_mode == Interactive = Nothing + | 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 @@ -754,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)) @@ -765,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 @@ -833,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 ) @@ -1105,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 @@ -1115,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) @@ -1124,10 +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 + -- BUG WARNING: this code is generally buggy unused_imp_mods :: [(ModuleName, SrcSpan)] - unused_imp_mods = [(mod_name,loc) | (mod,no_imp,loc) <- direct_import_mods, + 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, @@ -1233,8 +1302,9 @@ printMinimalImports 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 @@ -1296,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), @@ -1305,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") <+> @@ -1321,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 @@ -1343,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}