Commit a180ee15 authored by simonpj's avatar simonpj
Browse files

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

Environments in typechecker
parent 632de260
......@@ -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}
......
......@@ -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
......
......@@ -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
})}
......
......@@ -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
......
......@@ -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
......
......@@ -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 ->
......
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment