[project @ 2003-02-21 13:27:53 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 10fe8f6..270f509 100644 (file)
--- a/ghc/compiler/rename/RnEnv.lhs
+++ b/ghc/compiler/rename/RnEnv.lhs
@@ -29,11 +29,11 @@ import HscTypes             ( Provenance(..), pprNameProvenance, hasBetterProv,
                          lookupFixity
                        )
 import TcRnMonad
-import Name            ( Name, getName, getSrcLoc, nameIsLocalOrFrom, isWiredInName,
-                         mkInternalName, mkExternalName, mkIPName, nameSrcLoc,
-                         nameOccName, setNameSrcLoc, nameModule        )
+import Name            ( Name, getName, nameIsLocalOrFrom, 
+                         isWiredInName, mkInternalName, mkExternalName, mkIPName, 
+                         nameSrcLoc, nameOccName, setNameSrcLoc, nameModule    )
 import NameSet
-import OccName         ( OccName, tcName, isDataOcc, occNameUserString, occNameFlavour )
+import OccName         ( OccName, tcName, isDataOcc, occNameFlavour, reportIfUnused )
 import Module          ( Module, ModuleName, moduleName, mkHomeModule,
                          lookupModuleEnv, lookupModuleEnvByName, extendModuleEnv_C )
 import PrelNames       ( mkUnboundName, intTyConName, 
@@ -49,7 +49,7 @@ import TysWiredIn     ( unitTyCon )   -- A little odd
 import Finder          ( findModule )
 import FiniteMap
 import UniqSupply
-import SrcLoc          ( SrcLoc, noSrcLoc, importedSrcLoc )
+import SrcLoc          ( SrcLoc, importedSrcLoc )
 import Outputable
 import ListSetOps      ( removeDups, equivClasses )
 import BasicTypes      ( mapIPName, FixitySig(..) )
@@ -317,8 +317,9 @@ lookupInstDeclBndr cls_name rdr_name
     getGblEnv                          `thenM` \ gbl_env ->
     let
        avail_env = imp_env (tcg_imports gbl_env)
+        occ       = rdrNameOcc rdr_name
     in
-    case lookupAvailEnv avail_env cls_name of
+    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
@@ -342,8 +343,6 @@ lookupInstDeclBndr cls_name rdr_name
          -- NB: qualified names are rejected by the parser
     lookupOrigName rdr_name
 
-  where
-    occ = rdrNameOcc rdr_name
 
 lookupSysBndr :: RdrName -> RnM Name
 -- Used for the 'system binders' in a data type or class declaration
@@ -769,7 +768,7 @@ bindLocalsRn doc rdr_names 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               `thenM` \ (thing, fvs) ->
     returnM (thing, delListFromNameSet fvs names)
@@ -792,13 +791,11 @@ bindTyVarsRn doc_str tyvar_names enclosed_scope
     bindLocatedLocalsRn doc_str located_tyvars $ \ names ->
     enclosed_scope (zipWith replaceTyVarName tyvar_names names)
 
-bindPatSigTyVars :: [RdrNameHsType]
-                -> RnM (a, FreeVars)
-                -> RnM (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
+bindPatSigTyVars tys thing_inside
   = getLocalRdrEnv             `thenM` \ name_env ->
     getSrcLocM                 `thenM` \ loc ->
     let
@@ -813,10 +810,15 @@ 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                             `thenM` \ (thing, fvs) ->
-    returnM (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
@@ -895,7 +897,6 @@ mkGlobalRdrEnv this_mod unqual_imp mk_provenance avails deprecs
                                   else Just parent, 
                      gre_prov   = mk_provenance name, 
                      gre_deprec = lookupDeprec deprecs name}
-                     
 \end{code}
 
 \begin{code}
@@ -994,12 +995,8 @@ warnUnusedBinds names
    groups = equivClasses cmp (filter reportable names)
    (_,prov1) `cmp` (_,prov2) = prov1 `compare` prov2
  
+   reportable (name,_) = reportIfUnused (nameOccName name)
 
-   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 "_".
 
 -------------------------
 
@@ -1010,7 +1007,7 @@ warnUnusedGroup names
     sep [msg <> colon, nest 4 (fsep (punctuate comma (map (ppr.fst) names)))]
   where
     (name1, prov1) = head names
-    loc1          = getSrcLoc name1
+    loc1          = nameSrcLoc name1
     (def_loc, msg) = case prov1 of
                        LocalDef                           -> (loc1, unused_msg)
                        NonLocalDef (UserImport mod loc _) -> (loc,  imp_from mod)