X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2Ftypecheck%2FTcEnv.lhs;h=bda4f4a81be95bf314a437dd3c6b219690bf43c4;hb=f7ecf7234c224489be8a5e63fced903b655d92ee;hp=7702e31d652ec61e903d4366a71c73c1f4bf8006;hpb=5cf27e8f1731c52fe63a5b9615f927484164c61b;p=ghc-hetmet.git

diff --git a/ghc/compiler/typecheck/TcEnv.lhs b/ghc/compiler/typecheck/TcEnv.lhs
index 7702e31..bda4f4a 100644
--- a/ghc/compiler/typecheck/TcEnv.lhs
+++ b/ghc/compiler/typecheck/TcEnv.lhs
@@ -17,23 +17,23 @@ module TcEnv(
 	tcLookupGlobalValue, tcLookupGlobalValueByKey,
 
 	newMonoIds, newLocalIds, newLocalId,
-	tcGetGlobalTyVars
+	tcGetGlobalTyVars, tcExtendGlobalTyVars
   ) where
 
 
-import Ubiq
-import TcMLoop  -- for paranoia checking
+IMP_Ubiq()
+IMPORT_DELOOPER(TcMLoop)  -- for paranoia checking
 
-import Id	( Id(..), GenId, idType, mkUserLocal )
-import TcHsSyn	( TcIdBndr(..), TcIdOcc(..) )
+import Id	( SYN_IE(Id), GenId, idType, mkUserLocal )
+import TcHsSyn	( SYN_IE(TcIdBndr), TcIdOcc(..) )
 import TcKind	( TcKind, newKindVars, tcDefaultKind, kindToTcKind )
-import TcType	( TcType(..), TcMaybe, TcTyVar(..), TcTyVarSet(..),
-		  newTyVarTys, tcInstTyVars, tcInstType, zonkTcTyVars
+import TcType	( SYN_IE(TcType), TcMaybe, SYN_IE(TcTyVar), SYN_IE(TcTyVarSet),
+		  newTyVarTys, tcInstTyVars, zonkTcTyVars
 		)
 import TyVar	( mkTyVar, tyVarKind, unionTyVarSets, emptyTyVarSet )
-import Type	( tyVarsOfTypes )
-import TyCon	( TyCon, Arity(..), tyConKind, synTyConArity )
-import Class	( Class(..), GenClass, classSig )
+import Type	( tyVarsOfTypes, splitForAllTy )
+import TyCon	( TyCon, tyConKind, synTyConArity )
+import Class	( SYN_IE(Class), GenClass, classSig )
 
 import TcMonad		hiding ( rnMtoTcM )
 
@@ -41,11 +41,10 @@ import Name		( getOccName, getSrcLoc, Name{-instance NamedThing-} )
 import PprStyle
 import Pretty
 import RnHsSyn		( RnName(..) )
-import Type		( splitForAllTy )
-import Unique		( pprUnique10, pprUnique{-ToDo:rm-} )
+import Unique		( pprUnique10{-, pprUnique ToDo:rm-} )
 import UniqFM	     
 import Util		( zipEqual, zipWithEqual, zipWith3Equal, zipLazy,
-			  panic, pprPanic, pprTrace{-ToDo:rm-}
+			  panic, pprPanic{-, pprTrace ToDo:rm-}
 			)
 \end{code}
 
@@ -100,8 +99,7 @@ tcTyVarScopeGivenKinds names kinds thing_inside
 
 		-- Construct the real TyVars
 	let
-	  tyvars	     = zipWithEqual "tcTyVarScopeGivenKinds" mk_tyvar names kinds'
-	  mk_tyvar name kind = mkTyVar name (uniqueOf name) kind
+	  tyvars = zipWithEqual "tcTyVarScopeGivenKinds" mkTyVar names kinds'
 	in
 	returnTc (tyvars, result)
     )					`thenTc` \ (_,result) ->
@@ -232,6 +230,15 @@ tcGetGlobalTyVars
     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` extra_global_tvs
+    in
+    tcNewMutVar new_global_tyvars	`thenNF_Tc` \ gtvs' ->
+    tcSetEnv (TcEnv tve tce ce gve lve gtvs') scope
 \end{code}
 
 \begin{code}
@@ -294,7 +301,7 @@ newMonoIds names kind m
 
 	mk_id name uniq ty
 	  = let
-		name_str = case (getOccName name) of { Unqual n -> n }
+		name_str = case (getOccName name) of { Unqual n -> n; Qual m n -> n }
 	    in
 	    mkUserLocal name_str uniq ty (getSrcLoc name)
     in