X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2Ftypecheck%2FTcEnv.lhs;h=fe0cac9de1561cb0b27211ec38f5d6dc7e94dcdd;hb=3160f854580e6d8df412c8cd34d93bae27175d67;hp=6106df145d59eba354b8c8d40dc77b3faa37973f;hpb=83817d01dff687643eee23218435b968ba358a25;p=ghc-hetmet.git

diff --git a/ghc/compiler/typecheck/TcEnv.lhs b/ghc/compiler/typecheck/TcEnv.lhs
index 6106df1..fe0cac9 100644
--- a/ghc/compiler/typecheck/TcEnv.lhs
+++ b/ghc/compiler/typecheck/TcEnv.lhs
@@ -1,109 +1,117 @@
 \begin{code}
 module TcEnv(
-	TcIdOcc(..), TcIdBndr, tcIdType, tcIdTyVars, tcInstId,
+	TcId, TcIdSet, tcInstId,
+	tcLookupDataCon,
 
-	TcEnv, 
+	TcEnv, ValueEnv, TcTyThing(..),
 
-	initEnv, getEnv_LocalIds, getEnv_TyCons, getEnv_Classes,
+	initEnv, getEnvTyCons, getEnvClasses,
 	
-	tcExtendTyVarEnv, tcLookupTyVar, 
+	tcExtendTyVarEnv, tcExtendTyVarEnvForMeths, tcExtendTypeEnv, tcGetInScopeTyVars,
 
-	tcExtendTyConEnv, tcLookupTyCon, tcLookupTyConByKey, 
-	tcExtendClassEnv, tcLookupClass, tcLookupClassByKey,
-	tcGetTyConsAndClasses,
+	tcLookupTy,
+	tcLookupTyCon, tcLookupTyConByKey, 
+	tcLookupClass, tcLookupClassByKey,
 
 	tcExtendGlobalValEnv, tcExtendLocalValEnv,
-	tcLookupLocalValue, tcLookupLocalValueOK, tcLookupLocalValueByKey, 
-	tcLookupGlobalValue, tcLookupGlobalValueByKey, tcLookupGlobalValueMaybe,
-	tcAddImportedIdInfo, tcExplicitLookupGlobal,
-	tcLookupGlobalValueByKeyMaybe, 
+	tcGetValueEnv,        tcSetValueEnv, 
+	tcAddImportedIdInfo,
 
-	newMonoIds, newLocalIds, newLocalId, newSpecPragmaId,
-	tcGetGlobalTyVars, tcExtendGlobalTyVars
+	tcLookupValue,      tcLookupValueMaybe, 
+	tcLookupValueByKey, tcLookupValueByKeyMaybe,
+	explicitLookupValueByKey, explicitLookupValue,
+
+	newLocalIds, newLocalId, newSpecPragmaId,
+	tcGetGlobalTyVars, tcExtendGlobalTyVars,
+
+	badCon, badPrimOp
   ) where
 
 #include "HsVersions.h"
 
-import MkId	( mkUserLocal, mkUserId, mkSpecPragmaId )
-import Id	( Id, GenId, idType, replaceIdInfo, idInfo )
-import TcKind	( TcKind, kindToTcKind, Kind )
-import TcType	( TcType, TcMaybe, TcTyVar, TcTyVarSet, TcThetaType,
-		  newTyVarTys, tcInstTyVars, zonkTcTyVars, tcInstType
+import HsTypes	( HsTyVar, getTyVarName )
+import Id	( mkUserLocal, isDataConId_maybe )
+import MkId 	( mkSpecPragmaId )
+import Var	( TyVar, Id, setVarName,
+		  idType, setIdInfo, idInfo, tyVarKind
+		)
+import TcType	( TcType, TcTyVar, TcTyVarSet, TcThetaType,
+		  tcInstTyVars, zonkTcTyVars,
+		  TcKind, kindToTcKind
 		)
-import TyVar	( mkTyVarSet, unionTyVarSets, emptyTyVarSet, TyVar )
-import Type	( tyVarsOfType, tyVarsOfTypes, splitForAllTys, splitRhoTy )
-import TyCon	( TyCon, tyConKind, tyConArity, isSynTyCon, Arity )
+import VarEnv
+import VarSet
+import Type	( Kind, superKind,
+		  tyVarsOfType, tyVarsOfTypes, mkTyVarTy, substTy,
+		  splitForAllTys, splitRhoTy, splitFunTys, substTopTy,
+		  splitAlgTyConApp_maybe, getTyVar
+		)
+import DataCon	( DataCon )
+import TyCon	( TyCon, tyConKind, tyConArity, isSynTyCon )
 import Class	( Class )
 
 import TcMonad
 
+import BasicTypes	( Arity )
 import IdInfo		( noIdInfo )
-import Name		( Name, OccName(..), nameOccName,
+import Name		( Name, OccName, nameOccName, occNameString, mkLocalName,
 			  maybeWiredInTyConName, maybeWiredInIdName, isLocallyDefined,
+			  isSysLocalName,
 			  NamedThing(..)
 			)
-import Unique		( pprUnique10{-, pprUnique ToDo:rm-}, Unique, Uniquable(..) )
-import UniqFM	     
-import Util		( zipEqual, zipWithEqual, zipWith3Equal )
+import Unique		( pprUnique10, Unique, Uniquable(..) )
+import FiniteMap	( lookupFM, addToFM )
+import UniqFM
+import Unique		( Uniquable(..) )
+import Util		( zipEqual, zipWith3Equal, mapAccumL )
+import Bag		( bagToList )
 import Maybes		( maybeToBool )
+import FastString	( FastString )
 import Outputable
 \end{code}
 
 %************************************************************************
 %*									*
-\subsection{TcId, TcIdOcc}
+\subsection{TcId}
 %*									*
 %************************************************************************
 
 
 \begin{code}
-type TcIdBndr s = GenId  (TcType s)	-- Binders are all TcTypes
-data TcIdOcc  s = TcId   (TcIdBndr s)	-- Bindees may be either
-		| RealId Id
-
-instance Eq (TcIdOcc s) where
-  (TcId id1)   == (TcId id2)   = id1 == id2
-  (RealId id1) == (RealId id2) = id1 == id2
-  _	       == _	       = False
-
-instance Ord (TcIdOcc s) where
-  (TcId id1)   `compare` (TcId id2)   = id1 `compare` id2
-  (RealId id1) `compare` (RealId id2) = id1 `compare` id2
-  (TcId _)     `compare` (RealId _)   = LT
-  (RealId _)   `compare` (TcId _)     = GT
-
-instance Outputable (TcIdOcc s) where
-  ppr (TcId id)   = ppr id
-  ppr (RealId id) = ppr id
-
-instance NamedThing (TcIdOcc s) where
-  getName (TcId id)   = getName id
-  getName (RealId id) = getName id
-
-
-tcIdType :: TcIdOcc s -> TcType s
-tcIdType (TcId   id) = idType id
-tcIdType (RealId id) = pprPanic "tcIdType:" (ppr id)
-
-tcIdTyVars (TcId id)  = tyVarsOfType (idType id)
-tcIdTyVars (RealId _) = emptyTyVarSet		-- Top level Ids have no free type variables
-
+type TcId    = Id 			-- Type may be a TcType
+type TcIdSet = IdSet
+
+tcLookupDataCon :: Name -> TcM s (DataCon, [TcType], TcType)
+tcLookupDataCon con_name
+  = tcLookupValue con_name		`thenNF_Tc` \ con_id ->
+    case isDataConId_maybe con_id of {
+	Nothing -> failWithTc (badCon con_id);
+ 	Just data_con ->
+
+    tcInstId con_id			`thenNF_Tc` \ (_, _, con_tau) ->
+	     -- Ignore the con_theta; overloaded constructors only
+	     -- behave differently when called, not when used for
+	     -- matching.
+    let
+	(arg_tys, result_ty) = splitFunTys con_tau
+    in
+    ASSERT( maybeToBool (splitAlgTyConApp_maybe result_ty) )
+    returnTc (data_con, arg_tys, result_ty) }
 
 -- A useful function that takes an occurrence of a global thing
 -- and instantiates its type with fresh type variables
 tcInstId :: Id
-	 -> NF_TcM s ([TcTyVar s], 	-- It's instantiated type
-		      TcThetaType s,	--
-		      TcType s)		--
-
+	 -> NF_TcM s ([TcTyVar], 	-- It's instantiated type
+		      TcThetaType,	--
+		      TcType)		--
 tcInstId id
   = let
       (tyvars, rho) = splitForAllTys (idType id)
     in
     tcInstTyVars tyvars		`thenNF_Tc` \ (tyvars', arg_tys, tenv) ->
-    tcInstType tenv rho		`thenNF_Tc` \ rho' ->
     let
-	(theta', tau') = splitRhoTy rho'
+	rho'	       = substTopTy tenv rho
+	(theta', tau') = splitRhoTy rho' 
     in
     returnNF_Tc (tyvars', theta', tau')
 \end{code}
@@ -119,307 +127,308 @@ Data type declarations
 ~~~~~~~~~~~~~~~~~~~~~
 
 \begin{code}
-data TcEnv s = TcEnv
-		  (TyVarEnv s)
-		  (TyConEnv s)
-		  (ClassEnv s)
-		  (ValueEnv Id)			-- Globals
-		  (ValueEnv (TcIdBndr s))	-- Locals
-		  (TcRef s (TcTyVarSet s))	-- Free type variables of locals
-						-- ...why mutable? see notes with tcGetGlobalTyVars
-
-type TyVarEnv s  = UniqFM (TcKind s, TyVar)
-type TyConEnv s  = UniqFM (TcKind s, Maybe Arity, TyCon)	-- Arity present for Synonyms only
-type ClassEnv s  = UniqFM ([TcKind s], Class)		-- The kinds are the kinds of the args
-							-- to the class
-type ValueEnv id = UniqFM id
-
-initEnv :: TcRef s (TcTyVarSet s) -> TcEnv s
-initEnv mut = TcEnv emptyUFM emptyUFM emptyUFM emptyUFM emptyUFM mut 
-
-getEnv_LocalIds (TcEnv _ _ _ _ ls _) = eltsUFM ls
-getEnv_TyCons   (TcEnv _ ts _ _ _ _) = [tycon | (_, _, tycon) <- eltsUFM ts]
-getEnv_Classes  (TcEnv _ _ cs _ _ _) = [clas  | (_, clas)     <- eltsUFM cs]
+data TcEnv = TcEnv
+		  TypeEnv
+		  ValueEnv 
+		  (TcTyVarSet,		-- The in-scope TyVars
+		   TcRef TcTyVarSet)	-- Free type variables of the value env
+					-- ...why mutable? see notes with tcGetGlobalTyVars
+					-- Includes the in-scope tyvars
+
+type NameEnv val = UniqFM val		-- Keyed by Names
+
+type TypeEnv	= NameEnv (TcKind, Maybe Arity, TcTyThing)
+type ValueEnv	= NameEnv Id	
+
+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
+	       | ATyCon TyCon
+	       | AClass Class
+
+
+initEnv :: TcRef TcTyVarSet -> TcEnv
+initEnv mut = TcEnv emptyUFM emptyUFM (emptyVarSet, mut)
+
+getEnvTyCons  (TcEnv te _ _) = [tc | (_, _, ATyCon tc) <- eltsUFM te]
+getEnvClasses (TcEnv te _ _) = [cl | (_, _, AClass cl) <- eltsUFM te]
 \end{code}
 
-Type variable env
-~~~~~~~~~~~~~~~~~
+The TypeEnv
+~~~~~~~~~~~~
+
+Extending the type environment. 
+
 \begin{code}
-tcExtendTyVarEnv :: [Name] -> [(TcKind s, TyVar)] -> TcM s r -> TcM s r
-tcExtendTyVarEnv names kinds_w_types scope
-  = tcGetEnv					`thenNF_Tc` \ (TcEnv tve tce ce gve lve gtvs) ->
+tcExtendTyVarEnv :: [TyVar] -> TcM s r -> TcM s r
+tcExtendTyVarEnv tyvars scope
+  = tcGetEnv					`thenNF_Tc` \ (TcEnv te ve (in_scope_tvs, gtvs)) ->
     let
-	tve' = addListToUFM tve (zipEqual "tcTyVarScope" names kinds_w_types)
+	extend_list = [ (getName tv, (kindToTcKind (tyVarKind tv), Nothing, ATyVar tv))
+		      | tv <- tyvars
+		      ]
+ 	te'           = addListToUFM te extend_list
+	new_tv_set    = mkVarSet tyvars
+	in_scope_tvs' = in_scope_tvs `unionVarSet` new_tv_set
     in
-    tcSetEnv (TcEnv tve' tce ce gve lve gtvs) scope
-\end{code}
+	-- It's important to add the in-scope tyvars to the global tyvar set
+	-- as well.  Consider
+	--	f (x::r) = let g y = y::r in ...
+	-- Here, g mustn't be generalised.  This is also important during
+	-- class and instance decls, when we mustn't generalise the class tyvars
+	-- when typechecking the methods.
+    tc_extend_gtvs gtvs new_tv_set		`thenNF_Tc` \ gtvs' ->
+    tcSetEnv (TcEnv te' ve (in_scope_tvs', gtvs')) scope
+
+-- This variant, tcExtendTyVarEnvForMeths, takes *two* bunches of tyvars:
+--	the signature tyvars contain the original names
+--	the instance  tyvars are what those names should be mapped to
+-- It's needed when typechecking the method bindings of class and instance decls
+-- It does *not* extend the global tyvars; tcMethodBind does that for itself
+
+tcExtendTyVarEnvForMeths :: [TyVar] -> [TcTyVar] -> TcM s r -> TcM s r
+tcExtendTyVarEnvForMeths sig_tyvars inst_tyvars thing_inside
+  = tcGetEnv					`thenNF_Tc` \ (TcEnv te ve gtvs) ->
+    let
+	te' = addListToUFM te stuff
+    in
+    tcSetEnv (TcEnv te' ve gtvs) thing_inside
+  where
+    stuff = [ (getName sig_tv, (kindToTcKind (tyVarKind inst_tv), Nothing, ATyVar inst_tv))
+	    | (sig_tv, inst_tv) <- zipEqual "tcMeth" sig_tyvars inst_tyvars
+	    ]
 
-The Kind, TyVar, Class and TyCon envs
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+tcExtendGlobalTyVars extra_global_tvs scope
+  = tcGetEnv					`thenNF_Tc` \ (TcEnv te ve (in_scope,gtvs)) ->
+    tc_extend_gtvs gtvs	extra_global_tvs	`thenNF_Tc` \ gtvs' ->
+    tcSetEnv (TcEnv te ve (in_scope,gtvs')) scope
+
+tc_extend_gtvs gtvs extra_global_tvs
+  = tcReadMutVar gtvs			`thenNF_Tc` \ global_tvs ->
+    let
+	new_global_tyvars = global_tvs `unionVarSet` extra_global_tvs
+    in
+    tcNewMutVar new_global_tyvars
+\end{code}
 
-Extending the environments. 
+@tcGetGlobalTyVars@ returns a fully-zonked set of tyvars free in the environment.
+To improve subsequent calls to the same function it writes the zonked set back into
+the environment.
 
 \begin{code}
-tcExtendTyConEnv :: [(Name, (TcKind s, Maybe Arity, TyCon))] -> TcM s r -> TcM s r
-
-tcExtendTyConEnv bindings scope
-  = tcGetEnv					`thenNF_Tc` \ (TcEnv tve tce ce gve lve gtvs) ->
+tcGetGlobalTyVars :: NF_TcM s TcTyVarSet
+tcGetGlobalTyVars
+  = tcGetEnv 						`thenNF_Tc` \ (TcEnv te ve (_,gtvs)) ->
+    tcReadMutVar gtvs					`thenNF_Tc` \ global_tvs ->
+    zonkTcTyVars (varSetElems global_tvs)		`thenNF_Tc` \ global_tys' ->
     let
-	tce' = addListToUFM tce bindings
+	global_tvs' = (tyVarsOfTypes global_tys')
     in
-    tcSetEnv (TcEnv tve tce' ce gve lve gtvs) scope
+    tcWriteMutVar gtvs global_tvs'			`thenNF_Tc_` 
+    returnNF_Tc global_tvs'
+
+tcGetInScopeTyVars :: NF_TcM s [TcTyVar]
+tcGetInScopeTyVars
+  = tcGetEnv		`thenNF_Tc` \ (TcEnv te ve (in_scope_tvs, gtvs)) ->
+    returnNF_Tc (varSetElems in_scope_tvs)
+\end{code}
+
 
+Type constructors and classes
 
-tcExtendClassEnv :: [(Name, ([TcKind s], Class))] -> TcM s r -> TcM s r
-tcExtendClassEnv bindings scope
-  = tcGetEnv				`thenNF_Tc` \ (TcEnv tve tce ce gve lve gtvs) ->
+\begin{code}
+tcExtendTypeEnv :: [(Name, (TcKind, Maybe Arity, TcTyThing))] -> TcM s r -> TcM s r
+tcExtendTypeEnv bindings scope
+  = ASSERT( null [tv | (_, (_,_,ATyVar tv)) <- bindings] )
+	-- Not for tyvars; use tcExtendTyVarEnv
+    tcGetEnv					`thenNF_Tc` \ (TcEnv te ve gtvs) ->
     let
-	ce' = addListToUFM ce bindings
+	te' = addListToUFM te bindings
     in
-    tcSetEnv (TcEnv tve tce ce' gve lve gtvs) scope
+    tcSetEnv (TcEnv te' ve gtvs) scope
 \end{code}
 
 
 Looking up in the environments.
 
 \begin{code}
-tcLookupTyVar name
-  = tcGetEnv		`thenNF_Tc` \ (TcEnv tve tce ce gve lve gtvs) ->
-    returnNF_Tc (lookupWithDefaultUFM tve (pprPanic "tcLookupTyVar:" (ppr name)) name)
-
+tcLookupTy :: Name ->  NF_TcM s (TcKind, Maybe Arity, TcTyThing)
+tcLookupTy name
+  = tcGetEnv	`thenNF_Tc` \ (TcEnv te ve gtvs) ->
+    case lookupUFM te name of {
+	Just thing -> returnNF_Tc thing ;
+ 	Nothing    -> 
+
+    case maybeWiredInTyConName name of
+	Just tc -> returnNF_Tc (kindToTcKind (tyConKind tc), maybe_arity, ATyCon tc)
+		where
+		   maybe_arity | isSynTyCon tc = Just (tyConArity tc)
+			       | otherwise     = Nothing 
+
+	Nothing -> pprPanic "tcLookupTy" (ppr name)
+    }
+	
+tcLookupClass :: Name -> NF_TcM s Class
+tcLookupClass name
+  = tcLookupTy name	`thenNF_Tc` \ (_, _, AClass clas) ->
+    returnNF_Tc clas
 
+tcLookupTyCon :: Name -> NF_TcM s TyCon
 tcLookupTyCon name
-  =	-- Try for a wired-in tycon
-    case maybeWiredInTyConName name of {
-	Just tc | isSynTyCon tc -> returnTc (kind, Just (tyConArity tc), tc)
-		| otherwise     -> returnTc (kind, Nothing,              tc)
-		where {
-		  kind = kindToTcKind (tyConKind tc) 
-		};
-
-	Nothing -> 
-
-	    -- Try in the environment
-	  tcGetEnv	`thenNF_Tc` \ (TcEnv tve tce ce gve lve gtvs) ->
-          case lookupUFM tce name of {
-	      Just stuff -> returnTc stuff;
-
-	      Nothing    ->
-
-		-- Could be that he's using a class name as a type constructor
-	       case lookupUFM ce name of
-		 Just _  -> failWithTc (classAsTyConErr name)
-		 Nothing -> pprPanic "tcLookupTyCon:" (ppr name)
-	    } } 
-
-tcLookupTyConByKey uniq
-  = tcGetEnv		`thenNF_Tc` \ (TcEnv tve tce ce gve lve gtvs) ->
-    let 
-       (kind, arity, tycon) =  lookupWithDefaultUFM_Directly tce 
-					(pprPanic "tcLookupTyConByKey:" (pprUnique10 uniq)) 
-					uniq
-    in
+  = tcLookupTy name	`thenNF_Tc` \ (_, _, ATyCon tycon) ->
     returnNF_Tc tycon
 
-tcLookupClass name
-  = tcGetEnv		`thenNF_Tc` \ (TcEnv tve tce ce gve lve gtvs) ->
-    case lookupUFM ce name of
-	Just stuff         -- Common case: it's ok
-	  -> returnTc stuff
-
-	Nothing		   -- Could be that he's using a type constructor as a class
-	  |  maybeToBool (maybeWiredInTyConName name)
-	  || maybeToBool (lookupUFM tce name)
-	  -> failWithTc (tyConAsClassErr name)
-
-	  | otherwise      -- Wierd!  Renamer shouldn't let this happen
-	  -> pprPanic "tcLookupClass" (ppr name)
+tcLookupClassByKey :: Unique -> NF_TcM s Class
+tcLookupClassByKey key
+  = tcGetEnv		`thenNF_Tc` \ (TcEnv te ve gtvs) ->
+    case lookupUFM_Directly te key of
+	Just (_, _, AClass cl) -> returnNF_Tc cl
+	other		       -> pprPanic "tcLookupClassByKey:" (pprUnique10 key)
+
+tcLookupTyConByKey :: Unique -> NF_TcM s TyCon
+tcLookupTyConByKey key
+  = tcGetEnv		`thenNF_Tc` \ (TcEnv te ve gtvs) ->
+    case lookupUFM_Directly te key of
+	Just (_, _, ATyCon tc) -> returnNF_Tc tc
+	other		       -> pprPanic "tcLookupTyConByKey:" (pprUnique10 key)
+\end{code}
 
-tcLookupClassByKey uniq
-  = tcGetEnv		`thenNF_Tc` \ (TcEnv tve tce ce gve lve gtvs) ->
-    let
-	(kind, clas) = lookupWithDefaultUFM_Directly ce 
-				(pprPanic "tcLookupClassByKey:" (pprUnique10 uniq))
-				uniq
-    in
-    returnNF_Tc clas
 
-tcGetTyConsAndClasses :: NF_TcM s ([TyCon], [Class])
-tcGetTyConsAndClasses
-  = tcGetEnv		`thenNF_Tc` \ (TcEnv tve tce ce gve lve gtvs) ->
-    returnNF_Tc ([tc | (_, _, tc) <- eltsUFM tce],
-	         [c  | (_, c)     <- eltsUFM ce])
-\end{code}
 
 
+%************************************************************************
+%*									*
+\subsection{The value environment}
+%*									*
+%************************************************************************
 
-Extending and consulting the value environment
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 \begin{code}
+tcExtendGlobalValEnv :: [Id] -> TcM s a -> TcM s a
 tcExtendGlobalValEnv ids scope
-  = tcGetEnv		`thenNF_Tc` \ (TcEnv tve tce ce gve lve gtvs) ->
+  = tcGetEnv		`thenNF_Tc` \ (TcEnv te ve gtvs) ->
     let
-	gve' = addListToUFM_Directly gve [(uniqueOf id, id) | id <- ids]
+	ve' = addListToUFM_Directly ve [(getUnique id, id) | id <- ids]
     in
-    tcSetEnv (TcEnv tve tce ce gve' lve gtvs) scope
+    tcSetEnv (TcEnv te ve' gtvs) scope
 
-tcExtendLocalValEnv names ids scope
-  = tcGetEnv		`thenNF_Tc` \ (TcEnv tve tce ce gve lve gtvs) ->
+tcExtendLocalValEnv :: [(Name,TcId)] -> TcM s a -> TcM s a
+tcExtendLocalValEnv names_w_ids scope
+  = tcGetEnv		`thenNF_Tc` \ (TcEnv te ve (in_scope_tvs,gtvs)) ->
     tcReadMutVar gtvs	`thenNF_Tc` \ global_tvs ->
     let
-	lve' = addListToUFM lve (zipEqual "tcExtendLocalValEnv" names ids)
-	extra_global_tyvars = tyVarsOfTypes (map idType ids)
-	new_global_tyvars   = global_tvs `unionTyVarSets` extra_global_tyvars
+	ve'		    = addListToUFM ve names_w_ids
+	extra_global_tyvars = tyVarsOfTypes (map (idType . snd) names_w_ids)
     in
-    tcNewMutVar new_global_tyvars	`thenNF_Tc` \ gtvs' ->
-
-    tcSetEnv (TcEnv tve tce ce gve lve' gtvs') scope
+    tc_extend_gtvs gtvs extra_global_tyvars	`thenNF_Tc` \ gtvs' ->
+    tcSetEnv (TcEnv te ve' (in_scope_tvs,gtvs')) scope
 \end{code}
 
-@tcGetGlobalTyVars@ returns a fully-zonked set of tyvars free in the environment.
-To improve subsequent calls to the same function it writes the zonked set back into
-the environment.
 
 \begin{code}
-tcGetGlobalTyVars :: NF_TcM s (TcTyVarSet s)
-tcGetGlobalTyVars
-  = tcGetEnv 				`thenNF_Tc` \ (TcEnv tve tce ce gve lve gtvs) ->
-    tcReadMutVar gtvs			`thenNF_Tc` \ global_tvs ->
-    zonkTcTyVars global_tvs		`thenNF_Tc` \ global_tvs' ->
-    tcWriteMutVar gtvs global_tvs'	`thenNF_Tc_` 
-    returnNF_Tc global_tvs'
-
-tcExtendGlobalTyVars extra_global_tvs scope
-  = tcGetEnv				`thenNF_Tc` \ (TcEnv tve tce ce gve lve gtvs) ->
-    tcReadMutVar gtvs			`thenNF_Tc` \ global_tvs ->
-    let
-	new_global_tyvars = global_tvs `unionTyVarSets` mkTyVarSet extra_global_tvs
-    in
-    tcNewMutVar new_global_tyvars	`thenNF_Tc` \ gtvs' ->
-    tcSetEnv (TcEnv tve tce ce gve lve gtvs') scope
-\end{code}
-
-\begin{code}
-tcLookupLocalValue :: Name -> NF_TcM s (Maybe (TcIdBndr s))
-tcLookupLocalValue name
-  = tcGetEnv 		`thenNF_Tc` \ (TcEnv tve tce ce gve lve gtvs) ->
-    returnNF_Tc (lookupUFM lve name)
-
-tcLookupLocalValueByKey :: Unique -> NF_TcM s (Maybe (TcIdBndr s))
-tcLookupLocalValueByKey uniq
-  = tcGetEnv 		`thenNF_Tc` \ (TcEnv tve tce ce gve lve gtvs) ->
-    returnNF_Tc (lookupUFM_Directly lve uniq)
-
-tcLookupLocalValueOK :: String -> Name -> NF_TcM s (TcIdBndr s)
-tcLookupLocalValueOK err name
-  = tcGetEnv 		`thenNF_Tc` \ (TcEnv tve tce ce gve lve gtvs) ->
-    returnNF_Tc (lookupWithDefaultUFM lve (panic err) name)
-
-
-tcLookupGlobalValue :: Name -> NF_TcM s Id
-tcLookupGlobalValue name
+tcLookupValue :: Name -> NF_TcM s Id	-- Panics if not found
+tcLookupValue name
   = case maybeWiredInIdName name of
 	Just id -> returnNF_Tc id
-	Nothing -> tcGetEnv 		`thenNF_Tc` \ (TcEnv tve tce ce gve lve gtvs) ->
-		   returnNF_Tc (lookupWithDefaultUFM gve def name)
+	Nothing -> tcGetEnv 		`thenNF_Tc` \ (TcEnv te ve gtvs) ->
+		   returnNF_Tc (lookupWithDefaultUFM ve def name)
   where
-    def = pprPanic "tcLookupGlobalValue:" (ppr name)
+    def = pprPanic "tcLookupValue:" (ppr name)
 
-tcLookupGlobalValueMaybe :: Name -> NF_TcM s (Maybe Id)
-tcLookupGlobalValueMaybe name
+tcLookupValueMaybe :: Name -> NF_TcM s (Maybe Id)
+tcLookupValueMaybe name
   = case maybeWiredInIdName name of
 	Just id -> returnNF_Tc (Just id)
-	Nothing -> tcGetEnv 		`thenNF_Tc` \ (TcEnv tve tce ce gve lve gtvs) ->
-		   returnNF_Tc (lookupUFM gve name)
+	Nothing -> tcGetEnv 		`thenNF_Tc` \ (TcEnv te ve gtvs) ->
+		   returnNF_Tc (lookupUFM ve name)
 
+tcLookupValueByKey :: Unique -> NF_TcM s Id	-- Panics if not found
+tcLookupValueByKey key
+  = tcGetEnv 		`thenNF_Tc` \ (TcEnv te ve gtvs) ->
+    returnNF_Tc (explicitLookupValueByKey ve key)
 
-tcLookupGlobalValueByKey :: Unique -> NF_TcM s Id
-tcLookupGlobalValueByKey uniq
-  = tcGetEnv 		`thenNF_Tc` \ (TcEnv tve tce ce gve lve gtvs) ->
-    returnNF_Tc (lookupWithDefaultUFM_Directly gve def uniq)
-  where
-#ifdef DEBUG
-    def = pprPanic "tcLookupGlobalValueByKey:" (pprUnique10 uniq)
-#else
-    def = panic "tcLookupGlobalValueByKey"
-#endif
+tcLookupValueByKeyMaybe :: Unique -> NF_TcM s (Maybe Id)
+tcLookupValueByKeyMaybe key
+  = tcGetEnv 		`thenNF_Tc` \ (TcEnv te ve gtvs) ->
+    returnNF_Tc (lookupUFM_Directly ve key)
 
-tcLookupGlobalValueByKeyMaybe :: Unique -> NF_TcM s (Maybe Id)
-tcLookupGlobalValueByKeyMaybe uniq
-  = tcGetEnv 		`thenNF_Tc` \ (TcEnv tve tce ce gve lve gtvs) ->
-    returnNF_Tc (lookupUFM_Directly gve uniq)
+tcGetValueEnv :: NF_TcM s ValueEnv
+tcGetValueEnv
+  = tcGetEnv 		`thenNF_Tc` \ (TcEnv te ve gtvs) ->
+    returnNF_Tc ve
 
+tcSetValueEnv :: ValueEnv -> TcM s a -> TcM s a
+tcSetValueEnv ve scope
+  = tcGetEnv		`thenNF_Tc` \ (TcEnv te _ gtvs) ->
+    tcSetEnv (TcEnv te ve gtvs) scope
 
 -- Non-monadic version, environment given explicitly
-tcExplicitLookupGlobal :: TcEnv s -> Name -> Maybe Id
-tcExplicitLookupGlobal (TcEnv tve tce ce gve lve gtvs) name
+explicitLookupValueByKey :: ValueEnv -> Unique -> Id
+explicitLookupValueByKey ve key
+  = lookupWithDefaultUFM_Directly ve def key
+  where
+    def = pprPanic "lookupValueByKey:" (pprUnique10 key)
+
+explicitLookupValue :: ValueEnv -> Name -> Maybe Id
+explicitLookupValue ve name
   = case maybeWiredInIdName name of
 	Just id -> Just id
-	Nothing -> lookupUFM gve name
+	Nothing -> lookupUFM ve name
 
 	-- Extract the IdInfo from an IfaceSig imported from an interface file
-tcAddImportedIdInfo :: TcEnv s -> Id -> Id
+tcAddImportedIdInfo :: ValueEnv -> Id -> Id
 tcAddImportedIdInfo unf_env id
   | isLocallyDefined id		-- Don't look up locally defined Ids, because they
 				-- have explicit local definitions, so we get a black hole!
   = id
   | otherwise
-  = id `replaceIdInfo` new_info
+  = id `setIdInfo` new_info
 	-- The Id must be returned without a data dependency on maybe_id
   where
     new_info = -- pprTrace "tcAdd" (ppr id) $
-	       case tcExplicitLookupGlobal unf_env (getName id) of
+	       case explicitLookupValue unf_env (getName id) of
 		     Nothing	      -> noIdInfo
 		     Just imported_id -> idInfo imported_id
 		-- ToDo: could check that types are the same
 \end{code}
 
 
-Constructing new Ids
-~~~~~~~~~~~~~~~~~~~~
+%************************************************************************
+%*									*
+\subsection{Constructing new Ids}
+%*									*
+%************************************************************************
 
 \begin{code}
--- Uses the Name as the Name of the Id
-newMonoIds :: [Name] -> Kind -> ([TcIdBndr s] -> TcM s a) -> TcM s a
-
-newMonoIds names kind m
-  = newTyVarTys no_of_names kind	`thenNF_Tc` \ tys ->
-    let
-	new_ids       = zipWithEqual "newMonoIds" mk_id names tys
-	mk_id name ty = mkUserId name ty
-    in
-    tcExtendLocalValEnv names new_ids (m new_ids)
-  where
-    no_of_names = length names
-
-newLocalId :: OccName -> TcType s -> NF_TcM s (TcIdBndr s)
+newLocalId :: OccName -> TcType -> NF_TcM s TcId
 newLocalId name ty
-  = tcGetSrcLoc		`thenNF_Tc` \ loc ->
-    tcGetUnique		`thenNF_Tc` \ uniq ->
-    returnNF_Tc (mkUserLocal name uniq ty loc)
+  = tcGetUnique		`thenNF_Tc` \ uniq ->
+    returnNF_Tc (mkUserLocal name uniq ty)
 
-newLocalIds :: [OccName] -> [TcType s] -> NF_TcM s [TcIdBndr s]
+newLocalIds :: [OccName] -> [TcType] -> NF_TcM s [TcId]
 newLocalIds names tys
-  = tcGetSrcLoc			`thenNF_Tc` \ loc ->
-    tcGetUniques (length names) `thenNF_Tc` \ uniqs ->
+  = tcGetUniques (length names) `thenNF_Tc` \ uniqs ->
     let
 	new_ids            = zipWith3Equal "newLocalIds" mk_id names uniqs tys
-	mk_id name uniq ty = mkUserLocal name uniq ty loc
+	mk_id name uniq ty = mkUserLocal name uniq ty
     in
     returnNF_Tc new_ids
 
-newSpecPragmaId :: Name -> TcType s -> NF_TcM s (TcIdBndr s)
+newSpecPragmaId :: Name -> TcType -> NF_TcM s TcId
 newSpecPragmaId name ty 
-  = tcGetSrcLoc		`thenNF_Tc` \ loc ->
-    tcGetUnique		`thenNF_Tc` \ uniq ->
-    returnNF_Tc (mkSpecPragmaId (nameOccName name) uniq ty loc)
+  = tcGetUnique		`thenNF_Tc` \ uniq ->
+    returnNF_Tc (mkSpecPragmaId (nameOccName name) uniq ty)
 \end{code}
 
 
-\begin{code}
-classAsTyConErr name
-  = ptext SLIT("Class used as a type constructor:") <+> ppr name
+%************************************************************************
+%*									*
+\subsection{Errors}
+%*									*
+%************************************************************************
 
-tyConAsClassErr name
-  = ptext SLIT("Type constructor used as a class:") <+> ppr name
+\begin{code}
+badCon con_id
+  = quotes (ppr con_id) <+> ptext SLIT("is not a data constructor")
+badPrimOp op
+  = quotes (ppr op) <+> ptext SLIT("is not a primop")
 \end{code}