Commit c5eb828c authored by simonpj's avatar simonpj
Browse files

[project @ 2000-10-12 16:41:48 by simonpj]

Mainly TcModule plumbing
parent 435b542f
......@@ -63,11 +63,11 @@ emptyModDetails mod
moduleExports = [],
moduleEnv = emptyRdrEnv,
fixityEnv = emptyNameEnv,
deptecEnv = emptyNameEnv,
deprecEnv = emptyNameEnv,
typeEnv = emptyNameEnv,
instEnv = emptyInstEnv,
} ruleEnv = emptyRuleEnv
ruleEnv = emptyRuleEnv
}
\end{code}
Symbol tables map modules to ModDetails:
......@@ -121,9 +121,10 @@ lookupTypeEnv tbl name
Nothing -> Nothing
groupTyThings :: [TyThing] -> [(Module, TypeEnv)]
groupTyThings :: [TyThing] -> FiniteMap Module TypeEnv
-- Finite map because we want the range too
groupTyThings things
= fmToList (foldl add emptyFM things)
= foldl add emptyFM things
where
add :: FiniteMap Module TypeEnv -> TyThing -> FiniteMap Module TypeEnv
add tbl thing = addToFM tbl mod new_env
......@@ -134,11 +135,11 @@ groupTyThings things
Nothing -> unitNameEnv name thing
Just env -> extendNameEnv env name thing
extendTypeEnv :: SymbolTable -> [TyThing] -> SymbolTable
extendTypeEnv :: SymbolTable -> FiniteMap Module TypeEnv -> SymbolTable
extendTypeEnv tbl things
= foldl add tbl (groupTyThings things)
= foldFM add tbl things
where
add tbl (mod,type_env)
add mod type_env tbl
= extendModuleEnv mod new_details
where
new_details = case lookupModuleEnv tbl mod of
......
......@@ -62,7 +62,7 @@ import Name ( Name, OccName, Provenance(..), ExportFlag(..), NamedThing(..),
import OccName ( mkDFunOcc, mkDefaultMethodOcc, occNameString )
import Module ( Module )
import Unify ( unifyTyListsX, matchTys )
import HscTypes ( ModDetails(..), lookupTypeEnv )
import HscTypes ( ModDetails(..), InstEnv, lookupTypeEnv )
import Unique ( pprUnique10, Unique, Uniquable(..) )
import UniqFM
import Unique ( Uniquable(..) )
......
......@@ -68,15 +68,13 @@ Outside-world interface:
-- Convenient type synonyms first:
data TcResults
= TcResults {
tc_prs :: PersistentCompilerState, -- Augmented with imported information,
tc_pcs :: PersistentCompilerState, -- Augmented with imported information,
-- (but not stuff from this module)
tc_env :: TypeEnv, -- The TypeEnv just for the stuff from this module
tc_binds :: TypecheckedMonoBinds,
tc_tycons :: [TyCon],
tc_classes :: [Class],
tc_insts :: Bag InstInfo, -- Instance declaration information
tc_insts :: InstEnv, -- Instances, just for this module
tc_fords :: [TypecheckedForeignDecl], -- Foreign import & exports.
tc_rules :: [TypecheckedRuleDecl], -- Transformation rules
tc_env :: ValueEnv
}
---------------
......@@ -84,7 +82,7 @@ typecheckModule
:: PersistentCompilerState
-> HomeSymbolTable
-> RenamedHsModule
-> IO (Maybe TcResults)
-> IO (Maybe (PersistentCompilerState, TcResults))
typecheckModule pcs hst mod
= do { us <- mkSplitUniqSupply 'a' ;
......@@ -95,17 +93,29 @@ typecheckModule pcs hst mod
printErrorsAndWarnings errs warns ;
(case maybe_result of
Nothing -> return ()
Just results -> do { dumpIfSet opt_D_dump_types "Type signatures" (dump_sigs results)
dumpIfSet opt_D_dump_tc "Typechecked" (dump_tc results)
}) ;
case maybe_result of {
Nothing -> return Nothing ;
Just results -> do {
dumpIfSet opt_D_dump_types "Type signatures" (dump_sigs results) ;
dumpIfSet opt_D_dump_tc "Typechecked" (dump_tc results) ;
return (if isEmptyBag errs then
maybe_result
else
Nothing)
}
if isEmptyBag errs then
return Nothing
else
let groups :: FiniteMap Module TypeEnv
groups = groupTyThings (nameEnvElts (tc_env results))
local_type_env :: TypeEnv
local_type_env = lookupWithDefaultFM groups this_mod emptyNameEnv
new_pst :: PackageSymbolTable
new_pst = extendTypeEnv (pcsPST pcs) (delFromFM groups this_mod)
;
return (Just (pcs {pcsPST = new_pst},
results {tc_env = local_type_env}))
}}}
where
global_symbol_table = pcsPST pcs `plusModuleEnv` hst
......@@ -256,13 +266,11 @@ tcModule prs (HsModule mod_name _ _ _ decls _ src_loc)
zonkRules rules `thenNF_Tc` \ rules' ->
returnTc (really_final_env,
(TcResults { tc_binds = all_binds',
tc_tycons = local_tycons,
tc_classes = local_classes,
(TcResults { tc_env = tcGEnv really_final_env,
tc_binds = all_binds',
tc_insts = inst_info,
tc_fords = foi_decls ++ foe_decls',
tc_rules = rules',
tc_env = really_final_env
tc_rules = rules'
}))
-- End of outer fix loop
......
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