From 00eefb90925f224c1e22963df2a00d70fe934d5f Mon Sep 17 00:00:00 2001 From: simonpj Date: Fri, 28 May 1999 08:07:54 +0000 Subject: [PATCH] [project @ 1999-05-28 08:07:52 by simonpj] Make the renamer so that the class ops on the LEFT HAND SIDE of the bindings of an instance decl count as free variables of that declaration. E.g. instance Foo [a] where op x = ... bop y = ... Here, 'op' and 'bop' are now counted as free variables of the decl. This is vital, because the class decl for Foo might be imported, and look like this: class Foo a where op :: a -> S bop :: T -> a and these might happen to be the only mentions of S and T in the program. Then we need to treat S and T as instance gates for the purpose of hauling in further instance decls, and the Right Way to do that is to announce that 'op' and 'bop' have been mentioned. I also removed the (now obselete) rn_omit field in the monad. --- ghc/compiler/rename/Rename.lhs | 1156 ++++++++++++++++---------------- ghc/compiler/rename/RnBinds.lhs | 1204 ++++++++++++++++----------------- ghc/compiler/rename/RnMonad.lhs | 1409 +++++++++++++++++++-------------------- ghc/compiler/rename/RnNames.lhs | 1392 +++++++++++++++++++------------------- 4 files changed, 2579 insertions(+), 2582 deletions(-) diff --git a/ghc/compiler/rename/Rename.lhs b/ghc/compiler/rename/Rename.lhs index c0b52db..377e4ba 100644 --- a/ghc/compiler/rename/Rename.lhs +++ b/ghc/compiler/rename/Rename.lhs @@ -1,578 +1,578 @@ -% -% (c) The GRASP Project, Glasgow University, 1992-1998 -% -\section[Rename]{Renaming and dependency analysis passes} - -\begin{code} -module Rename ( renameModule ) where - -#include "HsVersions.h" - -import HsSyn -import RdrHsSyn ( RdrNameHsModule ) -import RnHsSyn ( RenamedHsModule, RenamedHsDecl, - extractHsTyNames, extractHsCtxtTyNames - ) - -import CmdLineOpts ( opt_HiMap, opt_D_dump_rn_trace, - opt_D_dump_rn, opt_D_dump_rn_stats, - opt_WarnUnusedBinds, opt_WarnUnusedImports - ) -import RnMonad -import RnNames ( getGlobalNames ) -import RnSource ( rnSourceDecls, rnDecl ) -import RnIfaces ( getImportedInstDecls, importDecl, getImportVersions, - getImportedRules, loadHomeInterface, getSlurped - ) -import RnEnv ( availName, availNames, availsToNameSet, - warnUnusedTopNames, mapFvRn, - FreeVars, plusFVs, plusFV, unitFV, emptyFVs, isEmptyFVs - ) -import Module ( Module, ModuleName, pprModule, mkSearchPath, mkThisModule ) -import Name ( Name, isLocallyDefined, - NamedThing(..), ImportReason(..), Provenance(..), - pprOccName, nameOccName, - getNameProvenance, occNameUserString, - maybeWiredInTyConName, maybeWiredInIdName, isWiredInName - ) -import Id ( idType ) -import DataCon ( dataConTyCon, dataConType ) -import TyCon ( TyCon, tyConDataCons, isSynTyCon, getSynTyConDefn ) -import RdrName ( RdrName ) -import NameSet -import PrelMods ( mAIN_Name, pREL_MAIN_Name ) -import TysWiredIn ( unitTyCon, intTyCon, doubleTyCon, boolTyCon ) -import PrelInfo ( ioTyCon_NAME, thinAirIdNames ) -import Type ( namesOfType, funTyCon ) -import ErrUtils ( pprBagOfErrors, pprBagOfWarnings, - doIfSet, dumpIfSet, ghcExit - ) -import BasicTypes ( NewOrData(..) ) -import Bag ( isEmptyBag, bagToList ) -import FiniteMap ( fmToList, delListFromFM, addToFM, sizeFM, eltsFM ) -import UniqSupply ( UniqSupply ) -import Util ( equivClasses ) -import Maybes ( maybeToBool ) -import Outputable -\end{code} - - - -\begin{code} -renameModule :: UniqSupply - -> RdrNameHsModule - -> IO (Maybe - ( Module - , RenamedHsModule -- Output, after renaming - , InterfaceDetails -- Interface; for interface file generation - , RnNameSupply -- Final env; for renaming derivings - , [ModuleName] -- Imported modules; for profiling - )) - -renameModule us this_mod@(HsModule mod_name vers exports imports local_decls loc) - = -- Initialise the renamer monad - initRn mod_name us (mkSearchPath opt_HiMap) loc - (rename this_mod) >>= - \ (maybe_rn_stuff, rn_errs_bag, rn_warns_bag) -> - - -- Check for warnings - doIfSet (not (isEmptyBag rn_warns_bag)) - (printErrs (pprBagOfWarnings rn_warns_bag)) >> - - -- Check for errors; exit if so - doIfSet (not (isEmptyBag rn_errs_bag)) - (printErrs (pprBagOfErrors rn_errs_bag) >> - ghcExit 1 - ) >> - - -- Dump output, if any - (case maybe_rn_stuff of - Nothing -> return () - Just results@(_, rn_mod, _, _, _) - -> dumpIfSet opt_D_dump_rn "Renamer:" - (ppr rn_mod) - ) >> - - -- Return results - return maybe_rn_stuff -\end{code} - - -\begin{code} -rename this_mod@(HsModule mod_name vers exports imports local_decls loc) - = -- FIND THE GLOBAL NAME ENVIRONMENT - getGlobalNames this_mod `thenRn` \ maybe_stuff -> - - -- CHECK FOR EARLY EXIT - if not (maybeToBool maybe_stuff) then - -- Everything is up to date; no need to recompile further - rnStats [] `thenRn_` - returnRn Nothing - else - let - Just (export_env, gbl_env, fixity_env, global_avail_env) = maybe_stuff - in - - -- RENAME THE SOURCE - initRnMS gbl_env fixity_env SourceMode ( - rnSourceDecls local_decls - ) `thenRn` \ (rn_local_decls, source_fvs) -> - - -- SLURP IN ALL THE NEEDED DECLARATIONS - let - real_source_fvs = implicitFVs mod_name `plusFV` source_fvs - -- It's important to do the "plus" this way round, so that - -- when compiling the prelude, locally-defined (), Bool, etc - -- override the implicit ones. - in - slurpImpDecls real_source_fvs `thenRn` \ rn_imp_decls -> - - -- EXIT IF ERRORS FOUND - checkErrsRn `thenRn` \ no_errs_so_far -> - if not no_errs_so_far then - -- Found errors already, so exit now - rnStats [] `thenRn_` - returnRn Nothing - else - - -- GENERATE THE VERSION/USAGE INFO - getImportVersions mod_name exports `thenRn` \ my_usages -> - getNameSupplyRn `thenRn` \ name_supply -> - - -- REPORT UNUSED NAMES - reportUnusedNames gbl_env global_avail_env - export_env - source_fvs `thenRn_` - - -- RETURN THE RENAMED MODULE - let - has_orphans = any isOrphanDecl rn_local_decls - direct_import_mods = [mod | ImportDecl mod _ _ _ _ _ <- imports] - rn_all_decls = rn_imp_decls ++ rn_local_decls - renamed_module = HsModule mod_name vers - trashed_exports trashed_imports - rn_all_decls - loc - in - rnStats rn_imp_decls `thenRn_` - returnRn (Just (mkThisModule mod_name, - renamed_module, - (has_orphans, my_usages, export_env), - name_supply, - direct_import_mods)) - where - trashed_exports = {-trace "rnSource:trashed_exports"-} Nothing - trashed_imports = {-trace "rnSource:trashed_imports"-} [] -\end{code} - -@implicitFVs@ forces the renamer to slurp in some things which aren't -mentioned explicitly, but which might be needed by the type checker. - -\begin{code} -implicitFVs mod_name - = implicit_main `plusFV` - mkNameSet default_tys `plusFV` - mkNameSet thinAirIdNames - where - -- Add occurrences for Int, Double, and (), because they - -- are the types to which ambigious type variables may be defaulted by - -- the type checker; so they won't always appear explicitly. - -- [The () one is a GHC extension for defaulting CCall results.] - -- ALSO: funTyCon, since it occurs implicitly everywhere! - -- (we don't want to be bothered with making funTyCon a - -- free var at every function application!) - default_tys = [getName intTyCon, getName doubleTyCon, - getName unitTyCon, getName funTyCon, getName boolTyCon] - - -- Add occurrences for IO or PrimIO - implicit_main | mod_name == mAIN_Name - || mod_name == pREL_MAIN_Name = unitFV ioTyCon_NAME - | otherwise = emptyFVs -\end{code} - -\begin{code} -isOrphanDecl (InstD (InstDecl inst_ty _ _ _ _)) - = not (foldNameSet ((||) . isLocallyDefined) False (extractHsTyNames inst_ty)) -isOrphanDecl (RuleD (RuleDecl _ _ _ lhs _ _)) - = check lhs - where - check (HsVar v) = not (isLocallyDefined v) - check (HsApp f a) = check f && check a - check other = True -isOrphanDecl other = False -\end{code} - - -%********************************************************* -%* * -\subsection{Slurping declarations} -%* * -%********************************************************* - -\begin{code} -------------------------------------------------------- -slurpImpDecls source_fvs - = traceRn (text "slurpImp" <+> fsep (map ppr (nameSetToList source_fvs))) `thenRn_` - - -- The current slurped-set records all local things - getSlurped `thenRn` \ source_binders -> - slurpSourceRefs source_binders source_fvs `thenRn` \ (decls1, needed1, inst_gates) -> - - -- Now we can get the instance decls - slurpInstDecls decls1 needed1 inst_gates `thenRn` \ (decls2, needed2) -> - - -- And finally get everything else - closeDecls decls2 needed2 - -------------------------------------------------------- -slurpSourceRefs :: NameSet -- Variables defined in source - -> FreeVars -- Variables referenced in source - -> RnMG ([RenamedHsDecl], - FreeVars, -- Un-satisfied needs - FreeVars) -- "Gates" --- The declaration (and hence home module) of each gate has --- already been loaded - -slurpSourceRefs source_binders source_fvs - = go [] -- Accumulating decls - emptyFVs -- Unsatisfied needs - source_fvs -- Accumulating gates - (nameSetToList source_fvs) -- Gates whose defn hasn't been loaded yet - where - go decls fvs gates [] - = returnRn (decls, fvs, gates) - - go decls fvs gates (wanted_name:refs) - | isWiredInName wanted_name - = load_home wanted_name `thenRn_` - go decls fvs (gates `plusFV` getWiredInGates wanted_name) refs - - | otherwise - = importDecl wanted_name `thenRn` \ maybe_decl -> - case maybe_decl of - -- No declaration... (already slurped, or local) - Nothing -> go decls fvs gates refs - Just decl -> rnIfaceDecl decl `thenRn` \ (new_decl, fvs1) -> - let - new_gates = getGates source_fvs new_decl - in - go (new_decl : decls) - (fvs1 `plusFV` fvs) - (gates `plusFV` new_gates) - (nameSetToList new_gates ++ refs) - - -- When we find a wired-in name we must load its - -- home module so that we find any instance decls therein - load_home name - | name `elemNameSet` source_binders = returnRn () - -- When compiling the prelude, a wired-in thing may - -- be defined in this module, in which case we don't - -- want to load its home module! - -- Using 'isLocallyDefined' doesn't work because some of - -- the free variables returned are simply 'listTyCon_Name', - -- with a system provenance. We could look them up every time - -- but that seems a waste. - | otherwise = loadHomeInterface doc name `thenRn_` - returnRn () - where - doc = ptext SLIT("need home module for wired in thing") <+> ppr name - -------------------------------------------------------- --- slurpInstDecls imports appropriate instance decls. --- It has to incorporate a loop, because consider --- instance Foo a => Baz (Maybe a) where ... --- It may be that Baz and Maybe are used in the source module, --- but not Foo; so we need to chase Foo too. - -slurpInstDecls decls needed gates - | isEmptyFVs gates - = returnRn (decls, needed) - - | otherwise - = getImportedInstDecls gates `thenRn` \ inst_decls -> - rnInstDecls decls needed emptyFVs inst_decls `thenRn` \ (decls1, needed1, gates1) -> - slurpInstDecls decls1 needed1 gates1 - where - rnInstDecls decls fvs gates [] - = returnRn (decls, fvs, gates) - rnInstDecls decls fvs gates (d:ds) - = rnIfaceDecl d `thenRn` \ (new_decl, fvs1) -> - rnInstDecls (new_decl:decls) - (fvs1 `plusFV` fvs) - (gates `plusFV` getInstDeclGates new_decl) - ds - - -------------------------------------------------------- --- closeDecls keeps going until the free-var set is empty -closeDecls decls needed - | not (isEmptyFVs needed) - = slurpDecls decls needed `thenRn` \ (decls1, needed1) -> - closeDecls decls1 needed1 - - | otherwise - = getImportedRules `thenRn` \ rule_decls -> - case rule_decls of - [] -> returnRn decls -- No new rules, so we are done - other -> rnIfaceDecls decls emptyFVs rule_decls `thenRn` \ (decls1, needed1) -> - closeDecls decls1 needed1 - - -------------------------------------------------------- -rnIfaceDecls :: [RenamedHsDecl] -> FreeVars - -> [(Module, RdrNameHsDecl)] - -> RnM d ([RenamedHsDecl], FreeVars) -rnIfaceDecls decls fvs [] = returnRn (decls, fvs) -rnIfaceDecls decls fvs (d:ds) = rnIfaceDecl d `thenRn` \ (new_decl, fvs1) -> - rnIfaceDecls (new_decl:decls) (fvs1 `plusFV` fvs) ds - -rnIfaceDecl (mod, decl) = initIfaceRnMS mod (rnDecl decl) - - -------------------------------------------------------- --- Augment decls with any decls needed by needed. --- Return also free vars of the new decls (only) -slurpDecls decls needed - = go decls emptyFVs (nameSetToList needed) - where - go decls fvs [] = returnRn (decls, fvs) - go decls fvs (ref:refs) = slurpDecl decls fvs ref `thenRn` \ (decls1, fvs1) -> - go decls1 fvs1 refs - -------------------------------------------------------- -slurpDecl decls fvs wanted_name - = importDecl wanted_name `thenRn` \ maybe_decl -> - case maybe_decl of - -- No declaration... (wired in thing) - Nothing -> returnRn (decls, fvs) - - -- Found a declaration... rename it - Just decl -> rnIfaceDecl decl `thenRn` \ (new_decl, fvs1) -> - returnRn (new_decl:decls, fvs1 `plusFV` fvs) -\end{code} - - -%********************************************************* -%* * -\subsection{Extracting the 'gates'} -%* * -%********************************************************* - -When we import a declaration like - - data T = T1 Wibble | T2 Wobble - -we don't want to treat Wibble and Wobble as gates *unless* T1, T2 -respectively are mentioned by the user program. If only T is mentioned -we want only T to be a gate; that way we don't suck in useless instance -decls for (say) Eq Wibble, when they can't possibly be useful. - -@getGates@ takes a newly imported (and renamed) decl, and the free -vars of the source program, and extracts from the decl the gate names. - -\begin{code} -getGates source_fvs (SigD (IfaceSig _ ty _ _)) - = extractHsTyNames ty - -getGates source_fvs (TyClD (ClassDecl ctxt cls tvs sigs _ _ _ _ _ _)) - = delListFromNameSet (foldr (plusFV . get) (extractHsCtxtTyNames ctxt) sigs) - (map getTyVarName tvs) - `addOneToNameSet` cls - where - get (ClassOpSig n _ ty _) - | n `elemNameSet` source_fvs = extractHsTyNames ty - | otherwise = emptyFVs - -getGates source_fvs (TyClD (TySynonym tycon tvs ty _)) - = delListFromNameSet (extractHsTyNames ty) - (map getTyVarName tvs) - -- A type synonym type constructor isn't a "gate" for instance decls - -getGates source_fvs (TyClD (TyData _ ctxt tycon tvs cons _ _ _)) - = delListFromNameSet (foldr (plusFV . get) (extractHsCtxtTyNames ctxt) cons) - (map getTyVarName tvs) - `addOneToNameSet` tycon - where - get (ConDecl n tvs ctxt details _) - | n `elemNameSet` source_fvs - -- If the constructor is method, get fvs from all its fields - = delListFromNameSet (get_details details `plusFV` - extractHsCtxtTyNames ctxt) - (map getTyVarName tvs) - get (ConDecl n tvs ctxt (RecCon fields) _) - -- Even if the constructor isn't mentioned, the fields - -- might be, as selectors. They can't mention existentially - -- bound tyvars (typechecker checks for that) so no need for - -- the deleteListFromNameSet part - = foldr (plusFV . get_field) emptyFVs fields - - get other_con = emptyFVs - - get_details (VanillaCon tys) = plusFVs (map get_bang tys) - get_details (InfixCon t1 t2) = get_bang t1 `plusFV` get_bang t2 - get_details (RecCon fields) = plusFVs [get_bang t | (_, t) <- fields] - get_details (NewCon t _) = extractHsTyNames t - - get_field (fs,t) | any (`elemNameSet` source_fvs) fs = get_bang t - | otherwise = emptyFVs - - get_bang (Banged t) = extractHsTyNames t - get_bang (Unbanged t) = extractHsTyNames t - get_bang (Unpacked t) = extractHsTyNames t - -getGates source_fvs other_decl = emptyFVs -\end{code} - -getWiredInGates is just like getGates, but it sees a wired-in Name -rather than a declaration. - -\begin{code} -getWiredInGates :: Name -> FreeVars -getWiredInGates name -- No classes are wired in - | is_id = getWiredInGates_s (namesOfType (idType the_id)) - | isSynTyCon the_tycon = getWiredInGates_s (delListFromNameSet (namesOfType ty) (map getName tyvars)) - | otherwise = unitFV name - where - maybe_wired_in_id = maybeWiredInIdName name - is_id = maybeToBool maybe_wired_in_id - maybe_wired_in_tycon = maybeWiredInTyConName name - Just the_id = maybe_wired_in_id - Just the_tycon = maybe_wired_in_tycon - (tyvars,ty) = getSynTyConDefn the_tycon - -getWiredInGates_s names = foldr (plusFV . getWiredInGates) emptyFVs (nameSetToList names) -\end{code} - -\begin{code} -getInstDeclGates (InstD (InstDecl inst_ty _ _ _ _)) = extractHsTyNames inst_ty -getInstDeclGates other = emptyFVs -\end{code} - - -%********************************************************* -%* * -\subsection{Unused names} -%* * -%********************************************************* - -\begin{code} -reportUnusedNames gbl_env avail_env (ExportEnv export_avails _) mentioned_names - | not (opt_WarnUnusedBinds || opt_WarnUnusedImports) - = returnRn () - - | otherwise - = let - used_names = mentioned_names `unionNameSets` availsToNameSet export_avails - - -- Now, a use of C implies a use of T, - -- if C was brought into scope by T(..) or T(C) - really_used_names = used_names `unionNameSets` - mkNameSet [ availName avail - | sub_name <- nameSetToList used_names, - let avail = case lookupNameEnv avail_env sub_name of - Just avail -> avail - Nothing -> pprTrace "r.u.n" (ppr sub_name) $ - Avail sub_name - ] - - defined_names = mkNameSet (concat (rdrEnvElts gbl_env)) - defined_but_not_used = nameSetToList (defined_names `minusNameSet` really_used_names) - - -- Filter out the ones only defined implicitly - bad_guys = filter reportableUnusedName defined_but_not_used - in - warnUnusedTopNames bad_guys `thenRn_` - returnRn () - -reportableUnusedName :: Name -> Bool -reportableUnusedName name - = explicitlyImported (getNameProvenance name) && - not (startsWithUnderscore (occNameUserString (nameOccName name))) - where - explicitlyImported (LocalDef _ _) = True -- Report unused defns of local vars - explicitlyImported (NonLocalDef (UserImport _ _ expl) _) = expl -- Report unused explicit imports - explicitlyImported other = False -- Don't report others - - -- Haskell 98 encourages compilers to suppress warnings about - -- unused names in a pattern if they start with "_". - startsWithUnderscore ('_' : _) = True -- Suppress warnings for names starting - startsWithUnderscore other = False -- with an underscore - -rnStats :: [RenamedHsDecl] -> RnMG () -rnStats imp_decls - | opt_D_dump_rn_trace || - opt_D_dump_rn_stats || - opt_D_dump_rn - = getRnStats imp_decls `thenRn` \ msg -> - ioToRnM (printErrs msg) `thenRn_` - returnRn () - - | otherwise = returnRn () -\end{code} - - - -%********************************************************* -%* * -\subsection{Statistics} -%* * -%********************************************************* - -\begin{code} -getRnStats :: [RenamedHsDecl] -> RnMG SDoc -getRnStats imported_decls - = getIfacesRn `thenRn` \ ifaces -> - let - n_mods = length [() | (_, _, Just _) <- eltsFM (iImpModInfo ifaces)] - - decls_read = [decl | (_, avail, True, (_,decl)) <- nameEnvElts (iDecls ifaces), - -- Data, newtype, and class decls are in the decls_fm - -- under multiple names; the tycon/class, and each - -- constructor/class op too. - -- The 'True' selects just the 'main' decl - not (isLocallyDefined (availName avail)) - ] - - (cd_rd, dd_rd, nd_rd, sd_rd, vd_rd, _) = count_decls decls_read - (cd_sp, dd_sp, nd_sp, sd_sp, vd_sp, id_sp) = count_decls imported_decls - - unslurped_insts = iInsts ifaces - inst_decls_unslurped = length (bagToList unslurped_insts) - inst_decls_read = id_sp + inst_decls_unslurped - - stats = vcat - [int n_mods <+> text "interfaces read", - hsep [ int cd_sp, text "class decls imported, out of", - int cd_rd, text "read"], - hsep [ int dd_sp, text "data decls imported, out of", - int dd_rd, text "read"], - hsep [ int nd_sp, text "newtype decls imported, out of", - int nd_rd, text "read"], - hsep [int sd_sp, text "type synonym decls imported, out of", - int sd_rd, text "read"], - hsep [int vd_sp, text "value signatures imported, out of", - int vd_rd, text "read"], - hsep [int id_sp, text "instance decls imported, out of", - int inst_decls_read, text "read"], - text "cls dcls slurp" <+> fsep (map (ppr . tyClDeclName) - [d | TyClD d <- imported_decls, isClassDecl d]), - text "cls dcls read" <+> fsep (map (ppr . tyClDeclName) - [d | TyClD d <- decls_read, isClassDecl d])] - in - returnRn (hcat [text "Renamer stats: ", stats]) - -count_decls decls - = (class_decls, - data_decls, - newtype_decls, - syn_decls, - val_decls, - inst_decls) - where - tycl_decls = [d | TyClD d <- decls] - (class_decls, data_decls, newtype_decls, syn_decls) = countTyClDecls tycl_decls - - val_decls = length [() | SigD _ <- decls] - inst_decls = length [() | InstD _ <- decls] -\end{code} - +% +% (c) The GRASP Project, Glasgow University, 1992-1998 +% +\section[Rename]{Renaming and dependency analysis passes} + +\begin{code} +module Rename ( renameModule ) where + +#include "HsVersions.h" + +import HsSyn +import RdrHsSyn ( RdrNameHsModule ) +import RnHsSyn ( RenamedHsModule, RenamedHsDecl, + extractHsTyNames, extractHsCtxtTyNames + ) + +import CmdLineOpts ( opt_HiMap, opt_D_dump_rn_trace, + opt_D_dump_rn, opt_D_dump_rn_stats, + opt_WarnUnusedBinds, opt_WarnUnusedImports + ) +import RnMonad +import RnNames ( getGlobalNames ) +import RnSource ( rnSourceDecls, rnDecl ) +import RnIfaces ( getImportedInstDecls, importDecl, getImportVersions, + getImportedRules, loadHomeInterface, getSlurped + ) +import RnEnv ( availName, availNames, availsToNameSet, + warnUnusedTopNames, mapFvRn, + FreeVars, plusFVs, plusFV, unitFV, emptyFVs, isEmptyFVs + ) +import Module ( Module, ModuleName, pprModule, mkSearchPath, mkThisModule ) +import Name ( Name, isLocallyDefined, + NamedThing(..), ImportReason(..), Provenance(..), + pprOccName, nameOccName, + getNameProvenance, occNameUserString, + maybeWiredInTyConName, maybeWiredInIdName, isWiredInName + ) +import Id ( idType ) +import DataCon ( dataConTyCon, dataConType ) +import TyCon ( TyCon, tyConDataCons, isSynTyCon, getSynTyConDefn ) +import RdrName ( RdrName ) +import NameSet +import PrelMods ( mAIN_Name, pREL_MAIN_Name ) +import TysWiredIn ( unitTyCon, intTyCon, doubleTyCon, boolTyCon ) +import PrelInfo ( ioTyCon_NAME, thinAirIdNames ) +import Type ( namesOfType, funTyCon ) +import ErrUtils ( pprBagOfErrors, pprBagOfWarnings, + doIfSet, dumpIfSet, ghcExit + ) +import BasicTypes ( NewOrData(..) ) +import Bag ( isEmptyBag, bagToList ) +import FiniteMap ( fmToList, delListFromFM, addToFM, sizeFM, eltsFM ) +import UniqSupply ( UniqSupply ) +import Util ( equivClasses ) +import Maybes ( maybeToBool ) +import Outputable +\end{code} + + + +\begin{code} +renameModule :: UniqSupply + -> RdrNameHsModule + -> IO (Maybe + ( Module + , RenamedHsModule -- Output, after renaming + , InterfaceDetails -- Interface; for interface file generation + , RnNameSupply -- Final env; for renaming derivings + , [ModuleName] -- Imported modules; for profiling + )) + +renameModule us this_mod@(HsModule mod_name vers exports imports local_decls loc) + = -- Initialise the renamer monad + initRn mod_name us (mkSearchPath opt_HiMap) loc + (rename this_mod) >>= + \ (maybe_rn_stuff, rn_errs_bag, rn_warns_bag) -> + + -- Check for warnings + doIfSet (not (isEmptyBag rn_warns_bag)) + (printErrs (pprBagOfWarnings rn_warns_bag)) >> + + -- Check for errors; exit if so + doIfSet (not (isEmptyBag rn_errs_bag)) + (printErrs (pprBagOfErrors rn_errs_bag) >> + ghcExit 1 + ) >> + + -- Dump output, if any + (case maybe_rn_stuff of + Nothing -> return () + Just results@(_, rn_mod, _, _, _) + -> dumpIfSet opt_D_dump_rn "Renamer:" + (ppr rn_mod) + ) >> + + -- Return results + return maybe_rn_stuff +\end{code} + + +\begin{code} +rename this_mod@(HsModule mod_name vers exports imports local_decls loc) + = -- FIND THE GLOBAL NAME ENVIRONMENT + getGlobalNames this_mod `thenRn` \ maybe_stuff -> + + -- CHECK FOR EARLY EXIT + if not (maybeToBool maybe_stuff) then + -- Everything is up to date; no need to recompile further + rnStats [] `thenRn_` + returnRn Nothing + else + let + Just (export_env, gbl_env, fixity_env, global_avail_env) = maybe_stuff + in + + -- RENAME THE SOURCE + initRnMS gbl_env fixity_env SourceMode ( + rnSourceDecls local_decls + ) `thenRn` \ (rn_local_decls, source_fvs) -> + + -- SLURP IN ALL THE NEEDED DECLARATIONS + let + real_source_fvs = implicitFVs mod_name `plusFV` source_fvs + -- It's important to do the "plus" this way round, so that + -- when compiling the prelude, locally-defined (), Bool, etc + -- override the implicit ones. + in + slurpImpDecls real_source_fvs `thenRn` \ rn_imp_decls -> + + -- EXIT IF ERRORS FOUND + checkErrsRn `thenRn` \ no_errs_so_far -> + if not no_errs_so_far then + -- Found errors already, so exit now + rnStats [] `thenRn_` + returnRn Nothing + else + + -- GENERATE THE VERSION/USAGE INFO + getImportVersions mod_name exports `thenRn` \ my_usages -> + getNameSupplyRn `thenRn` \ name_supply -> + + -- REPORT UNUSED NAMES + reportUnusedNames gbl_env global_avail_env + export_env + source_fvs `thenRn_` + + -- RETURN THE RENAMED MODULE + let + has_orphans = any isOrphanDecl rn_local_decls + direct_import_mods = [mod | ImportDecl mod _ _ _ _ _ <- imports] + rn_all_decls = rn_imp_decls ++ rn_local_decls + renamed_module = HsModule mod_name vers + trashed_exports trashed_imports + rn_all_decls + loc + in + rnStats rn_imp_decls `thenRn_` + returnRn (Just (mkThisModule mod_name, + renamed_module, + (has_orphans, my_usages, export_env), + name_supply, + direct_import_mods)) + where + trashed_exports = {-trace "rnSource:trashed_exports"-} Nothing + trashed_imports = {-trace "rnSource:trashed_imports"-} [] +\end{code} + +@implicitFVs@ forces the renamer to slurp in some things which aren't +mentioned explicitly, but which might be needed by the type checker. + +\begin{code} +implicitFVs mod_name + = implicit_main `plusFV` + mkNameSet default_tys `plusFV` + mkNameSet thinAirIdNames + where + -- Add occurrences for Int, Double, and (), because they + -- are the types to which ambigious type variables may be defaulted by + -- the type checker; so they won't always appear explicitly. + -- [The () one is a GHC extension for defaulting CCall results.] + -- ALSO: funTyCon, since it occurs implicitly everywhere! + -- (we don't want to be bothered with making funTyCon a + -- free var at every function application!) + default_tys = [getName intTyCon, getName doubleTyCon, + getName unitTyCon, getName funTyCon, getName boolTyCon] + + -- Add occurrences for IO or PrimIO + implicit_main | mod_name == mAIN_Name + || mod_name == pREL_MAIN_Name = unitFV ioTyCon_NAME + | otherwise = emptyFVs +\end{code} + +\begin{code} +isOrphanDecl (InstD (InstDecl inst_ty _ _ _ _)) + = not (foldNameSet ((||) . isLocallyDefined) False (extractHsTyNames inst_ty)) +isOrphanDecl (RuleD (RuleDecl _ _ _ lhs _ _)) + = check lhs + where + check (HsVar v) = not (isLocallyDefined v) + check (HsApp f a) = check f && check a + check other = True +isOrphanDecl other = False +\end{code} + + +%********************************************************* +%* * +\subsection{Slurping declarations} +%* * +%********************************************************* + +\begin{code} +------------------------------------------------------- +slurpImpDecls source_fvs + = traceRn (text "slurpImp" <+> fsep (map ppr (nameSetToList source_fvs))) `thenRn_` + + -- The current slurped-set records all local things + getSlurped `thenRn` \ source_binders -> + slurpSourceRefs source_binders source_fvs `thenRn` \ (decls1, needed1, inst_gates) -> + + -- Now we can get the instance decls + slurpInstDecls decls1 needed1 inst_gates `thenRn` \ (decls2, needed2) -> + + -- And finally get everything else + closeDecls decls2 needed2 + +------------------------------------------------------- +slurpSourceRefs :: NameSet -- Variables defined in source + -> FreeVars -- Variables referenced in source + -> RnMG ([RenamedHsDecl], + FreeVars, -- Un-satisfied needs + FreeVars) -- "Gates" +-- The declaration (and hence home module) of each gate has +-- already been loaded + +slurpSourceRefs source_binders source_fvs + = go [] -- Accumulating decls + emptyFVs -- Unsatisfied needs + source_fvs -- Accumulating gates + (nameSetToList source_fvs) -- Gates whose defn hasn't been loaded yet + where + go decls fvs gates [] + = returnRn (decls, fvs, gates) + + go decls fvs gates (wanted_name:refs) + | isWiredInName wanted_name + = load_home wanted_name `thenRn_` + go decls fvs (gates `plusFV` getWiredInGates wanted_name) refs + + | otherwise + = importDecl wanted_name `thenRn` \ maybe_decl -> + case maybe_decl of + -- No declaration... (already slurped, or local) + Nothing -> go decls fvs gates refs + Just decl -> rnIfaceDecl decl `thenRn` \ (new_decl, fvs1) -> + let + new_gates = getGates source_fvs new_decl + in + go (new_decl : decls) + (fvs1 `plusFV` fvs) + (gates `plusFV` new_gates) + (nameSetToList new_gates ++ refs) + + -- When we find a wired-in name we must load its + -- home module so that we find any instance decls therein + load_home name + | name `elemNameSet` source_binders = returnRn () + -- When compiling the prelude, a wired-in thing may + -- be defined in this module, in which case we don't + -- want to load its home module! + -- Using 'isLocallyDefined' doesn't work because some of + -- the free variables returned are simply 'listTyCon_Name', + -- with a system provenance. We could look them up every time + -- but that seems a waste. + | otherwise = loadHomeInterface doc name `thenRn_` + returnRn () + where + doc = ptext SLIT("need home module for wired in thing") <+> ppr name + +------------------------------------------------------- +-- slurpInstDecls imports appropriate instance decls. +-- It has to incorporate a loop, because consider +-- instance Foo a => Baz (Maybe a) where ... +-- It may be that Baz and Maybe are used in the source module, +-- but not Foo; so we need to chase Foo too. + +slurpInstDecls decls needed gates + | isEmptyFVs gates + = returnRn (decls, needed) + + | otherwise + = getImportedInstDecls gates `thenRn` \ inst_decls -> + rnInstDecls decls needed emptyFVs inst_decls `thenRn` \ (decls1, needed1, gates1) -> + slurpInstDecls decls1 needed1 gates1 + where + rnInstDecls decls fvs gates [] + = returnRn (decls, fvs, gates) + rnInstDecls decls fvs gates (d:ds) + = rnIfaceDecl d `thenRn` \ (new_decl, fvs1) -> + rnInstDecls (new_decl:decls) + (fvs1 `plusFV` fvs) + (gates `plusFV` getInstDeclGates new_decl) + ds + + +------------------------------------------------------- +-- closeDecls keeps going until the free-var set is empty +closeDecls decls needed + | not (isEmptyFVs needed) + = slurpDecls decls needed `thenRn` \ (decls1, needed1) -> + closeDecls decls1 needed1 + + | otherwise + = getImportedRules `thenRn` \ rule_decls -> + case rule_decls of + [] -> returnRn decls -- No new rules, so we are done + other -> rnIfaceDecls decls emptyFVs rule_decls `thenRn` \ (decls1, needed1) -> + closeDecls decls1 needed1 + + +------------------------------------------------------- +rnIfaceDecls :: [RenamedHsDecl] -> FreeVars + -> [(Module, RdrNameHsDecl)] + -> RnM d ([RenamedHsDecl], FreeVars) +rnIfaceDecls decls fvs [] = returnRn (decls, fvs) +rnIfaceDecls decls fvs (d:ds) = rnIfaceDecl d `thenRn` \ (new_decl, fvs1) -> + rnIfaceDecls (new_decl:decls) (fvs1 `plusFV` fvs) ds + +rnIfaceDecl (mod, decl) = initIfaceRnMS mod (rnDecl decl) + + +------------------------------------------------------- +-- Augment decls with any decls needed by needed. +-- Return also free vars of the new decls (only) +slurpDecls decls needed + = go decls emptyFVs (nameSetToList needed) + where + go decls fvs [] = returnRn (decls, fvs) + go decls fvs (ref:refs) = slurpDecl decls fvs ref `thenRn` \ (decls1, fvs1) -> + go decls1 fvs1 refs + +------------------------------------------------------- +slurpDecl decls fvs wanted_name + = importDecl wanted_name `thenRn` \ maybe_decl -> + case maybe_decl of + -- No declaration... (wired in thing) + Nothing -> returnRn (decls, fvs) + + -- Found a declaration... rename it + Just decl -> rnIfaceDecl decl `thenRn` \ (new_decl, fvs1) -> + returnRn (new_decl:decls, fvs1 `plusFV` fvs) +\end{code} + + +%********************************************************* +%* * +\subsection{Extracting the 'gates'} +%* * +%********************************************************* + +When we import a declaration like + + data T = T1 Wibble | T2 Wobble + +we don't want to treat Wibble and Wobble as gates *unless* T1, T2 +respectively are mentioned by the user program. If only T is mentioned +we want only T to be a gate; that way we don't suck in useless instance +decls for (say) Eq Wibble, when they can't possibly be useful. + +@getGates@ takes a newly imported (and renamed) decl, and the free +vars of the source program, and extracts from the decl the gate names. + +\begin{code} +getGates source_fvs (SigD (IfaceSig _ ty _ _)) + = extractHsTyNames ty + +getGates source_fvs (TyClD (ClassDecl ctxt cls tvs sigs _ _ _ _ _ _)) + = delListFromNameSet (foldr (plusFV . get) (extractHsCtxtTyNames ctxt) sigs) + (map getTyVarName tvs) + `addOneToNameSet` cls + where + get (ClassOpSig n _ ty _) + | n `elemNameSet` source_fvs = extractHsTyNames ty + | otherwise = emptyFVs + +getGates source_fvs (TyClD (TySynonym tycon tvs ty _)) + = delListFromNameSet (extractHsTyNames ty) + (map getTyVarName tvs) + -- A type synonym type constructor isn't a "gate" for instance decls + +getGates source_fvs (TyClD (TyData _ ctxt tycon tvs cons _ _ _)) + = delListFromNameSet (foldr (plusFV . get) (extractHsCtxtTyNames ctxt) cons) + (map getTyVarName tvs) + `addOneToNameSet` tycon + where + get (ConDecl n tvs ctxt details _) + | n `elemNameSet` source_fvs + -- If the constructor is method, get fvs from all its fields + = delListFromNameSet (get_details details `plusFV` + extractHsCtxtTyNames ctxt) + (map getTyVarName tvs) + get (ConDecl n tvs ctxt (RecCon fields) _) + -- Even if the constructor isn't mentioned, the fields + -- might be, as selectors. They can't mention existentially + -- bound tyvars (typechecker checks for that) so no need for + -- the deleteListFromNameSet part + = foldr (plusFV . get_field) emptyFVs fields + + get other_con = emptyFVs + + get_details (VanillaCon tys) = plusFVs (map get_bang tys) + get_details (InfixCon t1 t2) = get_bang t1 `plusFV` get_bang t2 + get_details (RecCon fields) = plusFVs [get_bang t | (_, t) <- fields] + get_details (NewCon t _) = extractHsTyNames t + + get_field (fs,t) | any (`elemNameSet` source_fvs) fs = get_bang t + | otherwise = emptyFVs + + get_bang (Banged t) = extractHsTyNames t + get_bang (Unbanged t) = extractHsTyNames t + get_bang (Unpacked t) = extractHsTyNames t + +getGates source_fvs other_decl = emptyFVs +\end{code} + +getWiredInGates is just like getGates, but it sees a wired-in Name +rather than a declaration. + +\begin{code} +getWiredInGates :: Name -> FreeVars +getWiredInGates name -- No classes are wired in + | is_id = getWiredInGates_s (namesOfType (idType the_id)) + | isSynTyCon the_tycon = getWiredInGates_s (delListFromNameSet (namesOfType ty) (map getName tyvars)) + | otherwise = unitFV name + where + maybe_wired_in_id = maybeWiredInIdName name + is_id = maybeToBool maybe_wired_in_id + maybe_wired_in_tycon = maybeWiredInTyConName name + Just the_id = maybe_wired_in_id + Just the_tycon = maybe_wired_in_tycon + (tyvars,ty) = getSynTyConDefn the_tycon + +getWiredInGates_s names = foldr (plusFV . getWiredInGates) emptyFVs (nameSetToList names) +\end{code} + +\begin{code} +getInstDeclGates (InstD (InstDecl inst_ty _ _ _ _)) = extractHsTyNames inst_ty +getInstDeclGates other = emptyFVs +\end{code} + + +%********************************************************* +%* * +\subsection{Unused names} +%* * +%********************************************************* + +\begin{code} +reportUnusedNames gbl_env avail_env (ExportEnv export_avails _) mentioned_names + | not (opt_WarnUnusedBinds || opt_WarnUnusedImports) + = returnRn () + + | otherwise + = let + used_names = mentioned_names `unionNameSets` availsToNameSet export_avails + + -- Now, a use of C implies a use of T, + -- if C was brought into scope by T(..) or T(C) + really_used_names = used_names `unionNameSets` + mkNameSet [ availName avail + | sub_name <- nameSetToList used_names, + let avail = case lookupNameEnv avail_env sub_name of + Just avail -> avail + Nothing -> pprTrace "r.u.n" (ppr sub_name) $ + Avail sub_name + ] + + defined_names = mkNameSet (concat (rdrEnvElts gbl_env)) + defined_but_not_used = nameSetToList (defined_names `minusNameSet` really_used_names) + + -- Filter out the ones only defined implicitly + bad_guys = filter reportableUnusedName defined_but_not_used + in + warnUnusedTopNames bad_guys `thenRn_` + returnRn () + +reportableUnusedName :: Name -> Bool +reportableUnusedName name + = explicitlyImported (getNameProvenance name) && + not (startsWithUnderscore (occNameUserString (nameOccName name))) + where + explicitlyImported (LocalDef _ _) = True -- Report unused defns of local vars + explicitlyImported (NonLocalDef (UserImport _ _ expl) _) = expl -- Report unused explicit imports + explicitlyImported other = False -- Don't report others + + -- Haskell 98 encourages compilers to suppress warnings about + -- unused names in a pattern if they start with "_". + startsWithUnderscore ('_' : _) = True -- Suppress warnings for names starting + startsWithUnderscore other = False -- with an underscore + +rnStats :: [RenamedHsDecl] -> RnMG () +rnStats imp_decls + | opt_D_dump_rn_trace || + opt_D_dump_rn_stats || + opt_D_dump_rn + = getRnStats imp_decls `thenRn` \ msg -> + ioToRnM (printErrs msg) `thenRn_` + returnRn () + + | otherwise = returnRn () +\end{code} + + + +%********************************************************* +%* * +\subsection{Statistics} +%* * +%********************************************************* + +\begin{code} +getRnStats :: [RenamedHsDecl] -> RnMG SDoc +getRnStats imported_decls + = getIfacesRn `thenRn` \ ifaces -> + let + n_mods = length [() | (_, _, Just _) <- eltsFM (iImpModInfo ifaces)] + + decls_read = [decl | (_, avail, True, (_,decl)) <- nameEnvElts (iDecls ifaces), + -- Data, newtype, and class decls are in the decls_fm + -- under multiple names; the tycon/class, and each + -- constructor/class op too. + -- The 'True' selects just the 'main' decl + not (isLocallyDefined (availName avail)) + ] + + (cd_rd, dd_rd, nd_rd, sd_rd, vd_rd, _) = count_decls decls_read + (cd_sp, dd_sp, nd_sp, sd_sp, vd_sp, id_sp) = count_decls imported_decls + + unslurped_insts = iInsts ifaces + inst_decls_unslurped = length (bagToList unslurped_insts) + inst_decls_read = id_sp + inst_decls_unslurped + + stats = vcat + [int n_mods <+> text "interfaces read", + hsep [ int cd_sp, text "class decls imported, out of", + int cd_rd, text "read"], + hsep [ int dd_sp, text "data decls imported, out of", + int dd_rd, text "read"], + hsep [ int nd_sp, text "newtype decls imported, out of", + int nd_rd, text "read"], + hsep [int sd_sp, text "type synonym decls imported, out of", + int sd_rd, text "read"], + hsep [int vd_sp, text "value signatures imported, out of", + int vd_rd, text "read"], + hsep [int id_sp, text "instance decls imported, out of", + int inst_decls_read, text "read"], + text "cls dcls slurp" <+> fsep (map (ppr . tyClDeclName) + [d | TyClD d <- imported_decls, isClassDecl d]), + text "cls dcls read" <+> fsep (map (ppr . tyClDeclName) + [d | TyClD d <- decls_read, isClassDecl d])] + in + returnRn (hcat [text "Renamer stats: ", stats]) + +count_decls decls + = (class_decls, + data_decls, + newtype_decls, + syn_decls, + val_decls, + inst_decls) + where + tycl_decls = [d | TyClD d <- decls] + (class_decls, data_decls, newtype_decls, syn_decls) = countTyClDecls tycl_decls + + val_decls = length [() | SigD _ <- decls] + inst_decls = length [() | InstD _ <- decls] +\end{code} + diff --git a/ghc/compiler/rename/RnBinds.lhs b/ghc/compiler/rename/RnBinds.lhs index b6f6d2c..b55f6fe 100644 --- a/ghc/compiler/rename/RnBinds.lhs +++ b/ghc/compiler/rename/RnBinds.lhs @@ -1,597 +1,607 @@ -% -% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998 -% -\section[RnBinds]{Renaming and dependency analysis of bindings} - -This module does renaming and dependency analysis on value bindings in -the abstract syntax. It does {\em not} do cycle-checks on class or -type-synonym declarations; those cannot be done at this stage because -they may be affected by renaming (which isn't fully worked out yet). - -\begin{code} -module RnBinds ( - rnTopBinds, rnTopMonoBinds, - rnMethodBinds, renameSigs, - rnBinds, - unknownSigErr - ) where - -#include "HsVersions.h" - -import {-# SOURCE #-} RnSource ( rnHsSigType ) - -import HsSyn -import HsBinds ( sigsForMe ) -import RdrHsSyn -import RnHsSyn -import RnMonad -import RnExpr ( rnMatch, rnGRHSs, rnPat, checkPrecMatch ) -import RnEnv ( bindLocatedLocalsRn, lookupBndrRn, lookupGlobalOccRn, - warnUnusedLocalBinds, mapFvRn, - FreeVars, emptyFVs, plusFV, plusFVs, unitFV, addOneFV, - unknownNameErr - ) -import CmdLineOpts ( opt_WarnMissingSigs ) -import Digraph ( stronglyConnComp, SCC(..) ) -import Name ( OccName, Name, nameOccName ) -import NameSet -import RdrName ( RdrName, rdrNameOcc ) -import BasicTypes ( RecFlag(..), TopLevelFlag(..) ) -import Util ( thenCmp, removeDups ) -import List ( partition ) -import ListSetOps ( minusList ) -import Bag ( bagToList ) -import FiniteMap ( lookupFM, listToFM ) -import Maybe ( isJust ) -import Outputable -\end{code} - --- ToDo: Put the annotations into the monad, so that they arrive in the proper --- place and can be used when complaining. - -The code tree received by the function @rnBinds@ contains definitions -in where-clauses which are all apparently mutually recursive, but which may -not really depend upon each other. For example, in the top level program -\begin{verbatim} -f x = y where a = x - y = x -\end{verbatim} -the definitions of @a@ and @y@ do not depend on each other at all. -Unfortunately, the typechecker cannot always check such definitions. -\footnote{Mycroft, A. 1984. Polymorphic type schemes and recursive -definitions. In Proceedings of the International Symposium on Programming, -Toulouse, pp. 217-39. LNCS 167. Springer Verlag.} -However, the typechecker usually can check definitions in which only the -strongly connected components have been collected into recursive bindings. -This is precisely what the function @rnBinds@ does. - -ToDo: deal with case where a single monobinds binds the same variable -twice. - -The vertag tag is a unique @Int@; the tags only need to be unique -within one @MonoBinds@, so that unique-Int plumbing is done explicitly -(heavy monad machinery not needed). - -\begin{code} -type VertexTag = Int -type Cycle = [VertexTag] -type Edge = (VertexTag, VertexTag) -\end{code} - -%************************************************************************ -%* * -%* naming conventions * -%* * -%************************************************************************ - -\subsection[name-conventions]{Name conventions} - -The basic algorithm involves walking over the tree and returning a tuple -containing the new tree plus its free variables. Some functions, such -as those walking polymorphic bindings (HsBinds) and qualifier lists in -list comprehensions (@Quals@), return the variables bound in local -environments. These are then used to calculate the free variables of the -expression evaluated in these environments. - -Conventions for variable names are as follows: -\begin{itemize} -\item -new code is given a prime to distinguish it from the old. - -\item -a set of variables defined in @Exp@ is written @dvExp@ - -\item -a set of variables free in @Exp@ is written @fvExp@ -\end{itemize} - -%************************************************************************ -%* * -%* analysing polymorphic bindings (HsBinds, Bind, MonoBinds) * -%* * -%************************************************************************ - -\subsubsection[dep-HsBinds]{Polymorphic bindings} - -Non-recursive expressions are reconstructed without any changes at top -level, although their component expressions may have to be altered. -However, non-recursive expressions are currently not expected as -\Haskell{} programs, and this code should not be executed. - -Monomorphic bindings contain information that is returned in a tuple -(a @FlatMonoBindsInfo@) containing: - -\begin{enumerate} -\item -a unique @Int@ that serves as the ``vertex tag'' for this binding. - -\item -the name of a function or the names in a pattern. These are a set -referred to as @dvLhs@, the defined variables of the left hand side. - -\item -the free variables of the body. These are referred to as @fvBody@. - -\item -the definition's actual code. This is referred to as just @code@. -\end{enumerate} - -The function @nonRecDvFv@ returns two sets of variables. The first is -the set of variables defined in the set of monomorphic bindings, while the -second is the set of free variables in those bindings. - -The set of variables defined in a non-recursive binding is just the -union of all of them, as @union@ removes duplicates. However, the -free variables in each successive set of cumulative bindings is the -union of those in the previous set plus those of the newest binding after -the defined variables of the previous set have been removed. - -@rnMethodBinds@ deals only with the declarations in class and -instance declarations. It expects only to see @FunMonoBind@s, and -it expects the global environment to contain bindings for the binders -(which are all class operations). - -%************************************************************************ -%* * -%* Top-level bindings -%* * -%************************************************************************ - -@rnTopBinds@ assumes that the environment already -contains bindings for the binders of this particular binding. - -\begin{code} -rnTopBinds :: RdrNameHsBinds -> RnMS (RenamedHsBinds, FreeVars) - -rnTopBinds EmptyBinds = returnRn (EmptyBinds, emptyFVs) -rnTopBinds (MonoBind bind sigs _) = rnTopMonoBinds bind sigs - -- The parser doesn't produce other forms - - -rnTopMonoBinds EmptyMonoBinds sigs - = returnRn (EmptyBinds, emptyFVs) - -rnTopMonoBinds mbinds sigs - = mapRn lookupBndrRn binder_rdr_names `thenRn` \ binder_names -> - let - binder_set = mkNameSet binder_names - binder_occ_fm = listToFM [(nameOccName x,x) | x <- binder_names] - in - renameSigs opt_WarnMissingSigs binder_set - (lookupSigOccRn binder_occ_fm) sigs `thenRn` \ (siglist, sig_fvs) -> - rn_mono_binds siglist mbinds `thenRn` \ (final_binds, bind_fvs) -> - returnRn (final_binds, bind_fvs `plusFV` sig_fvs) - where - binder_rdr_names = map fst (bagToList (collectMonoBinders mbinds)) - --- the names appearing in the sigs have to be bound by --- this group's binders. -lookupSigOccRn binder_occ_fm rdr_name - = case lookupFM binder_occ_fm (rdrNameOcc rdr_name) of - Nothing -> failWithRn (mkUnboundName rdr_name) - (unknownNameErr rdr_name) - Just x -> returnRn x -\end{code} - -%************************************************************************ -%* * -%* Nested binds -%* * -%************************************************************************ - -@rnMonoBinds@ - - collects up the binders for this declaration group, - - checks that they form a set - - extends the environment to bind them to new local names - - calls @rnMonoBinds@ to do the real work - -\begin{code} -rnBinds :: RdrNameHsBinds - -> (RenamedHsBinds -> RnMS (result, FreeVars)) - -> RnMS (result, FreeVars) - -rnBinds EmptyBinds thing_inside = thing_inside EmptyBinds -rnBinds (MonoBind bind sigs _) thing_inside = rnMonoBinds bind sigs thing_inside - -- the parser doesn't produce other forms - - -rnMonoBinds :: RdrNameMonoBinds - -> [RdrNameSig] - -> (RenamedHsBinds -> RnMS (result, FreeVars)) - -> RnMS (result, FreeVars) - -rnMonoBinds EmptyMonoBinds sigs thing_inside = thing_inside EmptyBinds - -rnMonoBinds mbinds sigs thing_inside -- Non-empty monobinds - = -- Extract all the binders in this group, - -- and extend current scope, inventing new names for the new binders - -- This also checks that the names form a set - bindLocatedLocalsRn (text "a binding group") mbinders_w_srclocs $ \ new_mbinders -> - let - binder_set = mkNameSet new_mbinders - - -- Weed out the fixity declarations that do not - -- apply to any of the binders in this group. - (sigs_for_me, fixes_not_for_me) = partition forLocalBind sigs - - forLocalBind (FixSig sig@(FixitySig name _ _ )) = - isJust (lookupFM binder_occ_fm (rdrNameOcc name)) - forLocalBind _ = True - - binder_occ_fm = listToFM [(nameOccName x,x) | x <- new_mbinders] - - in - -- Report the fixity declarations in this group that - -- don't refer to any of the group's binders. - -- - mapRn_ (unknownSigErr) fixes_not_for_me `thenRn_` - renameSigs False binder_set - (lookupSigOccRn binder_occ_fm) sigs_for_me `thenRn` \ (siglist, sig_fvs) -> - let - fixity_sigs = [(name,sig) | FixSig sig@(FixitySig name _ _) <- siglist ] - in - -- Install the fixity declarations that do apply here and go. - extendFixityEnv fixity_sigs ( - rn_mono_binds siglist mbinds - ) `thenRn` \ (binds, bind_fvs) -> - - -- Now do the "thing inside", and deal with the free-variable calculations - thing_inside binds `thenRn` \ (result,result_fvs) -> - let - all_fvs = result_fvs `plusFV` bind_fvs `plusFV` sig_fvs - unused_binders = nameSetToList (binder_set `minusNameSet` all_fvs) - in - warnUnusedLocalBinds unused_binders `thenRn_` - returnRn (result, delListFromNameSet all_fvs new_mbinders) - where - mbinders_w_srclocs = bagToList (collectMonoBinders mbinds) -\end{code} - - -%************************************************************************ -%* * -%* MonoBinds -- the main work is done here -%* * -%************************************************************************ - -@rn_mono_binds@ is used by *both* top-level and nested bindings. It -assumes that all variables bound in this group are already in scope. -This is done *either* by pass 3 (for the top-level bindings), *or* by -@rnMonoBinds@ (for the nested ones). - -\begin{code} -rn_mono_binds :: [RenamedSig] -- Signatures attached to this group - -> RdrNameMonoBinds - -> RnMS (RenamedHsBinds, -- - FreeVars) -- Free variables - -rn_mono_binds siglist mbinds - = - -- Rename the bindings, returning a MonoBindsInfo - -- which is a list of indivisible vertices so far as - -- the strongly-connected-components (SCC) analysis is concerned - flattenMonoBinds siglist mbinds `thenRn` \ mbinds_info -> - - -- Do the SCC analysis - let - edges = mkEdges (mbinds_info `zip` [(0::Int)..]) - scc_result = stronglyConnComp edges - final_binds = foldr1 ThenBinds (map reconstructCycle scc_result) - - -- Deal with bound and free-var calculation - rhs_fvs = plusFVs [fvs | (_,fvs,_,_) <- mbinds_info] - in - returnRn (final_binds, rhs_fvs) -\end{code} - -@flattenMonoBinds@ is ever-so-slightly magical in that it sticks -unique ``vertex tags'' on its output; minor plumbing required. - -Sigh - need to pass along the signatures for the group of bindings, -in case any of them - -\begin{code} -flattenMonoBinds :: [RenamedSig] -- Signatures - -> RdrNameMonoBinds - -> RnMS [FlatMonoBindsInfo] - -flattenMonoBinds sigs EmptyMonoBinds = returnRn [] - -flattenMonoBinds sigs (AndMonoBinds bs1 bs2) - = flattenMonoBinds sigs bs1 `thenRn` \ flat1 -> - flattenMonoBinds sigs bs2 `thenRn` \ flat2 -> - returnRn (flat1 ++ flat2) - -flattenMonoBinds sigs (PatMonoBind pat grhss locn) - = pushSrcLocRn locn $ - rnPat pat `thenRn` \ (pat', pat_fvs) -> - - -- Find which things are bound in this group - let - names_bound_here = mkNameSet (collectPatBinders pat') - sigs_for_me = sigsForMe (`elemNameSet` names_bound_here) sigs - in - rnGRHSs grhss `thenRn` \ (grhss', fvs) -> - returnRn - [(names_bound_here, - fvs `plusFV` pat_fvs, - PatMonoBind pat' grhss' locn, - sigs_for_me - )] - -flattenMonoBinds sigs (FunMonoBind name inf matches locn) - = pushSrcLocRn locn $ - lookupBndrRn name `thenRn` \ new_name -> - let - sigs_for_me = sigsForMe (new_name ==) sigs - in - mapFvRn rnMatch matches `thenRn` \ (new_matches, fvs) -> - mapRn_ (checkPrecMatch inf new_name) new_matches `thenRn_` - returnRn - [(unitNameSet new_name, - fvs, - FunMonoBind new_name inf new_matches locn, - sigs_for_me - )] -\end{code} - - -@rnMethodBinds@ is used for the method bindings of a class and an instance -declaration. like @rnMonoBinds@ but without dependency analysis. - -\begin{code} -rnMethodBinds :: RdrNameMonoBinds -> RnMS (RenamedMonoBinds, FreeVars) - -rnMethodBinds EmptyMonoBinds = returnRn (EmptyMonoBinds, emptyFVs) - -rnMethodBinds (AndMonoBinds mb1 mb2) - = rnMethodBinds mb1 `thenRn` \ (mb1', fvs1) -> - rnMethodBinds mb2 `thenRn` \ (mb2', fvs2) -> - returnRn (mb1' `AndMonoBinds` mb2', fvs1 `plusFV` fvs2) - -rnMethodBinds (FunMonoBind name inf matches locn) - = pushSrcLocRn locn $ - - lookupGlobalOccRn name `thenRn` \ sel_name -> - -- We use the selector name as the binder - - mapFvRn rnMatch matches `thenRn` \ (new_matches, fvs) -> - mapRn_ (checkPrecMatch inf sel_name) new_matches `thenRn_` - returnRn (FunMonoBind sel_name inf new_matches locn, fvs) - -rnMethodBinds (PatMonoBind (VarPatIn name) grhss locn) - = pushSrcLocRn locn $ - lookupGlobalOccRn name `thenRn` \ sel_name -> - rnGRHSs grhss `thenRn` \ (grhss', fvs) -> - returnRn (PatMonoBind (VarPatIn sel_name) grhss' locn, fvs) - --- Can't handle method pattern-bindings which bind multiple methods. -rnMethodBinds mbind@(PatMonoBind other_pat _ locn) - = pushSrcLocRn locn $ - failWithRn (EmptyMonoBinds, emptyFVs) (methodBindErr mbind) -\end{code} - - -%************************************************************************ -%* * -\subsection[reconstruct-deps]{Reconstructing dependencies} -%* * -%************************************************************************ - -This @MonoBinds@- and @ClassDecls@-specific code is segregated here, -as the two cases are similar. - -\begin{code} -reconstructCycle :: SCC FlatMonoBindsInfo - -> RenamedHsBinds - -reconstructCycle (AcyclicSCC (_, _, binds, sigs)) - = MonoBind binds sigs NonRecursive - -reconstructCycle (CyclicSCC cycle) - = MonoBind this_gp_binds this_gp_sigs Recursive - where - this_gp_binds = foldr1 AndMonoBinds [binds | (_, _, binds, _) <- cycle] - this_gp_sigs = foldr1 (++) [sigs | (_, _, _, sigs) <- cycle] -\end{code} - -%************************************************************************ -%* * -%* Manipulating FlatMonoBindInfo * -%* * -%************************************************************************ - -During analysis a @MonoBinds@ is flattened to a @FlatMonoBindsInfo@. -The @RenamedMonoBinds@ is always an empty bind, a pattern binding or -a function binding, and has itself been dependency-analysed and -renamed. - -\begin{code} -type FlatMonoBindsInfo - = (NameSet, -- Set of names defined in this vertex - NameSet, -- Set of names used in this vertex - RenamedMonoBinds, - [RenamedSig]) -- Signatures, if any, for this vertex - -mkEdges :: [(FlatMonoBindsInfo, VertexTag)] -> [(FlatMonoBindsInfo, VertexTag, [VertexTag])] - -mkEdges flat_info - = [ (info, tag, dest_vertices (nameSetToList names_used)) - | (info@(names_defined, names_used, mbind, sigs), tag) <- flat_info - ] - where - -- An edge (v,v') indicates that v depends on v' - dest_vertices src_mentions = [ target_vertex - | ((names_defined, _, _, _), target_vertex) <- flat_info, - mentioned_name <- src_mentions, - mentioned_name `elemNameSet` names_defined - ] -\end{code} - - -%************************************************************************ -%* * -\subsubsection[dep-Sigs]{Signatures (and user-pragmas for values)} -%* * -%************************************************************************ - -@renameSigs@ checks for: (a)~more than one sig for one thing; -(b)~signatures given for things not bound here; (c)~with suitably -flaggery, that all top-level things have type signatures. - -At the moment we don't gather free-var info from the types in -signatures. We'd only need this if we wanted to report unused tyvars. - -\begin{code} -renameSigs :: Bool -- True => warn if (required) type signatures are missing. - -> NameSet -- Set of names bound in this group - -> (RdrName -> RnMS Name) - -> [RdrNameSig] - -> RnMS ([RenamedSig], FreeVars) -- List of Sig constructors - -renameSigs sigs_required binders lookup_occ_nm sigs - = -- Rename the signatures - mapFvRn (renameSig lookup_occ_nm) sigs `thenRn` \ (sigs', fvs) -> - - -- Check for (a) duplicate signatures - -- (b) signatures for things not in this group - -- (c) optionally, bindings with no signature - let - (goodies, dups) = removeDups cmp_sig (sigsForMe (not . isUnboundName) sigs') - not_this_group = sigsForMe (not . (`elemNameSet` binders)) goodies - type_sig_vars = [n | Sig n _ _ <- goodies] - un_sigd_binders | sigs_required = nameSetToList binders `minusList` type_sig_vars - | otherwise = [] - in - mapRn_ dupSigDeclErr dups `thenRn_` - mapRn_ unknownSigErr not_this_group `thenRn_` - mapRn_ (addWarnRn.missingSigWarn) un_sigd_binders `thenRn_` - returnRn (sigs', fvs) - -- bad ones and all: - -- we need bindings of *some* sort for every name - --- We use lookupOccRn in the signatures, which is a little bit unsatisfactory --- because this won't work for: --- instance Foo T where --- {-# INLINE op #-} --- Baz.op = ... --- We'll just rename the INLINE prag to refer to whatever other 'op' --- is in scope. (I'm assuming that Baz.op isn't in scope unqualified.) --- Doesn't seem worth much trouble to sort this. - -renameSig lookup_occ_nm (Sig v ty src_loc) - = pushSrcLocRn src_loc $ - lookup_occ_nm v `thenRn` \ new_v -> - rnHsSigType (quotes (ppr v)) ty `thenRn` \ (new_ty,fvs) -> - returnRn (Sig new_v new_ty src_loc, fvs `addOneFV` new_v) - -renameSig _ (SpecInstSig ty src_loc) - = pushSrcLocRn src_loc $ - rnHsSigType (text "A SPECIALISE instance pragma") ty `thenRn` \ (new_ty, fvs) -> - returnRn (SpecInstSig new_ty src_loc, fvs) - -renameSig lookup_occ_nm (SpecSig v ty src_loc) - = pushSrcLocRn src_loc $ - lookup_occ_nm v `thenRn` \ new_v -> - rnHsSigType (quotes (ppr v)) ty `thenRn` \ (new_ty,fvs) -> - returnRn (SpecSig new_v new_ty src_loc, fvs `addOneFV` new_v) - -renameSig lookup_occ_nm (InlineSig v src_loc) - = pushSrcLocRn src_loc $ - lookup_occ_nm v `thenRn` \ new_v -> - returnRn (InlineSig new_v src_loc, unitFV new_v) - -renameSig lookup_occ_nm (FixSig (FixitySig v fix src_loc)) - = pushSrcLocRn src_loc $ - lookup_occ_nm v `thenRn` \ new_v -> - returnRn (FixSig (FixitySig new_v fix src_loc), unitFV new_v) - -renameSig lookup_occ_nm (NoInlineSig v src_loc) - = pushSrcLocRn src_loc $ - lookup_occ_nm v `thenRn` \ new_v -> - returnRn (NoInlineSig new_v src_loc, unitFV new_v) -\end{code} - -Checking for distinct signatures; oh, so boring - -\begin{code} -cmp_sig :: RenamedSig -> RenamedSig -> Ordering -cmp_sig (Sig n1 _ _) (Sig n2 _ _) = n1 `compare` n2 -cmp_sig (InlineSig n1 _) (InlineSig n2 _) = n1 `compare` n2 -cmp_sig (NoInlineSig n1 _) (NoInlineSig n2 _) = n1 `compare` n2 -cmp_sig (SpecInstSig ty1 _) (SpecInstSig ty2 _) = cmpHsType compare ty1 ty2 -cmp_sig (SpecSig n1 ty1 _) (SpecSig n2 ty2 _) - = -- may have many specialisations for one value; - -- but not ones that are exactly the same... - thenCmp (n1 `compare` n2) (cmpHsType compare ty1 ty2) - -cmp_sig other_1 other_2 -- Tags *must* be different - | (sig_tag other_1) _LT_ (sig_tag other_2) = LT - | otherwise = GT - -sig_tag (Sig n1 _ _) = (ILIT(1) :: FAST_INT) -sig_tag (SpecSig n1 _ _) = ILIT(2) -sig_tag (InlineSig n1 _) = ILIT(3) -sig_tag (NoInlineSig n1 _) = ILIT(4) -sig_tag (SpecInstSig _ _) = ILIT(5) -sig_tag (FixSig _) = ILIT(6) -sig_tag _ = panic# "tag(RnBinds)" -\end{code} - -%************************************************************************ -%* * -\subsection{Error messages} -%* * -%************************************************************************ - -\begin{code} -dupSigDeclErr (sig:sigs) - = pushSrcLocRn loc $ - addErrRn (sep [ptext SLIT("Duplicate") <+> ptext what_it_is <> colon, - ppr sig]) - where - (what_it_is, loc) = sig_doc sig - -unknownSigErr sig - = pushSrcLocRn loc $ - addErrRn (sep [ptext SLIT("Misplaced"), - ptext what_it_is <> colon, - ppr sig]) - where - (what_it_is, loc) = sig_doc sig - -sig_doc (Sig _ _ loc) = (SLIT("type signature"),loc) -sig_doc (ClassOpSig _ _ _ loc) = (SLIT("class-method type signature"), loc) -sig_doc (SpecSig _ _ loc) = (SLIT("SPECIALISE pragma"),loc) -sig_doc (InlineSig _ loc) = (SLIT("INLINE pragma"),loc) -sig_doc (NoInlineSig _ loc) = (SLIT("NOINLINE pragma"),loc) -sig_doc (SpecInstSig _ loc) = (SLIT("SPECIALISE instance pragma"),loc) -sig_doc (FixSig (FixitySig _ _ loc)) = (SLIT("fixity declaration"), loc) - -missingSigWarn var - = sep [ptext SLIT("definition but no type signature for"), quotes (ppr var)] - -methodBindErr mbind - = hang (ptext SLIT("Can't handle multiple methods defined by one pattern binding")) - 4 (ppr mbind) -\end{code} +% +% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998 +% +\section[RnBinds]{Renaming and dependency analysis of bindings} + +This module does renaming and dependency analysis on value bindings in +the abstract syntax. It does {\em not} do cycle-checks on class or +type-synonym declarations; those cannot be done at this stage because +they may be affected by renaming (which isn't fully worked out yet). + +\begin{code} +module RnBinds ( + rnTopBinds, rnTopMonoBinds, + rnMethodBinds, renameSigs, + rnBinds, + unknownSigErr + ) where + +#include "HsVersions.h" + +import {-# SOURCE #-} RnSource ( rnHsSigType ) + +import HsSyn +import HsBinds ( sigsForMe ) +import RdrHsSyn +import RnHsSyn +import RnMonad +import RnExpr ( rnMatch, rnGRHSs, rnPat, checkPrecMatch ) +import RnEnv ( bindLocatedLocalsRn, lookupBndrRn, lookupGlobalOccRn, + warnUnusedLocalBinds, mapFvRn, + FreeVars, emptyFVs, plusFV, plusFVs, unitFV, addOneFV, + unknownNameErr + ) +import CmdLineOpts ( opt_WarnMissingSigs ) +import Digraph ( stronglyConnComp, SCC(..) ) +import Name ( OccName, Name, nameOccName ) +import NameSet +import RdrName ( RdrName, rdrNameOcc ) +import BasicTypes ( RecFlag(..), TopLevelFlag(..) ) +import Util ( thenCmp, removeDups ) +import List ( partition ) +import ListSetOps ( minusList ) +import Bag ( bagToList ) +import FiniteMap ( lookupFM, listToFM ) +import Maybe ( isJust ) +import Outputable +\end{code} + +-- ToDo: Put the annotations into the monad, so that they arrive in the proper +-- place and can be used when complaining. + +The code tree received by the function @rnBinds@ contains definitions +in where-clauses which are all apparently mutually recursive, but which may +not really depend upon each other. For example, in the top level program +\begin{verbatim} +f x = y where a = x + y = x +\end{verbatim} +the definitions of @a@ and @y@ do not depend on each other at all. +Unfortunately, the typechecker cannot always check such definitions. +\footnote{Mycroft, A. 1984. Polymorphic type schemes and recursive +definitions. In Proceedings of the International Symposium on Programming, +Toulouse, pp. 217-39. LNCS 167. Springer Verlag.} +However, the typechecker usually can check definitions in which only the +strongly connected components have been collected into recursive bindings. +This is precisely what the function @rnBinds@ does. + +ToDo: deal with case where a single monobinds binds the same variable +twice. + +The vertag tag is a unique @Int@; the tags only need to be unique +within one @MonoBinds@, so that unique-Int plumbing is done explicitly +(heavy monad machinery not needed). + +\begin{code} +type VertexTag = Int +type Cycle = [VertexTag] +type Edge = (VertexTag, VertexTag) +\end{code} + +%************************************************************************ +%* * +%* naming conventions * +%* * +%************************************************************************ + +\subsection[name-conventions]{Name conventions} + +The basic algorithm involves walking over the tree and returning a tuple +containing the new tree plus its free variables. Some functions, such +as those walking polymorphic bindings (HsBinds) and qualifier lists in +list comprehensions (@Quals@), return the variables bound in local +environments. These are then used to calculate the free variables of the +expression evaluated in these environments. + +Conventions for variable names are as follows: +\begin{itemize} +\item +new code is given a prime to distinguish it from the old. + +\item +a set of variables defined in @Exp@ is written @dvExp@ + +\item +a set of variables free in @Exp@ is written @fvExp@ +\end{itemize} + +%************************************************************************ +%* * +%* analysing polymorphic bindings (HsBinds, Bind, MonoBinds) * +%* * +%************************************************************************ + +\subsubsection[dep-HsBinds]{Polymorphic bindings} + +Non-recursive expressions are reconstructed without any changes at top +level, although their component expressions may have to be altered. +However, non-recursive expressions are currently not expected as +\Haskell{} programs, and this code should not be executed. + +Monomorphic bindings contain information that is returned in a tuple +(a @FlatMonoBindsInfo@) containing: + +\begin{enumerate} +\item +a unique @Int@ that serves as the ``vertex tag'' for this binding. + +\item +the name of a function or the names in a pattern. These are a set +referred to as @dvLhs@, the defined variables of the left hand side. + +\item +the free variables of the body. These are referred to as @fvBody@. + +\item +the definition's actual code. This is referred to as just @code@. +\end{enumerate} + +The function @nonRecDvFv@ returns two sets of variables. The first is +the set of variables defined in the set of monomorphic bindings, while the +second is the set of free variables in those bindings. + +The set of variables defined in a non-recursive binding is just the +union of all of them, as @union@ removes duplicates. However, the +free variables in each successive set of cumulative bindings is the +union of those in the previous set plus those of the newest binding after +the defined variables of the previous set have been removed. + +@rnMethodBinds@ deals only with the declarations in class and +instance declarations. It expects only to see @FunMonoBind@s, and +it expects the global environment to contain bindings for the binders +(which are all class operations). + +%************************************************************************ +%* * +%* Top-level bindings +%* * +%************************************************************************ + +@rnTopBinds@ assumes that the environment already +contains bindings for the binders of this particular binding. + +\begin{code} +rnTopBinds :: RdrNameHsBinds -> RnMS (RenamedHsBinds, FreeVars) + +rnTopBinds EmptyBinds = returnRn (EmptyBinds, emptyFVs) +rnTopBinds (MonoBind bind sigs _) = rnTopMonoBinds bind sigs + -- The parser doesn't produce other forms + + +rnTopMonoBinds EmptyMonoBinds sigs + = returnRn (EmptyBinds, emptyFVs) + +rnTopMonoBinds mbinds sigs + = mapRn lookupBndrRn binder_rdr_names `thenRn` \ binder_names -> + let + binder_set = mkNameSet binder_names + binder_occ_fm = listToFM [(nameOccName x,x) | x <- binder_names] + in + renameSigs opt_WarnMissingSigs binder_set + (lookupSigOccRn binder_occ_fm) sigs `thenRn` \ (siglist, sig_fvs) -> + rn_mono_binds siglist mbinds `thenRn` \ (final_binds, bind_fvs) -> + returnRn (final_binds, bind_fvs `plusFV` sig_fvs) + where + binder_rdr_names = map fst (bagToList (collectMonoBinders mbinds)) + +-- the names appearing in the sigs have to be bound by +-- this group's binders. +lookupSigOccRn binder_occ_fm rdr_name + = case lookupFM binder_occ_fm (rdrNameOcc rdr_name) of + Nothing -> failWithRn (mkUnboundName rdr_name) + (unknownNameErr rdr_name) + Just x -> returnRn x +\end{code} + +%************************************************************************ +%* * +%* Nested binds +%* * +%************************************************************************ + +@rnMonoBinds@ + - collects up the binders for this declaration group, + - checks that they form a set + - extends the environment to bind them to new local names + - calls @rnMonoBinds@ to do the real work + +\begin{code} +rnBinds :: RdrNameHsBinds + -> (RenamedHsBinds -> RnMS (result, FreeVars)) + -> RnMS (result, FreeVars) + +rnBinds EmptyBinds thing_inside = thing_inside EmptyBinds +rnBinds (MonoBind bind sigs _) thing_inside = rnMonoBinds bind sigs thing_inside + -- the parser doesn't produce other forms + + +rnMonoBinds :: RdrNameMonoBinds + -> [RdrNameSig] + -> (RenamedHsBinds -> RnMS (result, FreeVars)) + -> RnMS (result, FreeVars) + +rnMonoBinds EmptyMonoBinds sigs thing_inside = thing_inside EmptyBinds + +rnMonoBinds mbinds sigs thing_inside -- Non-empty monobinds + = -- Extract all the binders in this group, + -- and extend current scope, inventing new names for the new binders + -- This also checks that the names form a set + bindLocatedLocalsRn (text "a binding group") mbinders_w_srclocs $ \ new_mbinders -> + let + binder_set = mkNameSet new_mbinders + + -- Weed out the fixity declarations that do not + -- apply to any of the binders in this group. + (sigs_for_me, fixes_not_for_me) = partition forLocalBind sigs + + forLocalBind (FixSig sig@(FixitySig name _ _ )) = + isJust (lookupFM binder_occ_fm (rdrNameOcc name)) + forLocalBind _ = True + + binder_occ_fm = listToFM [(nameOccName x,x) | x <- new_mbinders] + + in + -- Report the fixity declarations in this group that + -- don't refer to any of the group's binders. + -- + mapRn_ (unknownSigErr) fixes_not_for_me `thenRn_` + renameSigs False binder_set + (lookupSigOccRn binder_occ_fm) sigs_for_me `thenRn` \ (siglist, sig_fvs) -> + let + fixity_sigs = [(name,sig) | FixSig sig@(FixitySig name _ _) <- siglist ] + in + -- Install the fixity declarations that do apply here and go. + extendFixityEnv fixity_sigs ( + rn_mono_binds siglist mbinds + ) `thenRn` \ (binds, bind_fvs) -> + + -- Now do the "thing inside", and deal with the free-variable calculations + thing_inside binds `thenRn` \ (result,result_fvs) -> + let + all_fvs = result_fvs `plusFV` bind_fvs `plusFV` sig_fvs + unused_binders = nameSetToList (binder_set `minusNameSet` all_fvs) + in + warnUnusedLocalBinds unused_binders `thenRn_` + returnRn (result, delListFromNameSet all_fvs new_mbinders) + where + mbinders_w_srclocs = bagToList (collectMonoBinders mbinds) +\end{code} + + +%************************************************************************ +%* * +%* MonoBinds -- the main work is done here +%* * +%************************************************************************ + +@rn_mono_binds@ is used by *both* top-level and nested bindings. It +assumes that all variables bound in this group are already in scope. +This is done *either* by pass 3 (for the top-level bindings), *or* by +@rnMonoBinds@ (for the nested ones). + +\begin{code} +rn_mono_binds :: [RenamedSig] -- Signatures attached to this group + -> RdrNameMonoBinds + -> RnMS (RenamedHsBinds, -- + FreeVars) -- Free variables + +rn_mono_binds siglist mbinds + = + -- Rename the bindings, returning a MonoBindsInfo + -- which is a list of indivisible vertices so far as + -- the strongly-connected-components (SCC) analysis is concerned + flattenMonoBinds siglist mbinds `thenRn` \ mbinds_info -> + + -- Do the SCC analysis + let + edges = mkEdges (mbinds_info `zip` [(0::Int)..]) + scc_result = stronglyConnComp edges + final_binds = foldr1 ThenBinds (map reconstructCycle scc_result) + + -- Deal with bound and free-var calculation + rhs_fvs = plusFVs [fvs | (_,fvs,_,_) <- mbinds_info] + in + returnRn (final_binds, rhs_fvs) +\end{code} + +@flattenMonoBinds@ is ever-so-slightly magical in that it sticks +unique ``vertex tags'' on its output; minor plumbing required. + +Sigh - need to pass along the signatures for the group of bindings, +in case any of them + +\begin{code} +flattenMonoBinds :: [RenamedSig] -- Signatures + -> RdrNameMonoBinds + -> RnMS [FlatMonoBindsInfo] + +flattenMonoBinds sigs EmptyMonoBinds = returnRn [] + +flattenMonoBinds sigs (AndMonoBinds bs1 bs2) + = flattenMonoBinds sigs bs1 `thenRn` \ flat1 -> + flattenMonoBinds sigs bs2 `thenRn` \ flat2 -> + returnRn (flat1 ++ flat2) + +flattenMonoBinds sigs (PatMonoBind pat grhss locn) + = pushSrcLocRn locn $ + rnPat pat `thenRn` \ (pat', pat_fvs) -> + + -- Find which things are bound in this group + let + names_bound_here = mkNameSet (collectPatBinders pat') + sigs_for_me = sigsForMe (`elemNameSet` names_bound_here) sigs + in + rnGRHSs grhss `thenRn` \ (grhss', fvs) -> + returnRn + [(names_bound_here, + fvs `plusFV` pat_fvs, + PatMonoBind pat' grhss' locn, + sigs_for_me + )] + +flattenMonoBinds sigs (FunMonoBind name inf matches locn) + = pushSrcLocRn locn $ + lookupBndrRn name `thenRn` \ new_name -> + let + sigs_for_me = sigsForMe (new_name ==) sigs + in + mapFvRn rnMatch matches `thenRn` \ (new_matches, fvs) -> + mapRn_ (checkPrecMatch inf new_name) new_matches `thenRn_` + returnRn + [(unitNameSet new_name, + fvs, + FunMonoBind new_name inf new_matches locn, + sigs_for_me + )] +\end{code} + + +@rnMethodBinds@ is used for the method bindings of a class and an instance +declaration. like @rnMonoBinds@ but without dependency analysis. + +NOTA BENE: we record each *binder* of a method-bind group as a free variable. +That's crucial when dealing with an instance decl: + instance Foo (T a) where + op x = ... +This might be the *sole* occurrence of 'op' for an imported class Foo, +and unless op occurs we won't treat the type signature of op in the class +decl for Foo as a source of instance-decl gates. But we should! Indeed, +in many ways the op in an instance decl is just like an occurrence, not +a binder. + +\begin{code} +rnMethodBinds :: RdrNameMonoBinds -> RnMS (RenamedMonoBinds, FreeVars) + +rnMethodBinds EmptyMonoBinds = returnRn (EmptyMonoBinds, emptyFVs) + +rnMethodBinds (AndMonoBinds mb1 mb2) + = rnMethodBinds mb1 `thenRn` \ (mb1', fvs1) -> + rnMethodBinds mb2 `thenRn` \ (mb2', fvs2) -> + returnRn (mb1' `AndMonoBinds` mb2', fvs1 `plusFV` fvs2) + +rnMethodBinds (FunMonoBind name inf matches locn) + = pushSrcLocRn locn $ + + lookupGlobalOccRn name `thenRn` \ sel_name -> + -- We use the selector name as the binder + + mapFvRn rnMatch matches `thenRn` \ (new_matches, fvs) -> + mapRn_ (checkPrecMatch inf sel_name) new_matches `thenRn_` + returnRn (FunMonoBind sel_name inf new_matches locn, fvs `addOneFV` sel_name) + +rnMethodBinds (PatMonoBind (VarPatIn name) grhss locn) + = pushSrcLocRn locn $ + lookupGlobalOccRn name `thenRn` \ sel_name -> + rnGRHSs grhss `thenRn` \ (grhss', fvs) -> + returnRn (PatMonoBind (VarPatIn sel_name) grhss' locn, fvs `addOneFV` sel_name) + +-- Can't handle method pattern-bindings which bind multiple methods. +rnMethodBinds mbind@(PatMonoBind other_pat _ locn) + = pushSrcLocRn locn $ + failWithRn (EmptyMonoBinds, emptyFVs) (methodBindErr mbind) +\end{code} + + +%************************************************************************ +%* * +\subsection[reconstruct-deps]{Reconstructing dependencies} +%* * +%************************************************************************ + +This @MonoBinds@- and @ClassDecls@-specific code is segregated here, +as the two cases are similar. + +\begin{code} +reconstructCycle :: SCC FlatMonoBindsInfo + -> RenamedHsBinds + +reconstructCycle (AcyclicSCC (_, _, binds, sigs)) + = MonoBind binds sigs NonRecursive + +reconstructCycle (CyclicSCC cycle) + = MonoBind this_gp_binds this_gp_sigs Recursive + where + this_gp_binds = foldr1 AndMonoBinds [binds | (_, _, binds, _) <- cycle] + this_gp_sigs = foldr1 (++) [sigs | (_, _, _, sigs) <- cycle] +\end{code} + +%************************************************************************ +%* * +%* Manipulating FlatMonoBindInfo * +%* * +%************************************************************************ + +During analysis a @MonoBinds@ is flattened to a @FlatMonoBindsInfo@. +The @RenamedMonoBinds@ is always an empty bind, a pattern binding or +a function binding, and has itself been dependency-analysed and +renamed. + +\begin{code} +type FlatMonoBindsInfo + = (NameSet, -- Set of names defined in this vertex + NameSet, -- Set of names used in this vertex + RenamedMonoBinds, + [RenamedSig]) -- Signatures, if any, for this vertex + +mkEdges :: [(FlatMonoBindsInfo, VertexTag)] -> [(FlatMonoBindsInfo, VertexTag, [VertexTag])] + +mkEdges flat_info + = [ (info, tag, dest_vertices (nameSetToList names_used)) + | (info@(names_defined, names_used, mbind, sigs), tag) <- flat_info + ] + where + -- An edge (v,v') indicates that v depends on v' + dest_vertices src_mentions = [ target_vertex + | ((names_defined, _, _, _), target_vertex) <- flat_info, + mentioned_name <- src_mentions, + mentioned_name `elemNameSet` names_defined + ] +\end{code} + + +%************************************************************************ +%* * +\subsubsection[dep-Sigs]{Signatures (and user-pragmas for values)} +%* * +%************************************************************************ + +@renameSigs@ checks for: (a)~more than one sig for one thing; +(b)~signatures given for things not bound here; (c)~with suitably +flaggery, that all top-level things have type signatures. + +At the moment we don't gather free-var info from the types in +signatures. We'd only need this if we wanted to report unused tyvars. + +\begin{code} +renameSigs :: Bool -- True => warn if (required) type signatures are missing. + -> NameSet -- Set of names bound in this group + -> (RdrName -> RnMS Name) + -> [RdrNameSig] + -> RnMS ([RenamedSig], FreeVars) -- List of Sig constructors + +renameSigs sigs_required binders lookup_occ_nm sigs + = -- Rename the signatures + mapFvRn (renameSig lookup_occ_nm) sigs `thenRn` \ (sigs', fvs) -> + + -- Check for (a) duplicate signatures + -- (b) signatures for things not in this group + -- (c) optionally, bindings with no signature + let + (goodies, dups) = removeDups cmp_sig (sigsForMe (not . isUnboundName) sigs') + not_this_group = sigsForMe (not . (`elemNameSet` binders)) goodies + type_sig_vars = [n | Sig n _ _ <- goodies] + un_sigd_binders | sigs_required = nameSetToList binders `minusList` type_sig_vars + | otherwise = [] + in + mapRn_ dupSigDeclErr dups `thenRn_` + mapRn_ unknownSigErr not_this_group `thenRn_` + mapRn_ (addWarnRn.missingSigWarn) un_sigd_binders `thenRn_` + returnRn (sigs', fvs) + -- bad ones and all: + -- we need bindings of *some* sort for every name + +-- We use lookupOccRn in the signatures, which is a little bit unsatisfactory +-- because this won't work for: +-- instance Foo T where +-- {-# INLINE op #-} +-- Baz.op = ... +-- We'll just rename the INLINE prag to refer to whatever other 'op' +-- is in scope. (I'm assuming that Baz.op isn't in scope unqualified.) +-- Doesn't seem worth much trouble to sort this. + +renameSig lookup_occ_nm (Sig v ty src_loc) + = pushSrcLocRn src_loc $ + lookup_occ_nm v `thenRn` \ new_v -> + rnHsSigType (quotes (ppr v)) ty `thenRn` \ (new_ty,fvs) -> + returnRn (Sig new_v new_ty src_loc, fvs `addOneFV` new_v) + +renameSig _ (SpecInstSig ty src_loc) + = pushSrcLocRn src_loc $ + rnHsSigType (text "A SPECIALISE instance pragma") ty `thenRn` \ (new_ty, fvs) -> + returnRn (SpecInstSig new_ty src_loc, fvs) + +renameSig lookup_occ_nm (SpecSig v ty src_loc) + = pushSrcLocRn src_loc $ + lookup_occ_nm v `thenRn` \ new_v -> + rnHsSigType (quotes (ppr v)) ty `thenRn` \ (new_ty,fvs) -> + returnRn (SpecSig new_v new_ty src_loc, fvs `addOneFV` new_v) + +renameSig lookup_occ_nm (InlineSig v src_loc) + = pushSrcLocRn src_loc $ + lookup_occ_nm v `thenRn` \ new_v -> + returnRn (InlineSig new_v src_loc, unitFV new_v) + +renameSig lookup_occ_nm (FixSig (FixitySig v fix src_loc)) + = pushSrcLocRn src_loc $ + lookup_occ_nm v `thenRn` \ new_v -> + returnRn (FixSig (FixitySig new_v fix src_loc), unitFV new_v) + +renameSig lookup_occ_nm (NoInlineSig v src_loc) + = pushSrcLocRn src_loc $ + lookup_occ_nm v `thenRn` \ new_v -> + returnRn (NoInlineSig new_v src_loc, unitFV new_v) +\end{code} + +Checking for distinct signatures; oh, so boring + +\begin{code} +cmp_sig :: RenamedSig -> RenamedSig -> Ordering +cmp_sig (Sig n1 _ _) (Sig n2 _ _) = n1 `compare` n2 +cmp_sig (InlineSig n1 _) (InlineSig n2 _) = n1 `compare` n2 +cmp_sig (NoInlineSig n1 _) (NoInlineSig n2 _) = n1 `compare` n2 +cmp_sig (SpecInstSig ty1 _) (SpecInstSig ty2 _) = cmpHsType compare ty1 ty2 +cmp_sig (SpecSig n1 ty1 _) (SpecSig n2 ty2 _) + = -- may have many specialisations for one value; + -- but not ones that are exactly the same... + thenCmp (n1 `compare` n2) (cmpHsType compare ty1 ty2) + +cmp_sig other_1 other_2 -- Tags *must* be different + | (sig_tag other_1) _LT_ (sig_tag other_2) = LT + | otherwise = GT + +sig_tag (Sig n1 _ _) = (ILIT(1) :: FAST_INT) +sig_tag (SpecSig n1 _ _) = ILIT(2) +sig_tag (InlineSig n1 _) = ILIT(3) +sig_tag (NoInlineSig n1 _) = ILIT(4) +sig_tag (SpecInstSig _ _) = ILIT(5) +sig_tag (FixSig _) = ILIT(6) +sig_tag _ = panic# "tag(RnBinds)" +\end{code} + +%************************************************************************ +%* * +\subsection{Error messages} +%* * +%************************************************************************ + +\begin{code} +dupSigDeclErr (sig:sigs) + = pushSrcLocRn loc $ + addErrRn (sep [ptext SLIT("Duplicate") <+> ptext what_it_is <> colon, + ppr sig]) + where + (what_it_is, loc) = sig_doc sig + +unknownSigErr sig + = pushSrcLocRn loc $ + addErrRn (sep [ptext SLIT("Misplaced"), + ptext what_it_is <> colon, + ppr sig]) + where + (what_it_is, loc) = sig_doc sig + +sig_doc (Sig _ _ loc) = (SLIT("type signature"),loc) +sig_doc (ClassOpSig _ _ _ loc) = (SLIT("class-method type signature"), loc) +sig_doc (SpecSig _ _ loc) = (SLIT("SPECIALISE pragma"),loc) +sig_doc (InlineSig _ loc) = (SLIT("INLINE pragma"),loc) +sig_doc (NoInlineSig _ loc) = (SLIT("NOINLINE pragma"),loc) +sig_doc (SpecInstSig _ loc) = (SLIT("SPECIALISE instance pragma"),loc) +sig_doc (FixSig (FixitySig _ _ loc)) = (SLIT("fixity declaration"), loc) + +missingSigWarn var + = sep [ptext SLIT("definition but no type signature for"), quotes (ppr var)] + +methodBindErr mbind + = hang (ptext SLIT("Can't handle multiple methods defined by one pattern binding")) + 4 (ppr mbind) +\end{code} diff --git a/ghc/compiler/rename/RnMonad.lhs b/ghc/compiler/rename/RnMonad.lhs index 687451c..b303525 100644 --- a/ghc/compiler/rename/RnMonad.lhs +++ b/ghc/compiler/rename/RnMonad.lhs @@ -1,709 +1,700 @@ -% -% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998 -% -\section[RnMonad]{The monad used by the renamer} - -\begin{code} -module RnMonad( - module RnMonad, - Module, - FiniteMap, - Bag, - Name, - RdrNameHsDecl, - RdrNameInstDecl, - Version, - NameSet, - OccName, - Fixity - ) where - -#include "HsVersions.h" - -import PrelIOBase ( fixIO ) -- Should be in GlaExts -import IOExts ( IORef, newIORef, readIORef, writeIORef, unsafePerformIO ) - -import HsSyn -import RdrHsSyn -import RnHsSyn ( RenamedFixitySig ) -import BasicTypes ( Version ) -import SrcLoc ( noSrcLoc ) -import ErrUtils ( addShortErrLocLine, addShortWarnLocLine, - pprBagOfErrors, ErrMsg, WarnMsg, Message - ) -import Name ( Name, OccName, NamedThing(..), - isLocallyDefinedName, nameModule, nameOccName, - decode, mkLocalName - ) -import Module ( Module, ModuleName, ModuleHiMap, SearchPath, WhereFrom, - mkModuleHiMaps, moduleName - ) -import NameSet -import RdrName ( RdrName, dummyRdrVarName, rdrNameOcc ) -import CmdLineOpts ( opt_D_dump_rn_trace, opt_IgnoreIfacePragmas ) -import PrelInfo ( builtinNames ) -import TysWiredIn ( boolTyCon ) -import SrcLoc ( SrcLoc, mkGeneratedSrcLoc ) -import Unique ( Unique, getUnique, unboundKey ) -import UniqFM ( UniqFM ) -import FiniteMap ( FiniteMap, emptyFM, bagToFM, lookupFM, addToFM, addListToFM, - addListToFM_C, addToFM_C, eltsFM, fmToList - ) -import Bag ( Bag, mapBag, emptyBag, isEmptyBag, snocBag ) -import Maybes ( mapMaybe ) -import UniqSet -import UniqFM -import UniqSupply -import Util -import Outputable - -infixr 9 `thenRn`, `thenRn_` -\end{code} - - -%************************************************************************ -%* * -\subsection{Somewhat magical interface to other monads} -%* * -%************************************************************************ - -\begin{code} -ioToRnM :: IO r -> RnM d (Either IOError r) -ioToRnM io rn_down g_down = (io >>= \ ok -> return (Right ok)) - `catch` - (\ err -> return (Left err)) - -traceRn :: SDoc -> RnM d () -traceRn msg | opt_D_dump_rn_trace = putDocRn msg - | otherwise = returnRn () - -putDocRn :: SDoc -> RnM d () -putDocRn msg = ioToRnM (printErrs msg) `thenRn_` - returnRn () -\end{code} - - -%************************************************************************ -%* * -\subsection{Data types} -%* * -%************************************************************************ - -=================================================== - MONAD TYPES -=================================================== - -\begin{code} -type RnM d r = RnDown -> d -> IO r -type RnMS r = RnM SDown r -- Renaming source -type RnMG r = RnM () r -- Getting global names etc - - -- Common part -data RnDown = RnDown { - rn_mod :: ModuleName, - rn_loc :: SrcLoc, - rn_omit :: Name -> Bool, -- True <=> omit qualifier when printing - rn_ns :: IORef RnNameSupply, - rn_errs :: IORef (Bag WarnMsg, Bag ErrMsg), - rn_ifaces :: IORef Ifaces, - rn_hi_maps :: (ModuleHiMap, -- for .hi files - ModuleHiMap) -- for .hi-boot files - } - - -- For renaming source code -data SDown = SDown { - rn_mode :: RnMode, - - rn_genv :: GlobalRdrEnv, -- Global envt; the fixity component gets extended - -- with local fixity decls - - rn_lenv :: LocalRdrEnv, -- Local name envt - -- Does *not* includes global name envt; may shadow it - -- Includes both ordinary variables and type variables; - -- they are kept distinct because tyvar have a different - -- occurrence contructor (Name.TvOcc) - -- We still need the unsullied global name env so that - -- we can look up record field names - - rn_fixenv :: FixityEnv -- Local fixities - -- The global ones are held in the - -- rn_ifaces field - } - -data RnMode = SourceMode -- Renaming source code - | InterfaceMode -- Renaming interface declarations. -\end{code} - -=================================================== - ENVIRONMENTS -=================================================== - -\begin{code} --------------------------------- -type RdrNameEnv a = FiniteMap RdrName a -type GlobalRdrEnv = RdrNameEnv [Name] -- The list is because there may be name clashes - -- These only get reported on lookup, - -- not on construction -type LocalRdrEnv = RdrNameEnv Name - -emptyRdrEnv :: RdrNameEnv a -lookupRdrEnv :: RdrNameEnv a -> RdrName -> Maybe a -addListToRdrEnv :: RdrNameEnv a -> [(RdrName,a)] -> RdrNameEnv a -extendRdrEnv :: RdrNameEnv a -> RdrName -> a -> RdrNameEnv a - -emptyRdrEnv = emptyFM -lookupRdrEnv = lookupFM -addListToRdrEnv = addListToFM -rdrEnvElts = eltsFM -extendRdrEnv = addToFM -rdrEnvToList = fmToList - --------------------------------- -type NameEnv a = UniqFM a -- Domain is Name - -emptyNameEnv :: NameEnv a -nameEnvElts :: NameEnv a -> [a] -addToNameEnv_C :: (a->a->a) -> NameEnv a -> Name -> a -> NameEnv a -addToNameEnv :: NameEnv a -> Name -> a -> NameEnv a -plusNameEnv :: NameEnv a -> NameEnv a -> NameEnv a -extendNameEnv :: NameEnv a -> [(Name,a)] -> NameEnv a -lookupNameEnv :: NameEnv a -> Name -> Maybe a -delFromNameEnv :: NameEnv a -> Name -> NameEnv a -elemNameEnv :: Name -> NameEnv a -> Bool - -emptyNameEnv = emptyUFM -nameEnvElts = eltsUFM -addToNameEnv_C = addToUFM_C -addToNameEnv = addToUFM -plusNameEnv = plusUFM -extendNameEnv = addListToUFM -lookupNameEnv = lookupUFM -delFromNameEnv = delFromUFM -elemNameEnv = elemUFM - --------------------------------- -type FixityEnv = NameEnv RenamedFixitySig - -- We keep the whole fixity sig so that we - -- can report line-number info when there is a duplicate - -- fixity declaration -\end{code} - -\begin{code} --------------------------------- -type RnNameSupply - = ( UniqSupply - - , FiniteMap (OccName, OccName) Int - -- This is used as a name supply for dictionary functions - -- From the inst decl we derive a (class, tycon) pair; - -- this map then gives a unique int for each inst decl with that - -- (class, tycon) pair. (In Haskell 98 there can only be one, - -- but not so in more extended versions.) - -- - -- We could just use one Int for all the instance decls, but this - -- way the uniques change less when you add an instance decl, - -- hence less recompilation - - , FiniteMap (ModuleName, OccName) Name - -- Ensures that one (module,occname) pair gets one unique - ) - - --------------------------------- -data ExportEnv = ExportEnv Avails Fixities -type Avails = [AvailInfo] -type Fixities = [(Name, Fixity)] - -type ExportAvails = (FiniteMap ModuleName Avails, -- Used to figure out "module M" export specifiers - -- Includes avails only from *unqualified* imports - -- (see 1.4 Report Section 5.1.1) - - NameEnv AvailInfo) -- Used to figure out all other export specifiers. - -- Maps a Name to the AvailInfo that contains it - - -data GenAvailInfo name = Avail name -- An ordinary identifier - | AvailTC name -- The name of the type or class - [name] -- The available pieces of type/class. NB: If the type or - -- class is itself to be in scope, it must be in this list. - -- Thus, typically: AvailTC Eq [Eq, ==, /=] -type AvailInfo = GenAvailInfo Name -type RdrAvailInfo = GenAvailInfo OccName -\end{code} - -=================================================== - INTERFACE FILE STUFF -=================================================== - -\begin{code} -type ExportItem = (ModuleName, [RdrAvailInfo]) -type VersionInfo name = [ImportVersion name] - -type ImportVersion name = (ModuleName, Version, WhetherHasOrphans, WhatsImported name) - -type WhetherHasOrphans = Bool - -- An "orphan" is - -- * an instance decl in a module other than the defn module for - -- one of the tycons or classes in the instance head - -- * a transformation rule in a module other than the one defining - -- the function in the head of the rule. - -data WhatsImported name = Everything - | Specifically [LocalVersion name] -- List guaranteed non-empty - - -- ("M", hif, ver, Everything) means there was a "module M" in - -- this module's export list, so we just have to go by M's version, "ver", - -- not the list of LocalVersions. - - -type LocalVersion name = (name, Version) - -data ParsedIface - = ParsedIface { - pi_mod :: Version, -- Module version number - pi_orphan :: WhetherHasOrphans, -- Whether this module has orphans - pi_usages :: [ImportVersion OccName], -- Usages - pi_exports :: [ExportItem], -- Exports - pi_decls :: [(Version, RdrNameHsDecl)], -- Local definitions - pi_insts :: [RdrNameInstDecl], -- Local instance declarations - pi_rules :: [RdrNameRuleDecl] -- Rules - } - -type InterfaceDetails = (WhetherHasOrphans, - VersionInfo Name, -- Version information for what this module imports - ExportEnv) -- What modules this one depends on - - --- needed by Main to fish out the fixities assoc list. -getIfaceFixities :: InterfaceDetails -> Fixities -getIfaceFixities (_, _, ExportEnv _ fs) = fs - - -type RdrNamePragma = () -- Fudge for now -------------------- - -data Ifaces = Ifaces { - iImpModInfo :: ImportedModuleInfo, - -- Modules this one depends on: that is, the union - -- of the modules its direct imports depend on. - - iDecls :: DeclsMap, -- A single, global map of Names to decls - - iFixes :: FixityEnv, -- A single, global map of Names to fixities - - iSlurp :: NameSet, -- All the names (whether "big" or "small", whether wired-in or not, - -- whether locally defined or not) that have been slurped in so far. - - iVSlurp :: [(Name,Version)], -- All the (a) non-wired-in (b) "big" (c) non-locally-defined - -- names that have been slurped in so far, with their versions. - -- This is used to generate the "usage" information for this module. - -- Subset of the previous field. - - iInsts :: Bag GatedDecl, - -- The as-yet un-slurped instance decls; this bag is depleted when we - -- slurp an instance decl so that we don't slurp the same one twice. - -- Each is 'gated' by the names that must be available before - -- this instance decl is needed. - - iRules :: Bag GatedDecl - -- Ditto transformation rules - } - -type GatedDecl = (NameSet, (Module, RdrNameHsDecl)) - -type ImportedModuleInfo - = FiniteMap ModuleName (Version, Bool, Maybe (Module, Bool, Avails)) - -- Suppose the domain element is module 'A' - -- - -- The first Bool is True if A contains - -- 'orphan' rules or instance decls - - -- The second Bool is true if the interface file actually - -- read was an .hi-boot file - - -- Nothing => A's interface not yet read, but this module has - -- imported a module, B, that itself depends on A - -- - -- Just xx => A's interface has been read. The Module in - -- the Just has the correct Dll flag - - -- This set is used to decide whether to look for - -- A.hi or A.hi-boot when importing A.f. - -- Basically, we look for A.hi if A is in the map, and A.hi-boot - -- otherwise - -type DeclsMap = NameEnv (Version, AvailInfo, Bool, (Module, RdrNameHsDecl)) - -- A DeclsMap contains a binding for each Name in the declaration - -- including the constructors of a type decl etc. - -- The Bool is True just for the 'main' Name. -\end{code} - - -%************************************************************************ -%* * -\subsection{Main monad code} -%* * -%************************************************************************ - -\begin{code} -initRn :: ModuleName -> UniqSupply -> SearchPath -> SrcLoc - -> RnMG r - -> IO (r, Bag ErrMsg, Bag WarnMsg) - -initRn mod us dirs loc do_rn = do - himaps <- mkModuleHiMaps dirs - names_var <- newIORef (us, emptyFM, builtins) - errs_var <- newIORef (emptyBag,emptyBag) - iface_var <- newIORef emptyIfaces - let - rn_down = RnDown { rn_loc = loc, rn_omit = \n -> False, rn_ns = names_var, - rn_errs = errs_var, - rn_hi_maps = himaps, - rn_ifaces = iface_var, - rn_mod = mod } - - -- do the business - res <- do_rn rn_down () - - -- grab errors and return - (warns, errs) <- readIORef errs_var - - return (res, errs, warns) - - -initRnMS :: GlobalRdrEnv -> FixityEnv -> RnMode -> RnMS r -> RnM d r -initRnMS rn_env fixity_env mode thing_inside rn_down g_down - = let - s_down = SDown { rn_genv = rn_env, rn_lenv = emptyRdrEnv, - rn_fixenv = fixity_env, rn_mode = mode } - in - thing_inside rn_down s_down - -initIfaceRnMS :: Module -> RnMS r -> RnM d r -initIfaceRnMS mod thing_inside - = initRnMS emptyRdrEnv emptyNameEnv InterfaceMode $ - setModuleRn (moduleName mod) thing_inside - -emptyIfaces :: Ifaces -emptyIfaces = Ifaces { iImpModInfo = emptyFM, - iDecls = emptyNameEnv, - iFixes = emptyNameEnv, - iSlurp = unitNameSet (mkUnboundName dummyRdrVarName), - -- Pretend that the dummy unbound name has already been - -- slurped. This is what's returned for an out-of-scope name, - -- and we don't want thereby to try to suck it in! - iVSlurp = [], - iInsts = emptyBag, - iRules = emptyBag - } - --- mkUnboundName makes a place-holder Name; it shouldn't be looked at except possibly --- during compiler debugging. -mkUnboundName :: RdrName -> Name -mkUnboundName rdr_name = mkLocalName unboundKey (rdrNameOcc rdr_name) noSrcLoc - -isUnboundName :: Name -> Bool -isUnboundName name = getUnique name == unboundKey - -builtins :: FiniteMap (ModuleName,OccName) Name -builtins = - bagToFM ( - mapBag (\ name -> ((moduleName (nameModule name), nameOccName name), name)) - builtinNames) -\end{code} - -@renameSourceCode@ is used to rename stuff "out-of-line"; that is, not as part of -the main renamer. Sole examples: derived definitions, which are only generated -in the type checker. - -The @RnNameSupply@ includes a @UniqueSupply@, so if you call it more than -once you must either split it, or install a fresh unique supply. - -\begin{code} -renameSourceCode :: ModuleName - -> RnNameSupply - -> RnMS r - -> r - -renameSourceCode mod_name name_supply m - = unsafePerformIO ( - -- It's not really unsafe! When renaming source code we - -- only do any I/O if we need to read in a fixity declaration; - -- and that doesn't happen in pragmas etc - - newIORef name_supply >>= \ names_var -> - newIORef (emptyBag,emptyBag) >>= \ errs_var -> - let - rn_down = RnDown { rn_loc = mkGeneratedSrcLoc, rn_ns = names_var, - rn_errs = errs_var, - rn_mod = mod_name } - s_down = SDown { rn_mode = InterfaceMode, -- So that we can refer to PrelBase.True etc - rn_genv = emptyRdrEnv, rn_lenv = emptyRdrEnv, - rn_fixenv = emptyNameEnv } - in - m rn_down s_down >>= \ result -> - - readIORef errs_var >>= \ (warns,errs) -> - - (if not (isEmptyBag errs) then - pprTrace "Urk! renameSourceCode found errors" (display errs) -#ifdef DEBUG - else if not (isEmptyBag warns) then - pprTrace "Note: renameSourceCode found warnings" (display warns) -#endif - else - id) $ - - return result - ) - where - display errs = pprBagOfErrors errs - -{-# INLINE thenRn #-} -{-# INLINE thenRn_ #-} -{-# INLINE returnRn #-} -{-# INLINE andRn #-} - -returnRn :: a -> RnM d a -thenRn :: RnM d a -> (a -> RnM d b) -> RnM d b -thenRn_ :: RnM d a -> RnM d b -> RnM d b -andRn :: (a -> a -> a) -> RnM d a -> RnM d a -> RnM d a -mapRn :: (a -> RnM d b) -> [a] -> RnM d [b] -mapRn_ :: (a -> RnM d b) -> [a] -> RnM d () -mapMaybeRn :: (a -> RnM d (Maybe b)) -> [a] -> RnM d [b] -sequenceRn :: [RnM d a] -> RnM d [a] -foldlRn :: (b -> a -> RnM d b) -> b -> [a] -> RnM d b -mapAndUnzipRn :: (a -> RnM d (b,c)) -> [a] -> RnM d ([b],[c]) -fixRn :: (a -> RnM d a) -> RnM d a - -returnRn v gdown ldown = return v -thenRn m k gdown ldown = m gdown ldown >>= \ r -> k r gdown ldown -thenRn_ m k gdown ldown = m gdown ldown >> k gdown ldown -fixRn m gdown ldown = fixIO (\r -> m r gdown ldown) -andRn combiner m1 m2 gdown ldown - = m1 gdown ldown >>= \ res1 -> - m2 gdown ldown >>= \ res2 -> - return (combiner res1 res2) - -sequenceRn [] = returnRn [] -sequenceRn (m:ms) = m `thenRn` \ r -> - sequenceRn ms `thenRn` \ rs -> - returnRn (r:rs) - -mapRn f [] = returnRn [] -mapRn f (x:xs) - = f x `thenRn` \ r -> - mapRn f xs `thenRn` \ rs -> - returnRn (r:rs) - -mapRn_ f [] = returnRn () -mapRn_ f (x:xs) = - f x `thenRn_` - mapRn_ f xs - -foldlRn k z [] = returnRn z -foldlRn k z (x:xs) = k z x `thenRn` \ z' -> - foldlRn k z' xs - -mapAndUnzipRn f [] = returnRn ([],[]) -mapAndUnzipRn f (x:xs) - = f x `thenRn` \ (r1, r2) -> - mapAndUnzipRn f xs `thenRn` \ (rs1, rs2) -> - returnRn (r1:rs1, r2:rs2) - -mapAndUnzip3Rn f [] = returnRn ([],[],[]) -mapAndUnzip3Rn f (x:xs) - = f x `thenRn` \ (r1, r2, r3) -> - mapAndUnzip3Rn f xs `thenRn` \ (rs1, rs2, rs3) -> - returnRn (r1:rs1, r2:rs2, r3:rs3) - -mapMaybeRn f [] = returnRn [] -mapMaybeRn f (x:xs) = f x `thenRn` \ maybe_r -> - mapMaybeRn f xs `thenRn` \ rs -> - case maybe_r of - Nothing -> returnRn rs - Just r -> returnRn (r:rs) -\end{code} - - - -%************************************************************************ -%* * -\subsection{Boring plumbing for common part} -%* * -%************************************************************************ - - -================ Errors and warnings ===================== - -\begin{code} -failWithRn :: a -> Message -> RnM d a -failWithRn res msg (RnDown {rn_errs = errs_var, rn_loc = loc}) l_down - = readIORef errs_var >>= \ (warns,errs) -> - writeIORef errs_var (warns, errs `snocBag` err) >> - return res - where - err = addShortErrLocLine loc msg - -warnWithRn :: a -> Message -> RnM d a -warnWithRn res msg (RnDown {rn_errs = errs_var, rn_loc = loc}) l_down - = readIORef errs_var >>= \ (warns,errs) -> - writeIORef errs_var (warns `snocBag` warn, errs) >> - return res - where - warn = addShortWarnLocLine loc msg - -addErrRn :: Message -> RnM d () -addErrRn err = failWithRn () err - -checkRn :: Bool -> Message -> RnM d () -- Check that a condition is true -checkRn False err = addErrRn err -checkRn True err = returnRn () - -warnCheckRn :: Bool -> Message -> RnM d () -- Check that a condition is true -warnCheckRn False err = addWarnRn err -warnCheckRn True err = returnRn () - -addWarnRn :: Message -> RnM d () -addWarnRn warn = warnWithRn () warn - -checkErrsRn :: RnM d Bool -- True <=> no errors so far -checkErrsRn (RnDown {rn_errs = errs_var}) l_down - = readIORef errs_var >>= \ (warns,errs) -> - return (isEmptyBag errs) -\end{code} - - -================ Source location ===================== - -\begin{code} -pushSrcLocRn :: SrcLoc -> RnM d a -> RnM d a -pushSrcLocRn loc' m down l_down - = m (down {rn_loc = loc'}) l_down - -getSrcLocRn :: RnM d SrcLoc -getSrcLocRn down l_down - = return (rn_loc down) -\end{code} - -================ Name supply ===================== - -\begin{code} -getNameSupplyRn :: RnM d RnNameSupply -getNameSupplyRn rn_down l_down - = readIORef (rn_ns rn_down) - -setNameSupplyRn :: RnNameSupply -> RnM d () -setNameSupplyRn names' (RnDown {rn_ns = names_var}) l_down - = writeIORef names_var names' - --- See comments with RnNameSupply above. -newInstUniq :: (OccName, OccName) -> RnM d Int -newInstUniq key (RnDown {rn_ns = names_var}) l_down - = readIORef names_var >>= \ (us, mapInst, cache) -> - let - uniq = case lookupFM mapInst key of - Just x -> x+1 - Nothing -> 0 - mapInst' = addToFM mapInst key uniq - in - writeIORef names_var (us, mapInst', cache) >> - return uniq - -getUniqRn :: RnM d Unique -getUniqRn (RnDown {rn_ns = names_var}) l_down - = readIORef names_var >>= \ (us, mapInst, cache) -> - let - (us1,us') = splitUniqSupply us - in - writeIORef names_var (us', mapInst, cache) >> - return (uniqFromSupply us1) -\end{code} - -================ Module ===================== - -\begin{code} -getModuleRn :: RnM d ModuleName -getModuleRn (RnDown {rn_mod = mod_name}) l_down - = return mod_name - -setModuleRn :: ModuleName -> RnM d a -> RnM d a -setModuleRn new_mod enclosed_thing rn_down l_down - = enclosed_thing (rn_down {rn_mod = new_mod}) l_down -\end{code} - -\begin{code} -setOmitQualFn :: (Name -> Bool) -> RnM d a -> RnM d a -setOmitQualFn fn m g_down l_down = m (g_down { rn_omit = fn }) l_down - -getOmitQualFn :: RnM d (Name -> Bool) -getOmitQualFn (RnDown {rn_omit = omit_fn}) l_down - = return omit_fn -\end{code} - -%************************************************************************ -%* * -\subsection{Plumbing for rename-source part} -%* * -%************************************************************************ - -================ RnEnv ===================== - -\begin{code} -getNameEnvs :: RnMS (GlobalRdrEnv, LocalRdrEnv) -getNameEnvs rn_down (SDown {rn_genv = global_env, rn_lenv = local_env}) - = return (global_env, local_env) - -getLocalNameEnv :: RnMS LocalRdrEnv -getLocalNameEnv rn_down (SDown {rn_lenv = local_env}) - = return local_env - -setLocalNameEnv :: LocalRdrEnv -> RnMS a -> RnMS a -setLocalNameEnv local_env' m rn_down l_down - = m rn_down (l_down {rn_lenv = local_env'}) - -getFixityEnv :: RnMS FixityEnv -getFixityEnv rn_down (SDown {rn_fixenv = fixity_env}) - = return fixity_env - -extendFixityEnv :: [(Name, RenamedFixitySig)] -> RnMS a -> RnMS a -extendFixityEnv fixes enclosed_scope - rn_down l_down@(SDown {rn_fixenv = fixity_env}) - = let - new_fixity_env = extendNameEnv fixity_env fixes - in - enclosed_scope rn_down (l_down {rn_fixenv = new_fixity_env}) -\end{code} - -================ Mode ===================== - -\begin{code} -getModeRn :: RnMS RnMode -getModeRn rn_down (SDown {rn_mode = mode}) - = return mode - -setModeRn :: RnMode -> RnMS a -> RnMS a -setModeRn new_mode thing_inside rn_down l_down - = thing_inside rn_down (l_down {rn_mode = new_mode}) -\end{code} - - -%************************************************************************ -%* * -\subsection{Plumbing for rename-globals part} -%* * -%************************************************************************ - -\begin{code} -getIfacesRn :: RnM d Ifaces -getIfacesRn (RnDown {rn_ifaces = iface_var}) _ - = readIORef iface_var - -setIfacesRn :: Ifaces -> RnM d () -setIfacesRn ifaces (RnDown {rn_ifaces = iface_var}) _ - = writeIORef iface_var ifaces - -getHiMaps :: RnM d (ModuleHiMap, ModuleHiMap) -getHiMaps (RnDown {rn_hi_maps = himaps}) _ - = return himaps -\end{code} +% +% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998 +% +\section[RnMonad]{The monad used by the renamer} + +\begin{code} +module RnMonad( + module RnMonad, + Module, + FiniteMap, + Bag, + Name, + RdrNameHsDecl, + RdrNameInstDecl, + Version, + NameSet, + OccName, + Fixity + ) where + +#include "HsVersions.h" + +import PrelIOBase ( fixIO ) -- Should be in GlaExts +import IOExts ( IORef, newIORef, readIORef, writeIORef, unsafePerformIO ) + +import HsSyn +import RdrHsSyn +import RnHsSyn ( RenamedFixitySig ) +import BasicTypes ( Version ) +import SrcLoc ( noSrcLoc ) +import ErrUtils ( addShortErrLocLine, addShortWarnLocLine, + pprBagOfErrors, ErrMsg, WarnMsg, Message + ) +import Name ( Name, OccName, NamedThing(..), + isLocallyDefinedName, nameModule, nameOccName, + decode, mkLocalName + ) +import Module ( Module, ModuleName, ModuleHiMap, SearchPath, WhereFrom, + mkModuleHiMaps, moduleName + ) +import NameSet +import RdrName ( RdrName, dummyRdrVarName, rdrNameOcc ) +import CmdLineOpts ( opt_D_dump_rn_trace, opt_IgnoreIfacePragmas ) +import PrelInfo ( builtinNames ) +import TysWiredIn ( boolTyCon ) +import SrcLoc ( SrcLoc, mkGeneratedSrcLoc ) +import Unique ( Unique, getUnique, unboundKey ) +import UniqFM ( UniqFM ) +import FiniteMap ( FiniteMap, emptyFM, bagToFM, lookupFM, addToFM, addListToFM, + addListToFM_C, addToFM_C, eltsFM, fmToList + ) +import Bag ( Bag, mapBag, emptyBag, isEmptyBag, snocBag ) +import Maybes ( mapMaybe ) +import UniqSet +import UniqFM +import UniqSupply +import Util +import Outputable + +infixr 9 `thenRn`, `thenRn_` +\end{code} + + +%************************************************************************ +%* * +\subsection{Somewhat magical interface to other monads} +%* * +%************************************************************************ + +\begin{code} +ioToRnM :: IO r -> RnM d (Either IOError r) +ioToRnM io rn_down g_down = (io >>= \ ok -> return (Right ok)) + `catch` + (\ err -> return (Left err)) + +traceRn :: SDoc -> RnM d () +traceRn msg | opt_D_dump_rn_trace = putDocRn msg + | otherwise = returnRn () + +putDocRn :: SDoc -> RnM d () +putDocRn msg = ioToRnM (printErrs msg) `thenRn_` + returnRn () +\end{code} + + +%************************************************************************ +%* * +\subsection{Data types} +%* * +%************************************************************************ + +=================================================== + MONAD TYPES +=================================================== + +\begin{code} +type RnM d r = RnDown -> d -> IO r +type RnMS r = RnM SDown r -- Renaming source +type RnMG r = RnM () r -- Getting global names etc + + -- Common part +data RnDown = RnDown { + rn_mod :: ModuleName, + rn_loc :: SrcLoc, + rn_ns :: IORef RnNameSupply, + rn_errs :: IORef (Bag WarnMsg, Bag ErrMsg), + rn_ifaces :: IORef Ifaces, + rn_hi_maps :: (ModuleHiMap, -- for .hi files + ModuleHiMap) -- for .hi-boot files + } + + -- For renaming source code +data SDown = SDown { + rn_mode :: RnMode, + + rn_genv :: GlobalRdrEnv, -- Global envt; the fixity component gets extended + -- with local fixity decls + + rn_lenv :: LocalRdrEnv, -- Local name envt + -- Does *not* includes global name envt; may shadow it + -- Includes both ordinary variables and type variables; + -- they are kept distinct because tyvar have a different + -- occurrence contructor (Name.TvOcc) + -- We still need the unsullied global name env so that + -- we can look up record field names + + rn_fixenv :: FixityEnv -- Local fixities + -- The global ones are held in the + -- rn_ifaces field + } + +data RnMode = SourceMode -- Renaming source code + | InterfaceMode -- Renaming interface declarations. +\end{code} + +=================================================== + ENVIRONMENTS +=================================================== + +\begin{code} +-------------------------------- +type RdrNameEnv a = FiniteMap RdrName a +type GlobalRdrEnv = RdrNameEnv [Name] -- The list is because there may be name clashes + -- These only get reported on lookup, + -- not on construction +type LocalRdrEnv = RdrNameEnv Name + +emptyRdrEnv :: RdrNameEnv a +lookupRdrEnv :: RdrNameEnv a -> RdrName -> Maybe a +addListToRdrEnv :: RdrNameEnv a -> [(RdrName,a)] -> RdrNameEnv a +extendRdrEnv :: RdrNameEnv a -> RdrName -> a -> RdrNameEnv a + +emptyRdrEnv = emptyFM +lookupRdrEnv = lookupFM +addListToRdrEnv = addListToFM +rdrEnvElts = eltsFM +extendRdrEnv = addToFM +rdrEnvToList = fmToList + +-------------------------------- +type NameEnv a = UniqFM a -- Domain is Name + +emptyNameEnv :: NameEnv a +nameEnvElts :: NameEnv a -> [a] +addToNameEnv_C :: (a->a->a) -> NameEnv a -> Name -> a -> NameEnv a +addToNameEnv :: NameEnv a -> Name -> a -> NameEnv a +plusNameEnv :: NameEnv a -> NameEnv a -> NameEnv a +extendNameEnv :: NameEnv a -> [(Name,a)] -> NameEnv a +lookupNameEnv :: NameEnv a -> Name -> Maybe a +delFromNameEnv :: NameEnv a -> Name -> NameEnv a +elemNameEnv :: Name -> NameEnv a -> Bool + +emptyNameEnv = emptyUFM +nameEnvElts = eltsUFM +addToNameEnv_C = addToUFM_C +addToNameEnv = addToUFM +plusNameEnv = plusUFM +extendNameEnv = addListToUFM +lookupNameEnv = lookupUFM +delFromNameEnv = delFromUFM +elemNameEnv = elemUFM + +-------------------------------- +type FixityEnv = NameEnv RenamedFixitySig + -- We keep the whole fixity sig so that we + -- can report line-number info when there is a duplicate + -- fixity declaration +\end{code} + +\begin{code} +-------------------------------- +type RnNameSupply + = ( UniqSupply + + , FiniteMap (OccName, OccName) Int + -- This is used as a name supply for dictionary functions + -- From the inst decl we derive a (class, tycon) pair; + -- this map then gives a unique int for each inst decl with that + -- (class, tycon) pair. (In Haskell 98 there can only be one, + -- but not so in more extended versions.) + -- + -- We could just use one Int for all the instance decls, but this + -- way the uniques change less when you add an instance decl, + -- hence less recompilation + + , FiniteMap (ModuleName, OccName) Name + -- Ensures that one (module,occname) pair gets one unique + ) + + +-------------------------------- +data ExportEnv = ExportEnv Avails Fixities +type Avails = [AvailInfo] +type Fixities = [(Name, Fixity)] + +type ExportAvails = (FiniteMap ModuleName Avails, -- Used to figure out "module M" export specifiers + -- Includes avails only from *unqualified* imports + -- (see 1.4 Report Section 5.1.1) + + NameEnv AvailInfo) -- Used to figure out all other export specifiers. + -- Maps a Name to the AvailInfo that contains it + + +data GenAvailInfo name = Avail name -- An ordinary identifier + | AvailTC name -- The name of the type or class + [name] -- The available pieces of type/class. NB: If the type or + -- class is itself to be in scope, it must be in this list. + -- Thus, typically: AvailTC Eq [Eq, ==, /=] +type AvailInfo = GenAvailInfo Name +type RdrAvailInfo = GenAvailInfo OccName +\end{code} + +=================================================== + INTERFACE FILE STUFF +=================================================== + +\begin{code} +type ExportItem = (ModuleName, [RdrAvailInfo]) +type VersionInfo name = [ImportVersion name] + +type ImportVersion name = (ModuleName, Version, WhetherHasOrphans, WhatsImported name) + +type WhetherHasOrphans = Bool + -- An "orphan" is + -- * an instance decl in a module other than the defn module for + -- one of the tycons or classes in the instance head + -- * a transformation rule in a module other than the one defining + -- the function in the head of the rule. + +data WhatsImported name = Everything + | Specifically [LocalVersion name] -- List guaranteed non-empty + + -- ("M", hif, ver, Everything) means there was a "module M" in + -- this module's export list, so we just have to go by M's version, "ver", + -- not the list of LocalVersions. + + +type LocalVersion name = (name, Version) + +data ParsedIface + = ParsedIface { + pi_mod :: Version, -- Module version number + pi_orphan :: WhetherHasOrphans, -- Whether this module has orphans + pi_usages :: [ImportVersion OccName], -- Usages + pi_exports :: [ExportItem], -- Exports + pi_decls :: [(Version, RdrNameHsDecl)], -- Local definitions + pi_insts :: [RdrNameInstDecl], -- Local instance declarations + pi_rules :: [RdrNameRuleDecl] -- Rules + } + +type InterfaceDetails = (WhetherHasOrphans, + VersionInfo Name, -- Version information for what this module imports + ExportEnv) -- What modules this one depends on + + +-- needed by Main to fish out the fixities assoc list. +getIfaceFixities :: InterfaceDetails -> Fixities +getIfaceFixities (_, _, ExportEnv _ fs) = fs + + +type RdrNamePragma = () -- Fudge for now +------------------- + +data Ifaces = Ifaces { + iImpModInfo :: ImportedModuleInfo, + -- Modules this one depends on: that is, the union + -- of the modules its direct imports depend on. + + iDecls :: DeclsMap, -- A single, global map of Names to decls + + iFixes :: FixityEnv, -- A single, global map of Names to fixities + + iSlurp :: NameSet, -- All the names (whether "big" or "small", whether wired-in or not, + -- whether locally defined or not) that have been slurped in so far. + + iVSlurp :: [(Name,Version)], -- All the (a) non-wired-in (b) "big" (c) non-locally-defined + -- names that have been slurped in so far, with their versions. + -- This is used to generate the "usage" information for this module. + -- Subset of the previous field. + + iInsts :: Bag GatedDecl, + -- The as-yet un-slurped instance decls; this bag is depleted when we + -- slurp an instance decl so that we don't slurp the same one twice. + -- Each is 'gated' by the names that must be available before + -- this instance decl is needed. + + iRules :: Bag GatedDecl + -- Ditto transformation rules + } + +type GatedDecl = (NameSet, (Module, RdrNameHsDecl)) + +type ImportedModuleInfo + = FiniteMap ModuleName (Version, Bool, Maybe (Module, Bool, Avails)) + -- Suppose the domain element is module 'A' + -- + -- The first Bool is True if A contains + -- 'orphan' rules or instance decls + + -- The second Bool is true if the interface file actually + -- read was an .hi-boot file + + -- Nothing => A's interface not yet read, but this module has + -- imported a module, B, that itself depends on A + -- + -- Just xx => A's interface has been read. The Module in + -- the Just has the correct Dll flag + + -- This set is used to decide whether to look for + -- A.hi or A.hi-boot when importing A.f. + -- Basically, we look for A.hi if A is in the map, and A.hi-boot + -- otherwise + +type DeclsMap = NameEnv (Version, AvailInfo, Bool, (Module, RdrNameHsDecl)) + -- A DeclsMap contains a binding for each Name in the declaration + -- including the constructors of a type decl etc. + -- The Bool is True just for the 'main' Name. +\end{code} + + +%************************************************************************ +%* * +\subsection{Main monad code} +%* * +%************************************************************************ + +\begin{code} +initRn :: ModuleName -> UniqSupply -> SearchPath -> SrcLoc + -> RnMG r + -> IO (r, Bag ErrMsg, Bag WarnMsg) + +initRn mod us dirs loc do_rn = do + himaps <- mkModuleHiMaps dirs + names_var <- newIORef (us, emptyFM, builtins) + errs_var <- newIORef (emptyBag,emptyBag) + iface_var <- newIORef emptyIfaces + let + rn_down = RnDown { rn_loc = loc, rn_ns = names_var, + rn_errs = errs_var, + rn_hi_maps = himaps, + rn_ifaces = iface_var, + rn_mod = mod } + + -- do the business + res <- do_rn rn_down () + + -- grab errors and return + (warns, errs) <- readIORef errs_var + + return (res, errs, warns) + + +initRnMS :: GlobalRdrEnv -> FixityEnv -> RnMode -> RnMS r -> RnM d r +initRnMS rn_env fixity_env mode thing_inside rn_down g_down + = let + s_down = SDown { rn_genv = rn_env, rn_lenv = emptyRdrEnv, + rn_fixenv = fixity_env, rn_mode = mode } + in + thing_inside rn_down s_down + +initIfaceRnMS :: Module -> RnMS r -> RnM d r +initIfaceRnMS mod thing_inside + = initRnMS emptyRdrEnv emptyNameEnv InterfaceMode $ + setModuleRn (moduleName mod) thing_inside + +emptyIfaces :: Ifaces +emptyIfaces = Ifaces { iImpModInfo = emptyFM, + iDecls = emptyNameEnv, + iFixes = emptyNameEnv, + iSlurp = unitNameSet (mkUnboundName dummyRdrVarName), + -- Pretend that the dummy unbound name has already been + -- slurped. This is what's returned for an out-of-scope name, + -- and we don't want thereby to try to suck it in! + iVSlurp = [], + iInsts = emptyBag, + iRules = emptyBag + } + +-- mkUnboundName makes a place-holder Name; it shouldn't be looked at except possibly +-- during compiler debugging. +mkUnboundName :: RdrName -> Name +mkUnboundName rdr_name = mkLocalName unboundKey (rdrNameOcc rdr_name) noSrcLoc + +isUnboundName :: Name -> Bool +isUnboundName name = getUnique name == unboundKey + +builtins :: FiniteMap (ModuleName,OccName) Name +builtins = + bagToFM ( + mapBag (\ name -> ((moduleName (nameModule name), nameOccName name), name)) + builtinNames) +\end{code} + +@renameSourceCode@ is used to rename stuff "out-of-line"; that is, not as part of +the main renamer. Sole examples: derived definitions, which are only generated +in the type checker. + +The @RnNameSupply@ includes a @UniqueSupply@, so if you call it more than +once you must either split it, or install a fresh unique supply. + +\begin{code} +renameSourceCode :: ModuleName + -> RnNameSupply + -> RnMS r + -> r + +renameSourceCode mod_name name_supply m + = unsafePerformIO ( + -- It's not really unsafe! When renaming source code we + -- only do any I/O if we need to read in a fixity declaration; + -- and that doesn't happen in pragmas etc + + newIORef name_supply >>= \ names_var -> + newIORef (emptyBag,emptyBag) >>= \ errs_var -> + let + rn_down = RnDown { rn_loc = mkGeneratedSrcLoc, rn_ns = names_var, + rn_errs = errs_var, + rn_mod = mod_name } + s_down = SDown { rn_mode = InterfaceMode, -- So that we can refer to PrelBase.True etc + rn_genv = emptyRdrEnv, rn_lenv = emptyRdrEnv, + rn_fixenv = emptyNameEnv } + in + m rn_down s_down >>= \ result -> + + readIORef errs_var >>= \ (warns,errs) -> + + (if not (isEmptyBag errs) then + pprTrace "Urk! renameSourceCode found errors" (display errs) +#ifdef DEBUG + else if not (isEmptyBag warns) then + pprTrace "Note: renameSourceCode found warnings" (display warns) +#endif + else + id) $ + + return result + ) + where + display errs = pprBagOfErrors errs + +{-# INLINE thenRn #-} +{-# INLINE thenRn_ #-} +{-# INLINE returnRn #-} +{-# INLINE andRn #-} + +returnRn :: a -> RnM d a +thenRn :: RnM d a -> (a -> RnM d b) -> RnM d b +thenRn_ :: RnM d a -> RnM d b -> RnM d b +andRn :: (a -> a -> a) -> RnM d a -> RnM d a -> RnM d a +mapRn :: (a -> RnM d b) -> [a] -> RnM d [b] +mapRn_ :: (a -> RnM d b) -> [a] -> RnM d () +mapMaybeRn :: (a -> RnM d (Maybe b)) -> [a] -> RnM d [b] +sequenceRn :: [RnM d a] -> RnM d [a] +foldlRn :: (b -> a -> RnM d b) -> b -> [a] -> RnM d b +mapAndUnzipRn :: (a -> RnM d (b,c)) -> [a] -> RnM d ([b],[c]) +fixRn :: (a -> RnM d a) -> RnM d a + +returnRn v gdown ldown = return v +thenRn m k gdown ldown = m gdown ldown >>= \ r -> k r gdown ldown +thenRn_ m k gdown ldown = m gdown ldown >> k gdown ldown +fixRn m gdown ldown = fixIO (\r -> m r gdown ldown) +andRn combiner m1 m2 gdown ldown + = m1 gdown ldown >>= \ res1 -> + m2 gdown ldown >>= \ res2 -> + return (combiner res1 res2) + +sequenceRn [] = returnRn [] +sequenceRn (m:ms) = m `thenRn` \ r -> + sequenceRn ms `thenRn` \ rs -> + returnRn (r:rs) + +mapRn f [] = returnRn [] +mapRn f (x:xs) + = f x `thenRn` \ r -> + mapRn f xs `thenRn` \ rs -> + returnRn (r:rs) + +mapRn_ f [] = returnRn () +mapRn_ f (x:xs) = + f x `thenRn_` + mapRn_ f xs + +foldlRn k z [] = returnRn z +foldlRn k z (x:xs) = k z x `thenRn` \ z' -> + foldlRn k z' xs + +mapAndUnzipRn f [] = returnRn ([],[]) +mapAndUnzipRn f (x:xs) + = f x `thenRn` \ (r1, r2) -> + mapAndUnzipRn f xs `thenRn` \ (rs1, rs2) -> + returnRn (r1:rs1, r2:rs2) + +mapAndUnzip3Rn f [] = returnRn ([],[],[]) +mapAndUnzip3Rn f (x:xs) + = f x `thenRn` \ (r1, r2, r3) -> + mapAndUnzip3Rn f xs `thenRn` \ (rs1, rs2, rs3) -> + returnRn (r1:rs1, r2:rs2, r3:rs3) + +mapMaybeRn f [] = returnRn [] +mapMaybeRn f (x:xs) = f x `thenRn` \ maybe_r -> + mapMaybeRn f xs `thenRn` \ rs -> + case maybe_r of + Nothing -> returnRn rs + Just r -> returnRn (r:rs) +\end{code} + + + +%************************************************************************ +%* * +\subsection{Boring plumbing for common part} +%* * +%************************************************************************ + + +================ Errors and warnings ===================== + +\begin{code} +failWithRn :: a -> Message -> RnM d a +failWithRn res msg (RnDown {rn_errs = errs_var, rn_loc = loc}) l_down + = readIORef errs_var >>= \ (warns,errs) -> + writeIORef errs_var (warns, errs `snocBag` err) >> + return res + where + err = addShortErrLocLine loc msg + +warnWithRn :: a -> Message -> RnM d a +warnWithRn res msg (RnDown {rn_errs = errs_var, rn_loc = loc}) l_down + = readIORef errs_var >>= \ (warns,errs) -> + writeIORef errs_var (warns `snocBag` warn, errs) >> + return res + where + warn = addShortWarnLocLine loc msg + +addErrRn :: Message -> RnM d () +addErrRn err = failWithRn () err + +checkRn :: Bool -> Message -> RnM d () -- Check that a condition is true +checkRn False err = addErrRn err +checkRn True err = returnRn () + +warnCheckRn :: Bool -> Message -> RnM d () -- Check that a condition is true +warnCheckRn False err = addWarnRn err +warnCheckRn True err = returnRn () + +addWarnRn :: Message -> RnM d () +addWarnRn warn = warnWithRn () warn + +checkErrsRn :: RnM d Bool -- True <=> no errors so far +checkErrsRn (RnDown {rn_errs = errs_var}) l_down + = readIORef errs_var >>= \ (warns,errs) -> + return (isEmptyBag errs) +\end{code} + + +================ Source location ===================== + +\begin{code} +pushSrcLocRn :: SrcLoc -> RnM d a -> RnM d a +pushSrcLocRn loc' m down l_down + = m (down {rn_loc = loc'}) l_down + +getSrcLocRn :: RnM d SrcLoc +getSrcLocRn down l_down + = return (rn_loc down) +\end{code} + +================ Name supply ===================== + +\begin{code} +getNameSupplyRn :: RnM d RnNameSupply +getNameSupplyRn rn_down l_down + = readIORef (rn_ns rn_down) + +setNameSupplyRn :: RnNameSupply -> RnM d () +setNameSupplyRn names' (RnDown {rn_ns = names_var}) l_down + = writeIORef names_var names' + +-- See comments with RnNameSupply above. +newInstUniq :: (OccName, OccName) -> RnM d Int +newInstUniq key (RnDown {rn_ns = names_var}) l_down + = readIORef names_var >>= \ (us, mapInst, cache) -> + let + uniq = case lookupFM mapInst key of + Just x -> x+1 + Nothing -> 0 + mapInst' = addToFM mapInst key uniq + in + writeIORef names_var (us, mapInst', cache) >> + return uniq + +getUniqRn :: RnM d Unique +getUniqRn (RnDown {rn_ns = names_var}) l_down + = readIORef names_var >>= \ (us, mapInst, cache) -> + let + (us1,us') = splitUniqSupply us + in + writeIORef names_var (us', mapInst, cache) >> + return (uniqFromSupply us1) +\end{code} + +================ Module ===================== + +\begin{code} +getModuleRn :: RnM d ModuleName +getModuleRn (RnDown {rn_mod = mod_name}) l_down + = return mod_name + +setModuleRn :: ModuleName -> RnM d a -> RnM d a +setModuleRn new_mod enclosed_thing rn_down l_down + = enclosed_thing (rn_down {rn_mod = new_mod}) l_down +\end{code} + + +%************************************************************************ +%* * +\subsection{Plumbing for rename-source part} +%* * +%************************************************************************ + +================ RnEnv ===================== + +\begin{code} +getNameEnvs :: RnMS (GlobalRdrEnv, LocalRdrEnv) +getNameEnvs rn_down (SDown {rn_genv = global_env, rn_lenv = local_env}) + = return (global_env, local_env) + +getLocalNameEnv :: RnMS LocalRdrEnv +getLocalNameEnv rn_down (SDown {rn_lenv = local_env}) + = return local_env + +setLocalNameEnv :: LocalRdrEnv -> RnMS a -> RnMS a +setLocalNameEnv local_env' m rn_down l_down + = m rn_down (l_down {rn_lenv = local_env'}) + +getFixityEnv :: RnMS FixityEnv +getFixityEnv rn_down (SDown {rn_fixenv = fixity_env}) + = return fixity_env + +extendFixityEnv :: [(Name, RenamedFixitySig)] -> RnMS a -> RnMS a +extendFixityEnv fixes enclosed_scope + rn_down l_down@(SDown {rn_fixenv = fixity_env}) + = let + new_fixity_env = extendNameEnv fixity_env fixes + in + enclosed_scope rn_down (l_down {rn_fixenv = new_fixity_env}) +\end{code} + +================ Mode ===================== + +\begin{code} +getModeRn :: RnMS RnMode +getModeRn rn_down (SDown {rn_mode = mode}) + = return mode + +setModeRn :: RnMode -> RnMS a -> RnMS a +setModeRn new_mode thing_inside rn_down l_down + = thing_inside rn_down (l_down {rn_mode = new_mode}) +\end{code} + + +%************************************************************************ +%* * +\subsection{Plumbing for rename-globals part} +%* * +%************************************************************************ + +\begin{code} +getIfacesRn :: RnM d Ifaces +getIfacesRn (RnDown {rn_ifaces = iface_var}) _ + = readIORef iface_var + +setIfacesRn :: Ifaces -> RnM d () +setIfacesRn ifaces (RnDown {rn_ifaces = iface_var}) _ + = writeIORef iface_var ifaces + +getHiMaps :: RnM d (ModuleHiMap, ModuleHiMap) +getHiMaps (RnDown {rn_hi_maps = himaps}) _ + = return himaps +\end{code} diff --git a/ghc/compiler/rename/RnNames.lhs b/ghc/compiler/rename/RnNames.lhs index 0b7691f..633735b 100644 --- a/ghc/compiler/rename/RnNames.lhs +++ b/ghc/compiler/rename/RnNames.lhs @@ -1,698 +1,694 @@ -% -% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998 -% -\section[RnNames]{Extracting imported and top-level names in scope} - -\begin{code} -module RnNames ( - getGlobalNames - ) where - -#include "HsVersions.h" - -import CmdLineOpts ( opt_NoImplicitPrelude, opt_WarnDuplicateExports, - opt_SourceUnchanged, opt_WarnUnusedBinds - ) - -import HsSyn ( HsModule(..), HsDecl(..), TyClDecl(..), - IE(..), ieName, - ForeignDecl(..), ForKind(..), isDynamic, - FixitySig(..), Sig(..), ImportDecl(..), - collectTopBinders - ) -import RdrHsSyn ( RdrNameIE, RdrNameImportDecl, - RdrNameHsModule, RdrNameHsDecl - ) -import RnIfaces ( getInterfaceExports, getDeclBinders, - recordSlurp, checkUpToDate - ) -import RnEnv -import RnMonad - -import FiniteMap -import PrelMods -import PrelInfo ( main_RDR ) -import UniqFM ( lookupUFM ) -import Bag ( bagToList ) -import Maybes ( maybeToBool ) -import Module ( ModuleName, mkThisModule, pprModuleName, WhereFrom(..) ) -import NameSet -import Name ( Name, ExportFlag(..), ImportReason(..), Provenance(..), - isLocallyDefined, setNameProvenance, - nameOccName, getSrcLoc, pprProvenance, getNameProvenance - ) -import RdrName ( RdrName, rdrNameOcc, mkRdrQual, mkRdrUnqual, isQual ) -import SrcLoc ( SrcLoc ) -import NameSet ( elemNameSet, emptyNameSet ) -import Outputable -import Unique ( getUnique ) -import Util ( removeDups, equivClassesByUniq, sortLt ) -import List ( partition ) -\end{code} - - - -%************************************************************************ -%* * -\subsection{Get global names} -%* * -%************************************************************************ - -\begin{code} -getGlobalNames :: RdrNameHsModule - -> RnMG (Maybe (ExportEnv, - GlobalRdrEnv, - FixityEnv, -- Fixities for local decls only - NameEnv AvailInfo -- Maps a name to its parent AvailInfo - -- Just for in-scope things only - )) - -- 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 (\ ~(rec_gbl_env, rec_exported_avails, _) -> - --- fixRn (\ ~(rec_rn_env, _) -> - 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 = mk_export_fn (availsToNameSet rec_exported_avails) - in --- setOmitQualFn rec_unqual_fn $ - setModuleRn this_mod $ - - -- PROCESS LOCAL DECLS - -- Do these *first* so that the correct provenance gets - -- into the global name cache. - importsFromLocalDecls this_mod rec_exp_fn decls `thenRn` \ (local_gbl_env, local_mod_avails) -> - - -- PROCESS IMPORT DECLS - -- Do the non {- SOURCE -} ones first, so that we get a helpful - -- warning for {- SOURCE -} ones that are unnecessary - let - (source, ordinary) = partition is_source_import all_imports - is_source_import (ImportDecl _ ImportByUserSource _ _ _ _) = True - is_source_import other = False - in - mapAndUnzipRn (importsFromImportDecl rec_unqual_fn) ordinary `thenRn` \ (imp_gbl_envs1, imp_avails_s1) -> - mapAndUnzipRn (importsFromImportDecl rec_unqual_fn) source `thenRn` \ (imp_gbl_envs2, imp_avails_s2) -> - - -- COMBINE RESULTS - -- We put the local env second, so that a local provenance - -- "wins", even if a module imports itself. - let - gbl_env :: GlobalRdrEnv - imp_gbl_env = foldr plusGlobalRdrEnv emptyRdrEnv (imp_gbl_envs2 ++ imp_gbl_envs1) - gbl_env = imp_gbl_env `plusGlobalRdrEnv` local_gbl_env - - all_avails :: ExportAvails - all_avails = foldr plusExportAvails local_mod_avails (imp_avails_s2 ++ imp_avails_s1) - in --- returnRn (gbl_env, all_avails) --- ) `thenRn` \ (gbl_env, all_avails) -> - - -- TRY FOR EARLY EXIT - -- We can't go for an early exit before this because we have to check - -- for name clashes. Consider: - -- - -- module A where module B where - -- import B h = True - -- f = h - -- - -- Suppose I've compiled everything up, and then I add a - -- new definition to module B, that defines "f". - -- - -- Then I must detect the name clash in A before going for an early - -- exit. The early-exit code checks what's actually needed from B - -- 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. - checkEarlyExit this_mod `thenRn` \ up_to_date -> - if up_to_date then - returnRn (gbl_env, junk_exp_fn, 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 imp_gbl_env, - isQual rdr_name]) `thenRn_` - - -- PROCESS EXPORT LISTS - exportsFromAvail this_mod exports all_avails gbl_env `thenRn` \ exported_avails -> - - -- DONE - returnRn (gbl_env, exported_avails, Just all_avails) - ) `thenRn` \ (gbl_env, exported_avails, maybe_stuff) -> - - case maybe_stuff of { - Nothing -> returnRn Nothing ; - Just all_avails -> - - traceRn (text "updateProv" <+> fsep (map ppr (rdrEnvElts gbl_env))) `thenRn_` - - -- DEAL WITH FIXITIES - fixitiesFromLocalDecls gbl_env decls `thenRn` \ local_fixity_env -> - let - -- Export only those fixities that are for names that are - -- (a) defined in this module - -- (b) exported - exported_fixities :: [(Name,Fixity)] - exported_fixities = [(name,fixity) | FixitySig name fixity _ <- nameEnvElts local_fixity_env, - isLocallyDefined name - ] - in - traceRn (text "fixity env" <+> vcat (map ppr (nameEnvElts local_fixity_env))) `thenRn_` - - --- TIDY UP - let - export_env = ExportEnv exported_avails exported_fixities - (_, global_avail_env) = all_avails - in - returnRn (Just (export_env, gbl_env, local_fixity_env, global_avail_env)) - } - where - junk_exp_fn = error "RnNames:export_fn" - - all_imports = prel_imports ++ imports - - -- 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. - prel_imports | this_mod == pRELUDE_Name || - explicit_prelude_import || - opt_NoImplicitPrelude - = [] - - | otherwise = [ImportDecl pRELUDE_Name - ImportByUser - False {- Not qualified -} - Nothing {- No "as" -} - Nothing {- No import list -} - mod_loc] - - explicit_prelude_import - = not (null [ () | (ImportDecl mod _ _ _ _ _) <- imports, mod == pRELUDE_Name ]) -\end{code} - -\begin{code} -checkEarlyExit mod - = checkErrsRn `thenRn` \ no_errs_so_far -> - if not no_errs_so_far then - -- Found errors already, so exit now - returnRn True - else - - traceRn (text "Considering whether compilation is required...") `thenRn_` - if not opt_SourceUnchanged then - -- Source code changed and no errors yet... carry on - traceRn (nest 4 (text "source file changed or recompilation check turned off")) `thenRn_` - returnRn False - else - - -- Unchanged source, and no errors yet; see if usage info - -- up to date, and exit if so - checkUpToDate mod `thenRn` \ up_to_date -> - putDocRn (text "Compilation" <+> - text (if up_to_date then "IS NOT" else "IS") <+> - text "required") `thenRn_` - returnRn up_to_date -\end{code} - -\begin{code} -importsFromImportDecl :: (Name -> Bool) -- OK to omit qualifier - -> RdrNameImportDecl - -> RnMG (GlobalRdrEnv, - ExportAvails) - -importsFromImportDecl is_unqual (ImportDecl imp_mod_name from qual_only as_mod import_spec iloc) - = pushSrcLocRn iloc $ - getInterfaceExports imp_mod_name from `thenRn` \ (imp_mod, avails) -> - - if null avails then - -- If there's an error in getInterfaceExports, (e.g. interface - -- file not found) we get lots of spurious errors from 'filterImports' - returnRn (emptyRdrEnv, mkEmptyExportAvails imp_mod_name) - else - - filterImports imp_mod_name import_spec avails `thenRn` \ (filtered_avails, hides, explicits) -> - - -- 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 - -- But don't fiddle with wired-in things or we get in a twist - let - improve_prov name = setNameProvenance name (NonLocalDef (UserImport imp_mod iloc (is_explicit name)) - (is_unqual name)) - is_explicit name = name `elemNameSet` explicits - in - qualifyImports imp_mod_name - (not qual_only) -- Maybe want unqualified names - as_mod hides - filtered_avails improve_prov `thenRn` \ (rdr_name_env, mod_avails) -> - - returnRn (rdr_name_env, mod_avails) -\end{code} - - -\begin{code} -importsFromLocalDecls mod_name rec_exp_fn decls - = mapRn (getLocalDeclBinders newLocalName) decls `thenRn` \ avails_s -> - - let - avails = concat avails_s - - all_names :: [Name] -- All the defns; no dups eliminated - all_names = [name | avail <- avails, name <- availNames avail] - - dups :: [[Name]] - dups = filter non_singleton (equivClassesByUniq getUnique all_names) - where - non_singleton (x1:x2:xs) = True - non_singleton other = False - in - -- Check for duplicate definitions - mapRn_ (addErrRn . dupDeclErr) dups `thenRn_` - - -- Record that locally-defined things are available - mapRn_ (recordSlurp Nothing) avails `thenRn_` - - -- Build the environment - qualifyImports mod_name - True -- Want unqualified names - Nothing -- no 'as M' - [] -- Hide nothing - avails - (\n -> n) - - where - newLocalName rdr_name loc = newLocalTopBinder mod (rdrNameOcc rdr_name) - rec_exp_fn loc - mod = mkThisModule mod_name - -getLocalDeclBinders :: (RdrName -> SrcLoc -> RnMG Name) -- New-name function - -> RdrNameHsDecl - -> RnMG Avails -getLocalDeclBinders new_name (ValD binds) - = mapRn do_one (bagToList (collectTopBinders binds)) - where - do_one (rdr_name, loc) = new_name rdr_name loc `thenRn` \ name -> - returnRn (Avail name) - - -- foreign declarations -getLocalDeclBinders new_name (ForD (ForeignDecl nm kind _ dyn _ loc)) - | binds_haskell_name kind dyn - = new_name nm loc `thenRn` \ name -> - returnRn [Avail name] - - | otherwise - = returnRn [] - -getLocalDeclBinders new_name decl - = getDeclBinders new_name decl `thenRn` \ maybe_avail -> - case maybe_avail of - Nothing -> returnRn [] -- Instance decls and suchlike - Just avail -> returnRn [avail] - -binds_haskell_name (FoImport _) _ = True -binds_haskell_name FoLabel _ = True -binds_haskell_name FoExport ext_nm = isDynamic ext_nm - -fixitiesFromLocalDecls :: GlobalRdrEnv -> [RdrNameHsDecl] -> RnMG FixityEnv -fixitiesFromLocalDecls gbl_env decls - = foldlRn getFixities emptyNameEnv decls - where - getFixities :: FixityEnv -> RdrNameHsDecl -> RnMG FixityEnv - getFixities acc (FixD fix) - = fix_decl acc fix - - getFixities acc (TyClD (ClassDecl _ _ _ sigs _ _ _ _ _ _)) - = foldlRn fix_decl acc [sig | FixSig sig <- sigs] - -- Get fixities from class decl sigs too. - getFixities acc other_decl - = returnRn acc - - fix_decl acc sig@(FixitySig rdr_name fixity loc) - = -- Check for fixity decl for something not declared - case lookupRdrEnv gbl_env rdr_name of { - Nothing | opt_WarnUnusedBinds - -> pushSrcLocRn loc (addWarnRn (unusedFixityDecl rdr_name fixity)) `thenRn_` - returnRn acc - | otherwise -> returnRn acc ; - - Just (name:_) -> - - -- Check for duplicate fixity decl - case lookupNameEnv acc name of { - Just (FixitySig _ _ loc') -> addErrRn (dupFixityDecl rdr_name loc loc') `thenRn_` - returnRn acc ; - - Nothing -> returnRn (addToNameEnv acc name (FixitySig name fixity loc)) - }} -\end{code} - -%************************************************************************ -%* * -\subsection{Filtering imports} -%* * -%************************************************************************ - -@filterImports@ takes the @ExportEnv@ telling what the imported module makes -available, and filters it through the import spec (if any). - -\begin{code} -filterImports :: ModuleName -- The module being imported - -> Maybe (Bool, [RdrNameIE]) -- Import spec; True => hiding - -> [AvailInfo] -- What's available - -> RnMG ([AvailInfo], -- What's actually imported - [AvailInfo], -- What's to be hidden (the unqualified version, that is) - NameSet) -- What was imported explicitly - - -- Complains if import spec mentions things that the module doesn't export - -- Warns/informs if import spec contains duplicates. -filterImports mod Nothing imports - = returnRn (imports, [], emptyNameSet) - -filterImports mod (Just (want_hiding, import_items)) avails - = mapMaybeRn check_item import_items `thenRn` \ avails_w_explicits -> - let - (item_avails, explicits_s) = unzip avails_w_explicits - explicits = foldl addListToNameSet emptyNameSet explicits_s - in - if want_hiding - then - -- All imported; item_avails to be hidden - returnRn (avails, item_avails, emptyNameSet) - else - -- Just item_avails imported; nothing to be hidden - returnRn (item_avails, [], explicits) - where - import_fm :: FiniteMap OccName AvailInfo - import_fm = listToFM [ (nameOccName name, avail) - | avail <- avails, - name <- availNames avail] - -- Even though availNames returns data constructors too, - -- they won't make any difference because naked entities like T - -- in an import list map to TcOccs, not VarOccs. - - check_item item@(IEModuleContents _) - = addErrRn (badImportItemErr mod item) `thenRn_` - returnRn Nothing - - check_item item - | not (maybeToBool maybe_in_import_avails) || - not (maybeToBool maybe_filtered_avail) - = addErrRn (badImportItemErr mod item) `thenRn_` - returnRn Nothing - - | dodgy_import = addWarnRn (dodgyImportWarn mod item) `thenRn_` - returnRn (Just (filtered_avail, explicits)) - - | otherwise = returnRn (Just (filtered_avail, explicits)) - - where - wanted_occ = rdrNameOcc (ieName item) - maybe_in_import_avails = lookupFM import_fm wanted_occ - - Just avail = maybe_in_import_avails - maybe_filtered_avail = filterAvail item avail - Just filtered_avail = maybe_filtered_avail - explicits | dot_dot = [availName filtered_avail] - | otherwise = availNames filtered_avail - - dot_dot = case item of - IEThingAll _ -> True - other -> False - - dodgy_import = case (item, avail) of - (IEThingAll _, AvailTC _ [n]) -> True - -- This occurs when you import T(..), but - -- only export T abstractly. The single [n] - -- in the AvailTC is the type or class itself - - other -> False -\end{code} - - - -%************************************************************************ -%* * -\subsection{Qualifiying imports} -%* * -%************************************************************************ - -@qualifyImports@ takes the @ExportEnv@ after filtering through the import spec -of an import decl, and deals with producing an @RnEnv@ with the -right qualified names. It also turns the @Names@ in the @ExportEnv@ into -fully fledged @Names@. - -\begin{code} -qualifyImports :: ModuleName -- Imported module - -> Bool -- True <=> want unqualified import - -> Maybe ModuleName -- Optional "as M" part - -> [AvailInfo] -- What's to be hidden - -> Avails -- Whats imported and how - -> (Name -> Name) -- Improves the provenance on imported things - -> RnMG (GlobalRdrEnv, ExportAvails) - -- NB: the Names in ExportAvails don't have the improve-provenance - -- function applied to them - -- We could fix that, but I don't think it matters - -qualifyImports this_mod unqual_imp as_mod hides - avails improve_prov - = - -- Make the name environment. We're talking about a - -- single module here, so there must be no name clashes. - -- In practice there only ever will be if it's the module - -- being compiled. - let - -- Add the things that are available - name_env1 = foldl add_avail emptyRdrEnv avails - - -- Delete things that are hidden - name_env2 = foldl del_avail name_env1 hides - - -- Create the export-availability info - export_avails = mkExportAvails qual_mod unqual_imp name_env2 avails - in - returnRn (name_env2, export_avails) - - where - qual_mod = case as_mod of - Nothing -> this_mod - Just another_name -> another_name - - add_avail :: GlobalRdrEnv -> AvailInfo -> GlobalRdrEnv - add_avail env avail = foldl add_name env (availNames avail) - - add_name env name - | unqual_imp = env2 - | otherwise = env1 - where - env1 = addOneToGlobalRdrEnv env (mkRdrQual qual_mod occ) better_name - env2 = addOneToGlobalRdrEnv env1 (mkRdrUnqual occ) better_name - occ = nameOccName name - better_name = improve_prov name - - del_avail env avail = foldl delOneFromGlobalRdrEnv env rdr_names - where - rdr_names = map (mkRdrUnqual . nameOccName) (availNames avail) -\end{code} - - -%************************************************************************ -%* * -\subsection{Export list processing -%* * -%************************************************************************ - -Processing the export list. - -You might think that we should record things that appear in the export list as -``occurrences'' (using addOccurrenceName), but you'd be wrong. We do check (here) -that they are in scope, but there is no need to slurp in their actual declaration -(which is what addOccurrenceName forces). Indeed, doing so would big trouble when -compiling PrelBase, because it re-exports GHC, which includes takeMVar#, whose type -includes ConcBase.StateAndSynchVar#, and so on... - -\begin{code} -type ExportAccum -- The type of the accumulating parameter of - -- the main worker function in exportsFromAvail - = ([ModuleName], -- 'module M's seen so far - ExportOccMap, -- Tracks exported occurrence names - NameEnv AvailInfo) -- The accumulated exported stuff, kept in an env - -- so we can common-up related AvailInfos - -type ExportOccMap = FiniteMap OccName (Name, RdrNameIE) - -- 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 - - -exportsFromAvail :: ModuleName - -> Maybe [RdrNameIE] -- Export spec - -> ExportAvails - -> GlobalRdrEnv - -> RnMG Avails - -- Complains if two distinct exports have same OccName - -- Warns about identical exports. - -- Complains about exports items not in scope -exportsFromAvail this_mod Nothing export_avails global_name_env - = exportsFromAvail this_mod true_exports export_avails global_name_env - where - true_exports = Just $ if this_mod == mAIN_Name - then [IEVar main_RDR] - -- export Main.main *only* unless otherwise specified, - else [IEModuleContents this_mod] - -- but for all other modules export everything. - -exportsFromAvail this_mod (Just export_items) - (mod_avail_env, entity_avail_env) - global_name_env - = foldlRn exports_from_item - ([], emptyFM, emptyNameEnv) export_items `thenRn` \ (_, _, export_avail_map) -> - let - export_avails :: [AvailInfo] - export_avails = nameEnvElts export_avail_map - in - returnRn export_avails - - where - exports_from_item :: ExportAccum -> RdrNameIE -> RnMG ExportAccum - - exports_from_item acc@(mods, occs, avails) ie@(IEModuleContents mod) - | mod `elem` mods -- Duplicate export of M - = warnCheckRn opt_WarnDuplicateExports - (dupModuleExport mod) `thenRn_` - returnRn acc - - | otherwise - = case lookupFM mod_avail_env mod of - Nothing -> failWithRn acc (modExportErr mod) - Just mod_avails -> foldlRn (check_occs ie) occs mod_avails `thenRn` \ occs' -> - let - avails' = foldl add_avail avails mod_avails - in - returnRn (mod:mods, occs', avails') - - exports_from_item 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_` - returnRn acc - -#ifdef DEBUG - -- I can't see why this should ever happen; if the thing is in scope - -- at all it ought to have some availability - | not (maybeToBool maybe_avail) - = pprTrace "exportsFromAvail: curious Nothing:" (ppr name) - returnRn acc -#endif - - | not enough_avail - = failWithRn acc (exportItemErr ie) - - | otherwise -- Phew! It's OK! Now to check the occurrence stuff! - = check_occs ie occs export_avail `thenRn` \ occs' -> - returnRn (mods, occs', add_avail avails export_avail) - - where - rdr_name = ieName ie - maybe_in_scope = lookupFM global_name_env rdr_name - Just (name:dup_names) = maybe_in_scope - maybe_avail = lookupUFM entity_avail_env name - Just avail = maybe_avail - maybe_export_avail = filterAvail ie avail - enough_avail = maybeToBool maybe_export_avail - Just export_avail = maybe_export_avail - -add_avail avails avail = addToNameEnv_C plusAvail avails (availName avail) avail - -check_occs :: RdrNameIE -> ExportOccMap -> AvailInfo -> RnMG ExportOccMap -check_occs ie occs avail - = foldlRn check occs (availNames avail) - where - check 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 - (dupExportWarn name_occ ie ie') `thenRn_` - returnRn occs - - | otherwise -> -- Same occ name but different names: an error - failWithRn occs (exportClashErr name_occ ie ie') - 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 -\end{code} - -%************************************************************************ -%* * -\subsection{Errors} -%* * -%************************************************************************ - -\begin{code} -badImportItemErr mod ie - = sep [ptext SLIT("Module"), quotes (pprModuleName mod), - ptext SLIT("does not export"), quotes (ppr ie)] - -dodgyImportWarn mod (IEThingAll tc) - = sep [ptext SLIT("Module") <+> quotes (pprModuleName mod) <+> ptext SLIT("exports") <+> quotes (ppr tc), - ptext SLIT("with no constructors/class operations;"), - ptext SLIT("yet it is imported with a (..)")] - -modExportErr mod - = hsep [ ptext SLIT("Unknown module in export list: module"), quotes (pprModuleName mod)] - -exportItemErr export_item - = sep [ ptext SLIT("Bad export item"), quotes (ppr export_item)] - -exportClashErr occ_name ie1 ie2 - = hsep [ptext SLIT("The export items"), quotes (ppr ie1), ptext SLIT("and"), quotes (ppr ie2), - ptext SLIT("create conflicting exports for"), quotes (ppr occ_name)] - -dupDeclErr (n:ns) - = vcat [ptext SLIT("Multiple declarations of") <+> quotes (ppr n), - nest 4 (vcat (map pp sorted_ns))] - 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) - -dupExportWarn occ_name ie1 ie2 - = hsep [quotes (ppr occ_name), - ptext SLIT("is exported by"), quotes (ppr ie1), - ptext SLIT("and"), quotes (ppr ie2)] - -dupModuleExport mod - = hsep [ptext SLIT("Duplicate"), - quotes (ptext SLIT("Module") <+> pprModuleName mod), - ptext SLIT("in export list")] - -unusedFixityDecl rdr_name fixity - = hsep [ptext SLIT("Unused fixity declaration for"), quotes (ppr rdr_name)] - -dupFixityDecl rdr_name loc1 loc2 - = vcat [ptext SLIT("Multiple fixity declarations for") <+> quotes (ppr rdr_name), - ptext SLIT("at ") <+> ppr loc1, - ptext SLIT("and") <+> ppr loc2] - -\end{code} +% +% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998 +% +\section[RnNames]{Extracting imported and top-level names in scope} + +\begin{code} +module RnNames ( + getGlobalNames + ) where + +#include "HsVersions.h" + +import CmdLineOpts ( opt_NoImplicitPrelude, opt_WarnDuplicateExports, + opt_SourceUnchanged, opt_WarnUnusedBinds + ) + +import HsSyn ( HsModule(..), HsDecl(..), TyClDecl(..), + IE(..), ieName, + ForeignDecl(..), ForKind(..), isDynamic, + FixitySig(..), Sig(..), ImportDecl(..), + collectTopBinders + ) +import RdrHsSyn ( RdrNameIE, RdrNameImportDecl, + RdrNameHsModule, RdrNameHsDecl + ) +import RnIfaces ( getInterfaceExports, getDeclBinders, + recordSlurp, checkUpToDate + ) +import RnEnv +import RnMonad + +import FiniteMap +import PrelMods +import PrelInfo ( main_RDR ) +import UniqFM ( lookupUFM ) +import Bag ( bagToList ) +import Maybes ( maybeToBool ) +import Module ( ModuleName, mkThisModule, pprModuleName, WhereFrom(..) ) +import NameSet +import Name ( Name, ExportFlag(..), ImportReason(..), Provenance(..), + isLocallyDefined, setNameProvenance, + nameOccName, getSrcLoc, pprProvenance, getNameProvenance + ) +import RdrName ( RdrName, rdrNameOcc, mkRdrQual, mkRdrUnqual, isQual ) +import SrcLoc ( SrcLoc ) +import NameSet ( elemNameSet, emptyNameSet ) +import Outputable +import Unique ( getUnique ) +import Util ( removeDups, equivClassesByUniq, sortLt ) +import List ( partition ) +\end{code} + + + +%************************************************************************ +%* * +\subsection{Get global names} +%* * +%************************************************************************ + +\begin{code} +getGlobalNames :: RdrNameHsModule + -> RnMG (Maybe (ExportEnv, + GlobalRdrEnv, + FixityEnv, -- Fixities for local decls only + NameEnv AvailInfo -- Maps a name to its parent AvailInfo + -- Just for in-scope things only + )) + -- 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 (\ ~(rec_gbl_env, rec_exported_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 = mk_export_fn (availsToNameSet rec_exported_avails) + in + setModuleRn this_mod $ + + -- PROCESS LOCAL DECLS + -- Do these *first* so that the correct provenance gets + -- into the global name cache. + importsFromLocalDecls this_mod rec_exp_fn decls `thenRn` \ (local_gbl_env, local_mod_avails) -> + + -- PROCESS IMPORT DECLS + -- Do the non {- SOURCE -} ones first, so that we get a helpful + -- warning for {- SOURCE -} ones that are unnecessary + let + (source, ordinary) = partition is_source_import all_imports + is_source_import (ImportDecl _ ImportByUserSource _ _ _ _) = True + is_source_import other = False + in + mapAndUnzipRn (importsFromImportDecl rec_unqual_fn) ordinary `thenRn` \ (imp_gbl_envs1, imp_avails_s1) -> + mapAndUnzipRn (importsFromImportDecl rec_unqual_fn) source `thenRn` \ (imp_gbl_envs2, imp_avails_s2) -> + + -- COMBINE RESULTS + -- We put the local env second, so that a local provenance + -- "wins", even if a module imports itself. + let + gbl_env :: GlobalRdrEnv + imp_gbl_env = foldr plusGlobalRdrEnv emptyRdrEnv (imp_gbl_envs2 ++ imp_gbl_envs1) + gbl_env = imp_gbl_env `plusGlobalRdrEnv` local_gbl_env + + all_avails :: ExportAvails + all_avails = foldr plusExportAvails local_mod_avails (imp_avails_s2 ++ imp_avails_s1) + in + + -- TRY FOR EARLY EXIT + -- We can't go for an early exit before this because we have to check + -- for name clashes. Consider: + -- + -- module A where module B where + -- import B h = True + -- f = h + -- + -- Suppose I've compiled everything up, and then I add a + -- new definition to module B, that defines "f". + -- + -- Then I must detect the name clash in A before going for an early + -- exit. The early-exit code checks what's actually needed from B + -- 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. + checkEarlyExit this_mod `thenRn` \ up_to_date -> + if up_to_date then + returnRn (gbl_env, junk_exp_fn, 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 imp_gbl_env, + isQual rdr_name]) `thenRn_` + + -- PROCESS EXPORT LISTS + exportsFromAvail this_mod exports all_avails gbl_env `thenRn` \ exported_avails -> + + -- DONE + returnRn (gbl_env, exported_avails, Just all_avails) + ) `thenRn` \ (gbl_env, exported_avails, maybe_stuff) -> + + case maybe_stuff of { + Nothing -> returnRn Nothing ; + Just all_avails -> + + traceRn (text "updateProv" <+> fsep (map ppr (rdrEnvElts gbl_env))) `thenRn_` + + -- DEAL WITH FIXITIES + fixitiesFromLocalDecls gbl_env decls `thenRn` \ local_fixity_env -> + let + -- Export only those fixities that are for names that are + -- (a) defined in this module + -- (b) exported + exported_fixities :: [(Name,Fixity)] + exported_fixities = [(name,fixity) | FixitySig name fixity _ <- nameEnvElts local_fixity_env, + isLocallyDefined name + ] + in + traceRn (text "fixity env" <+> vcat (map ppr (nameEnvElts local_fixity_env))) `thenRn_` + + --- TIDY UP + let + export_env = ExportEnv exported_avails exported_fixities + (_, global_avail_env) = all_avails + in + returnRn (Just (export_env, gbl_env, local_fixity_env, global_avail_env)) + } + where + junk_exp_fn = error "RnNames:export_fn" + + all_imports = prel_imports ++ imports + + -- 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. + prel_imports | this_mod == pRELUDE_Name || + explicit_prelude_import || + opt_NoImplicitPrelude + = [] + + | otherwise = [ImportDecl pRELUDE_Name + ImportByUser + False {- Not qualified -} + Nothing {- No "as" -} + Nothing {- No import list -} + mod_loc] + + explicit_prelude_import + = not (null [ () | (ImportDecl mod _ _ _ _ _) <- imports, mod == pRELUDE_Name ]) +\end{code} + +\begin{code} +checkEarlyExit mod + = checkErrsRn `thenRn` \ no_errs_so_far -> + if not no_errs_so_far then + -- Found errors already, so exit now + returnRn True + else + + traceRn (text "Considering whether compilation is required...") `thenRn_` + if not opt_SourceUnchanged then + -- Source code changed and no errors yet... carry on + traceRn (nest 4 (text "source file changed or recompilation check turned off")) `thenRn_` + returnRn False + else + + -- Unchanged source, and no errors yet; see if usage info + -- up to date, and exit if so + checkUpToDate mod `thenRn` \ up_to_date -> + putDocRn (text "Compilation" <+> + text (if up_to_date then "IS NOT" else "IS") <+> + text "required") `thenRn_` + returnRn up_to_date +\end{code} + +\begin{code} +importsFromImportDecl :: (Name -> Bool) -- OK to omit qualifier + -> RdrNameImportDecl + -> RnMG (GlobalRdrEnv, + ExportAvails) + +importsFromImportDecl is_unqual (ImportDecl imp_mod_name from qual_only as_mod import_spec iloc) + = pushSrcLocRn iloc $ + getInterfaceExports imp_mod_name from `thenRn` \ (imp_mod, avails) -> + + if null avails then + -- If there's an error in getInterfaceExports, (e.g. interface + -- file not found) we get lots of spurious errors from 'filterImports' + returnRn (emptyRdrEnv, mkEmptyExportAvails imp_mod_name) + else + + filterImports imp_mod_name import_spec avails `thenRn` \ (filtered_avails, hides, explicits) -> + + -- 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 + -- But don't fiddle with wired-in things or we get in a twist + let + improve_prov name = setNameProvenance name (NonLocalDef (UserImport imp_mod iloc (is_explicit name)) + (is_unqual name)) + is_explicit name = name `elemNameSet` explicits + in + qualifyImports imp_mod_name + (not qual_only) -- Maybe want unqualified names + as_mod hides + filtered_avails improve_prov `thenRn` \ (rdr_name_env, mod_avails) -> + + returnRn (rdr_name_env, mod_avails) +\end{code} + + +\begin{code} +importsFromLocalDecls mod_name rec_exp_fn decls + = mapRn (getLocalDeclBinders newLocalName) decls `thenRn` \ avails_s -> + + let + avails = concat avails_s + + all_names :: [Name] -- All the defns; no dups eliminated + all_names = [name | avail <- avails, name <- availNames avail] + + dups :: [[Name]] + dups = filter non_singleton (equivClassesByUniq getUnique all_names) + where + non_singleton (x1:x2:xs) = True + non_singleton other = False + in + -- Check for duplicate definitions + mapRn_ (addErrRn . dupDeclErr) dups `thenRn_` + + -- Record that locally-defined things are available + mapRn_ (recordSlurp Nothing) avails `thenRn_` + + -- Build the environment + qualifyImports mod_name + True -- Want unqualified names + Nothing -- no 'as M' + [] -- Hide nothing + avails + (\n -> n) + + where + newLocalName rdr_name loc = newLocalTopBinder mod (rdrNameOcc rdr_name) + rec_exp_fn loc + mod = mkThisModule mod_name + +getLocalDeclBinders :: (RdrName -> SrcLoc -> RnMG Name) -- New-name function + -> RdrNameHsDecl + -> RnMG Avails +getLocalDeclBinders new_name (ValD binds) + = mapRn do_one (bagToList (collectTopBinders binds)) + where + do_one (rdr_name, loc) = new_name rdr_name loc `thenRn` \ name -> + returnRn (Avail name) + + -- foreign declarations +getLocalDeclBinders new_name (ForD (ForeignDecl nm kind _ dyn _ loc)) + | binds_haskell_name kind dyn + = new_name nm loc `thenRn` \ name -> + returnRn [Avail name] + + | otherwise + = returnRn [] + +getLocalDeclBinders new_name decl + = getDeclBinders new_name decl `thenRn` \ maybe_avail -> + case maybe_avail of + Nothing -> returnRn [] -- Instance decls and suchlike + Just avail -> returnRn [avail] + +binds_haskell_name (FoImport _) _ = True +binds_haskell_name FoLabel _ = True +binds_haskell_name FoExport ext_nm = isDynamic ext_nm + +fixitiesFromLocalDecls :: GlobalRdrEnv -> [RdrNameHsDecl] -> RnMG FixityEnv +fixitiesFromLocalDecls gbl_env decls + = foldlRn getFixities emptyNameEnv decls + where + getFixities :: FixityEnv -> RdrNameHsDecl -> RnMG FixityEnv + getFixities acc (FixD fix) + = fix_decl acc fix + + getFixities acc (TyClD (ClassDecl _ _ _ sigs _ _ _ _ _ _)) + = foldlRn fix_decl acc [sig | FixSig sig <- sigs] + -- Get fixities from class decl sigs too. + getFixities acc other_decl + = returnRn acc + + fix_decl acc sig@(FixitySig rdr_name fixity loc) + = -- Check for fixity decl for something not declared + case lookupRdrEnv gbl_env rdr_name of { + Nothing | opt_WarnUnusedBinds + -> pushSrcLocRn loc (addWarnRn (unusedFixityDecl rdr_name fixity)) `thenRn_` + returnRn acc + | otherwise -> returnRn acc ; + + Just (name:_) -> + + -- Check for duplicate fixity decl + case lookupNameEnv acc name of { + Just (FixitySig _ _ loc') -> addErrRn (dupFixityDecl rdr_name loc loc') `thenRn_` + returnRn acc ; + + Nothing -> returnRn (addToNameEnv acc name (FixitySig name fixity loc)) + }} +\end{code} + +%************************************************************************ +%* * +\subsection{Filtering imports} +%* * +%************************************************************************ + +@filterImports@ takes the @ExportEnv@ telling what the imported module makes +available, and filters it through the import spec (if any). + +\begin{code} +filterImports :: ModuleName -- The module being imported + -> Maybe (Bool, [RdrNameIE]) -- Import spec; True => hiding + -> [AvailInfo] -- What's available + -> RnMG ([AvailInfo], -- What's actually imported + [AvailInfo], -- What's to be hidden (the unqualified version, that is) + NameSet) -- What was imported explicitly + + -- Complains if import spec mentions things that the module doesn't export + -- Warns/informs if import spec contains duplicates. +filterImports mod Nothing imports + = returnRn (imports, [], emptyNameSet) + +filterImports mod (Just (want_hiding, import_items)) avails + = mapMaybeRn check_item import_items `thenRn` \ avails_w_explicits -> + let + (item_avails, explicits_s) = unzip avails_w_explicits + explicits = foldl addListToNameSet emptyNameSet explicits_s + in + if want_hiding + then + -- All imported; item_avails to be hidden + returnRn (avails, item_avails, emptyNameSet) + else + -- Just item_avails imported; nothing to be hidden + returnRn (item_avails, [], explicits) + where + import_fm :: FiniteMap OccName AvailInfo + import_fm = listToFM [ (nameOccName name, avail) + | avail <- avails, + name <- availNames avail] + -- Even though availNames returns data constructors too, + -- they won't make any difference because naked entities like T + -- in an import list map to TcOccs, not VarOccs. + + check_item item@(IEModuleContents _) + = addErrRn (badImportItemErr mod item) `thenRn_` + returnRn Nothing + + check_item item + | not (maybeToBool maybe_in_import_avails) || + not (maybeToBool maybe_filtered_avail) + = addErrRn (badImportItemErr mod item) `thenRn_` + returnRn Nothing + + | dodgy_import = addWarnRn (dodgyImportWarn mod item) `thenRn_` + returnRn (Just (filtered_avail, explicits)) + + | otherwise = returnRn (Just (filtered_avail, explicits)) + + where + wanted_occ = rdrNameOcc (ieName item) + maybe_in_import_avails = lookupFM import_fm wanted_occ + + Just avail = maybe_in_import_avails + maybe_filtered_avail = filterAvail item avail + Just filtered_avail = maybe_filtered_avail + explicits | dot_dot = [availName filtered_avail] + | otherwise = availNames filtered_avail + + dot_dot = case item of + IEThingAll _ -> True + other -> False + + dodgy_import = case (item, avail) of + (IEThingAll _, AvailTC _ [n]) -> True + -- This occurs when you import T(..), but + -- only export T abstractly. The single [n] + -- in the AvailTC is the type or class itself + + other -> False +\end{code} + + + +%************************************************************************ +%* * +\subsection{Qualifiying imports} +%* * +%************************************************************************ + +@qualifyImports@ takes the @ExportEnv@ after filtering through the import spec +of an import decl, and deals with producing an @RnEnv@ with the +right qualified names. It also turns the @Names@ in the @ExportEnv@ into +fully fledged @Names@. + +\begin{code} +qualifyImports :: ModuleName -- Imported module + -> Bool -- True <=> want unqualified import + -> Maybe ModuleName -- Optional "as M" part + -> [AvailInfo] -- What's to be hidden + -> Avails -- Whats imported and how + -> (Name -> Name) -- Improves the provenance on imported things + -> RnMG (GlobalRdrEnv, ExportAvails) + -- NB: the Names in ExportAvails don't have the improve-provenance + -- function applied to them + -- We could fix that, but I don't think it matters + +qualifyImports this_mod unqual_imp as_mod hides + avails improve_prov + = + -- Make the name environment. We're talking about a + -- single module here, so there must be no name clashes. + -- In practice there only ever will be if it's the module + -- being compiled. + let + -- Add the things that are available + name_env1 = foldl add_avail emptyRdrEnv avails + + -- Delete things that are hidden + name_env2 = foldl del_avail name_env1 hides + + -- Create the export-availability info + export_avails = mkExportAvails qual_mod unqual_imp name_env2 avails + in + returnRn (name_env2, export_avails) + + where + qual_mod = case as_mod of + Nothing -> this_mod + Just another_name -> another_name + + add_avail :: GlobalRdrEnv -> AvailInfo -> GlobalRdrEnv + add_avail env avail = foldl add_name env (availNames avail) + + add_name env name + | unqual_imp = env2 + | otherwise = env1 + where + env1 = addOneToGlobalRdrEnv env (mkRdrQual qual_mod occ) better_name + env2 = addOneToGlobalRdrEnv env1 (mkRdrUnqual occ) better_name + occ = nameOccName name + better_name = improve_prov name + + del_avail env avail = foldl delOneFromGlobalRdrEnv env rdr_names + where + rdr_names = map (mkRdrUnqual . nameOccName) (availNames avail) +\end{code} + + +%************************************************************************ +%* * +\subsection{Export list processing +%* * +%************************************************************************ + +Processing the export list. + +You might think that we should record things that appear in the export list as +``occurrences'' (using addOccurrenceName), but you'd be wrong. We do check (here) +that they are in scope, but there is no need to slurp in their actual declaration +(which is what addOccurrenceName forces). Indeed, doing so would big trouble when +compiling PrelBase, because it re-exports GHC, which includes takeMVar#, whose type +includes ConcBase.StateAndSynchVar#, and so on... + +\begin{code} +type ExportAccum -- The type of the accumulating parameter of + -- the main worker function in exportsFromAvail + = ([ModuleName], -- 'module M's seen so far + ExportOccMap, -- Tracks exported occurrence names + NameEnv AvailInfo) -- The accumulated exported stuff, kept in an env + -- so we can common-up related AvailInfos + +type ExportOccMap = FiniteMap OccName (Name, RdrNameIE) + -- 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 + + +exportsFromAvail :: ModuleName + -> Maybe [RdrNameIE] -- Export spec + -> ExportAvails + -> GlobalRdrEnv + -> RnMG Avails + -- Complains if two distinct exports have same OccName + -- Warns about identical exports. + -- Complains about exports items not in scope +exportsFromAvail this_mod Nothing export_avails global_name_env + = exportsFromAvail this_mod true_exports export_avails global_name_env + where + true_exports = Just $ if this_mod == mAIN_Name + then [IEVar main_RDR] + -- export Main.main *only* unless otherwise specified, + else [IEModuleContents this_mod] + -- but for all other modules export everything. + +exportsFromAvail this_mod (Just export_items) + (mod_avail_env, entity_avail_env) + global_name_env + = foldlRn exports_from_item + ([], emptyFM, emptyNameEnv) export_items `thenRn` \ (_, _, export_avail_map) -> + let + export_avails :: [AvailInfo] + export_avails = nameEnvElts export_avail_map + in + returnRn export_avails + + where + exports_from_item :: ExportAccum -> RdrNameIE -> RnMG ExportAccum + + exports_from_item acc@(mods, occs, avails) ie@(IEModuleContents mod) + | mod `elem` mods -- Duplicate export of M + = warnCheckRn opt_WarnDuplicateExports + (dupModuleExport mod) `thenRn_` + returnRn acc + + | otherwise + = case lookupFM mod_avail_env mod of + Nothing -> failWithRn acc (modExportErr mod) + Just mod_avails -> foldlRn (check_occs ie) occs mod_avails `thenRn` \ occs' -> + let + avails' = foldl add_avail avails mod_avails + in + returnRn (mod:mods, occs', avails') + + exports_from_item 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_` + returnRn acc + +#ifdef DEBUG + -- I can't see why this should ever happen; if the thing is in scope + -- at all it ought to have some availability + | not (maybeToBool maybe_avail) + = pprTrace "exportsFromAvail: curious Nothing:" (ppr name) + returnRn acc +#endif + + | not enough_avail + = failWithRn acc (exportItemErr ie) + + | otherwise -- Phew! It's OK! Now to check the occurrence stuff! + = check_occs ie occs export_avail `thenRn` \ occs' -> + returnRn (mods, occs', add_avail avails export_avail) + + where + rdr_name = ieName ie + maybe_in_scope = lookupFM global_name_env rdr_name + Just (name:dup_names) = maybe_in_scope + maybe_avail = lookupUFM entity_avail_env name + Just avail = maybe_avail + maybe_export_avail = filterAvail ie avail + enough_avail = maybeToBool maybe_export_avail + Just export_avail = maybe_export_avail + +add_avail avails avail = addToNameEnv_C plusAvail avails (availName avail) avail + +check_occs :: RdrNameIE -> ExportOccMap -> AvailInfo -> RnMG ExportOccMap +check_occs ie occs avail + = foldlRn check occs (availNames avail) + where + check 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 + (dupExportWarn name_occ ie ie') `thenRn_` + returnRn occs + + | otherwise -> -- Same occ name but different names: an error + failWithRn occs (exportClashErr name_occ ie ie') + 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 +\end{code} + +%************************************************************************ +%* * +\subsection{Errors} +%* * +%************************************************************************ + +\begin{code} +badImportItemErr mod ie + = sep [ptext SLIT("Module"), quotes (pprModuleName mod), + ptext SLIT("does not export"), quotes (ppr ie)] + +dodgyImportWarn mod (IEThingAll tc) + = sep [ptext SLIT("Module") <+> quotes (pprModuleName mod) <+> ptext SLIT("exports") <+> quotes (ppr tc), + ptext SLIT("with no constructors/class operations;"), + ptext SLIT("yet it is imported with a (..)")] + +modExportErr mod + = hsep [ ptext SLIT("Unknown module in export list: module"), quotes (pprModuleName mod)] + +exportItemErr export_item + = sep [ ptext SLIT("Bad export item"), quotes (ppr export_item)] + +exportClashErr occ_name ie1 ie2 + = hsep [ptext SLIT("The export items"), quotes (ppr ie1), ptext SLIT("and"), quotes (ppr ie2), + ptext SLIT("create conflicting exports for"), quotes (ppr occ_name)] + +dupDeclErr (n:ns) + = vcat [ptext SLIT("Multiple declarations of") <+> quotes (ppr n), + nest 4 (vcat (map pp sorted_ns))] + 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) + +dupExportWarn occ_name ie1 ie2 + = hsep [quotes (ppr occ_name), + ptext SLIT("is exported by"), quotes (ppr ie1), + ptext SLIT("and"), quotes (ppr ie2)] + +dupModuleExport mod + = hsep [ptext SLIT("Duplicate"), + quotes (ptext SLIT("Module") <+> pprModuleName mod), + ptext SLIT("in export list")] + +unusedFixityDecl rdr_name fixity + = hsep [ptext SLIT("Unused fixity declaration for"), quotes (ppr rdr_name)] + +dupFixityDecl rdr_name loc1 loc2 + = vcat [ptext SLIT("Multiple fixity declarations for") <+> quotes (ppr rdr_name), + ptext SLIT("at ") <+> ppr loc1, + ptext SLIT("and") <+> ppr loc2] + +\end{code} -- 1.7.10.4