[project @ 2000-10-24 10:36:08 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 13ce1ef..4d345fa 100644 (file)
--- a/ghc/compiler/typecheck/TcEnv.lhs
+++ b/ghc/compiler/typecheck/TcEnv.lhs
@@ -1,23 +1,25 @@
 \begin{code}
 module TcEnv(
        TcId, TcIdSet, 
-       TyThing(..), TyThingDetails(..),
+       TyThing(..), TyThingDetails(..), TcTyThing(..),
 
        -- Getting stuff from the environment
        TcEnv, initTcEnv, 
-       tcEnvTyCons, tcEnvClasses, tcEnvIds, tcEnvTcIds,
+       tcEnvTyCons, tcEnvClasses, tcEnvIds, tcEnvTcIds, tcEnvTyVars,
+       getTcGST, getTcGEnv,
        
        -- Instance environment
        tcGetInstEnv, tcSetInstEnv, 
 
        -- Global environment
        tcExtendGlobalEnv, tcExtendGlobalValEnv, 
-       tcLookupTy, tcLookupTyCon, tcLookupClass, tcLookupGlobalId, tcLookupDataCon,
+       tcLookupTyCon, tcLookupClass, tcLookupGlobalId, tcLookupDataCon,
+       tcLookupGlobal_maybe, tcLookupGlobal,
 
        -- Local environment
        tcExtendKindEnv, 
        tcExtendTyVarEnv, tcExtendTyVarEnvForMeths, 
-       tcExtendLocalValEnv,
+       tcExtendLocalValEnv, tcLookup,
 
        -- Global type variables
        tcGetGlobalTyVars, tcExtendGlobalTyVars,
@@ -27,50 +29,48 @@ module TcEnv(
 
        -- New Ids
        newLocalId, newSpecPragmaId,
-       newDefaultMethodName, newDFunName
+       newDefaultMethodName, newDFunName,
+
+       -- ???
+       tcSetEnv, explicitLookupId
   ) where
 
 #include "HsVersions.h"
 
 import TcMonad
-import TcType  ( TcKind,  TcType, TcTyVar, TcTyVarSet, TcThetaType,
-                 tcInstTyVars, zonkTcTyVars,
-               )
-import Id      ( mkUserLocal, isDataConWrapId_maybe )
-import IdInfo  ( vanillaIdInfo )
-import MkId    ( mkSpecPragmaId )
-import Var     ( TyVar, Id, setVarName,
-                 idType, lazySetIdInfo, idInfo, tyVarKind, UVar,
-               )
+import TcType          ( TcKind,  TcType, TcTyVar, TcTyVarSet, TcThetaType,
+                         tcInstTyVars, zonkTcTyVars,
+                       )
+import Id              ( mkUserLocal, isDataConWrapId_maybe )
+import IdInfo          ( vanillaIdInfo )
+import MkId            ( mkSpecPragmaId )
+import Var             ( TyVar, Id, idType, lazySetIdInfo, idInfo )
 import VarSet
-import VarEnv  ( TyVarSubstEnv )
-import Type    ( Kind, Type, superKind,
-                 tyVarsOfType, tyVarsOfTypes,
-                 splitForAllTys, splitRhoTy, splitFunTys,
-                 splitAlgTyConApp_maybe, getTyVar, getDFunTyKey
-               )
-import DataCon ( DataCon )
-import TyCon   ( TyCon, tyConKind, tyConArity, isSynTyCon )
-import Class   ( Class, ClassOpItem, ClassContext, classTyCon )
-import Subst   ( substTy )
-import Name    ( Name, OccName, Provenance(..), ExportFlag(..), NamedThing(..), 
-                 nameOccName, nameModule, getSrcLoc, mkGlobalName,
-                 maybeWiredInTyConName, maybeWiredInIdName, isLocallyDefined,
-                 NameEnv, emptyNameEnv, lookupNameEnv, nameEnvElts, 
-                 extendNameEnv, extendNameEnvList
-               )
-import OccName ( mkDFunOcc, mkDefaultMethodOcc, occNameString )
-import Module  ( Module )
-import Unify   ( unifyTyListsX, matchTys )
-import HscTypes        ( ModDetails(..), InstEnv, lookupTypeEnv )
-import Unique  ( pprUnique10, Unique, Uniquable(..) )
-import UniqFM
-import Unique  ( Uniquable(..) )
-import Util    ( zipEqual, zipWith3Equal, mapAccumL )
-import SrcLoc  ( SrcLoc )
-import FastString      ( FastString )
-import Maybes
+import Type            ( Type,
+                         tyVarsOfTypes,
+                         splitForAllTys, splitRhoTy,
+                         getDFunTyKey
+                       )
+import DataCon         ( DataCon )
+import TyCon           ( TyCon )
+import Class           ( Class, ClassOpItem, ClassContext )
+import Subst           ( substTy )
+import Name            ( Name, OccName, NamedThing(..), 
+                         nameOccName, nameModule, getSrcLoc, mkGlobalName,
+                         isLocallyDefined,
+                         NameEnv, lookupNameEnv, nameEnvElts, 
+                         extendNameEnvList, emptyNameEnv
+                       )
+import OccName         ( mkDFunOcc, mkDefaultMethodOcc, occNameString )
+import Module          ( Module )
+import HscTypes                ( InstEnv, lookupTypeEnv, TyThing(..),
+                         GlobalSymbolTable )
+import Util            ( zipEqual )
+import SrcLoc          ( SrcLoc )
 import Outputable
+import InstEnv ( emptyInstEnv )
+
+import IOExts          ( newIORef )
 \end{code}
 
 %************************************************************************
@@ -90,7 +90,7 @@ data TcEnv
        tcInsts  :: InstEnv,            -- All instances (both imported and in this module)
 
        tcGEnv   :: NameEnv TyThing,    -- The global type environment we've accumulated while
-                                       -- compiling this module:
+                   {- TypeEnv -}       -- compiling this module:
                                        --      types and classes (both imported and local)
                                        --      imported Ids
                                        -- (Ids defined in this module are in the local envt)
@@ -138,12 +138,12 @@ 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 -> InstEnv -> IO TcEnv
-initTcEnv gst inst_env
-  = do { gtv_var <- newIORef emptyVarSet
+initTcEnv :: GlobalSymbolTable -> IO TcEnv
+initTcEnv gst
+  = do { gtv_var <- newIORef emptyVarSet ;
         return (TcEnv { tcGST    = gst,
                         tcGEnv   = emptyNameEnv,
-                        tcInsts  = inst_env,
+                        tcInsts  = emptyInstEnv,
                         tcLEnv   = emptyNameEnv,
                         tcTyVars = gtv_var
         })}
@@ -154,6 +154,9 @@ 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
 -- when type checking type and class declarations
 data TyThingDetails = SynTyDetails Type
@@ -182,7 +185,7 @@ lookup_local env name
   = case lookupNameEnv (tcLEnv env) name of
        Just thing -> Just thing
        Nothing    -> case lookup_global env name of
-                       Just thing -> AGlobal thing
+                       Just thing -> Just (AGlobal thing)
                        Nothing    -> Nothing
 
 explicitLookupId :: TcEnv -> Name -> Maybe Id
@@ -262,7 +265,7 @@ newDFunName mod clas (ty:_) loc
     tcGetUnique                        `thenNF_Tc` \ uniq ->
     returnNF_Tc (mkGlobalName uniq mod
                              (mkDFunOcc dfun_string inst_uniq) 
-                             (LocalDef loc Exported))
+                             loc)
   where
        -- Any string that is somewhat unique will do
     dfun_string = occNameString (getOccName clas) ++ occNameString (getDFunTyKey ty)
@@ -272,7 +275,7 @@ newDefaultMethodName op_name loc
   = tcGetUnique                        `thenNF_Tc` \ uniq ->
     returnNF_Tc (mkGlobalName uniq (nameModule op_name)
                              (mkDefaultMethodOcc (getOccName op_name))
-                             (LocalDef loc Exported))
+                             loc)
 \end{code}
 
 
@@ -308,6 +311,7 @@ A variety of global lookups, when we know what we are looking for.
 
 \begin{code}
 tcLookupGlobal :: Name -> NF_TcM TyThing
+tcLookupGlobal name
   = tcLookupGlobal_maybe name  `thenNF_Tc` \ maybe_thing ->
     case maybe_thing of
        Just thing -> returnNF_Tc thing
@@ -317,7 +321,7 @@ tcLookupGlobalId :: Name -> NF_TcM Id
 tcLookupGlobalId name
   = tcLookupGlobal_maybe name  `thenNF_Tc` \ maybe_id ->
     case maybe_id of
-       Just (AnId clas) -> returnNF_Tc id
+       Just (AnId clas) -> returnNF_Tc clas
        other            -> notFound "tcLookupGlobalId:" name
        
 tcLookupDataCon :: Name -> TcM DataCon