[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 ba1bcbf..bda4f4a 100644 (file)
--- a/ghc/compiler/typecheck/TcEnv.lhs
+++ b/ghc/compiler/typecheck/TcEnv.lhs
@@ -10,29 +10,30 @@ module TcEnv(
 
        tcExtendTyConEnv, tcLookupTyCon, tcLookupTyConByKey, 
        tcExtendClassEnv, tcLookupClass, tcLookupClassByKey,
+       tcGetTyConsAndClasses,
 
        tcExtendGlobalValEnv, tcExtendLocalValEnv,
        tcLookupLocalValue, tcLookupLocalValueOK, tcLookupLocalValueByKey, 
        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 )
 
@@ -40,10 +41,11 @@ 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            ( zipWithEqual, zipWith3Equal, zipLazy, panic, pprPanic, pprTrace{-ToDo:rm-} )
+import Util            ( zipEqual, zipWithEqual, zipWith3Equal, zipLazy,
+                         panic, pprPanic{-, pprTrace ToDo:rm-}
+                       )
 \end{code}
 
 Data type declarations
@@ -87,7 +89,7 @@ tcTyVarScopeGivenKinds names kinds thing_inside
 
        tcGetEnv                                `thenNF_Tc` \ (TcEnv tve tce ce gve lve gtvs) ->
        let
-           tve' = addListToUFM tve (names `zip` (kinds `zipLazy` rec_tyvars))
+           tve' = addListToUFM tve (zipEqual "tcTyVarScopeGivenKinds" names (kinds `zipLazy` rec_tyvars))
        in
        tcSetEnv (TcEnv tve' tce ce gve lve gtvs) 
                 (thing_inside rec_tyvars)      `thenTc` \ result ->
@@ -97,8 +99,7 @@ tcTyVarScopeGivenKinds names kinds thing_inside
 
                -- Construct the real TyVars
        let
-         tyvars             = zipWithEqual 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) ->
@@ -124,8 +125,8 @@ tcExtendTyConEnv names_w_arities tycons scope
     tcGetEnv                                   `thenNF_Tc` \ (TcEnv tve tce ce gve lve gtvs) ->
     let
        tce' = addListToUFM tce [ (name, (kind, arity, tycon)) 
-                               | ((name,arity), (kind,tycon)) <- names_w_arities `zip`
-                                                                 (kinds `zipLazy` tycons)
+                               | ((name,arity), (kind,tycon))
+                                 <- zipEqual "tcExtendTyConEnv" names_w_arities (kinds `zipLazy` tycons)
                                ]
     in
     tcSetEnv (TcEnv tve tce' ce gve lve gtvs) scope    `thenTc` \ result ->
@@ -138,7 +139,7 @@ tcExtendClassEnv names classes scope
   = newKindVars (length names) `thenNF_Tc` \ kinds ->
     tcGetEnv                   `thenNF_Tc` \ (TcEnv tve tce ce gve lve gtvs) ->
     let
-       ce' = addListToUFM ce (names `zip` (kinds `zipLazy` classes))
+       ce' = addListToUFM ce (zipEqual "tcExtendClassEnv" names (kinds `zipLazy` classes))
     in
     tcSetEnv (TcEnv tve tce ce' gve lve gtvs) scope    `thenTc` \ result ->
     mapNF_Tc tcDefaultKind kinds                       `thenNF_Tc_`
@@ -184,6 +185,12 @@ tcLookupClassByKey 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}
 
 
@@ -202,7 +209,7 @@ tcExtendLocalValEnv names ids scope
   = tcGetEnv           `thenNF_Tc` \ (TcEnv tve tce ce gve lve gtvs) ->
     tcReadMutVar gtvs  `thenNF_Tc` \ global_tvs ->
     let
-       lve' = addListToUFM lve (names `zip` ids)
+       lve' = addListToUFM lve (zipEqual "tcExtendLocalValEnv" names ids)
        extra_global_tyvars = tyVarsOfTypes (map idType ids)
        new_global_tyvars   = global_tvs `unionTyVarSets` extra_global_tyvars
     in
@@ -223,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}
@@ -281,11 +297,11 @@ newMonoIds names kind m
   = newTyVarTys no_of_names kind       `thenNF_Tc` \ tys ->
     tcGetUniques no_of_names           `thenNF_Tc` \ uniqs ->
     let
-       new_ids = zipWith3Equal mk_id names uniqs tys
+       new_ids = zipWith3Equal "newMonoIds" mk_id names uniqs tys
 
        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
@@ -304,7 +320,7 @@ newLocalIds names tys
   = tcGetSrcLoc                        `thenNF_Tc` \ loc ->
     tcGetUniques (length names) `thenNF_Tc` \ uniqs ->
     let
-       new_ids            = zipWith3Equal mk_id names uniqs tys
+       new_ids            = zipWith3Equal "newLocalIds" mk_id names uniqs tys
        mk_id name uniq ty = TcId (mkUserLocal name uniq ty loc)
     in
     returnNF_Tc new_ids