[project @ 2000-10-17 09:33:41 by simonpj]

Environments in typechecker

diff --git a/ghc/compiler/deSugar/DsMonad.lhs b/ghc/compiler/deSugar/DsMonad.lhs
index d32e750..8b61bbb 100644 (file)
--- a/ghc/compiler/deSugar/DsMonad.lhs
+++ b/ghc/compiler/deSugar/DsMonad.lhs
@@ -50,9 +50,9 @@ presumably include source-file location information:
 \begin{code}
 type DsM result =
        UniqSupply
-        -> ValueEnv
-       -> SrcLoc                -- to put in pattern-matching error msgs
-       -> Module                -- module: for SCC profiling
+        -> (Name -> Id)                -- Lookup well-known Ids
+       -> SrcLoc               -- to put in pattern-matching error msgs
+       -> Module               -- module: for SCC profiling
        -> DsWarnings
        -> (result, DsWarnings)
 
@@ -66,13 +66,28 @@ type DsWarnings = Bag WarnMsg           -- The desugarer reports matches which a
 -- initDs returns the UniqSupply out the end (not just the result)
 
 initDs  :: UniqSupply
-       -> ValueEnv
+       -> (HomeSymbolTable, PersistentCompilerState, TypeEnv)
        -> Module   -- module name: for profiling
        -> DsM a
        -> (a, DsWarnings)
 
-initDs init_us genv mod action
-  = action init_us genv noSrcLoc mod emptyBag
+initDs init_us (hst,pcs,local_type_env) mod action
+  = action init_us lookup noSrcLoc mod emptyBag
+  where
+       -- This lookup is used for well-known Ids, 
+       -- such as fold, build, cons etc, so the chances are
+       -- it'll be found in the package symbol table.  That's
+       -- why we don't merge all these tables
+    pst = pcsPST pcs
+    lookup n = case lookupTypeEnv pst n of {
+                Just (AnId v) -> v ;
+                other -> 
+              case lookupTypeEnv hst n of {
+                Just (AnId v) -> v ;
+                other -> 
+              case lookupNameEnv local_type_env n of
+                Just (AnId v) -> v ;
+                other         -> pprPanic "initDS: lookup:" (ppr n)
 
 thenDs :: DsM a -> (a -> DsM b) -> DsM b
 andDs  :: (a -> a -> a) -> DsM a -> DsM a -> DsM a
@@ -198,11 +213,13 @@ getModuleDs us genv loc mod warns = (mod, warns)
 \end{code}
 
 \begin{code}
-dsLookupGlobalValue :: Unique -> DsM Id
+dsLookupGlobalValue :: Name -> DsM Id
 dsLookupGlobalValue key us genv loc mod warns
-  = (lookupWithDefaultUFM_Directly genv def key, warns)
+  = (result, warns)
   where
-    def = pprPanic "dsLookupGlobalValue:" (ppr key)
+    result = case lookupNameEnv genv name of
+               Just (AnId v) -> v
+               Nothing       -> pprPanic "dsLookupGlobalValue:" (ppr name)
 \end{code}
 
 

diff --git a/ghc/compiler/typecheck/TcClassDcl.lhs b/ghc/compiler/typecheck/TcClassDcl.lhs
index 324038c..4c038e7 100644 (file)
--- a/ghc/compiler/typecheck/TcClassDcl.lhs
+++ b/ghc/compiler/typecheck/TcClassDcl.lhs
@@ -25,7 +25,7 @@ import RnHsSyn                ( RenamedTyClDecl,
 import TcHsSyn         ( TcMonoBinds, idsToMonoBinds )
 
 import Inst            ( InstOrigin(..), LIE, emptyLIE, plusLIE, plusLIEs, newDicts, newMethod )
-import TcEnv           ( TcId, ValueEnv, TyThing(..), TyThingDetails(..), tcAddImportedIdInfo,
+import TcEnv           ( TcId, TcEnv, TyThing(..), TyThingDetails(..), tcAddImportedIdInfo,
                          tcLookupClass, tcExtendTyVarEnvForMeths, tcExtendGlobalTyVars,
                          tcExtendLocalValEnv, tcExtendTyVarEnv, newDefaultMethodName
                        )
@@ -99,7 +99,7 @@ Death to "ExpandingDicts".
 %************************************************************************
 
 \begin{code}
-tcClassDecl1 :: ValueEnv -> RenamedTyClDecl -> TcM (Name, TyThingDetails)
+tcClassDecl1 :: TcEnv -> RenamedTyClDecl -> TcM (Name, TyThingDetails)
 tcClassDecl1 rec_env
             (ClassDecl context class_name
                        tyvar_names fundeps class_sigs def_methods pragmas 
@@ -232,7 +232,7 @@ tcSuperClasses clas context sc_sel_names
     is_tyvar other      = False
 
 
-tcClassSig :: ValueEnv                 -- Knot tying only!
+tcClassSig :: TcEnv                    -- Knot tying only!
           -> Class                     -- ...ditto...
           -> [TyVar]                   -- The class type variable, used for error check only
           -> NameEnv (DefMeth Name)    -- Info about default methods

diff --git a/ghc/compiler/typecheck/TcEnv.lhs b/ghc/compiler/typecheck/TcEnv.lhs
index 96a0601..228a688 100644 (file)
--- a/ghc/compiler/typecheck/TcEnv.lhs
+++ b/ghc/compiler/typecheck/TcEnv.lhs
@@ -93,7 +93,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)
@@ -141,12 +141,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 :: GlobalSymbolTable -> IO TcEnv
 initTcEnv gst inst_env
   = do { gtv_var <- newIORef emptyVarSet ;
         return (TcEnv { tcGST    = gst,
                         tcGEnv   = emptyNameEnv,
-                        tcInsts  = inst_env,
+                        tcInsts  = emptyInstEnv,
                         tcLEnv   = emptyNameEnv,
                         tcTyVars = gtv_var
         })}

diff --git a/ghc/compiler/typecheck/TcInstDcls.lhs b/ghc/compiler/typecheck/TcInstDcls.lhs
index 5bdec50..459160d 100644 (file)
--- a/ghc/compiler/typecheck/TcInstDcls.lhs
+++ b/ghc/compiler/typecheck/TcInstDcls.lhs
@@ -28,7 +28,7 @@ import Inst           ( InstOrigin(..),
                          newDicts, newClassDicts,
                          LIE, emptyLIE, plusLIE, plusLIEs )
 import TcDeriv         ( tcDeriving )
-import TcEnv           ( ValueEnv, tcExtendGlobalValEnv, 
+import TcEnv           ( TcEnv, tcExtendGlobalValEnv, 
                          tcExtendTyVarEnvForMeths, TyThing (..),
                          tcAddImportedIdInfo, tcInstId, tcLookupClass,
                          newDFunName, tcExtendTyVarEnv
@@ -226,7 +226,7 @@ addInstDFuns dfuns infos
 \end{code} 
 
 \begin{code}
-tcInstDecl1 :: Module -> ValueEnv -> RenamedInstDecl -> NF_TcM [InstInfo]
+tcInstDecl1 :: Module -> TcEnv -> RenamedInstDecl -> NF_TcM [InstInfo]
 -- Deal with a single instance declaration
 tcInstDecl1 mod unf_env (InstDecl poly_ty binds uprags maybe_dfun_name src_loc)
   =    -- Prime error recovery, set source location

diff --git a/ghc/compiler/typecheck/TcModule.lhs b/ghc/compiler/typecheck/TcModule.lhs
index 9bb9fbf..150b266 100644 (file)
--- a/ghc/compiler/typecheck/TcModule.lhs
+++ b/ghc/compiler/typecheck/TcModule.lhs
@@ -85,7 +85,7 @@ typecheckModule
        -> IO (Maybe (PersistentCompilerState, TcResults))
 
 typecheckModule pcs hst (HsModule mod_name _ _ _ decls _ src_loc)
-  = do { env <- initTcEnv global_symbol_table global_inst_env ;
+  = do { env <- initTcEnv global_symbol_table ;
 
         (_, (maybe_result, msgs)) <- initTc env src_loc tc_module
                

diff --git a/ghc/compiler/typecheck/TcTyClsDecls.lhs b/ghc/compiler/typecheck/TcTyClsDecls.lhs
index 736f619..ae7e4d2 100644 (file)
--- a/ghc/compiler/typecheck/TcTyClsDecls.lhs
+++ b/ghc/compiler/typecheck/TcTyClsDecls.lhs
@@ -20,7 +20,7 @@ import RnHsSyn                ( RenamedHsDecl, RenamedTyClDecl, listTyCon_name )
 import BasicTypes      ( RecFlag(..), NewOrData(..) )
 
 import TcMonad
-import TcEnv           ( ValueEnv, TyThing(..), TyThingDetails(..), tyThingKind,
+import TcEnv           ( TcEnv, TyThing(..), TyThingDetails(..), tyThingKind,
                          tcExtendTypeEnv, tcExtendKindEnv, tcLookupGlobal
                        )
 import TcTyDecls       ( tcTyDecl1, kcConDetails, mkNewTyConRep )
@@ -61,7 +61,7 @@ import Generics         ( mkTyConGenInfo )
 The main function
 ~~~~~~~~~~~~~~~~~
 \begin{code}
-tcTyAndClassDecls :: ValueEnv          -- Knot tying stuff
+tcTyAndClassDecls :: TcEnv             -- Knot tying stuff
                  -> [RenamedHsDecl]
                  -> TcM TcEnv
 
@@ -111,7 +111,7 @@ The knot-tying parameters: @rec_details_list@ is an alist mapping @Name@s to
 @TyThing@s.  @rec_vrcs@ is a finite map from @Name@s to @ArgVrcs@s.
 
 \begin{code}
-tcGroup :: ValueEnv -> SCC RenamedTyClDecl -> TcM TcEnv
+tcGroup :: TcEnv -> SCC RenamedTyClDecl -> TcM TcEnv
 tcGroup unf_env scc
   =    -- Step 1
     mapNF_Tc getInitialKind decls                              `thenNF_Tc` \ initial_kinds ->