[project @ 2000-10-30 17:18:26 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 bbb8573..88d0159 100644 (file)
--- a/ghc/compiler/typecheck/TcEnv.lhs
+++ b/ghc/compiler/typecheck/TcEnv.lhs
@@ -6,7 +6,7 @@ module TcEnv(
        -- Getting stuff from the environment
        TcEnv, initTcEnv, 
        tcEnvTyCons, tcEnvClasses, tcEnvIds, tcEnvTcIds, tcEnvTyVars,
-       getTcGST, getTcGEnv,
+       getTcGEnv,
        
        -- Instance environment, and InstInfo type
        tcGetInstEnv, tcSetInstEnv, 
@@ -33,8 +33,8 @@ module TcEnv(
        newLocalId, newSpecPragmaId,
        newDefaultMethodName, newDFunName,
 
-       -- ???
-       tcSetEnv, explicitLookupId
+       -- Misc
+       isLocalThing, tcSetEnv, explicitLookupId
   ) where
 
 #include "HsVersions.h"
@@ -44,7 +44,7 @@ import TcMonad
 import TcType          ( TcKind,  TcType, TcTyVar, TcTyVarSet, TcThetaType,
                          tcInstTyVars, zonkTcTyVars,
                        )
-import Id              ( idName, mkUserLocal, isDataConWrapId_maybe )
+import Id              ( mkUserLocal, isDataConWrapId_maybe )
 import IdInfo          ( vanillaIdInfo )
 import MkId            ( mkSpecPragmaId )
 import Var             ( TyVar, Id, idType, lazySetIdInfo, idInfo )
@@ -60,15 +60,15 @@ import Class                ( Class, ClassOpItem, ClassContext )
 import Subst           ( substTy )
 import Name            ( Name, OccName, NamedThing(..), 
                          nameOccName, nameModule, getSrcLoc, mkGlobalName,
-                         isLocallyDefined, nameModule,
+                         isLocallyDefined, nameModule_maybe,
                          NameEnv, lookupNameEnv, nameEnvElts, 
                          extendNameEnvList, emptyNameEnv
                        )
 import OccName         ( mkDFunOcc, mkDefaultMethodOcc, occNameString )
-import HscTypes                ( DFunId, TypeEnv )
+import HscTypes                ( DFunId, TypeEnv, HomeSymbolTable, PackageTypeEnv )
 import Module          ( Module )
 import InstEnv         ( InstEnv, emptyInstEnv )
-import HscTypes                ( lookupTypeEnv, TyThing(..), GlobalSymbolTable )
+import HscTypes                ( lookupType, TyThing(..) )
 import Util            ( zipEqual )
 import SrcLoc          ( SrcLoc )
 import Outputable
@@ -88,12 +88,12 @@ type TcIdSet = IdSet
 
 data TcEnv
   = TcEnv {
-       tcGST    :: GlobalSymbolTable,  -- The symbol table at the moment we began this compilation
+       tcGST    :: Name -> Maybe TyThing,      -- The type environment at the moment we began this compilation
 
        tcInsts  :: InstEnv,            -- All instances (both imported and in this module)
 
        tcGEnv   :: TypeEnv,            -- The global type environment we've accumulated while
-                   {- NameEnv TyThing-}-- compiling this module:
+                {- NameEnv TyThing-}   -- compiling this module:
                                        --      types and classes (both imported and local)
                                        --      imported Ids
                                        -- (Ids defined in this module are in the local envt)
@@ -141,15 +141,18 @@ data TcTyThing
 --     3. Then we zonk the kind variable.
 --     4. Now we know the kind for 'a', and we add (a -> ATyVar a::K) to the environment
 
-initTcEnv :: GlobalSymbolTable -> IO TcEnv
-initTcEnv gst
+initTcEnv :: HomeSymbolTable -> PackageTypeEnv -> IO TcEnv
+initTcEnv hst pte 
   = do { gtv_var <- newIORef emptyVarSet ;
-        return (TcEnv { tcGST    = gst,
+        return (TcEnv { tcGST    = lookup,
                         tcGEnv   = emptyNameEnv,
                         tcInsts  = emptyInstEnv,
                         tcLEnv   = emptyNameEnv,
                         tcTyVars = gtv_var
         })}
+  where
+    lookup name = lookupType hst pte name
+
 
 tcEnvClasses env = [cl | AClass cl <- nameEnvElts (tcGEnv env)]
 tcEnvTyCons  env = [tc | ATyCon tc <- nameEnvElts (tcGEnv env)] 
@@ -157,7 +160,6 @@ tcEnvIds     env = [id | AnId   id <- nameEnvElts (tcGEnv env)]
 tcEnvTyVars  env = [tv | ATyVar tv <- nameEnvElts (tcLEnv env)]
 tcEnvTcIds   env = [id | ATcId  id <- nameEnvElts (tcLEnv env)]
 
-getTcGST  (TcEnv { tcGST = gst })   = gst
 getTcGEnv (TcEnv { tcGEnv = genv }) = genv
 
 -- This data type is used to help tie the knot
@@ -180,7 +182,7 @@ lookup_global :: TcEnv -> Name -> Maybe TyThing
 lookup_global env name 
   = case lookupNameEnv (tcGEnv env) name of
        Just thing -> Just thing
-       Nothing    -> lookupTypeEnv (tcGST env) name
+       Nothing    -> tcGST env name
 
 lookup_local :: TcEnv -> Name -> Maybe TcTyThing
        -- Try the local envt and then try the global
@@ -281,6 +283,14 @@ newDefaultMethodName op_name loc
                              loc)
 \end{code}
 
+\begin{code}
+isLocalThing :: NamedThing a => Module -> a -> Bool
+  -- True if the thing has a Local name, 
+  -- or a Global name from the specified module
+isLocalThing mod thing = case nameModule_maybe (getName thing) of
+                          Nothing -> True      -- A local name
+                          Just m  -> m == mod  -- A global thing
+\end{code}
 
 %************************************************************************
 %*                                                                     *
@@ -318,14 +328,14 @@ tcLookupGlobal name
   = tcLookupGlobal_maybe name  `thenNF_Tc` \ maybe_thing ->
     case maybe_thing of
        Just thing -> returnNF_Tc thing
-       other      -> notFound "tcLookupGlobal:" name
+       other      -> notFound "tcLookupGlobal" name
 
 tcLookupGlobalId :: Name -> NF_TcM Id
 tcLookupGlobalId name
   = tcLookupGlobal_maybe name  `thenNF_Tc` \ maybe_id ->
     case maybe_id of
        Just (AnId clas) -> returnNF_Tc clas
-       other            -> notFound "tcLookupGlobalId:" name
+       other            -> notFound "tcLookupGlobalId" name
        
 tcLookupDataCon :: Name -> TcM DataCon
 tcLookupDataCon con_name
@@ -340,14 +350,14 @@ tcLookupClass name
   = tcLookupGlobal_maybe name  `thenNF_Tc` \ maybe_clas ->
     case maybe_clas of
        Just (AClass clas) -> returnNF_Tc clas
-       other              -> notFound "tcLookupClass:" name
+       other              -> notFound "tcLookupClass" name
        
 tcLookupTyCon :: Name -> NF_TcM TyCon
 tcLookupTyCon name
   = tcLookupGlobal_maybe name  `thenNF_Tc` \ maybe_tc ->
     case maybe_tc of
        Just (ATyCon tc) -> returnNF_Tc tc
-       other            -> notFound "tcLookupTyCon:" name
+       other            -> notFound "tcLookupTyCon" name
 \end{code}
 
 
@@ -368,7 +378,7 @@ tcLookup name
   = tcLookup_maybe name                `thenNF_Tc` \ maybe_thing ->
     case maybe_thing of
        Just thing -> returnNF_Tc thing
-       other      -> notFound "tcLookup:" name
+       other      -> notFound "tcLookup" name
        -- Extract the IdInfo from an IfaceSig imported from an interface file
 \end{code}
 
@@ -525,7 +535,7 @@ simpleInstInfoTyCon inst
        Just (tycon, _) -> tycon
 
 isLocalInst :: Module -> InstInfo -> Bool
-isLocalInst mod info = mod == nameModule (idName (iDFunId info))
+isLocalInst mod info = isLocalThing mod (iDFunId info)
 \end{code}