[project @ 2001-11-19 16:34:12 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 ffcd10b..11800c4 100644 (file)
--- a/ghc/compiler/rename/RnEnv.lhs
+++ b/ghc/compiler/rename/RnEnv.lhs
@@ -11,9 +11,10 @@ module RnEnv where           -- Export everything
 import {-# SOURCE #-} RnHiFiles
 
 import HsSyn
-import RdrHsSyn                ( RdrNameIE )
+import RdrHsSyn                ( RdrNameIE, RdrNameHsType, extractHsTyRdrTyVars )
 import RdrName         ( RdrName, rdrNameModule, rdrNameOcc, isQual, isUnqual, isOrig,
-                         mkRdrUnqual, mkRdrQual, lookupRdrEnv, foldRdrEnv, rdrEnvToList,
+                         mkRdrUnqual, mkRdrQual, 
+                         lookupRdrEnv, foldRdrEnv, rdrEnvToList, elemRdrEnv,
                          unqualifyRdrName
                        )
 import HsTypes         ( hsTyVarName, replaceTyVarName )
@@ -54,7 +55,6 @@ import ListSetOps     ( removeDups, equivClasses )
 import Util            ( sortLt )
 import List            ( nub )
 import UniqFM          ( lookupWithDefaultUFM )
-import Maybes          ( orElse )
 import CmdLineOpts
 import FastString      ( FastString )
 \end{code}
@@ -482,31 +482,34 @@ bindLocatedLocalsRn :: SDoc       -- Documentation string for error message
                    -> RnMS a
 bindLocatedLocalsRn doc_str rdr_names_w_loc enclosed_scope
   = getModeRn                          `thenRn` \ mode ->
-    getLocalNameEnv                    `thenRn` \ name_env ->
+    getLocalNameEnv                    `thenRn` \ local_env ->
+    getGlobalNameEnv                   `thenRn` \ global_env ->
 
        -- Check for duplicate names
     checkDupOrQualNames doc_str rdr_names_w_loc        `thenRn_`
 
        -- 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)
+        | otherwise 
+       = returnRn ()
+    in
+
     (case mode of
        SourceMode -> ifOptRn Opt_WarnNameShadowing     $
-                     mapRn_ (check_shadow name_env) rdr_names_w_loc
+                     mapRn_ check_shadow rdr_names_w_loc
        other      -> returnRn ()
     )                                  `thenRn_`
-       
+
     newLocalsRn rdr_names_w_loc                `thenRn` \ names ->
     let
-       new_local_env = addListToRdrEnv name_env (map fst rdr_names_w_loc `zip` names)
+       new_local_env = addListToRdrEnv local_env (map fst rdr_names_w_loc `zip` names)
     in
     setLocalNameEnv new_local_env (enclosed_scope names)
 
-  where
-    check_shadow name_env (rdr_name,loc)
-       = case lookupRdrEnv name_env rdr_name of
-               Nothing   -> returnRn ()
-               Just name -> pushSrcLocRn loc $
-                            addWarnRn (shadowedNameWarn rdr_name)
-
 bindCoreLocalRn :: RdrName -> (Name -> RnMS a) -> RnMS a
   -- A specialised variant when renaming stuff from interface
   -- files (of which there is a lot)
@@ -591,32 +594,29 @@ bindTyVars2Rn doc_str tyvar_names enclosed_scope
     bindLocatedLocalsRn doc_str located_tyvars $ \ names ->
     enclosed_scope names (zipWith replaceTyVarName tyvar_names names)
 
-bindTyVarsFVRn :: SDoc -> [HsTyVarBndr RdrName]
-             -> ([HsTyVarBndr Name] -> RnMS (a, FreeVars))
-             -> RnMS (a, FreeVars)
-bindTyVarsFVRn doc_str rdr_names enclosed_scope
-  = bindTyVars2Rn doc_str rdr_names    $ \ names tyvars ->
-    enclosed_scope tyvars              `thenRn` \ (thing, fvs) ->
-    returnRn (thing, delListFromNameSet fvs names)
-
-bindTyVarsFV2Rn :: SDoc -> [HsTyVarBndr RdrName]
-             -> ([Name] -> [HsTyVarBndr Name] -> RnMS (a, FreeVars))
-             -> RnMS (a, FreeVars)
-bindTyVarsFV2Rn doc_str rdr_names enclosed_scope
-  = bindTyVars2Rn doc_str rdr_names    $ \ names tyvars ->
-    enclosed_scope names tyvars                `thenRn` \ (thing, fvs) ->
-    returnRn (thing, delListFromNameSet fvs names)
+bindPatSigTyVars :: [RdrNameHsType]
+                -> RnMS (a, FreeVars)
+                -> RnMS (a, FreeVars)
+  -- Find the type variables in the pattern type 
+  -- signatures that must be brought into scope
 
-bindNakedTyVarsFVRn :: SDoc -> [RdrName]
-                   -> ([Name] -> RnMS (a, FreeVars))
-                   -> RnMS (a, FreeVars)
-bindNakedTyVarsFVRn doc_str tyvar_names enclosed_scope
-  = getSrcLocRn                                        `thenRn` \ loc ->
+bindPatSigTyVars tys enclosed_scope
+  = getLocalNameEnv                    `thenRn` \ name_env ->
+    getSrcLocRn                                `thenRn` \ loc ->
     let
-       located_tyvars = [(tv, loc) | tv <- tyvar_names] 
+       forall_tyvars  = nub [ tv | ty <- tys,
+                                   tv <- extractHsTyRdrTyVars ty, 
+                                   not (tv `elemFM` name_env)
+                        ]
+               -- The 'nub' is important.  For example:
+               --      f (x :: t) (y :: t) = ....
+               -- We don't want to complain about binding t twice!
+
+       located_tyvars = [(tv, loc) | tv <- forall_tyvars] 
+       doc_sig        = text "In a pattern type-signature"
     in
-    bindLocatedLocalsRn doc_str located_tyvars $ \ names ->
-    enclosed_scope names                       `thenRn` \ (thing, fvs) ->
+    bindLocatedLocalsRn doc_sig located_tyvars $ \ names ->
+    enclosed_scope                             `thenRn` \ (thing, fvs) ->
     returnRn (thing, delListFromNameSet fvs names)