X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2Frename%2FRnEnv.lhs;h=f8dab26a12a189f4d336ce4c88c207f82139f351;hb=8ae0e52a7f204cb36c110f7f6a6e970992417b83;hp=066c9919fbba3d582e18cea3c48c7b7949dbc867;hpb=3160f854580e6d8df412c8cd34d93bae27175d67;p=ghc-hetmet.git diff --git a/ghc/compiler/rename/RnEnv.lhs b/ghc/compiler/rename/RnEnv.lhs index 066c991..f8dab26 100644 --- a/ghc/compiler/rename/RnEnv.lhs +++ b/ghc/compiler/rename/RnEnv.lhs @@ -11,121 +11,107 @@ module RnEnv where -- Export everything import CmdLineOpts ( opt_WarnNameShadowing, opt_WarnUnusedMatches, opt_WarnUnusedBinds, opt_WarnUnusedImports ) import HsSyn -import RdrHsSyn ( RdrName(..), RdrNameIE, - rdrNameOcc, isQual, qual +import RdrHsSyn ( RdrNameIE ) +import RnHsSyn ( RenamedHsType ) +import RdrName ( RdrName, rdrNameModule, rdrNameOcc, isQual, isUnqual, + mkRdrUnqual, qualifyRdrName ) import HsTypes ( getTyVarName, replaceTyVarName ) -import BasicTypes ( Fixity(..), FixityDirection(..), IfaceFlavour(..) ) + import RnMonad import Name ( Name, Provenance(..), ExportFlag(..), NamedThing(..), ImportReason(..), getSrcLoc, - mkLocalName, mkGlobalName, - nameOccName, - pprOccName, isLocalName, isLocallyDefined, isAnonOcc, + mkLocalName, mkImportedLocalName, mkGlobalName, isSystemName, + nameOccName, setNameModule, nameModule, + pprOccName, isLocallyDefined, nameUnique, nameOccName, + occNameUserString, setNameProvenance, getNameProvenance, pprNameProvenance ) import NameSet -import OccName ( OccName, mkModuleFS, - mkDFunOcc, tcOcc, varOcc, tvOcc, - isVarOcc, occNameFlavour, occNameString +import OccName ( OccName, + mkDFunOcc, occNameUserString, + occNameFlavour ) +import TysWiredIn ( tupleTyCon, unboxedTupleTyCon, listTyCon ) +import Type ( funTyCon ) +import Module ( ModuleName, mkThisModule, mkVanillaModule, moduleName ) import TyCon ( TyCon ) import FiniteMap -import Unique ( Unique, Uniquable(..), unboundKey ) +import Unique ( Unique, Uniquable(..) ) import UniqFM ( emptyUFM, listToUFM, plusUFM_C ) import UniqSupply import SrcLoc ( SrcLoc, noSrcLoc ) import Outputable -import Util ( removeDups ) +import Util ( removeDups, equivClasses, thenCmp ) import List ( nub ) -import Char ( isAlphanum ) +import Maybes ( mapMaybe ) \end{code} %********************************************************* %* * -\subsection{Making new rdr names} -%* * -%********************************************************* - -These functions make new RdrNames from stuff read from an interface file - -\begin{code} -ifaceQualTC (m,n,hif) = Qual (mkModuleFS m) (tcOcc n) hif -ifaceQualVar (m,n,hif) = Qual (mkModuleFS m) (varOcc n) hif - -ifaceUnqualTC n = Unqual (tcOcc n) -ifaceUnqualVar n = Unqual (varOcc n) -ifaceUnqualTv n = Unqual (tvOcc n) -\end{code} - -%********************************************************* -%* * \subsection{Making new names} %* * %********************************************************* \begin{code} -newImportedGlobalName :: Module -> OccName -> IfaceFlavour - -> RnM s d Name -newImportedGlobalName mod occ hif - = -- First check the cache - getNameSupplyRn `thenRn` \ (us, inst_ns, cache) -> - let - key = (mod,occ) - prov = NonLocalDef ImplicitImport hif False - -- For in-scope things we improve the provenance in RnNames.qualifyImports +newImportedGlobalName mod_name occ mod + = getNameSupplyRn `thenRn` \ (us, inst_ns, cache) -> + let + key = (mod_name, occ) in case lookupFM cache key of + Just name -> returnRn name + Nothing -> setNameSupplyRn (us', inst_ns, new_cache) `thenRn_` + returnRn name + where + (us', us1) = splitUniqSupply us + uniq = uniqFromSupply us1 + name = mkGlobalName uniq mod occ (NonLocalDef ImplicitImport False) + new_cache = addToFM cache key name + +updateProvenances :: [Name] -> RnM d () +updateProvenances names + = getNameSupplyRn `thenRn` \ (us, inst_ns, cache) -> + setNameSupplyRn (us, inst_ns, update cache names) + where + update cache [] = cache + update cache (name:names) = WARN( not (key `elemFM` cache), ppr name ) + update (addToFM cache key name) names + where + key = (moduleName (nameModule name), nameOccName name) + +newImportedBinder :: Module -> RdrName -> RnM d Name +newImportedBinder mod rdr_name + = ASSERT2( isUnqual rdr_name, ppr rdr_name ) + newImportedGlobalName (moduleName mod) (rdrNameOcc rdr_name) mod + +-- Make an imported global name, checking first to see if it's in the cache +mkImportedGlobalName :: ModuleName -> OccName -> RnM d Name +mkImportedGlobalName mod_name occ + = newImportedGlobalName mod_name occ (mkVanillaModule mod_name) - -- A hit in the cache! - -- If it has no provenance at the moment then set its provenance - -- so that it has the right HiFlag component. - -- (This is necessary for known-key things. - -- For example, GHCmain.lhs imports as SOURCE - -- Main; but Main.main is a known-key thing.) - -- Don't fiddle with the provenance if it already has one - Just name -> case getNameProvenance name of - NoProvenance -> let - new_name = setNameProvenance name prov - new_cache = addToFM cache key new_name - in - setNameSupplyRn (us, inst_ns, new_cache) `thenRn_` - returnRn new_name - other -> returnRn name - - Nothing -> -- Miss in the cache! - -- Build a new original name, and put it in the cache - let - (us', us1) = splitUniqSupply us - uniq = uniqFromSupply us1 - name = mkGlobalName uniq mod occ prov - new_cache = addToFM cache key name - in - setNameSupplyRn (us', inst_ns, new_cache) `thenRn_` - returnRn name +mkImportedGlobalFromRdrName rdr_name + | isQual rdr_name + = mkImportedGlobalName (rdrNameModule rdr_name) (rdrNameOcc rdr_name) - -newImportedGlobalFromRdrName (Qual mod_name occ hif) - = newImportedGlobalName mod_name occ hif - -newImportedGlobalFromRdrName (Unqual occ) + | otherwise = -- An Unqual is allowed; interface files contain -- unqualified names for locally-defined things, such as -- constructors of a data type. - getModuleRn `thenRn ` \ mod_name -> - newImportedGlobalName mod_name occ HiFile + getModuleRn `thenRn ` \ mod_name -> + mkImportedGlobalName mod_name (rdrNameOcc rdr_name) -newLocallyDefinedGlobalName :: Module -> OccName - -> (Name -> ExportFlag) -> SrcLoc - -> RnM s d Name -newLocallyDefinedGlobalName mod occ rec_exp_fn loc +newLocalTopBinder :: Module -> OccName + -> (Name -> ExportFlag) -> SrcLoc + -> RnM d Name +newLocalTopBinder mod occ rec_exp_fn loc = -- First check the cache getNameSupplyRn `thenRn` \ (us, inst_ns, cache) -> let - key = (mod,occ) + key = (moduleName mod,occ) mk_prov name = LocalDef loc (rec_exp_fn name) -- We must set the provenance of the thing in the cache -- correctly, particularly whether or not it is locally defined. @@ -160,67 +146,92 @@ newLocallyDefinedGlobalName mod occ rec_exp_fn loc in setNameSupplyRn (us', inst_ns, new_cache) `thenRn_` returnRn new_name +\end{code} +%********************************************************* +%* * +\subsection{Dfuns and default methods} +%* * +%********************************************************* -newLocalNames :: [(RdrName,SrcLoc)] -> RnM s d [Name] -newLocalNames rdr_names - = getNameSupplyRn `thenRn` \ (us, inst_ns, cache) -> - let - n = length rdr_names - (us', us1) = splitUniqSupply us - uniqs = uniqsFromSupply n us1 - -- Note: we're not making use of the source location. Not good. - locals = [ mkLocalName uniq (rdrNameOcc rdr_name) - | ((rdr_name,loc), uniq) <- rdr_names `zip` uniqs - ] - in - setNameSupplyRn (us', inst_ns, cache) `thenRn_` - returnRn locals - -newDFunName cl_occ tycon_occ (Just n) src_loc -- Imported ones have "Just n" - = getModuleRn `thenRn` \ mod_name -> - newImportedGlobalName mod_name (rdrNameOcc n) HiFile {- Correct? -} +@newImplicitBinder@ is used for (a) dfuns +(b) default methods, defined in this module. -newDFunName cl_occ tycon_occ Nothing src_loc -- Local instance decls have a "Nothing" +\begin{code} +newImplicitBinder occ src_loc = getModuleRn `thenRn` \ mod_name -> - newInstUniq (cl_occ, tycon_occ) `thenRn` \ inst_uniq -> - let - dfun_occ = mkDFunOcc cl_occ tycon_occ inst_uniq - in - newLocallyDefinedGlobalName mod_name dfun_occ (\_ -> Exported) src_loc + newLocalTopBinder (mkThisModule mod_name) occ (\_ -> Exported) src_loc +\end{code} +Make a name for the dict fun for an instance decl --- 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) +\begin{code} +newDFunName :: (OccName, OccName) -> SrcLoc -> RnMS Name +newDFunName key@(cl_occ, tycon_occ) loc + = newInstUniq key `thenRn` \ inst_uniq -> + newImplicitBinder (mkDFunOcc cl_occ tycon_occ inst_uniq) loc +\end{code} -isUnboundName :: Name -> Bool -isUnboundName name = getUnique name == unboundKey +\begin{code} +getDFunKey :: RenamedHsType -> (OccName, OccName) -- Used to manufacture DFun names +getDFunKey (HsForAllTy _ _ ty) = getDFunKey ty +getDFunKey (MonoFunTy _ ty) = getDFunKey ty +getDFunKey (MonoDictTy cls (ty:_)) = (nameOccName cls, get_tycon_key ty) + +get_tycon_key (MonoTyVar tv) = nameOccName (getName tv) +get_tycon_key (MonoTyApp ty _) = get_tycon_key ty +get_tycon_key (MonoTupleTy tys True) = getOccName (tupleTyCon (length tys)) +get_tycon_key (MonoTupleTy tys False) = getOccName (unboxedTupleTyCon (length tys)) +get_tycon_key (MonoListTy _) = getOccName listTyCon +get_tycon_key (MonoFunTy _ _) = getOccName funTyCon \end{code} + +%********************************************************* +%* * +\subsection{Binding} +%* * +%********************************************************* + \begin{code} ------------------------------------- -bindLocatedLocalsRn :: SDoc -- Documentation string for error message +bindLocatedLocalsRn :: SDoc -- Documentation string for error message -> [(RdrName,SrcLoc)] - -> ([Name] -> RnMS s a) - -> RnMS s a + -> ([Name] -> RnMS a) + -> RnMS a bindLocatedLocalsRn doc_str rdr_names_w_loc enclosed_scope = checkDupOrQualNames doc_str rdr_names_w_loc `thenRn_` getLocalNameEnv `thenRn` \ name_env -> (if opt_WarnNameShadowing then - mapRn (check_shadow name_env) rdr_names_w_loc + mapRn_ (check_shadow name_env) rdr_names_w_loc else - returnRn [] + returnRn () ) `thenRn_` - newLocalNames rdr_names_w_loc `thenRn` \ names -> + getNameSupplyRn `thenRn` \ (us, inst_ns, cache) -> + getModeRn `thenRn` \ mode -> + let + n = length rdr_names_w_loc + (us', us1) = splitUniqSupply us + uniqs = uniqsFromSupply n us1 + names = [ mk_name uniq (rdrNameOcc rdr_name) loc + | ((rdr_name,loc), uniq) <- rdr_names_w_loc `zip` uniqs + ] + mk_name = case mode of + SourceMode -> mkLocalName + InterfaceMode -> mkImportedLocalName + -- Keep track of whether the name originally came from + -- an interface file. + in + setNameSupplyRn (us', inst_ns, cache) `thenRn_` + let new_name_env = addListToRdrEnv name_env (map fst rdr_names_w_loc `zip` names) in setLocalNameEnv new_name_env (enclosed_scope names) + where check_shadow name_env (rdr_name,loc) = case lookupRdrEnv name_env rdr_name of @@ -228,45 +239,80 @@ bindLocatedLocalsRn doc_str rdr_names_w_loc enclosed_scope Just name -> pushSrcLocRn loc $ addWarnRn (shadowedNameWarn rdr_name) +bindCoreLocalFVRn :: RdrName -> (Name -> RnMS (a, FreeVars)) + -> RnMS (a, FreeVars) + -- A specialised variant when renaming stuff from interface + -- files (of which there is a lot) + -- * one at a time + -- * no checks for shadowing + -- * always imported + -- * deal with free vars +bindCoreLocalFVRn rdr_name enclosed_scope + = getSrcLocRn `thenRn` \ loc -> + getLocalNameEnv `thenRn` \ name_env -> + getNameSupplyRn `thenRn` \ (us, inst_ns, cache) -> + let + (us', us1) = splitUniqSupply us + uniq = uniqFromSupply us1 + name = mkImportedLocalName uniq (rdrNameOcc rdr_name) loc + in + setNameSupplyRn (us', inst_ns, cache) `thenRn_` + let + new_name_env = extendRdrEnv name_env rdr_name name + in + setLocalNameEnv new_name_env (enclosed_scope name) `thenRn` \ (result, fvs) -> + returnRn (result, delFromNameSet fvs name) + +bindCoreLocalsFVRn [] thing_inside = thing_inside [] +bindCoreLocalsFVRn (b:bs) thing_inside = bindCoreLocalFVRn b $ \ name' -> + bindCoreLocalsFVRn bs $ \ names' -> + thing_inside (name':names') ------------------------------------- -bindLocalsRn doc_str rdr_names enclosed_scope +bindLocalRn doc rdr_name enclosed_scope + = getSrcLocRn `thenRn` \ loc -> + bindLocatedLocalsRn doc [(rdr_name,loc)] $ \ (n:ns) -> + ASSERT( null ns ) + enclosed_scope n + +bindLocalsRn doc rdr_names enclosed_scope = getSrcLocRn `thenRn` \ loc -> - bindLocatedLocalsRn (text doc_str) + bindLocatedLocalsRn doc (rdr_names `zip` repeat loc) enclosed_scope -- binLocalsFVRn is the same as bindLocalsRn -- except that it deals with free vars -bindLocalsFVRn doc_str rdr_names enclosed_scope - = bindLocalsRn doc_str rdr_names $ \ names -> +bindLocalsFVRn doc rdr_names enclosed_scope + = bindLocalsRn doc rdr_names $ \ names -> enclosed_scope names `thenRn` \ (thing, fvs) -> returnRn (thing, delListFromNameSet fvs names) ------------------------------------- -extendTyVarEnvRn :: [HsTyVar Name] -> RnMS s a -> RnMS s a +extendTyVarEnvFVRn :: [HsTyVar Name] -> RnMS (a, FreeVars) -> RnMS (a, FreeVars) -- This tiresome function is used only in rnDecl on InstDecl -extendTyVarEnvRn tyvars enclosed_scope +extendTyVarEnvFVRn tyvars enclosed_scope = getLocalNameEnv `thenRn` \ env -> let - new_env = addListToRdrEnv env [ (Unqual (getOccName name), name) - | tyvar <- tyvars, - let name = getTyVarName tyvar + tyvar_names = map getTyVarName tyvars + new_env = addListToRdrEnv env [ (mkRdrUnqual (getOccName name), name) + | name <- tyvar_names ] in - setLocalNameEnv new_env enclosed_scope + setLocalNameEnv new_env enclosed_scope `thenRn` \ (thing, fvs) -> + returnRn (thing, delListFromNameSet fvs tyvar_names) bindTyVarsRn :: SDoc -> [HsTyVar RdrName] - -> ([HsTyVar Name] -> RnMS s a) - -> RnMS s a + -> ([HsTyVar Name] -> RnMS a) + -> RnMS a bindTyVarsRn doc_str tyvar_names enclosed_scope = bindTyVars2Rn doc_str tyvar_names $ \ names tyvars -> enclosed_scope tyvars -- Gruesome name: return Names as well as HsTyVars bindTyVars2Rn :: SDoc -> [HsTyVar RdrName] - -> ([Name] -> [HsTyVar Name] -> RnMS s a) - -> RnMS s a + -> ([Name] -> [HsTyVar Name] -> RnMS a) + -> RnMS a bindTyVars2Rn doc_str tyvar_names enclosed_scope = getSrcLocRn `thenRn` \ loc -> let @@ -276,16 +322,16 @@ bindTyVars2Rn doc_str tyvar_names enclosed_scope enclosed_scope names (zipWith replaceTyVarName tyvar_names names) bindTyVarsFVRn :: SDoc -> [HsTyVar RdrName] - -> ([HsTyVar Name] -> RnMS s (a, FreeVars)) - -> RnMS s (a, FreeVars) + -> ([HsTyVar Name] -> RnMS (a, FreeVars)) + -> RnMS (a, FreeVars) bindTyVarsFVRn doc_str rdr_names enclosed_scope = bindTyVars2Rn doc_str rdr_names $ \ names tyvars -> enclosed_scope tyvars `thenRn` \ (thing, fvs) -> returnRn (thing, delListFromNameSet fvs names) bindTyVarsFV2Rn :: SDoc -> [HsTyVar RdrName] - -> ([Name] -> [HsTyVar Name] -> RnMS s (a, FreeVars)) - -> RnMS s (a, FreeVars) + -> ([Name] -> [HsTyVar Name] -> RnMS (a, FreeVars)) + -> RnMS (a, FreeVars) bindTyVarsFV2Rn doc_str rdr_names enclosed_scope = bindTyVars2Rn doc_str rdr_names $ \ names tyvars -> enclosed_scope names tyvars `thenRn` \ (thing, fvs) -> @@ -295,28 +341,21 @@ bindTyVarsFV2Rn doc_str rdr_names enclosed_scope ------------------------------------- checkDupOrQualNames, checkDupNames :: SDoc -> [(RdrName, SrcLoc)] - -> RnM s d () + -> RnM d () -- Works in any variant of the renamer monad checkDupOrQualNames doc_str rdr_names_w_loc = -- Check for use of qualified names - mapRn (qualNameErr doc_str) quals `thenRn_` + mapRn_ (qualNameErr doc_str) quals `thenRn_` checkDupNames doc_str rdr_names_w_loc where quals = filter (isQual.fst) rdr_names_w_loc checkDupNames doc_str rdr_names_w_loc - = -- Check for dupicated names in a binding group - mapRn (dupNamesErr doc_str) dups `thenRn_` - returnRn () + = -- Check for duplicated names in a binding group + mapRn_ (dupNamesErr doc_str) dups where (_, dups) = removeDups (\(n1,l1) (n2,l2) -> n1 `compare` n2) rdr_names_w_loc - - --- Yuk! -ifaceFlavour name = case getNameProvenance name of - NonLocalDef _ hif _ -> hif - other -> HiFile -- Shouldn't happen \end{code} @@ -329,115 +368,106 @@ ifaceFlavour name = case getNameProvenance name of Looking up a name in the RnEnv. \begin{code} -checkUnboundRn :: RdrName -> Maybe Name -> RnMS s Name -checkUnboundRn rdr_name (Just name) - = -- Found it! - returnRn name +lookupBndrRn rdr_name + = getNameEnvs `thenRn` \ (global_env, local_env) -> + + -- Try local env + case lookupRdrEnv local_env rdr_name of { + Just name -> returnRn name ; + Nothing -> -checkUnboundRn rdr_name Nothing - = -- Not found by lookup getModeRn `thenRn` \ mode -> case mode of - -- Not found when processing source code; so fail - SourceMode -> failWithRn (mkUnboundName rdr_name) - (unknownNameErr rdr_name) - - -- Not found when processing an imported declaration, - -- so we create a new name for the purpose - InterfaceMode _ -> newImportedGlobalFromRdrName rdr_name - -lookupBndrRn rdr_name - = lookupNameRn rdr_name `thenRn` \ maybe_name -> - checkUnboundRn rdr_name maybe_name + InterfaceMode -> -- Look in the global name cache + mkImportedGlobalFromRdrName rdr_name + + SourceMode -> -- Source mode, so look up a *qualified* version + -- of the name, so that we get the right one even + -- if there are many with the same occ name + -- There must *be* a binding + getModuleRn `thenRn` \ mod -> + case lookupRdrEnv global_env (qualifyRdrName mod rdr_name) of + Just (name:rest) -> ASSERT( null rest ) + returnRn name + Nothing -> pprPanic "lookupBndrRn" (ppr mod <+> ppr rdr_name) + } -- Just like lookupRn except that we record the occurrence too -- Perhaps surprisingly, even wired-in names are recorded. -- Why? So that we know which wired-in names are referred to when -- deciding which instance declarations to import. -lookupOccRn :: RdrName -> RnMS s Name +lookupOccRn :: RdrName -> RnMS Name lookupOccRn rdr_name - = lookupNameRn rdr_name `thenRn` \ maybe_name -> - checkUnboundRn rdr_name maybe_name `thenRn` \ name -> - let - name' = mungePrintUnqual rdr_name name - in - addOccurrenceName name' + = getNameEnvs `thenRn` \ (global_env, local_env) -> + lookup_occ global_env local_env rdr_name -- lookupGlobalOccRn is like lookupOccRn, except that it looks in the global -- environment. It's used only for -- record field names -- class op names in class and instance decls -lookupGlobalOccRn :: RdrName -> RnMS s Name +lookupGlobalOccRn :: RdrName -> RnMS Name lookupGlobalOccRn rdr_name - = lookupGlobalNameRn rdr_name `thenRn` \ maybe_name -> - checkUnboundRn rdr_name maybe_name `thenRn` \ name -> - let - name' = mungePrintUnqual rdr_name name - in - addOccurrenceName name' - - --- mungePrintUnqual is used to make *imported* *occurrences* print unqualified --- if they were mentioned unqualified in the source code. --- This improves error messages from the type checker. --- NB: the binding site is treated differently; see lookupBndrRn --- After the type checker all occurrences are replaced by the one --- at the binding site. -mungePrintUnqual (Qual _ _ _) name = name -mungePrintUnqual (Unqual _) name - = case getNameProvenance name of - NonLocalDef imp hif False -> setNameProvenance name (NonLocalDef imp hif True) - other -> name - --- lookupImplicitOccRn takes an RdrName representing an *original* name, and --- adds it to the occurrence pool so that it'll be loaded later. This is --- used when language constructs (such as monad comprehensions, overloaded literals, --- or deriving clauses) require some stuff to be loaded that isn't explicitly --- mentioned in the code. --- --- This doesn't apply in interface mode, where everything is explicit, but --- we don't check for this case: it does no harm to record an "extra" occurrence --- and lookupImplicitOccRn isn't used much in interface mode (it's only the --- Nothing clause of rnDerivs that calls it at all I think). --- [Jan 98: this comment is wrong: rnHsType uses it quite a bit.] --- --- For List and Tuple types it's important to get the correct --- isLocallyDefined flag, which is used in turn when deciding --- whether there are any instance decls in this module are "special". --- The name cache should have the correct provenance, though. - -lookupImplicitOccRn :: RdrName -> RnMS s Name -lookupImplicitOccRn (Qual mod occ hif) - = newImportedGlobalName mod occ hif `thenRn` \ name -> - addOccurrenceName name - -addImplicitOccRn :: Name -> RnMS s Name -addImplicitOccRn name = addOccurrenceName name - -addImplicitOccsRn :: [Name] -> RnMS s () -addImplicitOccsRn names = addOccurrenceNames names + = getNameEnvs `thenRn` \ (global_env, local_env) -> + lookup_global_occ global_env rdr_name + +-- Look in both local and global env +lookup_occ global_env local_env rdr_name + = case lookupRdrEnv local_env rdr_name of + Just name -> returnRn name + Nothing -> lookup_global_occ global_env rdr_name + +-- Look in global env only +lookup_global_occ global_env rdr_name + = case lookupRdrEnv global_env rdr_name of + Just [name] -> returnRn name + Just stuff@(name:_) -> addNameClashErrRn rdr_name stuff `thenRn_` + returnRn name + Nothing -> getModeRn `thenRn` \ mode -> + case mode of + -- Not found when processing source code; so fail + SourceMode -> failWithRn (mkUnboundName rdr_name) + (unknownNameErr rdr_name) + + -- Not found when processing an imported declaration, + -- so we create a new name for the purpose + InterfaceMode -> mkImportedGlobalFromRdrName rdr_name \end{code} +% +@lookupImplicitOccRn@ takes an RdrName representing an {\em original} name, +and adds it to the occurrence pool so that it'll be loaded later. +This is used when language constructs +(such as monad comprehensions, overloaded literals, or deriving clauses) +require some stuff to be loaded that isn't explicitly mentioned in the code. + +This doesn't apply in interface mode, where everything is explicit, +but we don't check for this case: +it does no harm to record an ``extra'' occurrence +and @lookupImplicitOccRn@ isn't used much in interface mode +(it's only the @Nothing@ clause of @rnDerivs@ that calls it at all I think). + + \fbox{{\em Jan 98: this comment is wrong: @rnHsType@ uses it quite a bit.}} + +For List and Tuple types it's important to get the correct +@isLocallyDefined@ flag, which is used in turn when deciding +whether there are any instance decls in this module are ``special''. +The name cache should have the correct provenance, though. \begin{code} -lookupFixity :: Name -> RnMS s Fixity -lookupFixity name - = getFixityEnv `thenRn` \ fixity_env -> - case lookupNameEnv fixity_env name of - Just (FixitySig _ fixity _) -> returnRn fixity - Nothing -> returnRn (Fixity 9 InfixL) -- Default case +lookupImplicitOccRn :: RdrName -> RnM d Name +lookupImplicitOccRn rdr_name = mkImportedGlobalFromRdrName rdr_name \end{code} -mkPrintUnqualFn returns a function that takes a Name and tells whether +@unQualInScope@ returns a function that takes a @Name@ and tells whether its unqualified name is in scope. This is put as a boolean flag in -the Name's provenance to guide whether or not to print the name qualified +the @Name@'s provenance to guide whether or not to print the name qualified in error messages. \begin{code} -mkPrintUnqualFn :: GlobalRdrEnv -> Name -> Bool -mkPrintUnqualFn env +unQualInScope :: GlobalRdrEnv -> Name -> Bool +unQualInScope env = lookup where - lookup name = case lookupRdrEnv env (Unqual (nameOccName name)) of + lookup name = case lookupRdrEnv env (mkRdrUnqual (nameOccName name)) of Just [name'] -> name == name' other -> False \end{code} @@ -448,37 +478,9 @@ mkPrintUnqualFn env %* * %************************************************************************ -=============== RnEnv ================ -\begin{code} -plusRnEnv (RnEnv n1 f1) (RnEnv n2 f2) - = RnEnv (n1 `plusGlobalRdrEnv` n2) - (f1 `plusNameEnv` f2) -\end{code} +\subsubsection{NameEnv}% ================ - -=============== NameEnv ================ \begin{code} --- Look in global env only -lookupGlobalNameRn :: RdrName -> RnMS s (Maybe Name) -lookupGlobalNameRn rdr_name - = getNameEnvs `thenRn` \ (global_env, local_env) -> - lookup_global global_env rdr_name - --- Look in both local and global env -lookupNameRn :: RdrName -> RnMS s (Maybe Name) -lookupNameRn rdr_name - = getNameEnvs `thenRn` \ (global_env, local_env) -> - case lookupRdrEnv local_env rdr_name of - Just name -> returnRn (Just name) - Nothing -> lookup_global global_env rdr_name - -lookup_global global_env rdr_name - = case lookupRdrEnv global_env rdr_name of - Just [name] -> returnRn (Just name) - Just stuff@(name:_) -> addNameClashErrRn rdr_name stuff `thenRn_` - returnRn (Just name) - Nothing -> returnRn Nothing - plusGlobalRdrEnv :: GlobalRdrEnv -> GlobalRdrEnv -> GlobalRdrEnv plusGlobalRdrEnv env1 env2 = plusFM_C combine_globals env1 env2 @@ -494,8 +496,8 @@ combine_globals :: [Name] -- Old combine_globals ns_old ns_new -- ns_new is often short = foldr add ns_old ns_new where - add n ns | all (no_conflict n) ns_old = map choose ns -- Eliminate duplicates - | otherwise = n:ns + add n ns | any (is_duplicate n) ns_old = map choose ns -- Eliminate duplicates + | otherwise = n:ns where choose n' | n==n' && better_provenance n n' = n | otherwise = n' @@ -506,31 +508,36 @@ combine_globals ns_old ns_new -- ns_new is often short -- an explicitly-imported thing over an implicitly imported thing better_provenance n1 n2 = case (getNameProvenance n1, getNameProvenance n2) of - (LocalDef _ _, _ ) -> True - (NonLocalDef (UserImport _ _ True) _ _, _ ) -> True - (NonLocalDef (UserImport _ _ _ ) _ _, NonLocalDef ImplicitImport _ _) -> True - other -> False - -no_conflict :: Name -> Name -> Bool -no_conflict n1 n2 | isLocallyDefined n1 && isLocallyDefined n2 = False - | otherwise = n1 == n2 - -- We complain of a conflict if one RdrName maps to two different Names, - -- OR if one RdrName maps to the same *locally-defined* Name. The latter - -- case is to catch two separate, local definitions of the same thing. - -- - -- If a module imports itself then there might be a local defn and an imported - -- defn of the same name; in this case the names will compare as equal, but - -- will still have different provenances + (LocalDef _ _, _ ) -> True + (NonLocalDef (UserImport _ _ True) _, _ ) -> True + (NonLocalDef (UserImport _ _ _ ) _, NonLocalDef ImplicitImport _) -> True + other -> False + +is_duplicate :: Name -> Name -> Bool +is_duplicate n1 n2 | isLocallyDefined n1 && isLocallyDefined n2 = False + | otherwise = n1 == n2 \end{code} +We treat two bindings of a locally-defined name as a duplicate, +because they might be two separate, local defns and we want to report +and error for that, {\em not} eliminate a duplicate. +On the other hand, if you import the same name from two different +import statements, we {\em d}* want to eliminate the duplicate, not report +an error. +If a module imports itself then there might be a local defn and an imported +defn of the same name; in this case the names will compare as equal, but +will still have different provenances. + + + +\subsubsection{ExportAvails}% ================ -=============== ExportAvails ================ \begin{code} -mkEmptyExportAvails :: Module -> ExportAvails +mkEmptyExportAvails :: ModuleName -> ExportAvails mkEmptyExportAvails mod_name = (unitFM mod_name [], emptyUFM) -mkExportAvails :: Module -> Bool -> GlobalRdrEnv -> [AvailInfo] -> ExportAvails +mkExportAvails :: ModuleName -> Bool -> GlobalRdrEnv -> [AvailInfo] -> ExportAvails mkExportAvails mod_name unqual_imp name_env avails = (mod_avail_env, entity_avail_env) where @@ -543,13 +550,16 @@ mkExportAvails mod_name unqual_imp name_env avails -- we delete f from avails unqual_avails | not unqual_imp = [] -- Short cut when no unqualified imports - | otherwise = [prune avail | avail <- avails] + | otherwise = mapMaybe prune avails - prune (Avail n) | unqual_in_scope n = Avail n - prune (Avail n) | otherwise = NotAvailable - prune (AvailTC n ns) = AvailTC n (filter unqual_in_scope ns) + prune (Avail n) | unqual_in_scope n = Just (Avail n) + prune (Avail n) | otherwise = Nothing + prune (AvailTC n ns) | null uqs = Nothing + | otherwise = Just (AvailTC n uqs) + where + uqs = filter unqual_in_scope ns - unqual_in_scope n = Unqual (nameOccName n) `elemFM` name_env + unqual_in_scope n = unQualInScope name_env n entity_avail_env = listToUFM [ (name,avail) | avail <- avails, name <- availNames avail] @@ -561,12 +571,11 @@ plusExportAvails (m1, e1) (m2, e2) \end{code} -=============== AvailInfo ================ +\subsubsection{AvailInfo}% ================ + \begin{code} plusAvail (Avail n1) (Avail n2) = Avail n1 plusAvail (AvailTC n1 ns1) (AvailTC n2 ns2) = AvailTC n1 (nub (ns1 ++ ns2)) -plusAvail a NotAvailable = a -plusAvail NotAvailable a = a -- Added SOF 4/97 #ifdef DEBUG plusAvail a1 a2 = pprPanic "RnEnv.plusAvail" (hsep [pprAvail a1,pprAvail a2]) @@ -583,22 +592,17 @@ availName (Avail n) = n availName (AvailTC n _) = n availNames :: AvailInfo -> [Name] -availNames NotAvailable = [] availNames (Avail n) = [n] availNames (AvailTC n ns) = ns filterAvail :: RdrNameIE -- Wanted -> AvailInfo -- Available - -> AvailInfo -- Resulting available; - -- NotAvailable if (any of the) wanted stuff isn't there + -> Maybe AvailInfo -- Resulting available; + -- Nothing if (any of the) wanted stuff isn't there filterAvail ie@(IEThingWith want wants) avail@(AvailTC n ns) - | sub_names_ok = AvailTC n (filter is_wanted ns) - | otherwise = -#ifdef DEBUG - pprTrace "filterAvail" (hsep [ppr ie, pprAvail avail]) $ -#endif - NotAvailable + | sub_names_ok = Just (AvailTC n (filter is_wanted ns)) + | otherwise = Nothing where is_wanted name = nameOccName name `elem` wanted_occs sub_names_ok = all (`elem` avail_occs) wanted_occs @@ -606,11 +610,12 @@ filterAvail ie@(IEThingWith want wants) avail@(AvailTC n ns) wanted_occs = map rdrNameOcc (want:wants) filterAvail (IEThingAbs _) (AvailTC n ns) = ASSERT( n `elem` ns ) - AvailTC n [n] -filterAvail (IEThingAll _) avail@(AvailTC _ _) = avail + Just (AvailTC n [n]) -filterAvail (IEVar _) avail@(Avail n) = avail -filterAvail (IEVar v) avail@(AvailTC n ns) = AvailTC n (filter wanted ns) +filterAvail (IEThingAbs _) avail@(Avail n) = Just avail -- Type synonyms + +filterAvail (IEVar _) avail@(Avail n) = Just avail +filterAvail (IEVar v) avail@(AvailTC n ns) = Just (AvailTC n (filter wanted ns)) where wanted n = nameOccName n == occ occ = rdrNameOcc v @@ -618,10 +623,9 @@ filterAvail (IEVar v) avail@(AvailTC n ns) = AvailTC n (filter wanted ns) -- import A( op ) -- where op is a class operation +filterAvail (IEThingAll _) avail@(AvailTC _ _) = Just avail -#ifdef DEBUG -filterAvail ie avail = pprPanic "filterAvail" (ppr ie $$ pprAvail avail) -#endif +filterAvail ie avail = Nothing -- In interfaces, pprAvail gets given the OccName of the "host" thing @@ -631,7 +635,6 @@ pprAvail avail = getPprStyle $ \ sty -> else ppr_avail ppr avail -ppr_avail pp_name NotAvailable = ptext SLIT("NotAvailable") ppr_avail pp_name (AvailTC n ns) = hsep [ pp_name n, parens $ hsep $ punctuate comma $ @@ -658,11 +661,21 @@ unitFV :: Name -> FreeVars emptyFVs :: FreeVars plusFVs :: [FreeVars] -> FreeVars -plusFV = unionNameSets -addOneFV = addOneToNameSet -unitFV = unitNameSet -emptyFVs = emptyNameSet -plusFVs = unionManyNameSets +isEmptyFVs = isEmptyNameSet +emptyFVs = emptyNameSet +plusFVs = unionManyNameSets +plusFV = unionNameSets + +-- No point in adding implicitly imported names to the free-var set +addOneFV s n = addOneToNameSet s n +unitFV n = unitNameSet n + +-- A useful utility +mapFvRn f xs = mapRn f xs `thenRn` \ stuff -> + let + (ys, fvs_s) = unzip stuff + in + returnRn (ys, plusFVs fvs_s) \end{code} @@ -674,68 +687,76 @@ plusFVs = unionManyNameSets \begin{code} -warnUnusedBinds, warnUnusedMatches :: [Name] -> RnM s d () +warnUnusedLocalBinds, warnUnusedTopNames, warnUnusedMatches :: [Name] -> RnM d () -warnUnusedTopNames ns +warnUnusedTopNames names | not opt_WarnUnusedBinds && not opt_WarnUnusedImports - = returnRn () -- Don't force ns unless necessary - -warnUnusedTopNames (n:ns) - | is_local && opt_WarnUnusedBinds = warnUnusedNames False{-include name's provenance-} ns - | not is_local && opt_WarnUnusedImports = warnUnusedNames False ns - where - is_local = isLocallyDefined n - -warnUnusedTopName other = returnRn () + = returnRn () -- Don't force ns unless necessary + | otherwise + = warnUnusedBinds (\ is_local -> not is_local) names -warnUnusedBinds ns +warnUnusedLocalBinds ns | not opt_WarnUnusedBinds = returnRn () - | otherwise = warnUnusedNames False ns - -{- - Haskell 98 encourages compilers to suppress warnings about - unused names in a pattern if they start with "_". Which - we do here. + | otherwise = warnUnusedBinds (\ is_local -> is_local) ns - Note: omit the inclusion of the names' provenance in the - generated warning -- it's already given in the header - of the warning (+ the local names we've been given have - a provenance that's ultra low in content.) - --} warnUnusedMatches names - | opt_WarnUnusedMatches = warnUnusedNames True (filter (not.isAnonOcc.getOccName) names) + | opt_WarnUnusedMatches = warnUnusedGroup (const True) names | otherwise = returnRn () -warnUnusedNames :: Bool{-display provenance-} -> [Name] -> RnM s d () -warnUnusedNames _ [] - = returnRn () +------------------------- -warnUnusedNames short_msg names - = addWarnRn $ - sep [text "The following names are unused:", - nest 4 ((if short_msg then hsep else vcat) (map pp names))] +warnUnusedBinds :: (Bool -> Bool) -> [Name] -> RnM d () +warnUnusedBinds warn_when_local names + = mapRn_ (warnUnusedGroup warn_when_local) groups where - pp n - | short_msg = ppr n - | otherwise = ppr n <> comma <+> pprNameProvenance n - -addNameClashErrRn rdr_name names -{- NO LONGER NEEDED WITH LAZY NAME-CLASH REPORTING - | isClassDataConRdrName rdr_name - -- Nasty hack to prevent error messages complain about conflicts for ":C", - -- where "C" is a class. There'll be a message about C, and :C isn't - -- the programmer's business. There may be a better way to filter this - -- out, but I couldn't get up the energy to find it. - = returnRn () - + -- Group by provenance + groups = equivClasses cmp names + name1 `cmp` name2 = getNameProvenance name1 `cmp_prov` getNameProvenance name2 + + cmp_prov (LocalDef _ _) (NonLocalDef _ _) = LT + cmp_prov (LocalDef loc1 _) (LocalDef loc2 _) = loc1 `compare` loc2 + cmp_prov (NonLocalDef (UserImport m1 loc1 _) _) + (NonLocalDef (UserImport m2 loc2 _) _) = + (m1 `compare` m2) `thenCmp` (loc1 `compare` loc2) + cmp_prov (NonLocalDef _ _) (LocalDef _ _) = GT + -- In-scope NonLocalDefs must have UserImport info on them + +------------------------- + +warnUnusedGroup :: (Bool -> Bool) -> [Name] -> RnM d () +warnUnusedGroup emit_warning names + | null filtered_names = returnRn () + | not (emit_warning is_local) = returnRn () | otherwise --} + = pushSrcLocRn def_loc $ + addWarnRn $ + sep [msg <> colon, nest 4 (fsep (punctuate comma (map ppr filtered_names)))] + where + filtered_names = filter reportable names + name1 = head filtered_names + (is_local, def_loc, msg) + = case getNameProvenance name1 of + LocalDef loc _ -> (True, loc, text "Defined but not used") + NonLocalDef (UserImport mod loc _) _ -> + (True, loc, text "Imported from" <+> quotes (ppr mod) <+> + text "but not used") + other -> (False, getSrcLoc name1, text "Strangely defined but not used") + + reportable name = case occNameUserString (nameOccName name) of + ('_' : _) -> False + _other -> True + -- Haskell 98 encourages compilers to suppress warnings about + -- unused names in a pattern if they start with "_". +\end{code} +\begin{code} +addNameClashErrRn rdr_name (name1:names) = addErrRn (vcat [ptext SLIT("Ambiguous occurrence") <+> quotes (ppr rdr_name), - ptext SLIT("It could refer to:") <+> vcat (map mk_ref names)]) + ptext SLIT("It could refer to") <+> vcat (msg1 : msgs)]) where - mk_ref name = ppr name <> colon <+> pprNameProvenance name + msg1 = ptext SLIT("either") <+> mk_ref name1 + msgs = [ptext SLIT(" or") <+> mk_ref name | name <- names] + mk_ref name = quotes (ppr name) <> comma <+> pprNameProvenance name fixityClashErr (rdr_name, ((_,how_in_scope1), (_, how_in_scope2))) = hang (hsep [ptext SLIT("Conflicting fixities for"), quotes (ppr rdr_name)]) @@ -761,8 +782,8 @@ qualNameErr descriptor (name,loc) dupNamesErr descriptor ((name,loc) : dup_things) = pushSrcLocRn loc $ - addErrRn (hsep [ptext SLIT("Conflicting definitions for"), - quotes (ppr name), - ptext SLIT("in"), descriptor]) + addErrRn ((ptext SLIT("Conflicting definitions for") <+> quotes (ppr name)) + $$ + (ptext SLIT("in") <+> descriptor)) \end{code}