X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2Frename%2FRnEnv.lhs;h=d12aab932503c50329f6da2093344a9921d4727b;hb=10fcd78ccde892feccda3f5eacd221c1de75feea;hp=8c81f2e3d1078dc74a97e30afd52c415ce6d133b;hpb=bb91427f27c940e4dd0fc6c7360e7ef61264b240;p=ghc-hetmet.git diff --git a/ghc/compiler/rename/RnEnv.lhs b/ghc/compiler/rename/RnEnv.lhs index 8c81f2e..d12aab9 100644 --- a/ghc/compiler/rename/RnEnv.lhs +++ b/ghc/compiler/rename/RnEnv.lhs @@ -8,46 +8,60 @@ module RnEnv where -- Export everything #include "HsVersions.h" -import CmdLineOpts ( opt_WarnNameShadowing, opt_WarnUnusedMatches, - opt_WarnUnusedBinds, opt_WarnUnusedImports ) +import {-# SOURCE #-} RnHiFiles + +import FlattenInfo ( namesNeededForFlattening ) import HsSyn -import RdrHsSyn ( RdrNameIE ) -import RnHsSyn ( RenamedHsType ) -import RdrName ( RdrName, rdrNameModule, rdrNameOcc, isQual, isUnqual, - mkRdrUnqual, qualifyRdrName +import RdrHsSyn ( RdrNameIE, RdrNameHsType, extractHsTyRdrTyVars ) +import RdrName ( RdrName, rdrNameModule, rdrNameOcc, isQual, isUnqual, isOrig, + mkRdrUnqual, mkRdrQual, + lookupRdrEnv, foldRdrEnv, rdrEnvToList, elemRdrEnv, + unqualifyRdrName + ) +import HsTypes ( hsTyVarName, replaceTyVarName ) +import HscTypes ( Provenance(..), pprNameProvenance, hasBetterProv, + ImportReason(..), GlobalRdrEnv, GlobalRdrElt(..), AvailEnv, + AvailInfo, Avails, GenAvailInfo(..), NameSupply(..), + ModIface(..), GhciMode(..), + Deprecations(..), lookupDeprec, + extendLocalRdrEnv ) -import HsTypes ( getTyVarName, replaceTyVarName ) - import RnMonad -import Name ( Name, Provenance(..), ExportFlag(..), NamedThing(..), - ImportReason(..), getSrcLoc, - mkLocalName, mkImportedLocalName, mkGlobalName, mkUnboundName, - mkIPName, isSystemName, isWiredInName, - nameOccName, setNameModule, nameModule, - pprOccName, isLocallyDefined, nameUnique, nameOccName, - occNameUserString, - setNameProvenance, getNameProvenance, pprNameProvenance +import Name ( Name, + getSrcLoc, nameIsLocalOrFrom, + mkLocalName, mkGlobalName, + mkIPName, nameOccName, nameModule_maybe, + setNameModuleAndLoc ) +import NameEnv import NameSet -import OccName ( OccName, - mkDFunOcc, occNameUserString, occNameString, - occNameFlavour +import OccName ( OccName, occNameUserString, occNameFlavour ) +import Module ( ModuleName, moduleName, mkVanillaModule, + mkSysModuleNameFS, moduleNameFS, WhereFrom(..) ) +import PrelNames ( mkUnboundName, + derivingOccurrences, + mAIN_Name, main_RDR_Unqual, + runMainName, intTyConName, + boolTyConName, funTyConName, + unpackCStringName, unpackCStringFoldrName, unpackCStringUtf8Name, + eqStringName, printName, + bindIOName, returnIOName, failIOName ) -import TysWiredIn ( tupleTyCon, unboxedTupleTyCon, listTyCon ) -import Type ( funTyCon ) -import Module ( ModuleName, mkThisModule, moduleName, mkVanillaModule, pprModuleName ) -import TyCon ( TyCon ) +import TysWiredIn ( unitTyCon ) -- A little odd import FiniteMap -import Unique ( Unique, Uniquable(..) ) import UniqSupply import SrcLoc ( SrcLoc, noSrcLoc ) import Outputable -import Util ( removeDups, equivClasses, thenCmp ) +import ListSetOps ( removeDups, equivClasses ) +import Util ( sortLt ) +import BasicTypes ( mapIPName ) import List ( nub ) +import UniqFM ( lookupWithDefaultUFM ) +import Maybe ( mapMaybe ) +import CmdLineOpts +import FastString ( FastString ) \end{code} - - %********************************************************* %* * \subsection{Making new names} @@ -55,72 +69,72 @@ import List ( nub ) %********************************************************* \begin{code} -newLocalTopBinder :: Module -> OccName - -> (Name -> ExportFlag) -> SrcLoc - -> RnM d Name -newLocalTopBinder mod occ rec_exp_fn loc - = newTopBinder mod occ (\name -> setNameProvenance 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. - -- - -- Since newLocalTopBinder is used only - -- at binding occurrences, we may as well get the provenance - -- dead right first time; hence the rec_exp_fn passed in - -newImportedBinder :: Module -> RdrName -> RnM d Name -newImportedBinder mod rdr_name - = ASSERT2( isUnqual rdr_name, ppr rdr_name ) - newTopBinder mod (rdrNameOcc rdr_name) (\name -> name) - -- Provenance is already implicitImportProvenance +newTopBinder :: Module -> RdrName -> SrcLoc -> RnM d Name + -- newTopBinder puts into the cache the binder with the + -- module information set correctly. When the decl is later renamed, + -- the binding site will thereby get the correct module. + -- There maybe occurrences that don't have the correct Module, but + -- by the typechecker will propagate the binding definition to all + -- the occurrences, so that doesn't matter + +newTopBinder mod rdr_name loc + = -- First check the cache -implicitImportProvenance = NonLocalDef ImplicitImport False + -- There should never be a qualified name in a binding position (except in instance decls) + -- The parser doesn't check this because the same parser parses instance decls + (if isQual rdr_name then + qualNameErr (text "In its declaration") (rdr_name,loc) + else + returnRn () + ) `thenRn_` -newTopBinder :: Module -> OccName -> (Name -> Name) -> RnM d Name -newTopBinder mod occ set_prov - = -- First check the cache - getNameSupplyRn `thenRn` \ (us, inst_ns, cache, ipcache) -> + getNameSupplyRn `thenRn` \ name_supply -> let - key = (moduleName mod, occ) + occ = rdrNameOcc rdr_name + key = (moduleName mod, occ) + cache = nsNames name_supply in case lookupFM cache key of - -- A hit in the cache! - -- Set the Module of the thing, and set its provenance (hack pending - -- spj update) - -- - -- It also means that if there are two defns for the same thing - -- in a module, then each gets a separate SrcLoc - -- - -- There's a complication for wired-in names. We don't want to - -- forget that they are wired in even when compiling that module - -- (else we spit out redundant defns into the interface file) - -- So for them we just set the provenance + -- A hit in the cache! We are at the binding site of the name, and + -- this is the moment when we know all about + -- a) the Name's host Module (in particular, which + -- package it comes from) + -- b) its defining SrcLoc + -- So we update this info Just name -> let - new_name = set_prov (setNameModule name mod) + new_name = setNameModuleAndLoc name mod loc new_cache = addToFM cache key new_name in - setNameSupplyRn (us, inst_ns, new_cache, ipcache) `thenRn_` + setNameSupplyRn (name_supply {nsNames = new_cache}) `thenRn_` +-- traceRn (text "newTopBinder: overwrite" <+> ppr new_name) `thenRn_` returnRn new_name -- Miss in the cache! -- Build a completely new Name, and put it in the cache + -- Even for locally-defined names we use implicitImportProvenance; + -- updateProvenances will set it to rights Nothing -> let - (us', us1) = splitUniqSupply us + (us', us1) = splitUniqSupply (nsUniqs name_supply) uniq = uniqFromSupply us1 - new_name = set_prov (mkGlobalName uniq mod occ implicitImportProvenance) + new_name = mkGlobalName uniq mod occ loc new_cache = addToFM cache key new_name in - setNameSupplyRn (us', inst_ns, new_cache, ipcache) `thenRn_` + setNameSupplyRn (name_supply {nsUniqs = us', nsNames = new_cache}) `thenRn_` +-- traceRn (text "newTopBinder: new" <+> ppr new_name) `thenRn_` returnRn new_name -mkImportedGlobalName :: ModuleName -> OccName -> RnM d Name +newGlobalName :: ModuleName -> OccName -> RnM d Name -- Used for *occurrences*. We make a place-holder Name, really just -- to agree on its unique, which gets overwritten when we read in - -- the binding occurence later (newImportedBinder) - -- The place-holder Name doesn't have the right Provenance, and its - -- Module won't have the right Package either + -- the binding occurence later (newTopBinder) + -- The place-holder Name doesn't have the right SrcLoc, and its + -- Module won't have the right Package either. + -- + -- (We have to pass a ModuleName, not a Module, because we may be + -- simply looking at an occurrence M.x in an interface file.) -- -- This means that a renamed program may have incorrect info -- on implicitly-imported occurrences, but the correct info on the @@ -130,118 +144,373 @@ mkImportedGlobalName :: ModuleName -> OccName -> RnM d Name -- it doesn't matter that we get the correct info in place till later, -- (but since it affects DLL-ery it does matter that we get it right -- in the end). -mkImportedGlobalName mod_name occ - = getNameSupplyRn `thenRn` \ (us, inst_ns, cache, ipcache) -> +newGlobalName mod_name occ + = getNameSupplyRn `thenRn` \ name_supply -> let key = (mod_name, occ) + cache = nsNames name_supply in case lookupFM cache key of - Just name -> returnRn name - Nothing -> setNameSupplyRn (us', inst_ns, new_cache, ipcache) `thenRn_` + Just name -> -- traceRn (text "newGlobalName: hit" <+> ppr name) `thenRn_` + returnRn name + + Nothing -> setNameSupplyRn (name_supply {nsUniqs = us', nsNames = new_cache}) `thenRn_` + -- traceRn (text "newGlobalName: new" <+> ppr name) `thenRn_` returnRn name where - (us', us1) = splitUniqSupply us + (us', us1) = splitUniqSupply (nsUniqs name_supply) uniq = uniqFromSupply us1 mod = mkVanillaModule mod_name - name = mkGlobalName uniq mod occ implicitImportProvenance + name = mkGlobalName uniq mod occ noSrcLoc new_cache = addToFM cache key name -updateProvenances :: [Name] -> RnM d () --- Update the provenances of everything that is in scope. --- We must be careful not to disturb the Module package info --- already in the cache. Why not? Consider --- module A module M( f ) --- import M( f ) import N( f) --- import N --- So f is defined in N, and M re-exports it. --- When processing module A: --- 1. We read M.hi first, and make a vanilla name N.f --- (without reading N.hi). The package info says --- for lack of anything better. --- 2. Now we read N, which update the cache to record --- the correct package for N.f. --- 3. Finally we update provenances (once we've read all imports). --- Step 3 must not destroy package info recorded in Step 2. - -updateProvenances names - = getNameSupplyRn `thenRn` \ (us, inst_ns, cache, ipcache) -> - setNameSupplyRn (us, inst_ns, foldr update cache names, ipcache) +newIPName rdr_name_ip + = getNameSupplyRn `thenRn` \ name_supply -> + let + ipcache = nsIPs name_supply + in + case lookupFM ipcache key of + Just name_ip -> returnRn name_ip + Nothing -> setNameSupplyRn new_ns `thenRn_` + returnRn name_ip + where + (us', us1) = splitUniqSupply (nsUniqs name_supply) + uniq = uniqFromSupply us1 + name_ip = mapIPName mk_name rdr_name_ip + mk_name rdr_name = mkIPName uniq (rdrNameOcc rdr_name) + new_ipcache = addToFM ipcache key name_ip + new_ns = name_supply {nsUniqs = us', nsIPs = new_ipcache} + where + key = rdr_name_ip -- Ensures that ?x and %x get distinct Names +\end{code} + +%********************************************************* +%* * +\subsection{Looking up names} +%* * +%********************************************************* + +Looking up a name in the RnEnv. + +\begin{code} +lookupBndrRn rdr_name + = getLocalNameEnv `thenRn` \ local_env -> + case lookupRdrEnv local_env rdr_name of + Just name -> returnRn name + Nothing -> lookupTopBndrRn rdr_name + +lookupTopBndrRn rdr_name +-- Look up a top-level local binder. We may be looking up an unqualified 'f', +-- and there may be several imported 'f's too, which must not confuse us. +-- So we have to filter out the non-local ones. +-- A separate function (importsFromLocalDecls) reports duplicate top level +-- decls, so here it's safe just to choose an arbitrary one. + + | isOrig rdr_name + -- This is here just to catch the PrelBase defn of (say) [] and similar + -- The parser reads the special syntax and returns an Orig RdrName + -- But the global_env contains only Qual RdrNames, so we won't + -- find it there; instead just get the name via the Orig route + = lookupOrigName rdr_name + + | otherwise + = getModeRn `thenRn` \ mode -> + if isInterfaceMode mode + then lookupIfaceName rdr_name + else + getModuleRn `thenRn` \ mod -> + getGlobalNameEnv `thenRn` \ global_env -> + case lookup_local mod global_env rdr_name of + Just name -> returnRn name + Nothing -> failWithRn (mkUnboundName rdr_name) + (unknownNameErr rdr_name) + where + lookup_local mod global_env rdr_name + = case lookupRdrEnv global_env rdr_name of + Nothing -> Nothing + Just gres -> case [n | GRE n _ _ <- gres, nameIsLocalOrFrom mod n] of + [] -> Nothing + (n:ns) -> Just n + + +-- lookupSigOccRn is used for type signatures and pragmas +-- Is this valid? +-- module A +-- import M( f ) +-- f :: Int -> Int +-- f x = x +-- It's clear that the 'f' in the signature must refer to A.f +-- The Haskell98 report does not stipulate this, but it will! +-- So we must treat the 'f' in the signature in the same way +-- as the binding occurrence of 'f', using lookupBndrRn +lookupSigOccRn :: RdrName -> RnMS Name +lookupSigOccRn = lookupBndrRn + +-- lookupInstDeclBndr is used for the binders in an +-- instance declaration. Here we use the class name to +-- disambiguate. + +lookupInstDeclBndr :: Name -> RdrName -> RnMS Name + -- We use the selector name as the binder +lookupInstDeclBndr cls_name rdr_name + | isOrig rdr_name -- Occurs in derived instances, where we just + -- refer diectly to the right method + = lookupOrigName rdr_name + + | otherwise + = getGlobalAvails `thenRn` \ avail_env -> + case lookupNameEnv avail_env cls_name of + -- The class itself isn't in scope, so cls_name is unboundName + -- e.g. import Prelude hiding( Ord ) + -- instance Ord T where ... + -- The program is wrong, but that should not cause a crash. + Nothing -> returnRn (mkUnboundName rdr_name) + Just (AvailTC _ ns) -> case [n | n <- ns, nameOccName n == occ] of + (n:ns)-> ASSERT( null ns ) returnRn n + [] -> failWithRn (mkUnboundName rdr_name) + (unknownNameErr rdr_name) + other -> pprPanic "lookupInstDeclBndr" (ppr cls_name) where - update name cache = addToFM_C update_prov cache key name - where - key = (moduleName (nameModule name), nameOccName name) + occ = rdrNameOcc rdr_name - update_prov name_in_cache name_with_prov - = setNameProvenance name_in_cache (getNameProvenance name_with_prov) - +-- lookupOccRn looks up an occurrence of a RdrName +lookupOccRn :: RdrName -> RnMS Name +lookupOccRn rdr_name + = getLocalNameEnv `thenRn` \ local_env -> + case lookupRdrEnv local_env rdr_name of + Just name -> returnRn name + Nothing -> lookupGlobalOccRn 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 rdr_name + = getModeRn `thenRn` \ mode -> + if (isInterfaceMode mode) + then lookupIfaceName rdr_name + else -mkImportedGlobalFromRdrName :: RdrName -> RnM d Name -mkImportedGlobalFromRdrName rdr_name - | isQual rdr_name - = mkImportedGlobalName (rdrNameModule rdr_name) (rdrNameOcc rdr_name) + getGlobalNameEnv `thenRn` \ global_env -> + case mode of + SourceMode -> lookupSrcName global_env rdr_name + + CmdLineMode + | not (isQual rdr_name) -> + lookupSrcName global_env rdr_name + + -- We allow qualified names on the command line to refer to + -- *any* name exported by any module in scope, just as if + -- there was an "import qualified M" declaration for every + -- module. + -- + -- First look up the name in the normal environment. If + -- it isn't there, we manufacture a new occurrence of an + -- original name. + | otherwise -> + case lookupRdrEnv global_env rdr_name of + Just _ -> lookupSrcName global_env rdr_name + Nothing -> lookupQualifiedName rdr_name + +-- a qualified name on the command line can refer to any module at all: we +-- try to load the interface if we don't already have it. +lookupQualifiedName :: RdrName -> RnM d Name +lookupQualifiedName rdr_name + = let + mod = rdrNameModule rdr_name + occ = rdrNameOcc rdr_name + in + loadInterface (ppr rdr_name) mod ImportByUser `thenRn` \ iface -> + case [ name | (_,avails) <- mi_exports iface, + avail <- avails, + name <- availNames avail, + nameOccName name == occ ] of + (n:ns) -> ASSERT (null ns) returnRn n + _ -> failWithRn (mkUnboundName rdr_name) (unknownNameErr rdr_name) + +lookupSrcName :: GlobalRdrEnv -> RdrName -> RnM d Name +-- NB: passed GlobalEnv explicitly, not necessarily in RnMS monad +lookupSrcName global_env rdr_name + | isOrig rdr_name -- Can occur in source code too + = lookupOrigName rdr_name | otherwise - = -- An Unqual is allowed; interface files contain + = case lookupRdrEnv global_env rdr_name of + Just [GRE name _ Nothing] -> returnRn name + Just [GRE name _ (Just deprec)] -> warnDeprec name deprec `thenRn_` + returnRn name + Just stuff@(GRE name _ _ : _) -> addNameClashErrRn rdr_name stuff `thenRn_` + returnRn name + Nothing -> failWithRn (mkUnboundName rdr_name) + (unknownNameErr rdr_name) + +lookupOrigName :: RdrName -> RnM d Name +lookupOrigName rdr_name + = ASSERT( isOrig rdr_name ) + newGlobalName (rdrNameModule rdr_name) (rdrNameOcc rdr_name) + +lookupIfaceUnqual :: RdrName -> RnM d Name +lookupIfaceUnqual rdr_name + = ASSERT( isUnqual rdr_name ) + -- An Unqual is allowed; interface files contain -- unqualified names for locally-defined things, such as -- constructors of a data type. - getModuleRn `thenRn ` \ mod_name -> - mkImportedGlobalName mod_name (rdrNameOcc rdr_name) + getModuleRn `thenRn ` \ mod -> + newGlobalName (moduleName mod) (rdrNameOcc rdr_name) +lookupIfaceName :: RdrName -> RnM d Name +lookupIfaceName rdr_name + | isUnqual rdr_name = lookupIfaceUnqual rdr_name + | otherwise = lookupOrigName rdr_name +\end{code} -getIPName rdr_name - = getNameSupplyRn `thenRn` \ (us, inst_ns, cache, ipcache) -> - case lookupFM ipcache key of - Just name -> returnRn name - Nothing -> setNameSupplyRn (us', inst_ns, cache, new_ipcache) `thenRn_` - returnRn name - where - (us', us1) = splitUniqSupply us - uniq = uniqFromSupply us1 - name = mkIPName uniq key - new_ipcache = addToFM ipcache key name - where key = (rdrNameOcc rdr_name) +@lookupOrigName@ 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 @lookupOrigNames@ 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.}} + +\begin{code} +lookupOrigNames :: [RdrName] -> RnM d NameSet +lookupOrigNames rdr_names + = mapRn lookupOrigName rdr_names `thenRn` \ names -> + returnRn (mkNameSet names) +\end{code} + +lookupSysBinder is used for the "system binders" of a type, class, or +instance decl. It ensures that the module is set correctly in the +name cache, and sets the provenance on the returned name too. The +returned name will end up actually in the type, class, or instance. + +\begin{code} +lookupSysBinder rdr_name + = ASSERT( isUnqual rdr_name ) + getModuleRn `thenRn` \ mod -> + getSrcLocRn `thenRn` \ loc -> + newTopBinder mod rdr_name loc \end{code} + %********************************************************* %* * -\subsection{Dfuns and default methods} +\subsection{Implicit free vars and sugar names} %* * %********************************************************* -@newImplicitBinder@ is used for (a) dfuns -(b) default methods, defined in this module. +@getXImplicitFVs@ forces the renamer to slurp in some things which aren't +mentioned explicitly, but which might be needed by the type checker. \begin{code} -newImplicitBinder occ src_loc - = getModuleRn `thenRn` \ mod_name -> - newLocalTopBinder (mkThisModule mod_name) occ (\_ -> Exported) src_loc -\end{code} +getImplicitStmtFVs -- Compiling a statement + = returnRn (mkFVs [printName, bindIOName, returnIOName, failIOName] + `plusFV` ubiquitousNames) + -- These are all needed implicitly when compiling a statement + -- See TcModule.tc_stmts + +getImplicitModuleFVs decls -- Compiling a module + = lookupOrigNames deriv_occs `thenRn` \ deriving_names -> + returnRn (deriving_names `plusFV` ubiquitousNames) + where + -- deriv_classes is now a list of HsTypes, so a "normal" one + -- appears as a (HsClassP c []). The non-normal ones for the new + -- newtype-deriving extension, and they don't require any + -- implicit names, so we can silently filter them out. + deriv_occs = [occ | TyClD (TyData {tcdDerivs = Just deriv_classes}) <- decls, + HsClassP cls [] <- deriv_classes, + occ <- lookupWithDefaultUFM derivingOccurrences [] cls ] + +-- ubiquitous_names are loaded regardless, because +-- they are needed in virtually every program +ubiquitousNames + = mkFVs [unpackCStringName, unpackCStringFoldrName, + unpackCStringUtf8Name, eqStringName] + -- Virtually every program has error messages in it somewhere + + `plusFV` + mkFVs [getName unitTyCon, funTyConName, boolTyConName, intTyConName] + -- Add occurrences for very frequently used types. + -- (e.g. we don't want to be bothered with making funTyCon a + -- free var at every function application!) + `plusFV` + namesNeededForFlattening + -- this will be empty unless flattening is activated + +checkMain ghci_mode mod_name gbl_env + -- LOOKUP main IF WE'RE IN MODULE Main + -- The main point of this is to drag in the declaration for 'main', + -- its in another module, and for the Prelude function 'runMain', + -- so that the type checker will find them + -- + -- We have to return the main_name separately, because it's a + -- bona fide 'use', and should be recorded as such, but the others + -- aren't + | mod_name /= mAIN_Name + = returnRn (Nothing, emptyFVs, emptyFVs) -Make a name for the dict fun for an instance decl + | not (main_RDR_Unqual `elemRdrEnv` gbl_env) + = complain_no_main `thenRn_` + returnRn (Nothing, emptyFVs, emptyFVs) + + | otherwise + = lookupSrcName gbl_env main_RDR_Unqual `thenRn` \ main_name -> + returnRn (Just main_name, unitFV main_name, unitFV runMainName) -\begin{code} -newDFunName :: (OccName, OccName) -> SrcLoc -> RnMS Name -newDFunName key@(cl_occ, tycon_occ) loc - = newInstUniq string `thenRn` \ inst_uniq -> - newImplicitBinder (mkDFunOcc string inst_uniq) loc where - -- Any string that is somewhat unique will do - string = occNameString cl_occ ++ occNameString tycon_occ + complain_no_main | ghci_mode == Interactive = addWarnRn noMainMsg + | otherwise = addErrRn noMainMsg + -- In interactive mode, only warn about the absence of main \end{code} +%************************************************************************ +%* * +\subsection{Re-bindable desugaring names} +%* * +%************************************************************************ + +Haskell 98 says that when you say "3" you get the "fromInteger" from the +Standard Prelude, regardless of what is in scope. However, to experiment +with having a language that is less coupled to the standard prelude, we're +trying a non-standard extension that instead gives you whatever "Prelude.fromInteger" +happens to be in scope. Then you can + import Prelude () + import MyPrelude as Prelude +to get the desired effect. + +At the moment this just happens for + * fromInteger, fromRational on literals (in expressions and patterns) + * negate (in expressions) + * minus (arising from n+k patterns) + +We store the relevant Name in the HsSyn tree, in + * HsIntegral/HsFractional + * NegApp + * NPlusKPatIn +respectively. Initially, we just store the "standard" name (PrelNames.fromIntegralName, +fromRationalName etc), but the renamer changes this to the appropriate user +name if Opt_NoImplicitPrelude is on. That is what lookupSyntaxName does. + \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 +lookupSyntaxName :: Name -- The standard name + -> RnMS Name -- Possibly a non-standard name +lookupSyntaxName std_name + = doptRn Opt_NoImplicitPrelude `thenRn` \ no_prelude -> + if not no_prelude then + returnRn std_name -- Normal case + else + let + rdr_name = mkRdrUnqual (nameOccName std_name) + -- Get the similarly named thing from the local environment + in + lookupOccRn rdr_name \end{code} @@ -252,79 +521,92 @@ get_tycon_key (MonoFunTy _ _) = getOccName funTyCon %********************************************************* \begin{code} -------------------------------------- +newLocalsRn :: [(RdrName,SrcLoc)] + -> RnMS [Name] +newLocalsRn rdr_names_w_loc + = getNameSupplyRn `thenRn` \ name_supply -> + let + (us', us1) = splitUniqSupply (nsUniqs name_supply) + uniqs = uniqsFromSupply us1 + names = [ mkLocalName uniq (rdrNameOcc rdr_name) loc + | ((rdr_name,loc), uniq) <- rdr_names_w_loc `zip` uniqs + ] + in + setNameSupplyRn (name_supply {nsUniqs = us'}) `thenRn_` + returnRn names + + bindLocatedLocalsRn :: SDoc -- Documentation string for error message -> [(RdrName,SrcLoc)] -> ([Name] -> RnMS a) -> RnMS a bindLocatedLocalsRn doc_str rdr_names_w_loc enclosed_scope - = checkDupOrQualNames doc_str rdr_names_w_loc `thenRn_` + = getModeRn `thenRn` \ mode -> + getLocalNameEnv `thenRn` \ local_env -> + getGlobalNameEnv `thenRn` \ global_env -> - getLocalNameEnv `thenRn` \ name_env -> - (if opt_WarnNameShadowing - then - mapRn_ (check_shadow name_env) rdr_names_w_loc - else - returnRn () - ) `thenRn_` - - getNameSupplyRn `thenRn` \ (us, inst_ns, cache, ipcache) -> - getModeRn `thenRn` \ mode -> + -- Check for duplicate names + checkDupOrQualNames doc_str rdr_names_w_loc `thenRn_` + + -- Warn about shadowing, but only in source modules 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. + check_shadow (rdr_name,loc) + | rdr_name `elemRdrEnv` local_env + || rdr_name `elemRdrEnv` global_env + = pushSrcLocRn loc $ addWarnRn (shadowedNameWarn rdr_name) + | otherwise + = returnRn () in - setNameSupplyRn (us', inst_ns, cache, ipcache) `thenRn_` + (case mode of + SourceMode -> ifOptRn Opt_WarnNameShadowing $ + mapRn_ check_shadow rdr_names_w_loc + other -> returnRn () + ) `thenRn_` + + newLocalsRn rdr_names_w_loc `thenRn` \ names -> let - new_name_env = addListToRdrEnv name_env (map fst rdr_names_w_loc `zip` names) + new_local_env = addListToRdrEnv local_env (map fst rdr_names_w_loc `zip` names) in - setLocalNameEnv new_name_env (enclosed_scope names) + setLocalNameEnv new_local_env (enclosed_scope names) - where - check_shadow name_env (rdr_name,loc) - = case lookupRdrEnv name_env rdr_name of - Nothing -> returnRn () - Just name -> pushSrcLocRn loc $ - addWarnRn (shadowedNameWarn rdr_name) - -bindCoreLocalFVRn :: RdrName -> (Name -> RnMS (a, FreeVars)) - -> RnMS (a, FreeVars) +bindCoreLocalRn :: RdrName -> (Name -> RnMS a) -> RnMS a -- 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 +bindCoreLocalRn rdr_name enclosed_scope = getSrcLocRn `thenRn` \ loc -> getLocalNameEnv `thenRn` \ name_env -> - getNameSupplyRn `thenRn` \ (us, inst_ns, cache, ipcache) -> + getNameSupplyRn `thenRn` \ name_supply -> let - (us', us1) = splitUniqSupply us + (us', us1) = splitUniqSupply (nsUniqs name_supply) uniq = uniqFromSupply us1 - name = mkImportedLocalName uniq (rdrNameOcc rdr_name) loc + name = mkLocalName uniq (rdrNameOcc rdr_name) loc in - setNameSupplyRn (us', inst_ns, cache, ipcache) `thenRn_` + setNameSupplyRn (name_supply {nsUniqs = us'}) `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) + setLocalNameEnv new_name_env (enclosed_scope name) + +bindCoreLocalsRn [] thing_inside = thing_inside [] +bindCoreLocalsRn (b:bs) thing_inside = bindCoreLocalRn b $ \ name' -> + bindCoreLocalsRn bs $ \ names' -> + thing_inside (name':names') + +bindLocalNames names enclosed_scope + = getLocalNameEnv `thenRn` \ name_env -> + setLocalNameEnv (extendLocalRdrEnv name_env names) + enclosed_scope + +bindLocalNamesFV names enclosed_scope + = bindLocalNames names $ + enclosed_scope `thenRn` \ (thing, fvs) -> + returnRn (thing, delListFromNameSet fvs names) -bindCoreLocalsFVRn [] thing_inside = thing_inside [] -bindCoreLocalsFVRn (b:bs) thing_inside = bindCoreLocalFVRn b $ \ name' -> - bindCoreLocalsFVRn bs $ \ names' -> - thing_inside (name':names') ------------------------------------- bindLocalRn doc rdr_name enclosed_scope @@ -347,56 +629,46 @@ bindLocalsFVRn doc rdr_names enclosed_scope returnRn (thing, delListFromNameSet fvs names) ------------------------------------- -bindUVarRn :: SDoc -> RdrName -> (Name -> RnMS (a, FreeVars)) -> RnMS (a, FreeVars) -bindUVarRn = bindLocalRn - -------------------------------------- -extendTyVarEnvFVRn :: [HsTyVar Name] -> RnMS (a, FreeVars) -> RnMS (a, FreeVars) - -- This tiresome function is used only in rnDecl on InstDecl +extendTyVarEnvFVRn :: [Name] -> RnMS (a, FreeVars) -> RnMS (a, FreeVars) + -- This tiresome function is used only in rnSourceDecl on InstDecl extendTyVarEnvFVRn tyvars enclosed_scope - = getLocalNameEnv `thenRn` \ env -> - let - tyvar_names = map getTyVarName tyvars - new_env = addListToRdrEnv env [ (mkRdrUnqual (getOccName name), name) - | name <- tyvar_names - ] - in - setLocalNameEnv new_env enclosed_scope `thenRn` \ (thing, fvs) -> - returnRn (thing, delListFromNameSet fvs tyvar_names) + = bindLocalNames tyvars enclosed_scope `thenRn` \ (thing, fvs) -> + returnRn (thing, delListFromNameSet fvs tyvars) -bindTyVarsRn :: SDoc -> [HsTyVar RdrName] - -> ([HsTyVar Name] -> RnMS a) +bindTyVarsRn :: SDoc -> [HsTyVarBndr RdrName] + -> ([HsTyVarBndr 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 a) - -> RnMS a -bindTyVars2Rn doc_str tyvar_names enclosed_scope = getSrcLocRn `thenRn` \ loc -> let - located_tyvars = [(getTyVarName tv, loc) | tv <- tyvar_names] + located_tyvars = [(hsTyVarName tv, loc) | tv <- tyvar_names] in bindLocatedLocalsRn doc_str located_tyvars $ \ names -> - enclosed_scope names (zipWith replaceTyVarName tyvar_names names) - -bindTyVarsFVRn :: SDoc -> [HsTyVar RdrName] - -> ([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) + enclosed_scope (zipWith replaceTyVarName tyvar_names names) + +bindPatSigTyVars :: [RdrNameHsType] + -> RnMS (a, FreeVars) + -> RnMS (a, FreeVars) + -- Find the type variables in the pattern type + -- signatures that must be brought into scope -bindTyVarsFV2Rn :: SDoc -> [HsTyVar RdrName] - -> ([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) -> +bindPatSigTyVars tys enclosed_scope + = getLocalNameEnv `thenRn` \ name_env -> + getSrcLocRn `thenRn` \ loc -> + let + forall_tyvars = nub [ tv | ty <- tys, + tv <- extractHsTyRdrTyVars ty, + not (tv `elemFM` name_env) + ] + -- The 'nub' is important. For example: + -- f (x :: t) (y :: t) = .... + -- We don't want to complain about binding t twice! + + located_tyvars = [(tv, loc) | tv <- forall_tyvars] + doc_sig = text "In a pattern type-signature" + in + bindLocatedLocalsRn doc_sig located_tyvars $ \ names -> + enclosed_scope `thenRn` \ (thing, fvs) -> returnRn (thing, delListFromNameSet fvs names) @@ -411,7 +683,7 @@ checkDupOrQualNames doc_str rdr_names_w_loc mapRn_ (qualNameErr doc_str) quals `thenRn_` checkDupNames doc_str rdr_names_w_loc where - quals = filter (isQual.fst) rdr_names_w_loc + quals = filter (isQual . fst) rdr_names_w_loc checkDupNames doc_str rdr_names_w_loc = -- Check for duplicated names in a binding group @@ -421,170 +693,91 @@ checkDupNames doc_str rdr_names_w_loc \end{code} -%********************************************************* -%* * -\subsection{Looking up names} -%* * -%********************************************************* - -Looking up a name in the RnEnv. - -\begin{code} -lookupBndrRn rdr_name - = getNameEnvs `thenRn` \ (global_env, local_env) -> - - -- Try local env - case lookupRdrEnv local_env rdr_name of { - Just name -> returnRn name ; - Nothing -> - - getModeRn `thenRn` \ mode -> - case mode of - 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 Name -lookupOccRn rdr_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 Name -lookupGlobalOccRn rdr_name - = 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} -lookupImplicitOccRn :: RdrName -> RnM d Name -lookupImplicitOccRn rdr_name = mkImportedGlobalFromRdrName rdr_name -\end{code} - -@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 -in error messages. - -\begin{code} -unQualInScope :: GlobalRdrEnv -> Name -> Bool -unQualInScope env - = lookup - where - lookup name = case lookupRdrEnv env (mkRdrUnqual (nameOccName name)) of - Just [name'] -> name == name' - other -> False -\end{code} - %************************************************************************ %* * -\subsection{Envt utility functions} +\subsection{GlobalRdrEnv} %* * %************************************************************************ -\subsubsection{NameEnv}% ================ +\begin{code} +mkGlobalRdrEnv :: ModuleName -- Imported module (after doing the "as M" name change) + -> Bool -- True <=> want unqualified import + -> (Name -> Provenance) + -> Avails -- Whats imported + -> Deprecations + -> GlobalRdrEnv + +mkGlobalRdrEnv this_mod unqual_imp mk_provenance avails deprecs + = gbl_env2 + where + -- 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. + + -- Add qualified names for the things that are available + -- (Qualified names are always imported) + gbl_env1 = foldl add_avail emptyRdrEnv avails + + -- Add unqualified names + gbl_env2 | unqual_imp = foldl add_unqual gbl_env1 (rdrEnvToList gbl_env1) + | otherwise = gbl_env1 + + add_unqual env (qual_name, elts) + = foldl add_one env elts + where + add_one env elt = addOneToGlobalRdrEnv env unqual_name elt + unqual_name = unqualifyRdrName qual_name + -- The qualified import should only have added one + -- binding for each qualified name! But if there's an error in + -- the module (multiple bindings for the same name) we may get + -- duplicates. So the simple thing is to do the fold. + + add_avail :: GlobalRdrEnv -> AvailInfo -> GlobalRdrEnv + add_avail env avail = foldl add_name env (availNames avail) + + add_name env name -- Add qualified name only + = addOneToGlobalRdrEnv env (mkRdrQual this_mod occ) elt + where + occ = nameOccName name + elt = GRE name (mk_provenance name) (lookupDeprec deprecs name) +\end{code} \begin{code} plusGlobalRdrEnv :: GlobalRdrEnv -> GlobalRdrEnv -> GlobalRdrEnv plusGlobalRdrEnv env1 env2 = plusFM_C combine_globals env1 env2 -addOneToGlobalRdrEnv :: GlobalRdrEnv -> RdrName -> Name -> GlobalRdrEnv +addOneToGlobalRdrEnv :: GlobalRdrEnv -> RdrName -> GlobalRdrElt -> GlobalRdrEnv addOneToGlobalRdrEnv env rdr_name name = addToFM_C combine_globals env rdr_name [name] delOneFromGlobalRdrEnv :: GlobalRdrEnv -> RdrName -> GlobalRdrEnv delOneFromGlobalRdrEnv env rdr_name = delFromFM env rdr_name -combine_globals :: [Name] -- Old - -> [Name] -- New - -> [Name] +combine_globals :: [GlobalRdrElt] -- Old + -> [GlobalRdrElt] -- New + -> [GlobalRdrElt] combine_globals ns_old ns_new -- ns_new is often short = foldr add ns_old ns_new where - add n ns | any (is_duplicate n) ns_old = map choose ns -- Eliminate duplicates + add n ns | any (is_duplicate n) ns_old = map (choose n) ns -- Eliminate duplicates | otherwise = n:ns - where - choose n' | n==n' && better_provenance n n' = n - | otherwise = n' - --- Choose --- a local thing over an imported thing --- a user-imported thing over a non-user-imported thing --- 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 - -is_duplicate :: Name -> Name -> Bool -is_duplicate n1 n2 | isLocallyDefined n1 && isLocallyDefined n2 = False - | otherwise = n1 == n2 + + choose n m | n `beats` m = n + | otherwise = m + + (GRE n pn _) `beats` (GRE m pm _) = n==m && pn `hasBetterProv` pm + + is_duplicate :: GlobalRdrElt -> GlobalRdrElt -> Bool + is_duplicate (GRE n1 LocalDef _) (GRE n2 LocalDef _) = False + is_duplicate (GRE n1 _ _) (GRE n2 _ _) = 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 +import statements, we {\em do} want to eliminate the duplicate, not report an error. If a module imports itself then there might be a local defn and an imported @@ -592,21 +785,46 @@ defn of the same name; in this case the names will compare as equal, but will still have different provenances. +@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 +in error messages. + +\begin{code} +unQualInScope :: GlobalRdrEnv -> Name -> Bool +-- True if 'f' is in scope, and has only one binding, +-- and the thing it is bound to is the name we are looking for +-- (i.e. false if A.f and B.f are both in scope as unqualified 'f') +-- +-- This fn is only efficient if the shared +-- partial application is used a lot. +unQualInScope env + = (`elemNameSet` unqual_names) + where + unqual_names :: NameSet + unqual_names = foldRdrEnv add emptyNameSet env + add rdr_name [GRE name _ _] unquals | isUnqual rdr_name = addOneToNameSet unquals name + add _ _ unquals = unquals +\end{code} -\subsubsection{AvailInfo}% ================ + +%************************************************************************ +%* * +\subsection{Avails} +%* * +%************************************************************************ \begin{code} plusAvail (Avail n1) (Avail n2) = Avail n1 plusAvail (AvailTC n1 ns1) (AvailTC n2 ns2) = AvailTC n2 (nub (ns1 ++ ns2)) -- Added SOF 4/97 #ifdef DEBUG -plusAvail a1 a2 = pprPanic "RnEnv.plusAvail" (hsep [pprAvail a1,pprAvail a2]) +plusAvail a1 a2 = pprPanic "RnEnv.plusAvail" (hsep [ppr a1,ppr a2]) #endif addAvail :: AvailEnv -> AvailInfo -> AvailEnv -addAvail avails avail = addToNameEnv_C plusAvail avails (availName avail) avail +addAvail avails avail = extendNameEnv_C plusAvail avails (availName avail) avail -emptyAvailEnv = emptyNameEnv unitAvailEnv :: AvailInfo -> AvailEnv unitAvailEnv a = unitNameEnv (availName a) a @@ -621,18 +839,15 @@ addAvailToNameSet names avail = addListToNameSet names (availNames avail) availsToNameSet :: [AvailInfo] -> NameSet availsToNameSet avails = foldl addAvailToNameSet emptyNameSet avails -availName :: AvailInfo -> Name +availName :: GenAvailInfo name -> name availName (Avail n) = n availName (AvailTC n _) = n -availNames :: AvailInfo -> [Name] +availNames :: GenAvailInfo name -> [name] availNames (Avail n) = [n] availNames (AvailTC n ns) = ns -addSysAvails :: AvailInfo -> [Name] -> AvailInfo -addSysAvails avail [] = avail -addSysAvails (AvailTC n ns) sys = AvailTC n (sys ++ ns) - +------------------------------------- filterAvail :: RdrNameIE -- Wanted -> AvailInfo -- Available -> Maybe AvailInfo -- Resulting available; @@ -668,16 +883,60 @@ filterAvail (IEThingAll _) avail@(AvailTC _ _) = Just avail filterAvail ie avail = Nothing -pprAvail :: AvailInfo -> SDoc -pprAvail (AvailTC n ns) = ppr n <> case filter (/= n) ns of - [] -> empty - ns' -> parens (hsep (punctuate comma (map ppr ns'))) +------------------------------------- +groupAvails :: Module -> Avails -> [(ModuleName, Avails)] + -- Group by module and sort by occurrence + -- This keeps the list in canonical order +groupAvails this_mod avails + = [ (mkSysModuleNameFS fs, sortLt lt avails) + | (fs,avails) <- fmToList groupFM + ] + where + groupFM :: FiniteMap FastString Avails + -- Deliberately use the FastString so we + -- get a canonical ordering + groupFM = foldl add emptyFM avails -pprAvail (Avail n) = ppr n + add env avail = addToFM_C combine env mod_fs [avail'] + where + mod_fs = moduleNameFS (moduleName avail_mod) + avail_mod = case nameModule_maybe (availName avail) of + Just m -> m + Nothing -> this_mod + combine old _ = avail':old + avail' = sortAvail avail + + a1 `lt` a2 = occ1 < occ2 + where + occ1 = nameOccName (availName a1) + occ2 = nameOccName (availName a2) + +sortAvail :: AvailInfo -> AvailInfo +-- Sort the sub-names into canonical order. +-- The canonical order has the "main name" at the beginning +-- (if it's there at all) +sortAvail (Avail n) = Avail n +sortAvail (AvailTC n ns) | n `elem` ns = AvailTC n (n : sortLt lt (filter (/= n) ns)) + | otherwise = AvailTC n ( sortLt lt ns) + where + n1 `lt` n2 = nameOccName n1 < nameOccName n2 \end{code} - - +\begin{code} +pruneAvails :: (Name -> Bool) -- Keep if this is True + -> [AvailInfo] + -> [AvailInfo] +pruneAvails keep avails + = mapMaybe del avails + where + del :: AvailInfo -> Maybe AvailInfo -- Nothing => nothing left! + del (Avail n) | keep n = Just (Avail n) + | otherwise = Nothing + del (AvailTC n ns) | null ns' = Nothing + | otherwise = Just (AvailTC n ns') + where + ns' = filter keep ns +\end{code} %************************************************************************ %* * @@ -686,23 +945,6 @@ pprAvail (Avail n) = ppr n %************************************************************************ \begin{code} -type FreeVars = NameSet - -plusFV :: FreeVars -> FreeVars -> FreeVars -addOneFV :: FreeVars -> Name -> FreeVars -unitFV :: Name -> FreeVars -emptyFVs :: FreeVars -plusFVs :: [FreeVars] -> FreeVars - -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 @@ -718,103 +960,81 @@ mapFvRn f xs = mapRn f xs `thenRn` \ stuff -> %* * %************************************************************************ - - \begin{code} warnUnusedModules :: [ModuleName] -> RnM d () warnUnusedModules mods - | not opt_WarnUnusedImports = returnRn () - | otherwise = mapRn_ (addWarnRn . unused_mod) mods + = ifOptRn Opt_WarnUnusedImports (mapRn_ (addWarnRn . unused_mod) mods) where - unused_mod m = ptext SLIT("Module") <+> quotes (pprModuleName m) <+> - ptext SLIT("is imported, but nothing from it is used") + unused_mod m = vcat [ptext SLIT("Module") <+> quotes (ppr m) <+> + text "is imported, but nothing from it is used", + parens (ptext SLIT("except perhaps to re-export instances visible in") <+> + quotes (ppr m))] -warnUnusedLocalBinds, warnUnusedImports, warnUnusedMatches :: [Name] -> RnM d () +warnUnusedImports :: [(Name,Provenance)] -> RnM d () warnUnusedImports names - | not opt_WarnUnusedImports - = returnRn () -- Don't force names unless necessary - | otherwise - = warnUnusedBinds (const True) names + = ifOptRn Opt_WarnUnusedImports (warnUnusedBinds names) -warnUnusedLocalBinds ns - | not opt_WarnUnusedBinds = returnRn () - | otherwise = warnUnusedBinds (const True) ns +warnUnusedLocalBinds, warnUnusedMatches :: [Name] -> RnM d () +warnUnusedLocalBinds names + = ifOptRn Opt_WarnUnusedBinds (warnUnusedBinds [(n,LocalDef) | n<-names]) warnUnusedMatches names - | opt_WarnUnusedMatches = warnUnusedGroup (const True) names - | otherwise = returnRn () + = ifOptRn Opt_WarnUnusedMatches (warnUnusedGroup [(n,LocalDef) | n<-names]) ------------------------- -warnUnusedBinds :: (Bool -> Bool) -> [Name] -> RnM d () -warnUnusedBinds warn_when_local names - = mapRn_ (warnUnusedGroup warn_when_local) groups +warnUnusedBinds :: [(Name,Provenance)] -> RnM d () +warnUnusedBinds names + = mapRn_ warnUnusedGroup groups where -- Group by provenance groups = equivClasses cmp names - name1 `cmp` name2 = getNameProvenance name1 `cmp_prov` getNameProvenance name2 + (_,prov1) `cmp` (_,prov2) = prov1 `compare` prov2 - 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 ------------------------- --- NOTE: the function passed to warnUnusedGroup is --- now always (const True) so we should be able to --- simplify the code slightly. I'm leaving it there --- for now just in case I havn't realised why it was there. --- Looks highly bogus to me. SLPJ Dec 99 - -warnUnusedGroup :: (Bool -> Bool) -> [Name] -> RnM d () -warnUnusedGroup emit_warning names - | null filtered_names = returnRn () - | not (emit_warning is_local) = returnRn () +warnUnusedGroup :: [(Name,Provenance)] -> RnM d () +warnUnusedGroup names + | null filtered_names = returnRn () + | not is_local = returnRn () | otherwise = pushSrcLocRn def_loc $ addWarnRn $ - sep [msg <> colon, nest 4 (fsep (punctuate comma (map ppr filtered_names)))] + sep [msg <> colon, nest 4 (fsep (punctuate comma (map (ppr.fst) filtered_names)))] where filtered_names = filter reportable names - name1 = head filtered_names + (name1, prov1) = 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 - zz_other -> True + = case prov1 of + LocalDef -> (True, getSrcLoc name1, text "Defined but not used") + + NonLocalDef (UserImport mod loc _) + -> (True, loc, text "Imported from" <+> quotes (ppr mod) <+> text "but not used") + + reportable (name,_) = case occNameUserString (nameOccName name) of + ('_' : _) -> False + zz_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) +addNameClashErrRn rdr_name (np1:nps) = addErrRn (vcat [ptext SLIT("Ambiguous occurrence") <+> quotes (ppr rdr_name), ptext SLIT("It could refer to") <+> vcat (msg1 : msgs)]) where - 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)]) - 4 (vcat [ppr how_in_scope1, - ppr how_in_scope2]) + msg1 = ptext SLIT("either") <+> mk_ref np1 + msgs = [ptext SLIT(" or") <+> mk_ref np | np <- nps] + mk_ref (GRE name prov _) = quotes (ppr name) <> comma <+> pprNameProvenance name prov shadowedNameWarn shadow = hsep [ptext SLIT("This binding for"), quotes (ppr shadow), ptext SLIT("shadows an existing binding")] +noMainMsg = ptext SLIT("No 'main' defined in module Main") + unknownNameErr name = sep [text flavour, ptext SLIT("not in scope:"), quotes (ppr name)] where @@ -822,14 +1042,20 @@ unknownNameErr name qualNameErr descriptor (name,loc) = pushSrcLocRn loc $ - addErrRn (hsep [ ptext SLIT("Invalid use of qualified name"), - quotes (ppr name), - ptext SLIT("in"), + addErrRn (vcat [ ptext SLIT("Invalid use of qualified name") <+> quotes (ppr name), descriptor]) dupNamesErr descriptor ((name,loc) : dup_things) = pushSrcLocRn loc $ addErrRn ((ptext SLIT("Conflicting definitions for") <+> quotes (ppr name)) $$ - (ptext SLIT("in") <+> descriptor)) + descriptor) + +warnDeprec :: Name -> DeprecTxt -> RnM d () +warnDeprec name txt + = ifOptRn Opt_WarnDeprecations $ + addWarnRn (sep [ text (occNameFlavour (nameOccName name)) <+> + quotes (ppr name) <+> text "is deprecated:", + nest 4 (ppr txt) ]) \end{code} +