[project @ 2005-03-04 19:19:56 by sof]

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

diff --git a/ghc/compiler/typecheck/TcEnv.lhs b/ghc/compiler/typecheck/TcEnv.lhs
index 50f5c2b..12192a9 100644 (file)
--- a/ghc/compiler/typecheck/TcEnv.lhs
+++ b/ghc/compiler/typecheck/TcEnv.lhs
@@ -17,12 +17,12 @@ module TcEnv(
        
        -- Local environment
        tcExtendKindEnv,
-       tcExtendTyVarEnv, tcExtendTyVarEnv2, tcExtendTyVarEnv3, 
+       tcExtendTyVarEnv, tcExtendTyVarEnv2, 
        tcExtendIdEnv, tcExtendIdEnv1, tcExtendIdEnv2, 
        tcLookup, tcLookupLocated, tcLookupLocalIds,
        tcLookupId, tcLookupTyVar,
        lclEnvElts, getInLocalScope, findGlobals, 
-       wrongThingErr,
+       wrongThingErr, pprBinders,
 
        tcExtendRecEnv,         -- For knot-tying
 
@@ -47,16 +47,17 @@ module TcEnv(
 
 import HsSyn           ( LRuleDecl, LHsBinds, LSig, pprLHsBinds )
 import TcIface         ( tcImportDecl )
+import TcRnTypes       ( pprTcTyThingCategory )
 import TcRnMonad
-import TcMType         ( zonkTcType, zonkTcTyVar, zonkTcTyVarsAndFV )
+import TcMType         ( zonkTcType, zonkTcTyVarsAndFV )
 import TcType          ( Type, TcKind, TcTyVar, TcTyVarSet, TcType,
                          tyVarsOfType, tyVarsOfTypes, tcSplitDFunTy, mkGenTyConApp,
                          getDFunTyKey, tcTyConAppTyCon, tcGetTyVar, mkTyVarTy,
-                         tidyOpenType, tidyOpenTyVar, pprTyThingCategory
+                         tidyOpenType 
                        )
 import qualified Type  ( getTyVar_maybe )
 import Id              ( idName, isLocalId )
-import Var             ( TyVar, Id, idType )
+import Var             ( TyVar, Id, idType, tyVarName )
 import VarSet
 import VarEnv
 import RdrName         ( extendLocalRdrEnv )
@@ -105,8 +106,7 @@ tcLookupGlobal name
        { (eps,hpt) <- getEpsAndHpt
        ; case lookupType hpt (eps_PTE eps) name of 
            Just thing -> return thing 
-           Nothing    -> do { traceIf (text "tcLookupGlobal" <+> ppr name)
-                            ; initIfaceTcRn (tcImportDecl name) }
+           Nothing    -> tcImportDecl name
     }}
 \end{code}
 
@@ -248,25 +248,17 @@ tcExtendKindEnv things thing_inside
 
 tcExtendTyVarEnv :: [TyVar] -> TcM r -> TcM r
 tcExtendTyVarEnv tvs thing_inside
-  = tc_extend_tv_env [ATyVar tv (mkTyVarTy tv) | tv <- tvs] thing_inside
+  = tcExtendTyVarEnv2 [(tyVarName tv, mkTyVarTy tv) | tv <- tvs] thing_inside
 
-tcExtendTyVarEnv2 :: [(TyVar,TcTyVar)] -> TcM r -> TcM r
-tcExtendTyVarEnv2 tv_pairs thing_inside
-  = tc_extend_tv_env [ATyVar tv1 (mkTyVarTy tv2) | (tv1,tv2) <- tv_pairs] thing_inside
-
-tcExtendTyVarEnv3 :: [(TyVar,TcType)] -> TcM r -> TcM r
-tcExtendTyVarEnv3 ty_pairs thing_inside
-  = tc_extend_tv_env [ATyVar tv1 ty2 | (tv1,ty2) <- ty_pairs] thing_inside
-
-tc_extend_tv_env binds thing_inside
+tcExtendTyVarEnv2 :: [(Name,TcType)] -> TcM r -> TcM r
+tcExtendTyVarEnv2 binds thing_inside
   = getLclEnv     `thenM` \ env@(TcLclEnv {tcl_env = le, 
                                            tcl_tyvars = gtvs, 
                                            tcl_rdr = rdr_env}) ->
     let
-       names      = [getName tv | ATyVar tv _ <- binds]
-       rdr_env'   = extendLocalRdrEnv rdr_env names
-       le'        = extendNameEnvList le (names `zip` binds)
-       new_tv_set = tyVarsOfTypes [ty | ATyVar _ ty <- binds]
+       rdr_env'   = extendLocalRdrEnv rdr_env (map fst binds)
+       new_tv_set = tyVarsOfTypes (map snd binds)
+       le'        = extendNameEnvList le [(name, ATyVar name ty) | (name, ty) <- binds]
     in
        -- It's important to add the in-scope tyvars to the global tyvar set
        -- as well.  Consider
@@ -351,17 +343,17 @@ find_thing ignore_it tidy_env (ATyVar tv ty)
     if ignore_it tv_ty then
        returnM (tidy_env, Nothing)
     else let
-       (tidy_env1, tv1)     = tidyOpenTyVar tidy_env  tv
-       (tidy_env2, tidy_ty) = tidyOpenType  tidy_env1 tv_ty
-       msg = sep [ppr tv1 <+> eq_stuff, nest 2 bound_at]
+       -- The name tv is scoped, so we don't need to tidy it
+       (tidy_env1, tidy_ty) = tidyOpenType  tidy_env tv_ty
+       msg = sep [ptext SLIT("Scoped type variable") <+> quotes (ppr tv) <+> eq_stuff, nest 2 bound_at]
 
        eq_stuff | Just tv' <- Type.getTyVar_maybe tv_ty, 
-                  tv == tv' = empty
+                  getOccName tv == getOccName tv' = empty
                 | otherwise = equals <+> ppr tidy_ty
                -- It's ok to use Type.getTyVar_maybe because ty is zonked by now
-       bound_at = ptext SLIT("bound at:") <+> ppr (getSrcLoc tv)
+       bound_at = parens $ ptext SLIT("bound at:") <+> ppr (getSrcLoc tv)
     in
-    returnM (tidy_env2, Just msg)
+    returnM (tidy_env1, Just msg)
 \end{code}
 
 
@@ -559,8 +551,8 @@ as well as explicit user written ones.
 \begin{code}
 data InstInfo
   = InstInfo {
-      iDFunId :: DFunId,               -- The dfun id
-      iBinds  :: InstBindings
+      iDFunId :: DFunId,               -- The dfun id.  Its forall'd type variables 
+      iBinds  :: InstBindings          -- scope over the stuff in InstBindings!
     }
 
 data InstBindings
@@ -600,15 +592,17 @@ simpleInstInfoTyCon inst = tcTyConAppTyCon (simpleInstInfoTy inst)
 %************************************************************************
 
 \begin{code}
+pprBinders :: [Name] -> SDoc
+-- Used in error messages
+-- Use quotes for a single one; they look a bit "busy" for several
+pprBinders [bndr] = quotes (ppr bndr)
+pprBinders bndrs  = pprWithCommas ppr bndrs
+
 notFound name 
   = failWithTc (ptext SLIT("GHC internal error:") <+> quotes (ppr name) <+> 
                ptext SLIT("is not in scope"))
 
 wrongThingErr expected thing name
-  = failWithTc (pp_thing thing <+> quotes (ppr name) <+> 
+  = failWithTc (pprTcTyThingCategory thing <+> quotes (ppr name) <+> 
                ptext SLIT("used as a") <+> text expected)
-  where
-    pp_thing (AGlobal thing) = pprTyThingCategory thing
-    pp_thing (ATyVar _ _)    = ptext SLIT("Type variable")
-    pp_thing (ATcId _ _ _)   = ptext SLIT("Local identifier")
 \end{code}