[project @ 1996-07-19 18:36:04 by partain]

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

diff --git a/ghc/compiler/typecheck/TcEnv.lhs b/ghc/compiler/typecheck/TcEnv.lhs
index 7702e31..bda4f4a 100644 (file)
--- 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