[project @ 2000-11-21 09:57:02 by sewardj]

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

diff --git a/ghc/compiler/typecheck/TcEnv.lhs b/ghc/compiler/typecheck/TcEnv.lhs
index 3dfdb2e..ae1f4e6 100644 (file)
--- a/ghc/compiler/typecheck/TcEnv.lhs
+++ b/ghc/compiler/typecheck/TcEnv.lhs
@@ -16,7 +16,7 @@ module TcEnv(
        -- Global environment
        tcExtendGlobalEnv, tcExtendGlobalValEnv, 
        tcLookupTyCon, tcLookupClass, tcLookupGlobalId, tcLookupDataCon,
-       tcLookupGlobal_maybe, tcLookupGlobal,
+       tcLookupGlobal_maybe, tcLookupGlobal, 
 
        -- Local environment
        tcExtendKindEnv, 
@@ -27,14 +27,14 @@ module TcEnv(
        tcGetGlobalTyVars, tcExtendGlobalTyVars,
 
        -- Random useful things
-       tcAddImportedIdInfo, tcInstId,
+       RecTcEnv, tcAddImportedIdInfo, tcLookupRecId, tcLookupRecId_maybe, tcInstId,
 
        -- New Ids
        newLocalId, newSpecPragmaId,
        newDefaultMethodName, newDFunName,
 
        -- Misc
-       isLocalThing, tcSetEnv, explicitLookupId
+       isLocalThing, tcSetEnv
   ) where
 
 #include "HsVersions.h"
@@ -44,15 +44,15 @@ import TcMonad
 import TcType          ( TcKind,  TcType, TcTyVar, TcTyVarSet, TcThetaType,
                          tcInstTyVars, zonkTcTyVars,
                        )
-import Id              ( mkUserLocal, isDataConWrapId_maybe )
-import IdInfo          ( vanillaIdInfo )
+import Id              ( idName, mkUserLocal, isDataConWrapId_maybe )
+import IdInfo          ( constantIdInfo )
 import MkId            ( mkSpecPragmaId )
 import Var             ( TyVar, Id, idType, lazySetIdInfo, idInfo )
 import VarSet
 import Type            ( Type,
                          tyVarsOfTypes, splitDFunTy,
                          splitForAllTys, splitRhoTy,
-                         getDFunTyKey, splitTyConApp_maybe
+                         getDFunTyKey, tyConAppTyCon
                        )
 import DataCon         ( DataCon )
 import TyCon           ( TyCon )
@@ -60,10 +60,9 @@ import Class         ( Class, ClassOpItem, ClassContext )
 import Subst           ( substTy )
 import Name            ( Name, OccName, NamedThing(..), 
                          nameOccName, nameModule, getSrcLoc, mkGlobalName,
-                         isLocalName, nameModule_maybe,
-                         NameEnv, lookupNameEnv, nameEnvElts, 
-                         extendNameEnvList, emptyNameEnv
+                         isLocalName, nameModule_maybe
                        )
+import Name            ( NameEnv, lookupNameEnv, nameEnvElts, extendNameEnvList, emptyNameEnv )
 import OccName         ( mkDFunOcc, mkDefaultMethodOcc, occNameString )
 import HscTypes                ( DFunId, TypeEnv, HomeSymbolTable, PackageTypeEnv )
 import Module          ( Module )
@@ -166,7 +165,7 @@ 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] [Class]
+                   | DataTyDetails ClassContext [DataCon] [Id]
                    | ClassDetails ClassContext [Id] [ClassOpItem] DataCon
 \end{code}
 
@@ -193,13 +192,34 @@ lookup_local env name
        Nothing    -> case lookup_global env name of
                        Just thing -> Just (AGlobal thing)
                        Nothing    -> Nothing
-
-explicitLookupId :: TcEnv -> Name -> Maybe Id
-explicitLookupId env name = case lookup_global env name of
-                               Just (AnId id) -> Just id
-                               other          -> Nothing
 \end{code}
 
+\begin{code}
+type RecTcEnv = TcEnv
+-- This environment is used for getting the 'right' IdInfo 
+-- on imported things and for looking up Ids in unfoldings
+-- The environment doesn't have any local Ids in it
+
+tcAddImportedIdInfo :: RecTcEnv -> Id -> Id
+tcAddImportedIdInfo env id
+  = id `lazySetIdInfo` new_info
+       -- The Id must be returned without a data dependency on maybe_id
+  where
+    new_info = case tcLookupRecId_maybe env (idName id) of
+                 Nothing          -> constantIdInfo
+                 Just imported_id -> idInfo imported_id
+               -- ToDo: could check that types are the same
+
+tcLookupRecId_maybe :: RecTcEnv -> Name -> Maybe Id
+tcLookupRecId_maybe env name = case lookup_global env name of
+                                  Just (AnId id) -> Just id
+                                  other          -> Nothing
+
+tcLookupRecId ::  RecTcEnv -> Name -> Id
+tcLookupRecId env name = case lookup_global env name of
+                               Just (AnId id) -> id
+                               Nothing        -> pprPanic "tcLookupRecId" (ppr name)
+\end{code}
 
 %************************************************************************
 %*                                                                     *
@@ -225,20 +245,6 @@ tcInstId id
        (theta', tau') = splitRhoTy rho' 
     in
     returnNF_Tc (tyvars', theta', tau')
-
-tcAddImportedIdInfo :: TcEnv -> Id -> Id
-tcAddImportedIdInfo unf_env id
-  | isLocallyDefined id                -- Don't look up locally defined Ids, because they
-                               -- have explicit local definitions, so we get a black hole!
-  = id
-  | otherwise
-  = id `lazySetIdInfo` new_info
-       -- The Id must be returned without a data dependency on maybe_id
-  where
-    new_info = case explicitLookupId unf_env (getName id) of
-                    Nothing          -> vanillaIdInfo
-                    Just imported_id -> idInfo imported_id
-               -- ToDo: could check that types are the same
 \end{code}
 
 
@@ -276,6 +282,8 @@ newDFunName mod clas (ty:_) loc
        -- Any string that is somewhat unique will do
     dfun_string = occNameString (getOccName clas) ++ occNameString (getDFunTyKey ty)
 
+newDFunName mod clas [] loc = pprPanic "newDFunName" (ppr mod <+> ppr clas <+> ppr loc)
+
 newDefaultMethodName :: Name -> SrcLoc -> NF_TcM Name
 newDefaultMethodName op_name loc
   = tcGetUnique                        `thenNF_Tc` \ uniq ->
@@ -300,17 +308,21 @@ isLocalThing mod thing = case nameModule_maybe (getName thing) of
 %************************************************************************
 
 \begin{code}
-tcExtendGlobalEnv :: [(Name, TyThing)] -> TcM r -> TcM r
-tcExtendGlobalEnv bindings thing_inside
+tcExtendGlobalEnv :: [TyThing] -> TcM r -> TcM r
+tcExtendGlobalEnv things thing_inside
   = tcGetEnv                           `thenNF_Tc` \ env ->
     let
-       ge' = extendNameEnvList (tcGEnv env) bindings
+       ge' = extendNameEnvList (tcGEnv env) [(getName thing, thing) | thing <- things]
     in
     tcSetEnv (env {tcGEnv = ge'}) thing_inside
 
 tcExtendGlobalValEnv :: [Id] -> TcM a -> TcM a
 tcExtendGlobalValEnv ids thing_inside
-  = tcExtendGlobalEnv [(getName id, AnId id) | id <- ids] thing_inside
+  = tcGetEnv                           `thenNF_Tc` \ env ->
+    let
+       ge' = extendNameEnvList (tcGEnv env) [(getName id, AnId id) | id <- ids]
+    in
+    tcSetEnv (env {tcGEnv = ge'}) thing_inside
 \end{code}
 
 
@@ -525,9 +537,7 @@ simpleInstInfoTy info = case splitDFunTy (idType (iDFunId info)) of
 simpleInstInfoTyCon :: InstInfo -> TyCon
   -- Gets the type constructor for a simple instance declaration,
   -- i.e. one of the form      instance (...) => C (T a b c) where ...
-simpleInstInfoTyCon inst
-   = case splitTyConApp_maybe (simpleInstInfoTy inst) of 
-       Just (tycon, _) -> tycon
+simpleInstInfoTyCon inst = tyConAppTyCon (simpleInstInfoTy inst)
 \end{code}