[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 (file)
--- 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 (file)
--- 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 (file)
--- 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