X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2Frename%2FRnEnv.lhs;h=53bf1bcabceb5d3613fcc4af5d5bd8abfee00889;hb=94ff1ec1546169fc839b2318c0d141f3089d3e26;hp=664fa700226327d2454f490fa43e4b700815f7d9;hpb=87fe9c34612b5149ae8c8307567cb4cf54db82f2;p=ghc-hetmet.git diff --git a/ghc/compiler/rename/RnEnv.lhs b/ghc/compiler/rename/RnEnv.lhs index 664fa70..53bf1bc 100644 --- a/ghc/compiler/rename/RnEnv.lhs +++ b/ghc/compiler/rename/RnEnv.lhs @@ -1,5 +1,5 @@ % -% (c) The GRASP/AQUA Project, Glasgow University, 1992-1996 +% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998 % \section[RnEnv]{Environment manipulation for the renamer monad} @@ -11,31 +11,34 @@ module RnEnv where -- Export everything import CmdLineOpts ( opt_WarnNameShadowing, opt_WarnUnusedMatches, opt_WarnUnusedBinds, opt_WarnUnusedImports ) import HsSyn -import RdrHsSyn ( RdrName(..), RdrNameIE, - rdrNameOcc, ieOcc, isQual, qual - ) +import RdrHsSyn ( RdrNameIE ) +import RdrName ( RdrName, rdrNameModule, rdrNameOcc, isQual, mkRdrUnqual, qualifyRdrName ) import HsTypes ( getTyVarName, replaceTyVarName ) -import BasicTypes ( Fixity(..), FixityDirection(..), IfaceFlavour(..), pprModule ) +import BasicTypes ( Fixity(..), FixityDirection(..) ) import RnMonad -import Name ( Name, OccName(..), Provenance(..), ExportFlag(..), NamedThing(..), - occNameString, occNameFlavour, getSrcLoc, - NameSet, emptyNameSet, addListToNameSet, nameSetToList, - mkLocalName, mkGlobalName, modAndOcc, - nameOccName, setNameProvenance, isVarOcc, getNameProvenance, - pprProvenance, pprOccName, pprModule, pprNameProvenance, - isLocalName +import Name ( Name, Provenance(..), ExportFlag(..), NamedThing(..), + ImportReason(..), getSrcLoc, + mkLocalName, mkGlobalName, isSystemName, + nameOccName, nameModule, setNameModule, + pprOccName, isLocallyDefined, nameUnique, nameOccName, + setNameProvenance, getNameProvenance, pprNameProvenance + ) +import NameSet +import OccName ( OccName, + mkDFunOcc, + occNameFlavour ) +import Module ( moduleIfaceFlavour ) import TyCon ( TyCon ) -import TysWiredIn ( tupleTyCon, listTyCon, charTyCon, intTyCon ) import FiniteMap import Unique ( Unique, Uniquable(..), unboundKey ) -import UniqFM ( listToUFM, plusUFM_C ) -import Maybes ( maybeToBool ) +import UniqFM ( emptyUFM, listToUFM, plusUFM_C ) import UniqSupply import SrcLoc ( SrcLoc, noSrcLoc ) import Outputable -import Util ( removeDups ) +import Util ( removeDups, equivClasses, thenCmp ) import List ( nub ) +import Maybes ( mapMaybe ) \end{code} @@ -47,55 +50,61 @@ import List ( nub ) %********************************************************* \begin{code} -newImportedGlobalName :: Module -> OccName - -> IfaceFlavour - -> RnM s d Name -newImportedGlobalName mod occ hif +newImportedGlobalName :: Module -> OccName -> RnM s d Name +newImportedGlobalName mod occ = -- First check the cache getNameSupplyRn `thenRn` \ (us, inst_ns, cache) -> let - key = (mod,occ) - prov = NonLocalDef noSrcLoc hif False + key = (mod,occ) in case lookupFM cache key of - + -- A hit in the cache! - -- If it has no provenance at the moment then set its provenance + -- Make sure that the module in the name has the same IfaceFlavour as + -- the module we are looking for; if not, make it so -- so that it has the right HiFlag component. - -- (This is necessary - -- for known-key things. For example, GHCmain.lhs imports as SOURCE - -- Main; but Main.main is a known-key thing.) - -- Don't fiddle with the provenance if it already has one - Just name -> case getNameProvenance name of - NoProvenance -> let - new_name = setNameProvenance name prov - new_cache = addToFM cache key new_name - in - setNameSupplyRn (us, inst_ns, new_cache) `thenRn_` - returnRn new_name - other -> returnRn name + -- (This is necessary for known-key things. + -- For example, GHCmain.lhs imports as SOURCE + -- Main; but Main.main is a known-key thing.) + Just name | isSystemName name -- A known-key name; fix the provenance and module + -> getOmitQualFn `thenRn` \ omit_fn -> + let + new_name = setNameProvenance (setNameModule name mod) + (NonLocalDef ImplicitImport (omit_fn name)) + new_cache = addToFM cache key new_name + in + setNameSupplyRn (us, inst_ns, new_cache) `thenRn_` + returnRn new_name + + | otherwise + -> returnRn name Nothing -> -- Miss in the cache! -- Build a new original name, and put it in the cache + getOmitQualFn `thenRn` \ omit_fn -> + setModuleFlavourRn mod `thenRn` \ mod' -> let (us', us1) = splitUniqSupply us - uniq = getUnique us1 - name = mkGlobalName uniq mod occ prov + uniq = uniqFromSupply us1 + name = mkGlobalName uniq mod' occ (NonLocalDef ImplicitImport (omit_fn name)) + -- For in-scope things we improve the provenance + -- in RnNames.importsFromImportDecl new_cache = addToFM cache key name in setNameSupplyRn (us', inst_ns, new_cache) `thenRn_` returnRn name -{- - let - pprC ((mod,occ),name) = pprModule mod <> text "." <> pprOccName occ <+> text "--->" - <+> ppr name - in - pprTrace "ng" (vcat [text "newGlobalName miss" <+> pprModule mod <+> pprOccName occ, - brackets (sep (map pprC (fmToList cache))), - text "" - ]) $ --} + +newImportedGlobalFromRdrName rdr_name + | isQual rdr_name + = newImportedGlobalName (rdrNameModule rdr_name) (rdrNameOcc rdr_name) + + | otherwise + = -- An Unqual is allowed; interface files contain + -- unqualified names for locally-defined things, such as + -- constructors of a data type. + getModuleRn `thenRn ` \ mod_name -> + newImportedGlobalName mod_name (rdrNameOcc rdr_name) newLocallyDefinedGlobalName :: Module -> OccName @@ -105,7 +114,14 @@ newLocallyDefinedGlobalName mod occ rec_exp_fn loc = -- First check the cache getNameSupplyRn `thenRn` \ (us, inst_ns, cache) -> let - key = (mod,occ) + key = (mod,occ) + mk_prov name = LocalDef loc (rec_exp_fn name) + -- We must set the provenance of the thing in the cache + -- correctly, particularly whether or not it is locally defined. + -- + -- Since newLocallyDefinedGlobalName is used only + -- at binding occurrences, we may as well get the provenance + -- dead right first time; hence the rec_exp_fn passed in in case lookupFM cache key of @@ -113,8 +129,11 @@ newLocallyDefinedGlobalName mod occ rec_exp_fn loc -- Overwrite whatever provenance is in the cache already; -- this updates WiredIn things and known-key things, -- which are there from the start, to LocalDef. + -- + -- It also means that if there are two defns for the same thing + -- in a module, then each gets a separate SrcLoc Just name -> let - new_name = setNameProvenance name (LocalDef loc (rec_exp_fn new_name)) + new_name = setNameProvenance name (mk_prov new_name) new_cache = addToFM cache key new_name in setNameSupplyRn (us, inst_ns, new_cache) `thenRn_` @@ -123,42 +142,22 @@ newLocallyDefinedGlobalName mod occ rec_exp_fn loc -- Miss in the cache! -- Build a new original name, and put it in the cache Nothing -> let - provenance = LocalDef loc (rec_exp_fn new_name) (us', us1) = splitUniqSupply us - uniq = getUnique us1 - new_name = mkGlobalName uniq mod occ provenance + uniq = uniqFromSupply us1 + new_name = mkGlobalName uniq mod occ (mk_prov new_name) new_cache = addToFM cache key new_name in setNameSupplyRn (us', inst_ns, new_cache) `thenRn_` returnRn new_name --- newDfunName is a variant, specially for dfuns. --- When renaming derived definitions we are in *interface* mode (because we can trip --- over original names), but we still want to make the Dfun locally-defined. --- So we can't use whether or not we're in source mode to decide the locally-defined question. -newDfunName :: Maybe RdrName -> SrcLoc -> RnMS s Name -newDfunName Nothing src_loc -- Local instance decls have a "Nothing" - = getModuleRn `thenRn` \ mod_name -> - newInstUniq `thenRn` \ inst_uniq -> - let - dfun_occ = VarOcc (_PK_ ("$d" ++ show inst_uniq)) - in - newLocallyDefinedGlobalName mod_name dfun_occ - (\_ -> Exported) src_loc - -newDfunName (Just n) src_loc -- Imported ones have "Just n" - = getModuleRn `thenRn` \ mod_name -> - newImportedGlobalName mod_name (rdrNameOcc n) HiFile {- Correct? -} - - newLocalNames :: [(RdrName,SrcLoc)] -> RnM s d [Name] newLocalNames rdr_names = getNameSupplyRn `thenRn` \ (us, inst_ns, cache) -> let n = length rdr_names (us', us1) = splitUniqSupply us - uniqs = getUniques n us1 + uniqs = uniqsFromSupply n us1 locals = [ mkLocalName uniq (rdrNameOcc rdr_name) loc | ((rdr_name,loc), uniq) <- rdr_names `zip` uniqs ] @@ -166,16 +165,29 @@ newLocalNames rdr_names setNameSupplyRn (us', inst_ns, cache) `thenRn_` returnRn locals +newDFunName cl_occ tycon_occ (Just n) src_loc -- Imported ones have "Just n" + = newImportedGlobalFromRdrName n + +newDFunName cl_occ tycon_occ Nothing src_loc -- Local instance decls have a "Nothing" + = getModuleRn `thenRn` \ mod_name -> + newInstUniq (cl_occ, tycon_occ) `thenRn` \ inst_uniq -> + let + dfun_occ = mkDFunOcc cl_occ tycon_occ inst_uniq + in + newLocallyDefinedGlobalName mod_name dfun_occ (\_ -> Exported) src_loc + + -- mkUnboundName makes a place-holder Name; it shouldn't be looked at except possibly -- during compiler debugging. mkUnboundName :: RdrName -> Name mkUnboundName rdr_name = mkLocalName unboundKey (rdrNameOcc rdr_name) noSrcLoc isUnboundName :: Name -> Bool -isUnboundName name = uniqueOf name == unboundKey +isUnboundName name = getUnique name == unboundKey \end{code} \begin{code} +------------------------------------- bindLocatedLocalsRn :: SDoc -- Documentation string for error message -> [(RdrName,SrcLoc)] -> ([Name] -> RnMS s a) @@ -193,34 +205,86 @@ bindLocatedLocalsRn doc_str rdr_names_w_loc enclosed_scope newLocalNames rdr_names_w_loc `thenRn` \ names -> let - new_name_env = addListToFM name_env (map fst rdr_names_w_loc `zip` names) + new_name_env = addListToRdrEnv name_env (map fst rdr_names_w_loc `zip` names) in setLocalNameEnv new_name_env (enclosed_scope names) where check_shadow name_env (rdr_name,loc) - = case lookupFM name_env rdr_name of + = case lookupRdrEnv name_env rdr_name of Nothing -> returnRn () Just name -> pushSrcLocRn loc $ addWarnRn (shadowedNameWarn rdr_name) + +------------------------------------- bindLocalsRn doc_str rdr_names enclosed_scope = getSrcLocRn `thenRn` \ loc -> bindLocatedLocalsRn (text doc_str) (rdr_names `zip` repeat loc) enclosed_scope + -- binLocalsFVRn is the same as bindLocalsRn + -- except that it deals with free vars +bindLocalsFVRn doc_str rdr_names enclosed_scope + = bindLocalsRn doc_str rdr_names $ \ names -> + enclosed_scope names `thenRn` \ (thing, fvs) -> + returnRn (thing, delListFromNameSet fvs names) + +------------------------------------- +extendTyVarEnvFVRn :: [HsTyVar Name] -> RnMS s (a, FreeVars) -> RnMS s (a, FreeVars) + -- This tiresome function is used only in rnDecl 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) + +bindTyVarsRn :: SDoc -> [HsTyVar RdrName] + -> ([HsTyVar Name] -> RnMS s a) + -> RnMS s a bindTyVarsRn doc_str tyvar_names enclosed_scope + = bindTyVars2Rn doc_str tyvar_names $ \ names tyvars -> + enclosed_scope tyvars + +-- Gruesome name: return Names as well as HsTyVars +bindTyVars2Rn :: SDoc -> [HsTyVar RdrName] + -> ([Name] -> [HsTyVar Name] -> RnMS s a) + -> RnMS s a +bindTyVars2Rn doc_str tyvar_names enclosed_scope = getSrcLocRn `thenRn` \ loc -> let located_tyvars = [(getTyVarName tv, loc) | tv <- tyvar_names] in bindLocatedLocalsRn doc_str located_tyvars $ \ names -> - enclosed_scope (zipWith replaceTyVarName tyvar_names names) - - -- Works in any variant of the renamer monad + enclosed_scope names (zipWith replaceTyVarName tyvar_names names) + +bindTyVarsFVRn :: SDoc -> [HsTyVar RdrName] + -> ([HsTyVar Name] -> RnMS s (a, FreeVars)) + -> RnMS s (a, FreeVars) +bindTyVarsFVRn doc_str rdr_names enclosed_scope + = bindTyVars2Rn doc_str rdr_names $ \ names tyvars -> + enclosed_scope tyvars `thenRn` \ (thing, fvs) -> + returnRn (thing, delListFromNameSet fvs names) + +bindTyVarsFV2Rn :: SDoc -> [HsTyVar RdrName] + -> ([Name] -> [HsTyVar Name] -> RnMS s (a, FreeVars)) + -> RnMS s (a, FreeVars) +bindTyVarsFV2Rn doc_str rdr_names enclosed_scope + = bindTyVars2Rn doc_str rdr_names $ \ names tyvars -> + enclosed_scope names tyvars `thenRn` \ (thing, fvs) -> + returnRn (thing, delListFromNameSet fvs names) + + +------------------------------------- checkDupOrQualNames, checkDupNames :: SDoc -> [(RdrName, SrcLoc)] -> RnM s d () + -- Works in any variant of the renamer monad checkDupOrQualNames doc_str rdr_names_w_loc = -- Check for use of qualified names @@ -235,12 +299,6 @@ checkDupNames doc_str rdr_names_w_loc returnRn () where (_, dups) = removeDups (\(n1,l1) (n2,l2) -> n1 `compare` n2) rdr_names_w_loc - - --- Yuk! -ifaceFlavour name = case getNameProvenance name of - NonLocalDef _ hif _ -> hif - other -> HiFile -- Shouldn't happen \end{code} @@ -253,68 +311,28 @@ ifaceFlavour name = case getNameProvenance name of Looking up a name in the RnEnv. \begin{code} -lookupRn :: RdrName - -> Maybe Name -- Result of environment lookup - -> RnMS s Name - -lookupRn rdr_name (Just name) - = -- Found the name in the envt - returnRn name -- In interface mode the only things in - -- the environment are things in local (nested) scopes - -lookupRn rdr_name Nothing - = -- We didn't find the name in the environment - getModeRn `thenRn` \ mode -> - case mode of { - SourceMode -> failWithRn (mkUnboundName rdr_name) - (unknownNameErr rdr_name) ; - -- Souurce mode; lookup failure is an error - - InterfaceMode _ _ -> - - - ---------------------------------------------------- - -- OK, so we're in interface mode - -- An Unqual is allowed; interface files contain - -- unqualified names for locally-defined things, such as - -- constructors of a data type. - -- So, qualify the unqualified name with the - -- module of the interface file, and try again - case rdr_name of - Unqual occ -> getModuleRn `thenRn` \ mod -> - newImportedGlobalName mod occ HiFile - Qual mod occ hif -> newImportedGlobalName mod occ hif - - } - lookupBndrRn rdr_name - = lookupNameRn rdr_name `thenRn` \ maybe_name -> - lookupRn rdr_name maybe_name `thenRn` \ name -> - - if isLocalName name then - returnRn name - else - - ---------------------------------------------------- - -- OK, so we're at the binding site of a top-level defn - -- Check to see whether its an imported decl - getModeRn `thenRn` \ mode -> - case mode of { - SourceMode -> returnRn name ; - - InterfaceMode _ print_unqual_fn -> - - ---------------------------------------------------- - -- OK, the binding site of an *imported* defn - -- so we can make the provenance more informative - getSrcLocRn `thenRn` \ src_loc -> - let - name' = case getNameProvenance name of - NonLocalDef _ hif _ -> setNameProvenance name - (NonLocalDef src_loc hif (print_unqual_fn name')) - other -> name - in - returnRn 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 + newImportedGlobalFromRdrName 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 @@ -323,39 +341,43 @@ lookupBndrRn rdr_name -- deciding which instance declarations to import. lookupOccRn :: RdrName -> RnMS s Name lookupOccRn rdr_name - = lookupNameRn rdr_name `thenRn` \ maybe_name -> - lookupRn rdr_name maybe_name `thenRn` \ name -> - let - name' = mungePrintUnqual rdr_name name - in - addOccurrenceName name' + = getNameEnvs `thenRn` \ (global_env, local_env) -> + lookup_occ global_env local_env rdr_name `thenRn` \ name -> + addOccurrenceName name -- lookupGlobalOccRn is like lookupOccRn, except that it looks in the global --- environment only. It's used for record field names only. +-- environment. It's used only for +-- record field names +-- class op names in class and instance decls lookupGlobalOccRn :: RdrName -> RnMS s Name lookupGlobalOccRn rdr_name - = lookupGlobalNameRn rdr_name `thenRn` \ maybe_name -> - lookupRn rdr_name maybe_name `thenRn` \ name -> - let - name' = mungePrintUnqual rdr_name name - in - addOccurrenceName name' - --- mungePrintUnqual is used to make *imported* *occurrences* print unqualified --- if they were mentioned unqualified in the source code. --- This improves error messages from the type checker. --- NB: the binding site is treated differently; see lookupBndrRn --- After the type checker all occurrences are replaced by the one --- at the binding site. -mungePrintUnqual (Qual _ _ _) name = name -mungePrintUnqual (Unqual _) name = case new_prov of - Nothing -> name - Just prov' -> setNameProvenance name prov' - where - new_prov = case getNameProvenance name of - NonLocalDef loc hif False -> Just (NonLocalDef loc hif True) - other -> Nothing - + = getNameEnvs `thenRn` \ (global_env, local_env) -> + lookup_global_occ global_env rdr_name `thenRn` \ name -> + addOccurrenceName 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 _ -> newImportedGlobalFromRdrName rdr_name + + -- lookupImplicitOccRn takes an RdrName representing an *original* name, and -- adds it to the occurrence pool so that it'll be loaded later. This is -- used when language constructs (such as monad comprehensions, overloaded literals, @@ -374,8 +396,8 @@ mungePrintUnqual (Unqual _) name = case new_prov of -- The name cache should have the correct provenance, though. lookupImplicitOccRn :: RdrName -> RnMS s Name -lookupImplicitOccRn (Qual mod occ hif) - = newImportedGlobalName mod occ hif `thenRn` \ name -> +lookupImplicitOccRn rdr_name + = newImportedGlobalFromRdrName rdr_name `thenRn` \ name -> addOccurrenceName name addImplicitOccRn :: Name -> RnMS s Name @@ -383,35 +405,30 @@ addImplicitOccRn name = addOccurrenceName name addImplicitOccsRn :: [Name] -> RnMS s () addImplicitOccsRn names = addOccurrenceNames names - -listType_RDR = qual (modAndOcc listType_name) -tupleType_RDR n = qual (modAndOcc (tupleType_name n)) - -charType_name = getName charTyCon -listType_name = getName listTyCon -tupleType_name n = getName (tupleTyCon n) \end{code} \begin{code} -lookupFixity :: RdrName -> RnMS s Fixity -lookupFixity rdr_name +lookupFixity :: Name -> RnMS s Fixity +lookupFixity name = getFixityEnv `thenRn` \ fixity_env -> - returnRn (lookupFixityEnv fixity_env rdr_name) + case lookupNameEnv fixity_env name of + Just (FixitySig _ fixity _) -> returnRn fixity + Nothing -> returnRn (Fixity 9 InfixL) -- Default case \end{code} -mkImportFn returns a function that takes a Name and tells whether +unQualInScope returns a function that takes a Name and tells whether its unqualified name is in scope. This is put as a boolean flag in the Name's provenance to guide whether or not to print the name qualified in error messages. \begin{code} -mkImportFn :: RnEnv -> Name -> Bool -mkImportFn (RnEnv env _) +unQualInScope :: GlobalRdrEnv -> Name -> Bool +unQualInScope env = lookup where - lookup name = case lookupFM env (Unqual (nameOccName name)) of - Just (name', _) -> name == name' - Nothing -> False + lookup name = case lookupRdrEnv env (mkRdrUnqual (nameOccName name)) of + Just [name'] -> name == name' + other -> False \end{code} %************************************************************************ @@ -423,71 +440,69 @@ mkImportFn (RnEnv env _) =============== RnEnv ================ \begin{code} plusRnEnv (RnEnv n1 f1) (RnEnv n2 f2) - = plusGlobalNameEnvRn n1 n2 `thenRn` \ n -> - plusFixityEnvRn f1 f2 `thenRn` \ f -> - returnRn (RnEnv n f) + = RnEnv (n1 `plusGlobalRdrEnv` n2) + (f1 `plusNameEnv` f2) \end{code} =============== NameEnv ================ \begin{code} -plusGlobalNameEnvRn :: GlobalNameEnv -> GlobalNameEnv -> RnM s d GlobalNameEnv -plusGlobalNameEnvRn env1 env2 - = mapRn (addErrRn.nameClashErr) (conflictsFM conflicting_name env1 env2) `thenRn_` - returnRn (env1 `plusFM` env2) - -addOneToGlobalNameEnv :: GlobalNameEnv -> RdrName -> (Name, HowInScope) -> RnM s d GlobalNameEnv -addOneToGlobalNameEnv env rdr_name name - = case lookupFM env rdr_name of - Just name2 | conflicting_name name name2 - -> addErrRn (nameClashErr (rdr_name, (name, name2))) `thenRn_` - returnRn env - - other -> returnRn (addToFM env rdr_name name) - -delOneFromGlobalNameEnv :: GlobalNameEnv -> RdrName -> GlobalNameEnv -delOneFromGlobalNameEnv env rdr_name = delFromFM env rdr_name - -conflicting_name :: (Name, HowInScope) -> (Name, HowInScope) -> Bool -conflicting_name (n1, FromLocalDefn _) (n2, FromLocalDefn _) = True -conflicting_name (n1,h1) (n2,h2) = n1 /= n2 - -- We complain of a conflict if one RdrName maps to two different Names, - -- OR if one RdrName maps to the same *locally-defined* Name. The latter - -- case is to catch two separate, local definitions of the same thing. - -- - -- If a module imports itself then there might be a local defn and an imported - -- defn of the same name; in this case the names will compare as equal, but - -- will still have different HowInScope fields - -lookupNameEnv :: NameEnv -> RdrName -> Maybe Name -lookupNameEnv = lookupFM -\end{code} - -=============== FixityEnv ================ -\begin{code} -plusFixityEnvRn f1 f2 - = mapRn (addErrRn.fixityClashErr) (conflictsFM bad_fix f1 f2) `thenRn_` - returnRn (f1 `plusFM` f2) +plusGlobalRdrEnv :: GlobalRdrEnv -> GlobalRdrEnv -> GlobalRdrEnv +plusGlobalRdrEnv env1 env2 = plusFM_C combine_globals env1 env2 -addOneToFixityEnv env rdr_name fixity = addToFM env rdr_name fixity +addOneToGlobalRdrEnv :: GlobalRdrEnv -> RdrName -> Name -> GlobalRdrEnv +addOneToGlobalRdrEnv env rdr_name name = addToFM_C combine_globals env rdr_name [name] -lookupFixityEnv env rdr_name - = case lookupFM env rdr_name of - Just (fixity,_) -> fixity - Nothing -> Fixity 9 InfixL -- Default case +delOneFromGlobalRdrEnv :: GlobalRdrEnv -> RdrName -> GlobalRdrEnv +delOneFromGlobalRdrEnv env rdr_name = delFromFM env rdr_name -bad_fix :: (Fixity, HowInScope) -> (Fixity, HowInScope) -> Bool -bad_fix (f1,_) (f2,_) = f1 /= f2 - -pprFixityProvenance :: (Fixity, HowInScope) -> SDoc -pprFixityProvenance (fixity, how_in_scope) = ppr how_in_scope +combine_globals :: [Name] -- Old + -> [Name] -- New + -> [Name] +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 + | 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 + -- 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, *not* eliminate a duplicate. + + -- On the other hand, if you import the same name from two different + -- import statements, we *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 + -- defn of the same name; in this case the names will compare as equal, but + -- will still have different provenances \end{code} =============== ExportAvails ================ \begin{code} -mkExportAvails :: Module -> Bool -> GlobalNameEnv -> [AvailInfo] -> ExportAvails +mkEmptyExportAvails :: Module -> ExportAvails +mkEmptyExportAvails mod_name = (unitFM mod_name [], emptyUFM) + +mkExportAvails :: Module -> Bool -> GlobalRdrEnv -> [AvailInfo] -> ExportAvails mkExportAvails mod_name unqual_imp name_env avails = (mod_avail_env, entity_avail_env) where @@ -500,20 +515,24 @@ mkExportAvails mod_name unqual_imp name_env avails -- we delete f from avails unqual_avails | not unqual_imp = [] -- Short cut when no unqualified imports - | otherwise = [prune avail | avail <- avails] + | otherwise = mapMaybe prune avails - prune (Avail n) | unqual_in_scope n = Avail n - prune (Avail n) | otherwise = NotAvailable - prune (AvailTC n ns) = AvailTC n (filter unqual_in_scope ns) + prune (Avail n) | unqual_in_scope n = Just (Avail n) + prune (Avail n) | otherwise = Nothing + prune (AvailTC n ns) | null uqs = Nothing + | otherwise = Just (AvailTC n uqs) + where + uqs = filter unqual_in_scope ns - unqual_in_scope n = Unqual (nameOccName n) `elemFM` name_env + unqual_in_scope n = unQualInScope name_env n entity_avail_env = listToUFM [ (name,avail) | avail <- avails, - name <- availEntityNames avail] + name <- availNames avail] plusExportAvails :: ExportAvails -> ExportAvails -> ExportAvails plusExportAvails (m1, e1) (m2, e2) = (plusFM_C (++) m1 m2, plusUFM_C plusAvail e1 e2) + -- ToDo: wasteful: we do this once for each constructor! \end{code} @@ -521,8 +540,6 @@ plusExportAvails (m1, e1) (m2, e2) \begin{code} plusAvail (Avail n1) (Avail n2) = Avail n1 plusAvail (AvailTC n1 ns1) (AvailTC n2 ns2) = AvailTC n1 (nub (ns1 ++ ns2)) -plusAvail a NotAvailable = a -plusAvail NotAvailable a = a -- Added SOF 4/97 #ifdef DEBUG plusAvail a1 a2 = pprPanic "RnEnv.plusAvail" (hsep [pprAvail a1,pprAvail a2]) @@ -539,31 +556,17 @@ availName (Avail n) = n availName (AvailTC n _) = n availNames :: AvailInfo -> [Name] -availNames NotAvailable = [] availNames (Avail n) = [n] availNames (AvailTC n ns) = ns --- availEntityNames is used to extract the names that can appear on their own in --- an export or import list. For class decls, class methods can appear on their --- own, thus import A( op ) --- but constructors cannot; thus --- import B( T ) --- means import type T from B, not constructor T. - -availEntityNames :: AvailInfo -> [Name] -availEntityNames NotAvailable = [] -availEntityNames (Avail n) = [n] -availEntityNames (AvailTC n ns) = n : filter (isVarOcc . nameOccName) ns - filterAvail :: RdrNameIE -- Wanted -> AvailInfo -- Available - -> AvailInfo -- Resulting available; - -- NotAvailable if wanted stuff isn't there + -> Maybe AvailInfo -- Resulting available; + -- Nothing if (any of the) wanted stuff isn't there filterAvail ie@(IEThingWith want wants) avail@(AvailTC n ns) - | sub_names_ok = AvailTC n (filter is_wanted ns) - | otherwise = pprTrace "filterAvail" (hsep [ppr ie, pprAvail avail]) $ - NotAvailable + | sub_names_ok = Just (AvailTC n (filter is_wanted ns)) + | otherwise = Nothing where is_wanted name = nameOccName name `elem` wanted_occs sub_names_ok = all (`elem` avail_occs) wanted_occs @@ -571,12 +574,12 @@ filterAvail ie@(IEThingWith want wants) avail@(AvailTC n ns) wanted_occs = map rdrNameOcc (want:wants) filterAvail (IEThingAbs _) (AvailTC n ns) = ASSERT( n `elem` ns ) - AvailTC n [n] + Just (AvailTC n [n]) -filterAvail (IEThingAbs _) avail@(Avail n) = avail -- Type synonyms +filterAvail (IEThingAbs _) avail@(Avail n) = Just avail -- Type synonyms -filterAvail (IEVar _) avail@(Avail n) = avail -filterAvail (IEVar v) avail@(AvailTC n ns) = AvailTC n (filter wanted ns) +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 @@ -584,9 +587,9 @@ filterAvail (IEVar v) avail@(AvailTC n ns) = AvailTC n (filter wanted ns) -- import A( op ) -- where op is a class operation -filterAvail (IEThingAll _) avail@(AvailTC _ _) = avail +filterAvail (IEThingAll _) avail@(AvailTC _ _) = Just avail -filterAvail ie avail = NotAvailable +filterAvail ie avail = Nothing -- In interfaces, pprAvail gets given the OccName of the "host" thing @@ -596,7 +599,6 @@ pprAvail avail = getPprStyle $ \ sty -> else ppr_avail ppr avail -ppr_avail pp_name NotAvailable = ptext SLIT("NotAvailable") ppr_avail pp_name (AvailTC n ns) = hsep [ pp_name n, parens $ hsep $ punctuate comma $ @@ -610,30 +612,26 @@ ppr_avail pp_name (Avail n) = pp_name n %************************************************************************ %* * -\subsection{Finite map utilities} +\subsection{Free variable manipulation} %* * %************************************************************************ +\begin{code} +type FreeVars = NameSet -Generally useful function on finite maps to check for overlap. +plusFV :: FreeVars -> FreeVars -> FreeVars +addOneFV :: FreeVars -> Name -> FreeVars +unitFV :: Name -> FreeVars +emptyFVs :: FreeVars +plusFVs :: [FreeVars] -> FreeVars -\begin{code} -conflictsFM :: Ord a - => (b->b->Bool) -- False <=> no conflict; you can pick either - -> FiniteMap a b -> FiniteMap a b - -> [(a,(b,b))] -conflictsFM bad fm1 fm2 - = filter (\(a,(b1,b2)) -> bad b1 b2) - (fmToList (intersectFM_C (\b1 b2 -> (b1,b2)) fm1 fm2)) - -conflictFM :: Ord a - => (b->b->Bool) - -> FiniteMap a b -> a -> b - -> Maybe (a,(b,b)) -conflictFM bad fm key elt - = case lookupFM fm key of - Just elt' | bad elt elt' -> Just (key,(elt,elt')) - other -> Nothing +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 \end{code} @@ -645,34 +643,68 @@ conflictFM bad fm key elt \begin{code} -warnUnusedBinds, warnUnusedMatches, warnUnusedImports :: NameSet -> RnM s d () +warnUnusedLocalBinds, warnUnusedTopNames, warnUnusedMatches :: [Name] -> RnM s d () + +warnUnusedTopNames names + | not opt_WarnUnusedBinds && not opt_WarnUnusedImports = returnRn () -- Don't force ns unless necessary + | otherwise = warnUnusedBinds (\ is_local -> not is_local) names -warnUnusedBinds names - | opt_WarnUnusedBinds = warnUnusedNames names - | otherwise = returnRn () +warnUnusedLocalBinds ns + | not opt_WarnUnusedBinds = returnRn () + | otherwise = warnUnusedBinds (\ is_local -> is_local) ns warnUnusedMatches names - | opt_WarnUnusedMatches = warnUnusedNames names - | otherwise = returnRn () + | opt_WarnUnusedMatches = warnUnusedGroup (const True) names + | otherwise = returnRn () -warnUnusedImports names - | opt_WarnUnusedImports = warnUnusedNames names - | otherwise = returnRn () +------------------------- -warnUnusedNames :: NameSet -> RnM s d () -warnUnusedNames names - = mapRn warn (nameSetToList names) `thenRn_` +warnUnusedBinds :: (Bool -> Bool) -> [Name] -> RnM s d () +warnUnusedBinds warn_when_local names + = mapRn (warnUnusedGroup warn_when_local) groups `thenRn_` returnRn () where - warn name = pushSrcLocRn (getSrcLoc name) $ - addWarnRn (unusedNameWarn name) - -unusedNameWarn name = quotes (ppr name) <+> ptext SLIT("is bound but not used") + -- Group by provenance + groups = equivClasses cmp names + name1 `cmp` name2 = getNameProvenance name1 `cmp_prov` getNameProvenance name2 + + cmp_prov (LocalDef _ _) (NonLocalDef _ _) = LT + cmp_prov (LocalDef loc1 _) (LocalDef loc2 _) = loc1 `compare` loc2 + cmp_prov (NonLocalDef (UserImport m1 loc1 _) _) + (NonLocalDef (UserImport m2 loc2 _) _) = (m1 `compare` m2) `thenCmp` (loc1 `compare` loc2) + cmp_prov (NonLocalDef _ _) (LocalDef _ _) = GT + -- In-scope NonLocalDefs must have UserImport info on them + +------------------------- + +warnUnusedGroup :: (Bool -> Bool) -> [Name] -> RnM s d () +warnUnusedGroup _ [] + = returnRn () + +warnUnusedGroup emit_warning names + | not (emit_warning is_local) = returnRn () + | otherwise + = pushSrcLocRn def_loc $ + addWarnRn $ + sep [msg <> colon, nest 4 (fsep (punctuate comma (map ppr names)))] + where + name1 = head 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 but not used") + other -> (False, getSrcLoc name1, text "Strangely defined but not used") +\end{code} -nameClashErr (rdr_name, ((_,how_in_scope1), (_, how_in_scope2))) - = hang (hsep [ptext SLIT("Conflicting definitions for"), quotes (ppr rdr_name)]) - 4 (vcat [ppr how_in_scope1, - ppr how_in_scope2]) +\begin{code} +addNameClashErrRn rdr_name (name1:names) + = 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)]) @@ -680,7 +712,7 @@ fixityClashErr (rdr_name, ((_,how_in_scope1), (_, how_in_scope2))) ppr how_in_scope2]) shadowedNameWarn shadow - = hcat [ptext SLIT("This binding for"), + = hsep [ptext SLIT("This binding for"), quotes (ppr shadow), ptext SLIT("shadows an existing binding")] @@ -698,8 +730,8 @@ qualNameErr descriptor (name,loc) dupNamesErr descriptor ((name,loc) : dup_things) = pushSrcLocRn loc $ - addErrRn (hsep [ptext SLIT("Conflicting definitions for"), - quotes (ppr name), - ptext SLIT("in"), descriptor]) + addErrRn ((ptext SLIT("Conflicting definitions for") <+> quotes (ppr name)) + $$ + (ptext SLIT("in") <+> descriptor)) \end{code}