[project @ 2000-11-14 08:07:11 by simonpj]

[ghc-hetmet.git] / ghc / compiler / rename / RnEnv.lhs

diff --git a/ghc/compiler/rename/RnEnv.lhs b/ghc/compiler/rename/RnEnv.lhs
index a3c31d6..74d6b2e 100644 (file)
--- a/ghc/compiler/rename/RnEnv.lhs
+++ b/ghc/compiler/rename/RnEnv.lhs
@@ -11,7 +11,7 @@ module RnEnv where            -- Export everything
 import HsSyn
 import RdrHsSyn                ( RdrNameIE )
 import RdrName         ( RdrName, rdrNameModule, rdrNameOcc, isQual, isUnqual, isOrig,
-                         mkRdrUnqual, mkRdrUnqual, qualifyRdrName, lookupRdrEnv
+                         mkRdrUnqual, mkRdrUnqual, qualifyRdrName, lookupRdrEnv, foldRdrEnv
                        )
 import HsTypes         ( hsTyVarName, replaceTyVarName )
 import HscTypes                ( Provenance(..), pprNameProvenance, hasBetterProv,
@@ -20,7 +20,7 @@ import HscTypes               ( Provenance(..), pprNameProvenance, hasBetterProv,
 import RnMonad
 import Name            ( Name, NamedThing(..),
                          getSrcLoc, 
-                         mkLocalName, mkImportedLocalName, mkGlobalName,
+                         mkLocalName, mkGlobalName,
                          mkIPName, nameOccName, nameModule_maybe,
                          setNameModuleAndLoc
                        )
@@ -180,7 +180,8 @@ lookupTopBndrRn rdr_name
                         -- if there are many with the same occ name
                         -- There must *be* a binding
                getModuleRn             `thenRn` \ mod ->
-               lookupSrcGlobalOcc (qualifyRdrName (moduleName mod) rdr_name)
+               getGlobalNameEnv        `thenRn` \ global_env ->
+               lookupSrcName global_env (qualifyRdrName (moduleName mod) rdr_name)
 
 -- lookupSigOccRn is used for type signatures and pragmas
 -- Is this valid?
@@ -209,19 +210,21 @@ lookupOccRn rdr_name
 --     class op names in class and instance decls
 
 lookupGlobalOccRn rdr_name
+  = getModeRn          `thenRn` \ mode ->
+    case mode of 
+       SourceMode    -> getGlobalNameEnv                       `thenRn` \ global_env ->
+                        lookupSrcName global_env rdr_name
+
+       InterfaceMode -> lookupIfaceName 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
-  = getModeRn          `thenRn` \ mode ->
-    case mode of 
-       SourceMode    -> lookupSrcGlobalOcc rdr_name
-       InterfaceMode -> lookupIfaceUnqual rdr_name
-
-lookupSrcGlobalOcc rdr_name
-  -- Lookup a source-code rdr-name; may be qualified or not
-  = getGlobalNameEnv                   `thenRn` \ global_env ->
-    case lookupRdrEnv global_env rdr_name of
+  = case lookupRdrEnv global_env rdr_name of
        Just [(name,_)]         -> returnRn name
        Just stuff@((name,_):_) -> addNameClashErrRn rdr_name stuff     `thenRn_`
                                   returnRn name
@@ -246,15 +249,6 @@ lookupIfaceName :: RdrName -> RnM d Name
 lookupIfaceName rdr_name
   | isUnqual rdr_name = lookupIfaceUnqual rdr_name
   | otherwise        = lookupOrigName rdr_name
-
-lookupGlobalRn :: GlobalRdrEnv -> RdrName -> RnM d (Maybe Name)
-  -- Checks that there is exactly one
-lookupGlobalRn global_env rdr_name
-  = case lookupRdrEnv global_env rdr_name of
-       Just [(name,_)]         -> returnRn (Just name)
-       Just stuff@((name,_):_) -> addNameClashErrRn rdr_name stuff     `thenRn_`
-                                  returnRn (Just name)
-       Nothing                 -> returnRn Nothing
 \end{code}
 
 @lookupOrigName@ takes an RdrName representing an {\em original}
@@ -271,10 +265,6 @@ 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}
 lookupOrigNames :: [RdrName] -> RnM d NameSet
@@ -367,7 +357,7 @@ bindCoreLocalRn rdr_name enclosed_scope
     let
        (us', us1) = splitUniqSupply us
        uniq       = uniqFromSupply us1
-       name       = mkImportedLocalName uniq (rdrNameOcc rdr_name) loc
+       name       = mkLocalName uniq (rdrNameOcc rdr_name) loc
     in
     setNameSupplyRn (us', cache, ipcache)      `thenRn_`
     let
@@ -387,6 +377,12 @@ bindLocalNames names enclosed_scope
   where
     pairs = [(mkRdrUnqual (nameOccName n), n) | n <- names]
 
+bindLocalNamesFV names enclosed_scope
+  = bindLocalNames names $
+    enclosed_scope `thenRn` \ (thing, fvs) ->
+    returnRn (thing, delListFromNameSet fvs names)
+
+
 -------------------------------------
 bindLocalRn doc rdr_name enclosed_scope
   = getSrcLocRn                                `thenRn` \ loc ->
@@ -408,10 +404,6 @@ bindLocalsFVRn doc rdr_names enclosed_scope
     returnRn (thing, delListFromNameSet fvs names)
 
 -------------------------------------
-bindUVarRn :: RdrName -> (Name -> RnMS a) -> RnMS a
-bindUVarRn = bindCoreLocalRn
-
--------------------------------------
 extendTyVarEnvFVRn :: [Name] -> RnMS (a, FreeVars) -> RnMS (a, FreeVars)
        -- This tiresome function is used only in rnDecl on InstDecl
 extendTyVarEnvFVRn tyvars enclosed_scope
@@ -543,11 +535,12 @@ in error messages.
 \begin{code}
 unQualInScope :: GlobalRdrEnv -> Name -> Bool
 unQualInScope env
-  = lookup
+  = (`elemNameSet` unqual_names)
   where
-    lookup name = case lookupRdrEnv env (mkRdrUnqual (nameOccName name)) of
-                          Just [(name',_)] -> name == name'
-                          other            -> False
+    unqual_names :: NameSet
+    unqual_names = foldRdrEnv add emptyNameSet env
+    add rdr_name [(name,_)] unquals | isUnqual rdr_name = addOneToNameSet unquals name
+    add _        _          unquals                    = unquals
 \end{code}
 
 
@@ -750,7 +743,7 @@ warnUnusedGroup names
        = case prov1 of
                LocalDef -> (True, getSrcLoc name1, text "Defined but not used")
 
-               NonLocalDef (UserImport mod loc _) _ 
+               NonLocalDef (UserImport mod loc _)
                        -> (True, loc, text "Imported from" <+> quotes (ppr mod) <+> text "but not used")
 
     reportable (name,_) = case occNameUserString (nameOccName name) of