X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2Frename%2FRnNames.lhs;h=a33df882cb40023c58ecaf972562c3c6398601c1;hb=33d4a6bdb9a9b267464459aa049a25f4542305f1;hp=5988b32c5195e6530d49c578a023ced3cd0adcbb;hpb=1bba522f5ec82c43abd2ba4e84127b9c915dd020;p=ghc-hetmet.git diff --git a/ghc/compiler/rename/RnNames.lhs b/ghc/compiler/rename/RnNames.lhs index 5988b32..a33df88 100644 --- a/ghc/compiler/rename/RnNames.lhs +++ b/ghc/compiler/rename/RnNames.lhs @@ -10,39 +10,40 @@ module RnNames ( #include "HsVersions.h" -import CmdLineOpts ( opt_NoImplicitPrelude, opt_WarnDuplicateExports, opt_SourceUnchanged ) - -import HsSyn ( HsModule(..), HsDecl(..), IE(..), ieName, ImportDecl(..), - collectTopBinders - ) -import RdrHsSyn ( RdrNameIE, RdrNameImportDecl, - RdrNameHsModule, RdrNameHsDecl - ) -import RnIfaces ( getInterfaceExports, getDeclBinders, - recordLocalSlurps, checkModUsage, findAndReadIface, outOfDate - ) +import CmdLineOpts ( DynFlag(..), opt_NoImplicitPrelude ) + +import HsSyn ( HsModule(..), HsDecl(..), IE(..), ieName, ImportDecl(..), + ForeignDecl(..), ForKind(..), isDynamicExtName, + collectTopBinders + ) +import RdrHsSyn ( RdrNameIE, RdrNameImportDecl, + RdrNameHsModule, RdrNameHsDecl + ) +import RnIfaces ( getInterfaceExports, recordLocalSlurps ) +import RnHiFiles ( getTyClDeclBinders ) import RnEnv import RnMonad import FiniteMap -import PrelInfo ( pRELUDE_Name, mAIN_Name, main_RDR ) -import UniqFM ( lookupUFM ) -import Bag ( bagToList ) -import Module ( ModuleName, mkThisModule, pprModuleName, WhereFrom(..) ) +import PrelNames ( pRELUDE_Name, mAIN_Name, main_RDR ) +import UniqFM ( lookupUFM ) +import Bag ( bagToList ) +import Module ( ModuleName, mkModuleInThisPackage, WhereFrom(..) ) import NameSet -import Name ( Name, ExportFlag(..), ImportReason(..), Provenance(..), - setNameProvenance, - nameOccName, getSrcLoc, pprProvenance, getNameProvenance, - nameEnvElts - ) -import RdrName ( RdrName, rdrNameOcc, setRdrNameOcc, mkRdrQual, mkRdrUnqual, isQual, isUnqual ) -import OccName ( setOccNameSpace, dataName ) -import NameSet ( elemNameSet, emptyNameSet ) +import Name ( Name, nameSrcLoc, + setLocalNameSort, nameOccName, nameEnvElts ) +import HscTypes ( Provenance(..), ImportReason(..), GlobalRdrEnv, + GenAvailInfo(..), AvailInfo, Avails, AvailEnv ) +import RdrName ( RdrName, rdrNameOcc, setRdrNameOcc, mkRdrQual, mkRdrUnqual, isUnqual ) +import OccName ( setOccNameSpace, dataName ) +import NameSet ( elemNameSet, emptyNameSet ) +import SrcLoc ( SrcLoc ) import Outputable -import Maybes ( maybeToBool, catMaybes, mapMaybe ) -import UniqFM ( emptyUFM, listToUFM ) -import Util ( removeDups, sortLt ) -import List ( partition ) +import Maybes ( maybeToBool, catMaybes, mapMaybe ) +import UniqFM ( emptyUFM, listToUFM ) +import ListSetOps ( removeDups ) +import Util ( sortLt ) +import List ( partition ) \end{code} @@ -58,22 +59,21 @@ getGlobalNames :: RdrNameHsModule -> RnMG (Maybe (GlobalRdrEnv, -- Maps all in-scope things GlobalRdrEnv, -- Maps just *local* things Avails, -- The exported stuff - AvailEnv, -- Maps a name to its parent AvailInfo + AvailEnv -- Maps a name to its parent AvailInfo -- Just for in-scope things only - Maybe ParsedIface -- The old interface file, if any )) -- Nothing => no need to recompile getGlobalNames (HsModule this_mod _ exports imports decls _ mod_loc) = -- These two fix-loops are to get the right -- provenance information into a Name - fixRn ( \ ~(Just (rec_gbl_env, _, rec_export_avails, _, _)) -> + fixRn ( \ ~(Just (rec_gbl_env, _, rec_export_avails, _)) -> let rec_unqual_fn :: Name -> Bool -- Is this chap in scope unqualified? rec_unqual_fn = unQualInScope rec_gbl_env - rec_exp_fn :: Name -> ExportFlag + rec_exp_fn :: Name -> Bool rec_exp_fn = mk_export_fn (availsToNameSet rec_export_avails) in @@ -125,33 +125,19 @@ getGlobalNames (HsModule this_mod _ exports imports decls _ mod_loc) -- to compile A, and of course that doesn't include B.f. That's -- why we wait till after the plusEnv stuff to do the early-exit. - -- Check For eacly exit + -- Check For early exit checkErrsRn `thenRn` \ no_errs_so_far -> if not no_errs_so_far then -- Found errors already, so exit now returnRn Nothing else - checkEarlyExit this_mod `thenRn` \ (up_to_date, old_iface) -> - if up_to_date then - -- Interface files are sufficiently unchanged - putDocRn (text "Compilation IS NOT required") `thenRn_` - returnRn Nothing - else - - -- RECORD BETTER PROVENANCES IN THE CACHE - -- The names in the envirnoment have better provenances (e.g. imported on line x) - -- than the names in the name cache. We update the latter now, so that we - -- we start renaming declarations we'll get the good names - -- The isQual is because the qualified name is always in scope - updateProvenances (concat [names | (rdr_name, names) <- rdrEnvToList gbl_env, - isQual rdr_name]) `thenRn_` -- PROCESS EXPORT LISTS exportsFromAvail this_mod exports all_avails gbl_env `thenRn` \ export_avails -> -- ALL DONE - returnRn (Just (gbl_env, local_gbl_env, export_avails, global_avail_env, old_iface)) + returnRn (Just (gbl_env, local_gbl_env, export_avails, global_avail_env)) ) where all_imports = prel_imports ++ imports @@ -176,35 +162,6 @@ getGlobalNames (HsModule this_mod _ exports imports decls _ mod_loc) \end{code} \begin{code} -checkEarlyExit mod_name - = traceRn (text "Considering whether compilation is required...") `thenRn_` - - -- Read the old interface file, if any, for the module being compiled - findAndReadIface doc_str mod_name False {- Not hi-boot -} `thenRn` \ maybe_iface -> - - -- CHECK WHETHER WE HAVE IT ALREADY - case maybe_iface of - Left err -> -- Old interface file not found, so we'd better bail out - traceRn (vcat [ptext SLIT("No old interface file for") <+> pprModuleName mod_name, - err]) `thenRn_` - returnRn (outOfDate, Nothing) - - Right iface - | not opt_SourceUnchanged - -> -- Source code changed - traceRn (nest 4 (text "source file changed or recompilation check turned off")) `thenRn_` - returnRn (False, Just iface) - - | otherwise - -> -- Source code unchanged and no errors yet... carry on - checkModUsage (pi_usages iface) `thenRn` \ up_to_date -> - returnRn (up_to_date, Just iface) - where - -- Only look in current directory, with suffix .hi - doc_str = sep [ptext SLIT("need usage info from"), pprModuleName mod_name] -\end{code} - -\begin{code} importsFromImportDecl :: (Name -> Bool) -- OK to omit qualifier -> RdrNameImportDecl -> RnMG (GlobalRdrEnv, @@ -222,33 +179,22 @@ importsFromImportDecl is_unqual (ImportDecl imp_mod_name from qual_only as_mod i filterImports imp_mod_name import_spec avails `thenRn` \ (filtered_avails, hides, explicits) -> + let + mk_provenance name = NonLocalDef (UserImport imp_mod iloc (name `elemNameSet` explicits)) + (is_unqual name) + in + qualifyImports imp_mod_name (not qual_only) -- Maybe want unqualified names as_mod hides - (improveAvails imp_mod iloc explicits - is_unqual filtered_avails) - - -improveAvails imp_mod iloc explicits is_unqual avails - -- We 'improve' the provenance by setting - -- (a) the import-reason field, so that the Name says how it came into scope - -- including whether it's explicitly imported - -- (b) the print-unqualified field - = map improve_avail avails - where - improve_avail (Avail n) = Avail (improve n) - improve_avail (AvailTC n ns) = AvailTC (improve n) (map improve ns) - - improve name = setNameProvenance name - (NonLocalDef (UserImport imp_mod iloc (is_explicit name)) - (is_unqual name)) - is_explicit name = name `elemNameSet` explicits + mk_provenance + filtered_avails \end{code} \begin{code} importsFromLocalDecls mod_name rec_exp_fn decls - = mapRn (getLocalDeclBinders mod rec_exp_fn) decls `thenRn` \ avails_s -> + = mapRn (getLocalDeclBinders (newLocalName mod rec_exp_fn)) decls `thenRn` \ avails_s -> let avails = concat avails_s @@ -267,32 +213,52 @@ importsFromLocalDecls mod_name rec_exp_fn decls -- Build the environment qualifyImports mod_name - True -- Want unqualified names - Nothing -- no 'as M' - [] -- Hide nothing + True -- Want unqualified names + Nothing -- no 'as M' + [] -- Hide nothing + (\n -> LocalDef) -- Provenance is local avails - where - mod = mkThisModule mod_name + mod = mkModuleInThisPackage mod_name -getLocalDeclBinders :: Module -> (Name -> ExportFlag) +--------------------------- +getLocalDeclBinders :: (RdrName -> SrcLoc -> RnMG Name) -> RdrNameHsDecl -> RnMG Avails -getLocalDeclBinders mod rec_exp_fn (ValD binds) +getLocalDeclBinders new_name (ValD binds) = mapRn do_one (bagToList (collectTopBinders binds)) where - do_one (rdr_name, loc) = newLocalName mod rec_exp_fn rdr_name loc `thenRn` \ name -> + do_one (rdr_name, loc) = new_name rdr_name loc `thenRn` \ name -> returnRn (Avail name) -getLocalDeclBinders mod rec_exp_fn decl - = getDeclBinders (newLocalName mod rec_exp_fn) decl `thenRn` \ maybe_avail -> - case maybe_avail of - Nothing -> returnRn [] -- Instance decls and suchlike - Just avail -> returnRn [avail] +getLocalDeclBinders new_name (TyClD tycl_decl) + = getTyClDeclBinders new_name tycl_decl `thenRn` \ avail -> + returnRn [avail] + +getLocalDeclBinders new_name (ForD (ForeignDecl nm kind _ ext_nm _ loc)) + | binds_haskell_name kind + = new_name nm loc `thenRn` \ name -> + returnRn [Avail name] + | otherwise -- a foreign export + = lookupOrigName nm `thenRn_` + returnRn [] + where + binds_haskell_name (FoImport _) = True + binds_haskell_name FoLabel = True + binds_haskell_name FoExport = isDynamicExtName ext_nm + +getLocalDeclBinders new_name (FixD _) = returnRn [] +getLocalDeclBinders new_name (DeprecD _) = returnRn [] +getLocalDeclBinders new_name (DefD _) = returnRn [] +getLocalDeclBinders new_name (InstD _) = returnRn [] +getLocalDeclBinders new_name (RuleD _) = returnRn [] + + +--------------------------- newLocalName mod rec_exp_fn rdr_name loc - = check_unqual rdr_name loc `thenRn_` - newTopBinder mod (rdrNameOcc rdr_name) `thenRn` \ name -> - returnRn (setNameProvenance name (LocalDef loc (rec_exp_fn name))) + = check_unqual rdr_name loc `thenRn_` + newTopBinder mod rdr_name loc `thenRn` \ name -> + returnRn (setLocalNameSort name (rec_exp_fn name)) where -- There should never be a qualified name in a binding position (except in instance decls) -- The parser doesn't check this because the same parser parses instance decls @@ -416,10 +382,11 @@ qualifyImports :: ModuleName -- Imported module -> Bool -- True <=> want unqualified import -> Maybe ModuleName -- Optional "as M" part -> [AvailInfo] -- What's to be hidden + -> (Name -> Provenance) -> Avails -- Whats imported and how -> RnMG (GlobalRdrEnv, ExportAvails) -qualifyImports this_mod unqual_imp as_mod hides avails +qualifyImports this_mod unqual_imp as_mod hides mk_provenance avails = -- Make the name environment. We're talking about a -- single module here, so there must be no name clashes. @@ -449,9 +416,10 @@ qualifyImports this_mod unqual_imp as_mod hides avails | unqual_imp = env2 | otherwise = env1 where - env1 = addOneToGlobalRdrEnv env (mkRdrQual qual_mod occ) name - env2 = addOneToGlobalRdrEnv env1 (mkRdrUnqual occ) name + env1 = addOneToGlobalRdrEnv env (mkRdrQual qual_mod occ) (name,prov) + env2 = addOneToGlobalRdrEnv env1 (mkRdrUnqual occ) (name,prov) occ = nameOccName name + prov = mk_provenance name del_avail env avail = foldl delOneFromGlobalRdrEnv env rdr_names where @@ -548,8 +516,10 @@ exportsFromAvail this_mod Nothing export_avails global_name_env exportsFromAvail this_mod (Just export_items) (mod_avail_env, entity_avail_env) global_name_env - = foldlRn exports_from_item - ([], emptyFM, emptyAvailEnv) export_items `thenRn` \ (_, _, export_avail_map) -> + = doptRn Opt_WarnDuplicateExports `thenRn` \ warn_dup_exports -> + foldlRn (exports_from_item warn_dup_exports) + ([], emptyFM, emptyAvailEnv) export_items + `thenRn` \ (_, _, export_avail_map) -> let export_avails :: [AvailInfo] export_avails = nameEnvElts export_avail_map @@ -557,12 +527,11 @@ exportsFromAvail this_mod (Just export_items) returnRn export_avails where - exports_from_item :: ExportAccum -> RdrNameIE -> RnMG ExportAccum + exports_from_item :: Bool -> ExportAccum -> RdrNameIE -> RnMG ExportAccum - exports_from_item acc@(mods, occs, avails) ie@(IEModuleContents mod) + exports_from_item warn_dups acc@(mods, occs, avails) ie@(IEModuleContents mod) | mod `elem` mods -- Duplicate export of M - = warnCheckRn opt_WarnDuplicateExports - (dupModuleExport mod) `thenRn_` + = warnCheckRn warn_dups (dupModuleExport mod) `thenRn_` returnRn acc | otherwise @@ -575,12 +544,12 @@ exportsFromAvail this_mod (Just export_items) in returnRn (mod:mods, occs', avails') - exports_from_item acc@(mods, occs, avails) ie + exports_from_item warn_dups acc@(mods, occs, avails) ie | not (maybeToBool maybe_in_scope) = failWithRn acc (unknownNameErr (ieName ie)) | not (null dup_names) - = addNameClashErrRn rdr_name (name:dup_names) `thenRn_` + = addNameClashErrRn rdr_name ((name,prov):dup_names) `thenRn_` returnRn acc #ifdef DEBUG @@ -604,7 +573,7 @@ exportsFromAvail this_mod (Just export_items) where rdr_name = ieName ie maybe_in_scope = lookupFM global_name_env rdr_name - Just (name:dup_names) = maybe_in_scope + Just ((name,prov):dup_names) = maybe_in_scope maybe_avail = lookupUFM entity_avail_env name Just avail = maybe_avail maybe_export_avail = filterAvail ie avail @@ -619,14 +588,15 @@ exportsFromAvail this_mod (Just export_items) check_occs :: RdrNameIE -> ExportOccMap -> AvailInfo -> RnMG ExportOccMap check_occs ie occs avail - = foldlRn check occs (availNames avail) + = doptRn Opt_WarnDuplicateExports `thenRn` \ warn_dup_exports -> + foldlRn (check warn_dup_exports) occs (availNames avail) where - check occs name + check warn_dup occs name = case lookupFM occs name_occ of Nothing -> returnRn (addToFM occs name_occ (name, ie)) Just (name', ie') | name == name' -> -- Duplicate export - warnCheckRn opt_WarnDuplicateExports + warnCheckRn warn_dup (dupExportWarn name_occ ie ie') `thenRn_` returnRn occs @@ -635,11 +605,8 @@ check_occs ie occs avail where name_occ = nameOccName name -mk_export_fn :: NameSet -> (Name -> ExportFlag) -mk_export_fn exported_names - = \name -> if name `elemNameSet` exported_names - then Exported - else NotExported +mk_export_fn :: NameSet -> (Name -> Bool) -- True => exported +mk_export_fn exported_names = \name -> name `elemNameSet` exported_names \end{code} %************************************************************************ @@ -650,7 +617,7 @@ mk_export_fn exported_names \begin{code} badImportItemErr mod ie - = sep [ptext SLIT("Module"), quotes (pprModuleName mod), + = sep [ptext SLIT("Module"), quotes (ppr mod), ptext SLIT("does not export"), quotes (ppr ie)] dodgyImportWarn mod item = dodgyMsg (ptext SLIT("import")) item @@ -662,7 +629,7 @@ dodgyMsg kind item@(IEThingAll tc) ptext SLIT("but it has none; it is a type synonym or abstract type or class") ] modExportErr mod - = hsep [ ptext SLIT("Unknown module in export list: module"), quotes (pprModuleName mod)] + = hsep [ ptext SLIT("Unknown module in export list: module"), quotes (ppr mod)] exportItemErr export_item = sep [ ptext SLIT("The export item") <+> quotes (ppr export_item), @@ -675,13 +642,10 @@ exportClashErr occ_name ie1 ie2 dupDeclErr (n:ns) = vcat [ptext SLIT("Multiple declarations of") <+> quotes (ppr n), - nest 4 (vcat (map pp sorted_ns))] + nest 4 (vcat (map ppr sorted_locs))] where - sorted_ns = sortLt occ'ed_before (n:ns) - - occ'ed_before a b = LT == compare (getSrcLoc a) (getSrcLoc b) - - pp n = pprProvenance (getNameProvenance n) + sorted_locs = sortLt occ'ed_before (map nameSrcLoc (n:ns)) + occ'ed_before a b = LT == compare a b dupExportWarn occ_name ie1 ie2 = hsep [quotes (ppr occ_name), @@ -690,6 +654,6 @@ dupExportWarn occ_name ie1 ie2 dupModuleExport mod = hsep [ptext SLIT("Duplicate"), - quotes (ptext SLIT("Module") <+> pprModuleName mod), + quotes (ptext SLIT("Module") <+> ppr mod), ptext SLIT("in export list")] \end{code}