[project @ 2001-05-01 09:16:55 by qrczak]

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

diff --git a/ghc/compiler/typecheck/TcEnv.lhs b/ghc/compiler/typecheck/TcEnv.lhs
index ac92dc3..809abce 100644 (file)
--- a/ghc/compiler/typecheck/TcEnv.lhs
+++ b/ghc/compiler/typecheck/TcEnv.lhs
@@ -14,14 +14,14 @@ module TcEnv(
        simpleInstInfoTy, simpleInstInfoTyCon, 
 
        -- Global environment
-       tcExtendGlobalEnv, tcExtendGlobalValEnv, 
+       tcExtendGlobalEnv, tcExtendGlobalValEnv, tcExtendGlobalTypeEnv,
        tcLookupTyCon, tcLookupClass, tcLookupGlobalId, tcLookupDataCon,
        tcLookupGlobal_maybe, tcLookupGlobal, tcLookupSyntaxId, tcLookupSyntaxName,
 
        -- Local environment
        tcExtendKindEnv,  tcLookupLocalIds,
        tcExtendTyVarEnv, tcExtendTyVarEnvForMeths, 
-       tcExtendLocalValEnv, tcLookup, tcLookup_maybe, 
+       tcExtendLocalValEnv, tcLookup, tcLookup_maybe, tcLookupId,
 
        -- Global type variables
        tcGetGlobalTyVars, tcExtendGlobalTyVars,
@@ -44,25 +44,30 @@ import TcMonad
 import TcType          ( TcKind,  TcType, TcTyVar, TcTyVarSet, 
                          zonkTcTyVarsAndFV
                        )
-import Id              ( idName, mkUserLocal, isDataConWrapId_maybe )
-import IdInfo          ( constantIdInfo )
-import MkId            ( mkSpecPragmaId )
+import Id              ( idName, mkSpecPragmaId, mkUserLocal, isDataConWrapId_maybe )
+import IdInfo          ( vanillaIdInfo )
 import Var             ( TyVar, Id, idType, lazySetIdInfo, idInfo )
 import VarSet
-import Type            ( Type,
+import Type            ( Type, ThetaType, 
                          tyVarsOfTypes, splitDFunTy,
                          getDFunTyKey, tyConAppTyCon
                        )
 import DataCon         ( DataCon )
 import TyCon           ( TyCon )
-import Class           ( Class, ClassOpItem, ClassContext )
+import Class           ( Class, ClassOpItem )
 import Name            ( Name, OccName, NamedThing(..), 
-                         nameOccName, getSrcLoc, mkLocalName,
-                         isLocalName, nameModule_maybe
+                         nameOccName, getSrcLoc, mkLocalName, isLocalName,
+                         nameIsLocalOrFrom
                        )
-import Name            ( NameEnv, lookupNameEnv, nameEnvElts, extendNameEnvList, emptyNameEnv )
+import NameEnv         ( NameEnv, lookupNameEnv, nameEnvElts, 
+                         extendNameEnvList, emptyNameEnv, plusNameEnv )
 import OccName         ( mkDFunOcc, occNameString )
-import HscTypes                ( DFunId, TypeEnv, HomeSymbolTable, PackageTypeEnv )
+import HscTypes                ( DFunId, 
+                         PackageTypeEnv, TypeEnv, 
+                         extendTypeEnvList, extendTypeEnvWithIds,
+                         typeEnvTyCons, typeEnvClasses, typeEnvIds,
+                         HomeSymbolTable
+                       )
 import Module          ( Module )
 import InstEnv         ( InstEnv, emptyInstEnv )
 import HscTypes                ( lookupType, TyThing(..) )
@@ -96,7 +101,8 @@ data TcEnv
                 {- NameEnv TyThing-}   -- compiling this module:
                                        --      types and classes (both imported and local)
                                        --      imported Ids
-                                       -- (Ids defined in this module are in the local envt)
+                                       -- (Ids defined in this module start in the local envt, 
+                                       --  though they move to the global envt during zonking)
 
        tcLEnv   :: NameEnv TcTyThing,  -- The local type environment: Ids and TyVars
                                        -- defined in this module
@@ -156,9 +162,9 @@ initTcEnv syntax_map hst pte
                | otherwise        = lookupType hst pte name
 
 
-tcEnvClasses env = [cl | AClass cl <- nameEnvElts (tcGEnv env)]
-tcEnvTyCons  env = [tc | ATyCon tc <- nameEnvElts (tcGEnv env)] 
-tcEnvIds     env = [id | AnId   id <- nameEnvElts (tcGEnv env)] 
+tcEnvClasses env = typeEnvClasses (tcGEnv env)
+tcEnvTyCons  env = typeEnvTyCons  (tcGEnv env) 
+tcEnvIds     env = typeEnvIds     (tcGEnv env) 
 tcEnvTyVars  env = [tv | ATyVar tv <- nameEnvElts (tcLEnv env)]
 tcEnvTcIds   env = [id | ATcId  id <- nameEnvElts (tcLEnv env)]
 
@@ -167,8 +173,8 @@ getTcGEnv (TcEnv { tcGEnv = genv }) = genv
 -- This data type is used to help tie the knot
 -- when type checking type and class declarations
 data TyThingDetails = SynTyDetails Type
-                   | DataTyDetails ClassContext [DataCon] [Id]
-                   | ClassDetails ClassContext [Id] [ClassOpItem] DataCon
+                   | DataTyDetails ThetaType [DataCon] [Id]
+                   | ClassDetails ThetaType [Id] [ClassOpItem] DataCon
 \end{code}
 
 
@@ -208,7 +214,7 @@ tcAddImportedIdInfo env id
        -- The Id must be returned without a data dependency on maybe_id
   where
     new_info = case tcLookupRecId_maybe env (idName id) of
-                 Nothing          -> pprTrace "tcAddIdInfo" (ppr id) constantIdInfo
+                 Nothing          -> pprTrace "tcAddIdInfo" (ppr id) vanillaIdInfo
                  Just imported_id -> idInfo imported_id
                -- ToDo: could check that types are the same
 
@@ -261,11 +267,7 @@ newDFunName clas [] loc = pprPanic "newDFunName" (ppr clas <+> ppr loc)
 
 \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
+isLocalThing mod thing = nameIsLocalOrFrom mod (getName thing)
 \end{code}
 
 %************************************************************************
@@ -279,7 +281,16 @@ tcExtendGlobalEnv :: [TyThing] -> TcM r -> TcM r
 tcExtendGlobalEnv things thing_inside
   = tcGetEnv                           `thenNF_Tc` \ env ->
     let
-       ge' = extendNameEnvList (tcGEnv env) [(getName thing, thing) | thing <- things]
+       ge' = extendTypeEnvList (tcGEnv env) things
+    in
+    tcSetEnv (env {tcGEnv = ge'}) thing_inside
+
+
+tcExtendGlobalTypeEnv :: TypeEnv -> TcM r -> TcM r
+tcExtendGlobalTypeEnv extra_env thing_inside
+  = tcGetEnv                           `thenNF_Tc` \ env ->
+    let
+       ge' = tcGEnv env `plusNameEnv` extra_env
     in
     tcSetEnv (env {tcGEnv = ge'}) thing_inside
 
@@ -287,7 +298,7 @@ tcExtendGlobalValEnv :: [Id] -> TcM a -> TcM a
 tcExtendGlobalValEnv ids thing_inside
   = tcGetEnv                           `thenNF_Tc` \ env ->
     let
-       ge' = extendNameEnvList (tcGEnv env) [(getName id, AnId id) | id <- ids]
+       ge' = extendTypeEnvWithIds (tcGEnv env) ids
     in
     tcSetEnv (env {tcGEnv = ge'}) thing_inside
 \end{code}
@@ -339,6 +350,14 @@ tcLookupTyCon name
        Just (ATyCon tc) -> returnNF_Tc tc
        other            -> notFound "tcLookupTyCon" name
 
+tcLookupId :: Name -> NF_TcM Id
+tcLookupId name
+  = tcLookup name      `thenNF_Tc` \ thing -> 
+    case thing of
+       ATcId tc_id       -> returnNF_Tc tc_id
+       AGlobal (AnId id) -> returnNF_Tc id
+       other             -> pprPanic "tcLookupId" (ppr name)
+
 tcLookupLocalIds :: [Name] -> NF_TcM [TcId]
 tcLookupLocalIds ns
   = tcGetEnv           `thenNF_Tc` \ env ->
@@ -509,7 +528,6 @@ The InstInfo type summarises the information in an instance declaration
 \begin{code}
 data InstInfo
   = InstInfo {
-      iLocal  :: Bool,                 -- True <=> it's defined in this module
       iDFunId :: DFunId,               -- The dfun id
       iBinds  :: RenamedMonoBinds,     -- Bindings, b
       iPrags  :: [RenamedSig]          -- User pragmas recorded for generating specialised instances