X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2Frename%2FRnEnv.lhs;h=84d0f69ac06e9e756c3786bff17c890ed7a42e69;hb=9bb32dd2adae0a71b558b366bb73c4d4771ef80a;hp=6835f93a45007e38a8617bee943cc9e67ff3bda5;hpb=f587e76c3314fb89ba898b4c2aa2f5e5ef56c4f6;p=ghc-hetmet.git diff --git a/ghc/compiler/rename/RnEnv.lhs b/ghc/compiler/rename/RnEnv.lhs index 6835f93..84d0f69 100644 --- a/ghc/compiler/rename/RnEnv.lhs +++ b/ghc/compiler/rename/RnEnv.lhs @@ -8,55 +8,53 @@ module RnEnv where -- Export everything #include "HsVersions.h" -import {-# SOURCE #-} RnHiFiles +import {-# SOURCE #-} RnHiFiles( loadInterface ) +import FlattenInfo ( namesNeededForFlattening ) import HsSyn -import RdrHsSyn ( RdrNameIE, RdrNameHsType, extractHsTyRdrTyVars ) +import RdrHsSyn ( RdrNameHsType, RdrNameFixitySig, extractHsTyRdrTyVars ) import RdrName ( RdrName, rdrNameModule, rdrNameOcc, isQual, isUnqual, isOrig, - mkRdrUnqual, mkRdrQual, - lookupRdrEnv, foldRdrEnv, rdrEnvToList, elemRdrEnv, - unqualifyRdrName + mkRdrUnqual, mkRdrQual, setRdrNameSpace, rdrNameOcc, + lookupRdrEnv, rdrEnvToList, elemRdrEnv, + extendRdrEnv, addListToRdrEnv, emptyRdrEnv, + isExact_maybe, unqualifyRdrName ) import HsTypes ( hsTyVarName, replaceTyVarName ) import HscTypes ( Provenance(..), pprNameProvenance, hasBetterProv, - ImportReason(..), GlobalRdrEnv, GlobalRdrElt(..), AvailEnv, - AvailInfo, Avails, GenAvailInfo(..), NameSupply(..), - ModIface(..), - Deprecations(..), lookupDeprec, - extendLocalRdrEnv + ImportReason(..), GlobalRdrEnv, GlobalRdrElt(..), + GenAvailInfo(..), AvailInfo, Avails, + ModIface(..), NameCache(..), OrigNameCache, + Deprecations(..), lookupDeprec, isLocalGRE, + extendLocalRdrEnv, availName, availNames, + lookupFixity ) -import RnMonad -import Name ( Name, - getSrcLoc, nameIsLocalOrFrom, - mkLocalName, mkGlobalName, - mkIPName, nameOccName, nameModule_maybe, - setNameModuleAndLoc - ) -import NameEnv +import TcRnMonad +import Name ( Name, getName, nameIsLocalOrFrom, + isWiredInName, mkInternalName, mkExternalName, mkIPName, + nameSrcLoc, nameOccName, setNameSrcLoc, nameModule ) import NameSet -import OccName ( OccName, occNameUserString, occNameFlavour ) -import Module ( ModuleName, moduleName, mkVanillaModule, - mkSysModuleNameFS, moduleNameFS, WhereFrom(..) ) -import PrelNames ( mkUnboundName, - derivingOccurrences, - mAIN_Name, pREL_MAIN_Name, - ioTyConName, intTyConName, +import OccName ( OccName, tcName, isDataOcc, occNameFlavour, reportIfUnused ) +import Module ( Module, ModuleName, moduleName, mkHomeModule, + lookupModuleEnv, lookupModuleEnvByName, extendModuleEnv_C ) +import PrelNames ( mkUnboundName, intTyConName, boolTyConName, funTyConName, unpackCStringName, unpackCStringFoldrName, unpackCStringUtf8Name, - eqStringName, printName, - bindIOName, returnIOName, failIOName + eqStringName, printName, integerTyConName, + bindIOName, returnIOName, failIOName, thenIOName, + rOOT_MAIN_Name ) +#ifdef GHCI +import DsMeta ( templateHaskellNames, qTyConName ) +#endif import TysWiredIn ( unitTyCon ) -- A little odd +import Finder ( findModule ) import FiniteMap import UniqSupply -import SrcLoc ( SrcLoc, noSrcLoc ) +import SrcLoc ( SrcLoc, importedSrcLoc ) import Outputable import ListSetOps ( removeDups, equivClasses ) -import Util ( sortLt ) -import BasicTypes ( mapIPName ) +import BasicTypes ( mapIPName, FixitySig(..) ) import List ( nub ) -import UniqFM ( lookupWithDefaultUFM ) -import Maybe ( mapMaybe ) import CmdLineOpts import FastString ( FastString ) \end{code} @@ -68,110 +66,120 @@ import FastString ( FastString ) %********************************************************* \begin{code} -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 :: Module -> RdrName -> SrcLoc -> TcRn m Name newTopBinder mod rdr_name loc - = -- First check the cache + | Just name <- isExact_maybe rdr_name + = returnM name - -- 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_` - - getNameSupplyRn `thenRn` \ name_supply -> - let - occ = rdrNameOcc rdr_name - key = (moduleName mod, occ) - cache = nsNames name_supply - in - case lookupFM cache key of - - -- 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 = setNameModuleAndLoc name mod loc - new_cache = addToFM cache key new_name - in - setNameSupplyRn (name_supply {nsNames = new_cache}) `thenRn_` --- traceRn (text "newTopBinder: overwrite" <+> ppr new_name) `thenRn_` - returnRn new_name + | isOrig rdr_name + = ASSERT( rdr_mod == moduleName mod || rdr_mod == rOOT_MAIN_Name ) + -- When reading External Core we get Orig names as binders, + -- but they should agree with the module gotten from the monad + -- + -- Except for the ":Main.main = ..." definition inserted into + -- the Main module + -- + -- Because of this latter case, we take the module from the RdrName, + -- not from the environment. In principle, it'd be fine to have an + -- arbitrary mixture of external core definitions in a single module, + -- (apart from module-initialisation issues, perhaps). + newGlobalName (mkHomeModule rdr_mod) (rdrNameOcc rdr_name) loc + + | otherwise + = newGlobalName mod (rdrNameOcc rdr_name) loc + where + rdr_mod = rdrNameModule rdr_name + +newGlobalName :: Module -> OccName -> SrcLoc -> TcRn m Name +newGlobalName mod occ loc + = -- First check the cache + getNameCache `thenM` \ name_supply -> + case lookupOrigNameCache (nsNames name_supply) mod occ of + + -- A hit in the cache! We are at the binding site of the name. + -- This is the moment when we know the defining SrcLoc + -- of the Name, so we set the SrcLoc of the name we return. + -- + -- Main reason: then (bogus) multiple bindings of the same Name + -- get different SrcLocs can can be reported as such. + -- + -- Possible other reason: it might be in the cache because we + -- encountered an occurrence before the binding site for an + -- implicitly-imported Name. Perhaps the current SrcLoc is + -- better... but not really: it'll still just say 'imported' + -- + -- IMPORTANT: Don't mess with wired-in names. + -- Their wired-in-ness is in the SrcLoc + + Just name | isWiredInName name -> returnM name + | otherwise -> returnM (setNameSrcLoc name loc) -- 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 (nsUniqs name_supply) - uniq = uniqFromSupply us1 - new_name = mkGlobalName uniq mod occ loc - new_cache = addToFM cache key new_name - in - setNameSupplyRn (name_supply {nsUniqs = us', nsNames = new_cache}) `thenRn_` --- traceRn (text "newTopBinder: new" <+> ppr new_name) `thenRn_` - returnRn new_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 (newTopBinder) - -- The place-holder Name doesn't have the right SrcLoc, and its - -- Module won't have the right Package either. + Nothing -> addNewName name_supply mod occ loc + +-- Look up a "system name" in the name cache. +-- This is done by the type checker... +lookupSysName :: Name -- Base name + -> (OccName -> OccName) -- Occurrence name modifier + -> TcRn m Name -- System name +lookupSysName base_name mk_sys_occ + = newGlobalName (nameModule base_name) + (mk_sys_occ (nameOccName base_name)) + (nameSrcLoc base_name) + + +newGlobalNameFromRdrName rdr_name -- Qualified original name + = newGlobalName2 (rdrNameModule rdr_name) (rdrNameOcc rdr_name) + +newGlobalName2 :: ModuleName -> OccName -> TcRn m Name + -- This one starts with a ModuleName, not a Module, because + -- we may be simply looking at an occurrence M.x in an interface file. -- - -- (We have to pass a ModuleName, not a Module, because we may be - -- simply looking at an occurrence M.x in an interface file.) + -- Used for *occurrences*. Even if we get a miss in the + -- original-name cache, we make a new External Name. + -- We get its Module either from the OrigNameCache, or (if this + -- is the first Name from that module) from the Finder -- - -- This means that a renamed program may have incorrect info - -- on implicitly-imported occurrences, but the correct info on the - -- *binding* declaration. It's the type checker that propagates the - -- correct information to all the occurrences. - -- Since implicitly-imported names never occur in error messages, - -- 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). -newGlobalName mod_name occ - = getNameSupplyRn `thenRn` \ name_supply -> + -- In the case of a miss, we have to make up the SrcLoc, but that's + -- OK: it must be an implicitly-imported Name, and that never occurs + -- in an error message. + +newGlobalName2 mod_name occ + = getNameCache `thenM` \ name_supply -> let - key = (mod_name, occ) - cache = nsNames name_supply + new_name mod = addNewName name_supply mod occ importedSrcLoc in - case lookupFM cache key of - Just name -> -- traceRn (text "newGlobalName: hit" <+> ppr name) `thenRn_` - returnRn name + case lookupModuleEnvByName (nsNames name_supply) mod_name of + Just (mod, occ_env) -> + -- There are some names from this module already + -- Next, look up in the OccNameEnv + case lookupFM occ_env occ of + Just name -> returnM name + Nothing -> new_name mod + + Nothing -> -- No names from this module yet + ioToTcRn (findModule mod_name) `thenM` \ mb_loc -> + case mb_loc of + Right (mod, _) -> new_name mod + Left files -> + getDOpts `thenM` \ dflags -> + addErr (noIfaceErr dflags mod_name False files) `thenM_` + -- Things have really gone wrong at this point, + -- so having the wrong package info in the + -- Module is the least of our worries. + new_name (mkHomeModule mod_name) - Nothing -> setNameSupplyRn (name_supply {nsUniqs = us', nsNames = new_cache}) `thenRn_` - -- traceRn (text "newGlobalName: new" <+> ppr name) `thenRn_` - returnRn name - where - (us', us1) = splitUniqSupply (nsUniqs name_supply) - uniq = uniqFromSupply us1 - mod = mkVanillaModule mod_name - name = mkGlobalName uniq mod occ noSrcLoc - new_cache = addToFM cache key name newIPName rdr_name_ip - = getNameSupplyRn `thenRn` \ name_supply -> + = getNameCache `thenM` \ 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 + Just name_ip -> returnM name_ip + Nothing -> setNameCache new_ns `thenM_` + returnM name_ip where (us', us1) = splitUniqSupply (nsUniqs name_supply) uniq = uniqFromSupply us1 @@ -181,6 +189,43 @@ newIPName rdr_name_ip new_ns = name_supply {nsUniqs = us', nsIPs = new_ipcache} where key = rdr_name_ip -- Ensures that ?x and %x get distinct Names + +-- A local helper function +addNewName name_supply mod occ loc + = setNameCache new_name_supply `thenM_` + returnM name + where + (new_name_supply, name) = newExternalName name_supply mod occ loc + + +newExternalName :: NameCache -> Module -> OccName -> SrcLoc + -> (NameCache,Name) +-- Allocate a new unique, manufacture a new External Name, +-- put it in the cache, and return the two +newExternalName name_supply mod occ loc + = (new_name_supply, name) + where + (us', us1) = splitUniqSupply (nsUniqs name_supply) + uniq = uniqFromSupply us1 + name = mkExternalName uniq mod occ loc + new_cache = extend_name_cache (nsNames name_supply) mod occ name + new_name_supply = name_supply {nsUniqs = us', nsNames = new_cache} + +lookupOrigNameCache :: OrigNameCache -> Module -> OccName -> Maybe Name +lookupOrigNameCache nc mod occ + = case lookupModuleEnv nc mod of + Nothing -> Nothing + Just (_, occ_env) -> lookupFM occ_env occ + +extendOrigNameCache :: OrigNameCache -> Name -> OrigNameCache +extendOrigNameCache nc name + = extend_name_cache nc (nameModule name) (nameOccName name) name + +extend_name_cache :: OrigNameCache -> Module -> OccName -> Name -> OrigNameCache +extend_name_cache nc mod occ name + = extendModuleEnv_C combine nc mod (mod, unitFM occ name) + where + combine (mod, occ_env) _ = (mod, addToFM occ_env occ name) \end{code} %********************************************************* @@ -193,9 +238,9 @@ Looking up a name in the RnEnv. \begin{code} lookupBndrRn rdr_name - = getLocalNameEnv `thenRn` \ local_env -> + = getLocalRdrEnv `thenM` \ local_env -> case lookupRdrEnv local_env rdr_name of - Just name -> returnRn name + Just name -> returnM name Nothing -> lookupTopBndrRn rdr_name lookupTopBndrRn rdr_name @@ -205,31 +250,59 @@ lookupTopBndrRn rdr_name -- A separate function (importsFromLocalDecls) reports duplicate top level -- decls, so here it's safe just to choose an arbitrary one. - | isOrig rdr_name +-- There should never be a qualified name in a binding position in Haskell, +-- but there can be if we have read in an external-Core file. +-- The Haskell parser checks for the illegal qualified name in Haskell +-- source files, so we don't need to do so here. + + = getModeRn `thenM` \ mode -> + case mode of + InterfaceMode mod -> + getSrcLocM `thenM` \ loc -> + newTopBinder mod rdr_name loc + + other -> lookupTopSrcBndr rdr_name + +lookupTopSrcBndr :: RdrName -> TcRn m Name +lookupTopSrcBndr rdr_name + = lookupTopSrcBndr_maybe rdr_name `thenM` \ maybe_name -> + case maybe_name of + Just name -> returnM name + Nothing -> unboundName rdr_name + + +lookupTopSrcBndr_maybe :: RdrName -> TcRn m (Maybe Name) +-- Look up a source-code binder + +-- Ignores imported names; for example, this is OK: +-- import Foo( f ) +-- infix 9 f -- The 'f' here does not need to be qualified +-- f x = x -- Nor here, of course + +lookupTopSrcBndr_maybe rdr_name + | Just name <- isExact_maybe 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 + -- The parser reads the special syntax and returns an Exact 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 + -- + -- We are at a binding site for the name, so check first that it + -- the current module is the correct one; otherwise GHC can get + -- very confused indeed. This test rejects code like + -- data T = (,) Int Int + -- unless we are in GHC.Tup + = getModule `thenM` \ mod -> + checkErr (moduleName mod == moduleName (nameModule name)) + (badOrigBinding rdr_name) `thenM_` + returnM (Just 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 + = getGlobalRdrEnv `thenM` \ global_env -> + case lookupRdrEnv global_env rdr_name of + Nothing -> returnM Nothing + Just gres -> case [gre_name gre | gre <- gres, isLocalGRE gre] of + [] -> returnM Nothing + (n:ns) -> returnM (Just n) -- lookupSigOccRn is used for type signatures and pragmas @@ -242,42 +315,69 @@ lookupTopBndrRn rdr_name -- 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 :: RdrName -> RnM 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 +lookupInstDeclBndr :: Name -> RdrName -> RnM 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) + | isUnqual rdr_name + = -- Find all the things the class op name maps to + -- and pick the one with the right parent name + getGblEnv `thenM` \ gbl_env -> + let + avail_env = imp_env (tcg_imports gbl_env) + occ = rdrNameOcc rdr_name + in + case lookupAvailEnv_maybe avail_env cls_name of + Nothing -> + -- If the class itself isn't in scope, then cls_name will + -- be unboundName, and there'll already be an error for + -- that in the error list. Example: + -- e.g. import Prelude hiding( Ord ) + -- instance Ord T where ... + -- The program is wrong, but that should not cause a crash. + returnM (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) + (n:ns)-> ASSERT( null ns ) returnM n + [] -> unboundName rdr_name + other -> pprPanic "lookupInstDeclBndr" (ppr cls_name) - where - occ = rdrNameOcc rdr_name + + + | otherwise -- Occurs in derived instances, where we just + -- refer directly to the right method, and avail_env + -- isn't available + = ASSERT2( not (isQual rdr_name), ppr rdr_name ) + -- NB: qualified names are rejected by the parser + lookupOrigName rdr_name + + +lookupSysBndr :: RdrName -> RnM Name +-- Used for the 'system binders' in a data type or class declaration +-- Do *not* look up in the RdrEnv; these system binders are never in scope +-- Instead, get the module from the monad... but remember that +-- where the module is depends on whether we are renaming source or +-- interface file stuff +lookupSysBndr rdr_name + = getSrcLocM `thenM` \ loc -> + getModeRn `thenM` \ mode -> + case mode of + InterfaceMode mod -> newTopBinder mod rdr_name loc + other -> getModule `thenM` \ mod -> + newTopBinder mod rdr_name loc -- lookupOccRn looks up an occurrence of a RdrName -lookupOccRn :: RdrName -> RnMS Name +lookupOccRn :: RdrName -> RnM Name lookupOccRn rdr_name - = getLocalNameEnv `thenRn` \ local_env -> + = getLocalRdrEnv `thenM` \ local_env -> case lookupRdrEnv local_env rdr_name of - Just name -> returnRn name + Just name -> returnM name Nothing -> lookupGlobalOccRn rdr_name -- lookupGlobalOccRn is like lookupOccRn, except that it looks in the global @@ -286,18 +386,14 @@ lookupOccRn rdr_name -- class op names in class and instance decls lookupGlobalOccRn rdr_name - = getModeRn `thenRn` \ mode -> - if (isInterfaceMode mode) - then lookupIfaceName rdr_name - else - - getGlobalNameEnv `thenRn` \ global_env -> - case mode of - SourceMode -> lookupSrcName global_env rdr_name + = getModeRn `thenM` \ mode -> + case mode of + InterfaceMode mod -> lookupIfaceName mod rdr_name + SourceMode -> lookupSrcName rdr_name - CmdLineMode + CmdLineMode | not (isQual rdr_name) -> - lookupSrcName global_env rdr_name + lookupSrcName rdr_name -- We allow qualified names on the command line to refer to -- *any* name exported by any module in scope, just as if @@ -308,94 +404,168 @@ lookupGlobalOccRn rdr_name -- 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 + lookupSrcName_maybe rdr_name `thenM` \ mb_name -> + case mb_name of + Just name -> returnM name + Nothing -> lookupQualifiedName rdr_name --- a qualified name on the command line can refer to any module at all: we +-- 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 :: RdrName -> TcRn m Name lookupQualifiedName rdr_name = let mod = rdrNameModule rdr_name occ = rdrNameOcc rdr_name in - loadInterface (ppr rdr_name) mod ImportByUser `thenRn` \ iface -> + loadInterface (ppr rdr_name) mod (ImportByUser False) `thenM` \ 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 + (n:ns) -> ASSERT (null ns) returnM n + _ -> unboundName rdr_name + +lookupSrcName :: RdrName -> TcRn m Name +lookupSrcName rdr_name + = lookupSrcName_maybe rdr_name `thenM` \ mb_name -> + case mb_name of + Nothing -> unboundName rdr_name + Just name -> returnM name + +lookupSrcName_maybe :: RdrName -> TcRn m (Maybe Name) +lookupSrcName_maybe rdr_name + | Just name <- isExact_maybe rdr_name -- Can occur in source code too + = returnM (Just name) + + | isOrig rdr_name -- An original name + = newGlobalNameFromRdrName rdr_name `thenM` \ name -> + returnM (Just name) | otherwise - = 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 ) + = lookupGRE rdr_name `thenM` \ mb_gre -> + case mb_gre of + Nothing -> returnM Nothing + Just gre -> returnM (Just (gre_name gre)) + +lookupGRE :: RdrName -> TcRn m (Maybe GlobalRdrElt) +lookupGRE rdr_name + = getGlobalRdrEnv `thenM` \ global_env -> + case lookupRdrEnv global_env rdr_name of + Just [gre] -> case gre_deprec gre of + Nothing -> returnM (Just gre) + Just _ -> warnDeprec gre `thenM_` + returnM (Just gre) + Just stuff@(gre : _) -> addNameClashErrRn rdr_name stuff `thenM_` + returnM (Just gre) + Nothing -> return Nothing + +lookupIfaceName :: Module -> RdrName -> TcRn m Name -- An Unqual is allowed; interface files contain -- unqualified names for locally-defined things, such as -- constructors of a data type. - getModuleRn `thenRn ` \ mod -> - newGlobalName (moduleName mod) (rdrNameOcc rdr_name) - -lookupIfaceName :: RdrName -> RnM d Name -lookupIfaceName rdr_name - | isUnqual rdr_name = lookupIfaceUnqual rdr_name +lookupIfaceName mod rdr_name + | isUnqual rdr_name = newGlobalName mod (rdrNameOcc rdr_name) importedSrcLoc | otherwise = lookupOrigName rdr_name -\end{code} -@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. +lookupOrigName :: RdrName -> TcRn m Name + -- Just for original or exact names +lookupOrigName rdr_name + | Just n <- isExact_maybe rdr_name + -- This happens in derived code, which we + -- rename in InterfaceMode + = returnM n -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). + | otherwise -- Usually Orig, but can be a Qual when + -- we are reading a .hi-boot file + = newGlobalNameFromRdrName rdr_name - \fbox{{\em Jan 98: this comment is wrong: @rnHsType@ uses it quite a bit.}} + +dataTcOccs :: RdrName -> [RdrName] +-- If the input is a data constructor, return both it and a type +-- constructor. This is useful when we aren't sure which we are +-- looking at. +-- +-- ToDo: If the user typed "[]" or "(,,)", we'll generate an Exact RdrName, +-- and we don't have a systematic way to find the TyCon's Name from +-- the DataCon's name. Sigh +dataTcOccs rdr_name + | isDataOcc occ = [rdr_name_tc, rdr_name] + | otherwise = [rdr_name] + where + occ = rdrNameOcc rdr_name + rdr_name_tc = setRdrNameSpace rdr_name tcName +\end{code} \begin{code} -lookupOrigNames :: [RdrName] -> RnM d NameSet -lookupOrigNames rdr_names - = mapRn lookupOrigName rdr_names `thenRn` \ names -> - returnRn (mkNameSet names) +unboundName rdr_name = addErr (unknownNameErr rdr_name) `thenM_` + returnM (mkUnboundName rdr_name) \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. +%********************************************************* +%* * + Fixities +%* * +%********************************************************* + +\begin{code} +-------------------------------- +bindLocalFixities :: [RdrNameFixitySig] -> RnM a -> RnM a +-- Used for nested fixity decls +-- No need to worry about type constructors here, +-- Should check for duplicates but we don't +bindLocalFixities fixes thing_inside + | null fixes = thing_inside + | otherwise = mappM rn_sig fixes `thenM` \ new_bit -> + extendFixityEnv new_bit thing_inside + where + rn_sig (FixitySig v fix src_loc) + = addSrcLoc src_loc $ + lookupSigOccRn v `thenM` \ new_v -> + returnM (new_v, FixitySig new_v fix src_loc) +\end{code} + +-------------------------------- +lookupFixity is a bit strange. + +* Nested local fixity decls are put in the local fixity env, which we + find with getFixtyEnv + +* Imported fixities are found in the HIT or PIT + +* Top-level fixity decls in this module may be for Names that are + either Global (constructors, class operations) + or Local/Exported (everything else) + (See notes with RnNames.getLocalDeclBinders for why we have this split.) + We put them all in the local fixity environment \begin{code} -lookupSysBinder rdr_name - = ASSERT( isUnqual rdr_name ) - getModuleRn `thenRn` \ mod -> - getSrcLocRn `thenRn` \ loc -> - newTopBinder mod rdr_name loc +lookupFixityRn :: Name -> RnM Fixity +lookupFixityRn name + = getModule `thenM` \ this_mod -> + if nameIsLocalOrFrom this_mod name + then -- It's defined in this module + getFixityEnv `thenM` \ local_fix_env -> + returnM (lookupFixity local_fix_env name) + + else -- It's imported + -- For imported names, we have to get their fixities by doing a + -- loadHomeInterface, and consulting the Ifaces that comes back + -- from that, because the interface file for the Name might not + -- have been loaded yet. Why not? Suppose you import module A, + -- which exports a function 'f', thus; + -- module CurrentModule where + -- import A( f ) + -- module A( f ) where + -- import B( f ) + -- Then B isn't loaded right away (after all, it's possible that + -- nothing from B will be used). When we come across a use of + -- 'f', we need to know its fixity, and it's then, and only + -- then, that we load B.hi. That is what's happening here. + loadInterface doc name_mod ImportBySystem `thenM` \ iface -> + returnM (lookupFixity (mi_fixities iface) name) + where + doc = ptext SLIT("Checking fixity for") <+> ppr name + name_mod = moduleName (nameModule name) \end{code} @@ -409,41 +579,60 @@ lookupSysBinder rdr_name mentioned explicitly, but which might be needed by the type checker. \begin{code} -getImplicitStmtFVs -- Compiling a statement - = returnRn (mkFVs [printName, bindIOName, returnIOName, failIOName] - `plusFV` ubiquitousNames) +implicitStmtFVs source_fvs -- Compiling a statement + = stmt_fvs `plusFV` implicitModuleFVs source_fvs + where + stmt_fvs = mkFVs [printName, bindIOName, thenIOName, returnIOName, failIOName, + integerTyConName] -- These are all needed implicitly when compiling a statement -- See TcModule.tc_stmts - -getImplicitModuleFVs mod_name decls -- Compiling a module - = lookupOrigNames deriv_occs `thenRn` \ deriving_names -> - returnRn (deriving_names `plusFV` implicit_main `plusFV` ubiquitousNames) - where - -- Add occurrences for IO or PrimIO - implicit_main | mod_name == mAIN_Name - || mod_name == pREL_MAIN_Name = unitFV ioTyConName - | otherwise = emptyFVs - - -- 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 ] + -- Reason for integerTyConName: consider this in GHCi + -- ghci> [] + -- We get an ambigous constraint (Show a), which we now default just like + -- numeric types... but unless we have the instance decl for Integer we + -- won't find a valid default! + +implicitModuleFVs source_fvs + = mkTemplateHaskellFVs source_fvs `plusFV` + namesNeededForFlattening `plusFV` + ubiquitousNames + + +thProxyName :: NameSet +mkTemplateHaskellFVs :: NameSet -> NameSet + -- This is a bit of a hack. When we see the Template-Haskell construct + -- [| expr |] + -- we are going to need lots of the ``smart constructors'' defined in + -- the main Template Haskell data type module. Rather than treat them + -- all as free vars at every occurrence site, we just make the Q type + -- consructor a free var.... and then use that here to haul in the others + +#ifdef GHCI +--------------- Template Haskell enabled -------------- +thProxyName = unitFV qTyConName + +mkTemplateHaskellFVs source_fvs + | qTyConName `elemNameSet` source_fvs = templateHaskellNames + | otherwise = emptyFVs + +#else +--------------- Template Haskell disabled -------------- + +thProxyName = emptyFVs +mkTemplateHaskellFVs source_fvs = emptyFVs +#endif +-------------------------------------------------------- -- 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!) + unpackCStringUtf8Name, eqStringName, + -- Virtually every program has error messages in it somewhere + 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!) \end{code} %************************************************************************ @@ -465,28 +654,52 @@ At the moment this just happens for * fromInteger, fromRational on literals (in expressions and patterns) * negate (in expressions) * minus (arising from n+k patterns) + * "do" notation We store the relevant Name in the HsSyn tree, in * HsIntegral/HsFractional * NegApp * NPlusKPatIn + * HsDo 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. +We treat the orignal (standard) names as free-vars too, because the type checker +checks the type of the user thing against the type of the standard thing. + \begin{code} -lookupSyntaxName :: Name -- The standard name - -> RnMS Name -- Possibly a non-standard name +lookupSyntaxName :: Name -- The standard name + -> RnM (Name, FreeVars) -- Possibly a non-standard name lookupSyntaxName std_name - = doptRn Opt_NoImplicitPrelude `thenRn` \ no_prelude -> - if not no_prelude then - returnRn std_name -- Normal case + = doptM Opt_NoImplicitPrelude `thenM` \ no_prelude -> + if not no_prelude then normal_case + else + getModeRn `thenM` \ mode -> + if isInterfaceMode mode then normal_case + -- Happens for 'derived' code where we don't want to rebind else - let - rdr_name = mkRdrUnqual (nameOccName std_name) -- Get the similarly named thing from the local environment - in - lookupOccRn rdr_name + lookupOccRn (mkRdrUnqual (nameOccName std_name)) `thenM` \ usr_name -> + returnM (usr_name, mkFVs [usr_name, std_name]) + where + normal_case = returnM (std_name, unitFV std_name) + +lookupSyntaxNames :: [Name] -- Standard names + -> RnM (ReboundNames Name, FreeVars) -- See comments with HsExpr.ReboundNames +lookupSyntaxNames std_names + = doptM Opt_NoImplicitPrelude `thenM` \ no_prelude -> + if not no_prelude then normal_case + else + getModeRn `thenM` \ mode -> + if isInterfaceMode mode then normal_case + else + -- Get the similarly named thing from the local environment + mappM (lookupOccRn . mkRdrUnqual . nameOccName) std_names `thenM` \ usr_names -> + + returnM (std_names `zip` map HsVar usr_names, mkFVs std_names `plusFV` mkFVs usr_names) + where + normal_case = returnM (std_names `zip` map HsVar std_names, mkFVs std_names) \end{code} @@ -498,55 +711,53 @@ lookupSyntaxName std_name \begin{code} newLocalsRn :: [(RdrName,SrcLoc)] - -> RnMS [Name] + -> RnM [Name] newLocalsRn rdr_names_w_loc - = getNameSupplyRn `thenRn` \ name_supply -> + = newUniqueSupply `thenM` \ us -> let - (us', us1) = splitUniqSupply (nsUniqs name_supply) - uniqs = uniqsFromSupply us1 - names = [ mkLocalName uniq (rdrNameOcc rdr_name) loc + uniqs = uniqsFromSupply us + names = [ mkInternalName uniq (rdrNameOcc rdr_name) loc | ((rdr_name,loc), uniq) <- rdr_names_w_loc `zip` uniqs ] in - setNameSupplyRn (name_supply {nsUniqs = us'}) `thenRn_` - returnRn names + returnM names bindLocatedLocalsRn :: SDoc -- Documentation string for error message -> [(RdrName,SrcLoc)] - -> ([Name] -> RnMS a) - -> RnMS a + -> ([Name] -> RnM a) + -> RnM a bindLocatedLocalsRn doc_str rdr_names_w_loc enclosed_scope - = getModeRn `thenRn` \ mode -> - getLocalNameEnv `thenRn` \ local_env -> - getGlobalNameEnv `thenRn` \ global_env -> + = getModeRn `thenM` \ mode -> + getLocalRdrEnv `thenM` \ local_env -> + getGlobalRdrEnv `thenM` \ global_env -> -- Check for duplicate names - checkDupOrQualNames doc_str rdr_names_w_loc `thenRn_` + checkDupOrQualNames doc_str rdr_names_w_loc `thenM_` -- Warn about shadowing, but only in source modules let check_shadow (rdr_name,loc) | rdr_name `elemRdrEnv` local_env || rdr_name `elemRdrEnv` global_env - = pushSrcLocRn loc $ addWarnRn (shadowedNameWarn rdr_name) + = addSrcLoc loc $ addWarn (shadowedNameWarn rdr_name) | otherwise - = returnRn () + = returnM () in (case mode of - SourceMode -> ifOptRn Opt_WarnNameShadowing $ - mapRn_ check_shadow rdr_names_w_loc - other -> returnRn () - ) `thenRn_` + SourceMode -> ifOptM Opt_WarnNameShadowing $ + mappM_ check_shadow rdr_names_w_loc + other -> returnM () + ) `thenM_` - newLocalsRn rdr_names_w_loc `thenRn` \ names -> + newLocalsRn rdr_names_w_loc `thenM` \ names -> let new_local_env = addListToRdrEnv local_env (map fst rdr_names_w_loc `zip` names) in - setLocalNameEnv new_local_env (enclosed_scope names) + setLocalRdrEnv new_local_env (enclosed_scope names) -bindCoreLocalRn :: RdrName -> (Name -> RnMS a) -> RnMS a +bindCoreLocalRn :: RdrName -> (Name -> RnM a) -> RnM a -- A specialised variant when renaming stuff from interface -- files (of which there is a lot) -- * one at a time @@ -554,19 +765,14 @@ bindCoreLocalRn :: RdrName -> (Name -> RnMS a) -> RnMS a -- * always imported -- * deal with free vars bindCoreLocalRn rdr_name enclosed_scope - = getSrcLocRn `thenRn` \ loc -> - getLocalNameEnv `thenRn` \ name_env -> - getNameSupplyRn `thenRn` \ name_supply -> - let - (us', us1) = splitUniqSupply (nsUniqs name_supply) - uniq = uniqFromSupply us1 - name = mkLocalName uniq (rdrNameOcc rdr_name) loc - in - setNameSupplyRn (name_supply {nsUniqs = us'}) `thenRn_` + = getSrcLocM `thenM` \ loc -> + getLocalRdrEnv `thenM` \ name_env -> + newUnique `thenM` \ uniq -> let + name = mkInternalName uniq (rdrNameOcc rdr_name) loc new_name_env = extendRdrEnv name_env rdr_name name in - setLocalNameEnv new_name_env (enclosed_scope name) + setLocalRdrEnv new_name_env (enclosed_scope name) bindCoreLocalsRn [] thing_inside = thing_inside [] bindCoreLocalsRn (b:bs) thing_inside = bindCoreLocalRn b $ \ name' -> @@ -574,63 +780,61 @@ bindCoreLocalsRn (b:bs) thing_inside = bindCoreLocalRn b $ \ name' -> thing_inside (name':names') bindLocalNames names enclosed_scope - = getLocalNameEnv `thenRn` \ name_env -> - setLocalNameEnv (extendLocalRdrEnv name_env names) + = getLocalRdrEnv `thenM` \ name_env -> + setLocalRdrEnv (extendLocalRdrEnv name_env names) enclosed_scope bindLocalNamesFV names enclosed_scope = bindLocalNames names $ - enclosed_scope `thenRn` \ (thing, fvs) -> - returnRn (thing, delListFromNameSet fvs names) + enclosed_scope `thenM` \ (thing, fvs) -> + returnM (thing, delListFromNameSet fvs names) ------------------------------------- bindLocalRn doc rdr_name enclosed_scope - = getSrcLocRn `thenRn` \ loc -> + = getSrcLocM `thenM` \ loc -> bindLocatedLocalsRn doc [(rdr_name,loc)] $ \ (n:ns) -> ASSERT( null ns ) enclosed_scope n bindLocalsRn doc rdr_names enclosed_scope - = getSrcLocRn `thenRn` \ loc -> + = getSrcLocM `thenM` \ loc -> bindLocatedLocalsRn doc (rdr_names `zip` repeat loc) enclosed_scope -- binLocalsFVRn is the same as bindLocalsRn -- except that it deals with free vars -bindLocalsFVRn doc rdr_names enclosed_scope +bindLocalsFV doc rdr_names enclosed_scope = bindLocalsRn doc rdr_names $ \ names -> - enclosed_scope names `thenRn` \ (thing, fvs) -> - returnRn (thing, delListFromNameSet fvs names) + enclosed_scope names `thenM` \ (thing, fvs) -> + returnM (thing, delListFromNameSet fvs names) ------------------------------------- -extendTyVarEnvFVRn :: [Name] -> RnMS (a, FreeVars) -> RnMS (a, FreeVars) +extendTyVarEnvFVRn :: [Name] -> RnM (a, FreeVars) -> RnM (a, FreeVars) -- This tiresome function is used only in rnSourceDecl on InstDecl extendTyVarEnvFVRn tyvars enclosed_scope - = bindLocalNames tyvars enclosed_scope `thenRn` \ (thing, fvs) -> - returnRn (thing, delListFromNameSet fvs tyvars) + = bindLocalNames tyvars enclosed_scope `thenM` \ (thing, fvs) -> + returnM (thing, delListFromNameSet fvs tyvars) bindTyVarsRn :: SDoc -> [HsTyVarBndr RdrName] - -> ([HsTyVarBndr Name] -> RnMS a) - -> RnMS a + -> ([HsTyVarBndr Name] -> RnM a) + -> RnM a bindTyVarsRn doc_str tyvar_names enclosed_scope - = getSrcLocRn `thenRn` \ loc -> + = getSrcLocM `thenM` \ loc -> let located_tyvars = [(hsTyVarName tv, loc) | tv <- tyvar_names] in bindLocatedLocalsRn doc_str located_tyvars $ \ names -> enclosed_scope (zipWith replaceTyVarName tyvar_names names) -bindPatSigTyVars :: [RdrNameHsType] - -> RnMS (a, FreeVars) - -> RnMS (a, FreeVars) +bindPatSigTyVars :: [RdrNameHsType] -> ([Name] -> RnM a) -> RnM a -- Find the type variables in the pattern type -- signatures that must be brought into scope -bindPatSigTyVars tys enclosed_scope - = getLocalNameEnv `thenRn` \ name_env -> - getSrcLocRn `thenRn` \ loc -> +bindPatSigTyVars tys thing_inside + = getLocalRdrEnv `thenM` \ name_env -> + getSrcLocM `thenM` \ loc -> let forall_tyvars = nub [ tv | ty <- tys, tv <- extractHsTyRdrTyVars ty, @@ -643,27 +847,35 @@ bindPatSigTyVars tys enclosed_scope 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) + bindLocatedLocalsRn doc_sig located_tyvars thing_inside +bindPatSigTyVarsFV :: [RdrNameHsType] + -> RnM (a, FreeVars) + -> RnM (a, FreeVars) +bindPatSigTyVarsFV tys thing_inside + = bindPatSigTyVars tys $ \ tvs -> + thing_inside `thenM` \ (result,fvs) -> + returnM (result, fvs `delListFromNameSet` tvs) ------------------------------------- checkDupOrQualNames, checkDupNames :: SDoc -> [(RdrName, SrcLoc)] - -> RnM d () + -> TcRn m () -- 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_` + = -- Qualified names in patterns are now rejected by the parser + -- but I'm not 100% certain that it finds all cases, so I've left + -- this check in for now. Should go eventually. + -- Hmm. Sooner rather than later.. data type decls +-- mappM_ (qualNameErr doc_str) quals `thenM_` 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 duplicated names in a binding group - mapRn_ (dupNamesErr doc_str) dups + mappM_ (dupNamesErr doc_str) dups where (_, dups) = removeDups (\(n1,l1) (n2,l2) -> n1 `compare` n2) rdr_names_w_loc \end{code} @@ -710,13 +922,18 @@ mkGlobalRdrEnv this_mod unqual_imp mk_provenance avails deprecs -- 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_avail env avail = foldl (add_name (availName avail)) env (availNames avail) - add_name env name -- Add qualified name only - = addOneToGlobalRdrEnv env (mkRdrQual this_mod occ) elt + add_name parent 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) + elt = GRE {gre_name = name, + gre_parent = if name == parent + then Nothing + else Just parent, + gre_prov = mk_provenance name, + gre_deprec = lookupDeprec deprecs name} \end{code} \begin{code} @@ -741,11 +958,12 @@ combine_globals ns_old ns_new -- ns_new is often short choose n m | n `beats` m = n | otherwise = m - (GRE n pn _) `beats` (GRE m pm _) = n==m && pn `hasBetterProv` pm + g1 `beats` g2 = gre_name g1 == gre_name g2 && + gre_prov g1 `hasBetterProv` gre_prov g2 is_duplicate :: GlobalRdrElt -> GlobalRdrElt -> Bool - is_duplicate (GRE n1 LocalDef _) (GRE n2 LocalDef _) = False - is_duplicate (GRE n1 _ _) (GRE n2 _ _) = n1 == n2 + is_duplicate g1 g2 | isLocalGRE g1 && isLocalGRE g2 = False + is_duplicate g1 g2 = gre_name g1 == gre_name g2 \end{code} We treat two bindings of a locally-defined name as a duplicate, @@ -761,159 +979,6 @@ 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} - - -%************************************************************************ -%* * -\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 [ppr a1,ppr a2]) -#endif - -addAvail :: AvailEnv -> AvailInfo -> AvailEnv -addAvail avails avail = extendNameEnv_C plusAvail avails (availName avail) avail - -unitAvailEnv :: AvailInfo -> AvailEnv -unitAvailEnv a = unitNameEnv (availName a) a - -plusAvailEnv :: AvailEnv -> AvailEnv -> AvailEnv -plusAvailEnv = plusNameEnv_C plusAvail - -availEnvElts = nameEnvElts - -addAvailToNameSet :: NameSet -> AvailInfo -> NameSet -addAvailToNameSet names avail = addListToNameSet names (availNames avail) - -availsToNameSet :: [AvailInfo] -> NameSet -availsToNameSet avails = foldl addAvailToNameSet emptyNameSet avails - -availName :: GenAvailInfo name -> name -availName (Avail n) = n -availName (AvailTC n _) = n - -availNames :: GenAvailInfo name -> [name] -availNames (Avail n) = [n] -availNames (AvailTC n ns) = ns - -------------------------------------- -filterAvail :: RdrNameIE -- Wanted - -> AvailInfo -- Available - -> 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 = 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 - avail_occs = map nameOccName ns - wanted_occs = map rdrNameOcc (want:wants) - -filterAvail (IEThingAbs _) (AvailTC n ns) = ASSERT( n `elem` ns ) - Just (AvailTC n [n]) - -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 - -- The second equation happens if we import a class op, thus - -- import A( op ) - -- where op is a class operation - -filterAvail (IEThingAll _) avail@(AvailTC _ _) = Just avail - -- We don't complain even if the IE says T(..), but - -- no constrs/class ops of T are available - -- Instead that's caught with a warning by the caller - -filterAvail ie avail = Nothing - -------------------------------------- -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 - - 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} - %************************************************************************ %* * \subsection{Free variable manipulation} @@ -922,11 +987,11 @@ pruneAvails keep avails \begin{code} -- A useful utility -mapFvRn f xs = mapRn f xs `thenRn` \ stuff -> +mapFvRn f xs = mappM f xs `thenM` \ stuff -> let (ys, fvs_s) = unzip stuff in - returnRn (ys, plusFVs fvs_s) + returnM (ys, plusFVs fvs_s) \end{code} @@ -937,72 +1002,65 @@ mapFvRn f xs = mapRn f xs `thenRn` \ stuff -> %************************************************************************ \begin{code} -warnUnusedModules :: [ModuleName] -> RnM d () +warnUnusedModules :: [ModuleName] -> TcRn m () warnUnusedModules mods - = ifOptRn Opt_WarnUnusedImports (mapRn_ (addWarnRn . unused_mod) mods) + = ifOptM Opt_WarnUnusedImports (mappM_ (addWarn . unused_mod) mods) where 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") <+> + parens (ptext SLIT("except perhaps instances visible in") <+> quotes (ppr m))] -warnUnusedImports :: [(Name,Provenance)] -> RnM d () -warnUnusedImports names - = ifOptRn Opt_WarnUnusedImports (warnUnusedBinds names) - -warnUnusedLocalBinds, warnUnusedMatches :: [Name] -> RnM d () -warnUnusedLocalBinds names - = ifOptRn Opt_WarnUnusedBinds (warnUnusedBinds [(n,LocalDef) | n<-names]) +warnUnusedImports, warnUnusedTopBinds :: [GlobalRdrElt] -> TcRn m () +warnUnusedImports gres = ifOptM Opt_WarnUnusedImports (warnUnusedGREs gres) +warnUnusedTopBinds gres = ifOptM Opt_WarnUnusedBinds (warnUnusedGREs gres) -warnUnusedMatches names - = ifOptRn Opt_WarnUnusedMatches (warnUnusedGroup [(n,LocalDef) | n<-names]) +warnUnusedLocalBinds, warnUnusedMatches :: [Name] -> TcRn m () +warnUnusedLocalBinds names = ifOptM Opt_WarnUnusedBinds (warnUnusedLocals names) +warnUnusedMatches names = ifOptM Opt_WarnUnusedMatches (warnUnusedLocals names) ------------------------- +-- Helpers +warnUnusedGREs gres = warnUnusedBinds [(n,p) | GRE {gre_name = n, gre_prov = p} <- gres] +warnUnusedLocals names = warnUnusedBinds [(n,LocalDef) | n<-names] -warnUnusedBinds :: [(Name,Provenance)] -> RnM d () +warnUnusedBinds :: [(Name,Provenance)] -> TcRn m () warnUnusedBinds names - = mapRn_ warnUnusedGroup groups + = mappM_ warnUnusedGroup groups where -- Group by provenance - groups = equivClasses cmp names + groups = equivClasses cmp (filter reportable names) (_,prov1) `cmp` (_,prov2) = prov1 `compare` prov2 + reportable (name,_) = reportIfUnused (nameOccName name) + ------------------------- -warnUnusedGroup :: [(Name,Provenance)] -> RnM d () +warnUnusedGroup :: [(Name,Provenance)] -> TcRn m () 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.fst) filtered_names)))] + = addSrcLoc def_loc $ + addWarn $ + sep [msg <> colon, nest 4 (fsep (punctuate comma (map (ppr.fst) names)))] where - filtered_names = filter reportable names - (name1, prov1) = head filtered_names - (is_local, def_loc, msg) - = 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 "_". + (name1, prov1) = head names + loc1 = nameSrcLoc name1 + (def_loc, msg) = case prov1 of + LocalDef -> (loc1, unused_msg) + NonLocalDef (UserImport mod loc _) -> (loc, imp_from mod) + + unused_msg = text "Defined but not used" + imp_from mod = text "Imported from" <+> quotes (ppr mod) <+> text "but not used" \end{code} \begin{code} addNameClashErrRn rdr_name (np1:nps) - = addErrRn (vcat [ptext SLIT("Ambiguous occurrence") <+> quotes (ppr rdr_name), - ptext SLIT("It could refer to") <+> vcat (msg1 : msgs)]) + = addErr (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 np1 msgs = [ptext SLIT(" or") <+> mk_ref np | np <- nps] - mk_ref (GRE name prov _) = quotes (ppr name) <> comma <+> pprNameProvenance name prov + mk_ref gre = quotes (ppr (gre_name gre)) <> comma <+> pprNameProvenance gre shadowedNameWarn shadow = hsep [ptext SLIT("This binding for"), @@ -1014,21 +1072,35 @@ unknownNameErr name where flavour = occNameFlavour (rdrNameOcc name) +badOrigBinding name + = ptext SLIT("Illegal binding of built-in syntax:") <+> ppr (rdrNameOcc name) + -- The rdrNameOcc is because we don't want to print Prelude.(,) + qualNameErr descriptor (name,loc) - = pushSrcLocRn loc $ - addErrRn (vcat [ ptext SLIT("Invalid use of qualified name") <+> quotes (ppr name), + = addSrcLoc loc $ + addErr (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)) + = addSrcLoc loc $ + addErr ((ptext SLIT("Conflicting definitions for") <+> quotes (ppr name)) $$ descriptor) -warnDeprec :: Name -> DeprecTxt -> RnM d () -warnDeprec name txt - = ifOptRn Opt_WarnDeprecations $ - addWarnRn (sep [ text (occNameFlavour (nameOccName name)) <+> +noIfaceErr dflags mod_name boot_file files + = ptext SLIT("Could not find interface file for") <+> quotes (ppr mod_name) + $$ extra + where + extra + | verbosity dflags < 3 = + text "(use -v to see a list of the files searched for)" + | otherwise = + hang (ptext SLIT("locations searched:")) 4 (vcat (map text files)) + +warnDeprec :: GlobalRdrElt -> TcRn m () +warnDeprec (GRE {gre_name = name, gre_deprec = Just txt}) + = ifOptM Opt_WarnDeprecations $ + addWarn (sep [ text (occNameFlavour (nameOccName name)) <+> quotes (ppr name) <+> text "is deprecated:", nest 4 (ppr txt) ]) \end{code}