[project @ 2004-12-24 11:02:39 by simonpj]

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

diff --git a/ghc/compiler/typecheck/TcEnv.lhs b/ghc/compiler/typecheck/TcEnv.lhs
index 1aa86dc..2f64d4c 100644 (file)
--- a/ghc/compiler/typecheck/TcEnv.lhs
+++ b/ghc/compiler/typecheck/TcEnv.lhs
@@ -49,14 +49,14 @@ import HsSyn                ( LRuleDecl, LHsBinds, LSig, pprLHsBinds )
 import TcIface         ( tcImportDecl )
 import TcRnMonad
 import TcMType         ( zonkTcType, zonkTcTyVar, zonkTcTyVarsAndFV )
-import TcType          ( Type, TcKind, TcTyVar, TcTyVarSet, 
+import TcType          ( Type, TcKind, TcTyVar, TcTyVarSet, TcType,
                          tyVarsOfType, tyVarsOfTypes, tcSplitDFunTy, mkGenTyConApp,
-                         getDFunTyKey, tcTyConAppTyCon, 
+                         getDFunTyKey, tcTyConAppTyCon, tcGetTyVar, mkTyVarTy,
                          tidyOpenType, tidyOpenTyVar, pprTyThingCategory
                        )
 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 )
@@ -197,12 +197,12 @@ tcLookup name
        Nothing    -> tcLookupGlobal name `thenM` \ thing ->
                      returnM (AGlobal thing)
 
-tcLookupTyVar :: Name -> TcM Id
+tcLookupTyVar :: Name -> TcM TcTyVar
 tcLookupTyVar name
   = tcLookup name      `thenM` \ thing -> 
     case thing of
-       ATyVar tv -> returnM tv
-       other     -> pprPanic "tcLookupTyVar" (ppr name)
+       ATyVar _ ty -> returnM (tcGetTyVar "tcLookupTyVar" ty)
+       other       -> pprPanic "tcLookupTyVar" (ppr name)
 
 tcLookupId :: Name -> TcM Id
 -- Used when we aren't interested in the binding level
@@ -248,22 +248,17 @@ tcExtendKindEnv things thing_inside
 
 tcExtendTyVarEnv :: [TyVar] -> TcM r -> TcM r
 tcExtendTyVarEnv tvs thing_inside
-  = tc_extend_tv_env [(getName tv, ATyVar tv) | tv <- tvs] 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 [(getName tv1, ATyVar tv2) | (tv1,tv2) <- tv_pairs]
-                    [tv | (_,tv) <- tv_pairs]
-                    thing_inside
-
-tc_extend_tv_env binds tyvars 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
-       le'        = extendNameEnvList le binds
        rdr_env'   = extendLocalRdrEnv rdr_env (map fst binds)
-       new_tv_set = mkVarSet tyvars
+       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
@@ -343,22 +338,22 @@ find_thing ignore_it tidy_env (ATcId id _ _)
     in
     returnM (tidy_env', Just msg)
 
-find_thing ignore_it tidy_env (ATyVar tv)
-  = zonkTcTyVar tv             `thenM` \ tv_ty ->
+find_thing ignore_it tidy_env (ATyVar tv ty)
+  = zonkTcType ty              `thenM` \ 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 [ppr tv <+> eq_stuff, nest 2 bound_at]
 
        eq_stuff | Just tv' <- Type.getTyVar_maybe tv_ty, 
-                  tv == tv' = empty
+                  tv == tyVarName 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)
     in
-    returnM (tidy_env2, Just msg)
+    returnM (tidy_env1, Just msg)
 \end{code}
 
 
@@ -485,7 +480,7 @@ topIdLvl id | isLocalId id = topLevel
 -- Indicates the legal transitions on bracket( [| |] ).
 bracketOK :: ThStage -> Maybe ThLevel
 bracketOK (Brack _ _ _) = Nothing      -- Bracket illegal inside a bracket
-bracketOK stage         = (Just (thLevel stage + 1))
+bracketOK stage         = Just (thLevel stage + 1)
 
 -- Indicates the legal transitions on splice($).
 spliceOK :: ThStage -> Maybe ThLevel
@@ -556,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
@@ -606,6 +601,6 @@ wrongThingErr expected thing name
                ptext SLIT("used as a") <+> text expected)
   where
     pp_thing (AGlobal thing) = pprTyThingCategory thing
-    pp_thing (ATyVar _)      = ptext SLIT("Type variable")
+    pp_thing (ATyVar _ _)    = ptext SLIT("Type variable")
     pp_thing (ATcId _ _ _)   = ptext SLIT("Local identifier")
 \end{code}