From: simonpj <unknown>
Date: Fri, 16 Jul 1999 09:36:08 +0000 (+0000)
Subject: [project @ 1999-07-16 09:36:07 by simonpj]
X-Git-Tag: Approximately_9120_patches~5973
X-Git-Url: http://git.megacz.com/?a=commitdiff_plain;h=c3cf681e8f65430d4e0dcef08c8f7b75332a034e;hp=bcfdbbe5a48c7d18089c3d4a2e2758a3b9291482;p=ghc-hetmet.git

[project @ 1999-07-16 09:36:07 by simonpj]
* Fix long-standing bug in TcIfaceSig which meant it occasionally complained
  about a lint error in an unfolding, with a locally-defined name not
  being in scope.   This only happened when hi-boot loops were being
  tied, so an unfolding might mention a locally-defined name.
---

diff --git a/ghc/compiler/typecheck/TcEnv.lhs b/ghc/compiler/typecheck/TcEnv.lhs
index 586c5a5..49da0db 100644
--- a/ghc/compiler/typecheck/TcEnv.lhs
+++ b/ghc/compiler/typecheck/TcEnv.lhs
@@ -22,6 +22,7 @@ module TcEnv(
 	tcLookupValue,      tcLookupValueMaybe, 
 	tcLookupValueByKey, tcLookupValueByKeyMaybe,
 	explicitLookupValueByKey, explicitLookupValue,
+	valueEnvIds,
 
 	newLocalId, newSpecPragmaId,
 	tcGetGlobalTyVars, tcExtendGlobalTyVars,
@@ -152,6 +153,9 @@ type UsageEnv   = NameEnv UVar
 type TypeEnv	= NameEnv (TcKind, Maybe Arity, TcTyThing)
 type ValueEnv	= NameEnv Id	
 
+valueEnvIds :: ValueEnv -> [Id]
+valueEnvIds ve = eltsUFM ve
+
 data TcTyThing = ATyVar TcTyVar		-- Mutable only so that the kind can be mutable
 					-- if the kind is mutable, the tyvar must be so that
 					-- zonking works
diff --git a/ghc/compiler/typecheck/TcIfaceSig.lhs b/ghc/compiler/typecheck/TcIfaceSig.lhs
index 4aba2a1..bb63100 100644
--- a/ghc/compiler/typecheck/TcIfaceSig.lhs
+++ b/ghc/compiler/typecheck/TcIfaceSig.lhs
@@ -19,7 +19,7 @@ import TcMonoType	( tcHsType, tcHsTypeKind,
 import TcEnv		( ValueEnv, tcExtendTyVarEnv, 
 			  tcExtendGlobalValEnv, tcSetValueEnv,
 			  tcLookupTyConByKey, tcLookupValueMaybe,
-			  explicitLookupValue, badCon, badPrimOp
+			  explicitLookupValue, badCon, badPrimOp, valueEnvIds
 			)
 import TcType		( TcKind, kindToTcKind )
 
@@ -42,7 +42,7 @@ import DataCon		( dataConSig, dataConArgTys )
 import Type		( mkSynTy, mkTyVarTys, splitAlgTyConApp, unUsgTy )
 import Var		( IdOrTyVar, mkTyVar, tyVarKind )
 import VarEnv
-import Name		( Name, NamedThing(..) )
+import Name		( Name, NamedThing(..), isLocallyDefined )
 import Unique		( rationalTyConKey )
 import TysWiredIn	( integerTy, stringTy )
 import Demand		( wwLazy )
@@ -65,23 +65,23 @@ tcInterfaceSigs :: ValueEnv		-- Envt to use when checking unfoldings
 		-> TcM s [Id]
 		
 
-tcInterfaceSigs unf_env (SigD (IfaceSig name ty id_infos src_loc) : rest)
-  = tcAddSrcLoc src_loc (
-    tcAddErrCtxt (ifaceSigCtxt name) (
-	tcHsType ty						`thenTc` \ sigma_ty ->
-	tcIdInfo unf_env name sigma_ty vanillaIdInfo id_infos	`thenTc` \ id_info ->
+tcInterfaceSigs unf_env decls
+  = listTc [ do_one name ty id_infos src_loc
+	   | SigD (IfaceSig name ty id_infos src_loc) <- decls]
+  where
+    in_scope_vars = filter isLocallyDefined (valueEnvIds unf_env)
+
+    do_one name ty id_infos src_loc
+      = tcAddSrcLoc src_loc 		 		$	
+	tcAddErrCtxt (ifaceSigCtxt name)		$
+	tcHsType ty					`thenTc` \ sigma_ty ->
+	tcIdInfo unf_env in_scope_vars name 
+		 sigma_ty vanillaIdInfo id_infos	`thenTc` \ id_info ->
 	returnTc (mkId name sigma_ty id_info)
-    ))						`thenTc` \ sig_id ->
-    tcInterfaceSigs unf_env rest		`thenTc` \ sig_ids ->
-    returnTc (sig_id : sig_ids)
-
-tcInterfaceSigs unf_env (other_decl : rest) = tcInterfaceSigs unf_env rest
-
-tcInterfaceSigs unf_env [] = returnTc []
 \end{code}
 
 \begin{code}
-tcIdInfo unf_env name ty info info_ins
+tcIdInfo unf_env in_scope_vars name ty info info_ins
   = foldlTc tcPrag vanillaIdInfo info_ins
   where
     tcPrag info (HsArity arity) = returnTc (info `setArityInfo`  arity)
@@ -91,7 +91,7 @@ tcIdInfo unf_env name ty info info_ins
 
     tcPrag info (HsUnfold inline_prag maybe_expr)
 	= (case maybe_expr of
-		Just expr -> tcPragExpr unf_env name [] expr
+		Just expr -> tcPragExpr unf_env name in_scope_vars expr
 		Nothing   -> returnNF_Tc Nothing
 	  )				 	`thenNF_Tc` \ maybe_expr' ->
 	  let
diff --git a/ghc/compiler/typecheck/TcMonoType.lhs b/ghc/compiler/typecheck/TcMonoType.lhs
index 6569592..86963d3 100644
--- a/ghc/compiler/typecheck/TcMonoType.lhs
+++ b/ghc/compiler/typecheck/TcMonoType.lhs
@@ -21,7 +21,7 @@ import TcHsSyn		( TcId )
 import TcMonad
 import TcEnv		( tcExtendTyVarEnv, tcLookupTy, tcGetValueEnv, tcGetInScopeTyVars,
                           tcExtendUVarEnv, tcLookupUVar,
-			  tcGetGlobalTyVars, TcTyThing(..)
+			  tcGetGlobalTyVars, valueEnvIds, TcTyThing(..)
 			)
 import TcType		( TcType, TcKind, TcTyVar, TcThetaType, TcTauType,
 			  typeToTcType, kindToTcKind,
@@ -51,7 +51,6 @@ import Name		( Name, OccName, isLocallyDefined )
 import TysWiredIn	( mkListTy, mkTupleTy, mkUnboxedTupleTy )
 import SrcLoc		( SrcLoc )
 import Unique		( Unique, Uniquable(..) )
-import UniqFM		( eltsUFM )
 import Util		( zipWithEqual, zipLazy, mapAccumL )
 import Outputable
 \end{code}
@@ -562,7 +561,7 @@ checkSigTyVars sig_tyvars
 	    if tv `elemVarSet` globals	-- Error (c)! Type variable escapes
 					-- The least comprehensible, so put it last
 	    then   tcGetValueEnv 			`thenNF_Tc` \ ve ->
-        	   find_globals tv env (eltsUFM ve) 	`thenNF_Tc` \ (env1, globs) ->
+        	   find_globals tv env (valueEnvIds ve) `thenNF_Tc` \ (env1, globs) ->
 		   returnNF_Tc (env1, acc, escape_msg sig_tyvar tv globs : msgs)
 
 	    else 	-- All OK