[project @ 2000-10-16 16:39:29 by sewardj]

[ghc-hetmet.git] / ghc / compiler / typecheck / TcMonoType.lhs

diff --git a/ghc/compiler/typecheck/TcMonoType.lhs b/ghc/compiler/typecheck/TcMonoType.lhs
index 38e4cbf..531baeb 100644 (file)
--- a/ghc/compiler/typecheck/TcMonoType.lhs
+++ b/ghc/compiler/typecheck/TcMonoType.lhs
@@ -25,10 +25,10 @@ import TcHsSyn              ( TcId )
 
 import TcMonad
 import TcEnv           ( tcExtendTyVarEnv, tcExtendKindEnv, 
-                         tcLookup, tcLookupGlobal,
-                         tcGetEnv, tcEnvTyVars, tcEnvTcIds,
+                         tcLookupGlobal, tcLookup,
+                         tcEnvTcIds, tcEnvTyVars,
                          tcGetGlobalTyVars, 
-                         TyThing(..)
+                         TyThing(..), TcTyThing(..)
                        )
 import TcType          ( TcType, TcKind, TcTyVar, TcThetaType, TcTauType,
                          newKindVar, tcInstSigVar,
@@ -51,8 +51,8 @@ import Type           ( Type, Kind, PredType(..), ThetaType, UsageAnn(..),
                        )
 import PprType         ( pprType, pprPred )
 import Subst           ( mkTopTyVarSubst, substTy )
-import Id              ( mkVanillaId, idName, idType, idFreeTyVars )
-import Var             ( TyVar, mkTyVar, tyVarKind )
+import Id              ( Id, mkVanillaId, idName, idType, idFreeTyVars )
+import Var             ( Var, TyVar, mkTyVar, tyVarKind )
 import VarEnv
 import VarSet
 import ErrUtils                ( Message )
@@ -65,7 +65,7 @@ import BasicTypes     ( Boxity(..) )
 import SrcLoc          ( SrcLoc )
 import Util            ( mapAccumL, isSingleton )
 import Outputable
-
+import HscTypes                ( TyThing(..) )
 \end{code}
 
 
@@ -747,44 +747,54 @@ checkSigTyVars sig_tyvars free_tyvars
 
        main_msg = ptext SLIT("Inferred type is less polymorphic than expected")
 
-       check (env, acc, msgs) (sig_tyvar,ty)
+       check (tidy_env, acc, msgs) (sig_tyvar,ty)
                -- sig_tyvar is from the signature;
                -- ty is what you get if you zonk sig_tyvar and then tidy it
                --
                -- acc maps a zonked type variable back to a signature type variable
          = case getTyVar_maybe ty of {
              Nothing ->                        -- Error (a)!
-                       returnNF_Tc (env, acc, unify_msg sig_tyvar (ppr ty) : msgs) ;
+                       returnNF_Tc (tidy_env, acc, unify_msg sig_tyvar (ppr ty) : msgs) ;
 
              Just tv ->
 
            case lookupVarEnv acc tv of {
                Just sig_tyvar' ->      -- Error (b) or (d)!
-                       returnNF_Tc (env, acc, unify_msg sig_tyvar (ppr sig_tyvar') : msgs) ;
+                       returnNF_Tc (tidy_env, acc, unify_msg sig_tyvar (ppr sig_tyvar') : msgs) ;
 
                Nothing ->
 
            if tv `elemVarSet` globals  -- Error (c)! Type variable escapes
                                        -- The least comprehensible, so put it last
-           then   tcGetEnv                                             `thenNF_Tc` \ env ->
-                  find_globals tv env  [] (tcEnvTcIds)                 `thenNF_Tc` \ (env1, globs) ->
-                  find_frees   tv env1 [] (varSetElems free_tyvars)    `thenNF_Tc` \ (env2, frees) ->
-                  returnNF_Tc (env2, acc, escape_msg sig_tyvar tv globs frees : msgs)
+                       -- Game plan: 
+                       --    a) get the local TcIds from the environment,
+                       --       and pass them to find_globals (they might have tv free)
+                       --    b) similarly, find any free_tyvars that mention tv
+           then   tcGetEnv                                                     `thenNF_Tc` \ tc_env ->
+                  find_globals tv tidy_env  [] (tcEnvTcIds tc_env)             `thenNF_Tc` \ (tidy_env1, globs) ->
+                  find_frees   tv tidy_env1 [] (varSetElems free_tyvars)       `thenNF_Tc` \ (tidy_env2, frees) ->
+                  returnNF_Tc (tidy_env2, acc, escape_msg sig_tyvar tv globs frees : msgs)
 
            else        -- All OK
-           returnNF_Tc (env, extendVarEnv acc tv sig_tyvar, msgs)
+           returnNF_Tc (tidy_env, extendVarEnv acc tv sig_tyvar, msgs)
            }}
 
 -- find_globals looks at the value environment and finds values
 -- whose types mention the offending type variable.  It has to be 
 -- careful to zonk the Id's type first, so it has to be in the monad.
 -- We must be careful to pass it a zonked type variable, too.
+
+find_globals :: Var 
+             -> TidyEnv 
+             -> [(Name,Type)] 
+             -> [Id] 
+             -> NF_TcM (TidyEnv,[(Name,Type)])
+
 find_globals tv tidy_env acc []
   = returnNF_Tc (tidy_env, acc)
 
 find_globals tv tidy_env acc (id:ids) 
-  | not (isLocallyDefined id) ||
-    isEmptyVarSet (idFreeTyVars id)
+  | isEmptyVarSet (idFreeTyVars id)
   = find_globals tv tidy_env acc ids
 
   | otherwise