Commit 8fbe28ca authored by simonpj's avatar simonpj
Browse files

[project @ 2000-11-21 09:30:16 by simonpj]

Fix renamer bugs
parent 96cf57e3
......@@ -287,9 +287,14 @@ Allocation of unique supply characters:
mkAlphaTyVarUnique i = mkUnique '1' i
mkPreludeClassUnique i = mkUnique '2' i
-- Prelude type constructors occupy *three* slots.
-- The first is for the tycon itself; the latter two
-- are for the generic to/from Ids. See TysWiredIn.mk_tc_gen_info.
mkPreludeTyConUnique i = mkUnique '3' (3*i)
mkTupleTyConUnique Boxed a = mkUnique '4' a
mkTupleTyConUnique Unboxed a = mkUnique '5' a
mkTupleTyConUnique Boxed a = mkUnique '4' (3*a)
mkTupleTyConUnique Unboxed a = mkUnique '5' (3*a)
-- Data constructor keys occupy *two* slots. The first is used for the
-- data constructor itself and its wrapper function (the function that
......
......@@ -257,6 +257,11 @@ instance NamedThing TyThing where
getName (ATyCon tc) = getName tc
getName (AClass cl) = getName cl
instance Outputable TyThing where
ppr (AnId id) = ptext SLIT("AnId") <+> ppr id
ppr (ATyCon tc) = ptext SLIT("ATyCon") <+> ppr tc
ppr (AClass cl) = ptext SLIT("AClass") <+> ppr cl
typeEnvClasses env = [cl | AClass cl <- nameEnvElts env]
typeEnvTyCons env = [tc | ATyCon tc <- nameEnvElts env]
......
......@@ -178,6 +178,20 @@ pcTyCon new_or_data is_rec name tyvars argvrcs cons
kind = mkArrowKinds (map tyVarKind tyvars) boxedTypeKind
gen_info = mk_tc_gen_info mod (nameUnique name) name tycon
-- We generate names for the generic to/from Ids by incrementing
-- the TyCon unique. So each Prelude tycon needs 3 slots, one
-- for itself and two more for the generic Ids.
mk_tc_gen_info mod tc_uniq tc_name tycon
= mkTyConGenInfo tycon name1 name2
where
tc_occ_name = nameOccName tc_name
occ_name1 = mkGenOcc1 tc_occ_name
occ_name2 = mkGenOcc2 tc_occ_name
fn1_key = incrUnique tc_uniq
fn2_key = incrUnique fn1_key
name1 = mkWiredInName mod occ_name1 fn1_key
name2 = mkWiredInName mod occ_name2 fn2_key
pcDataCon :: Name -> [TyVar] -> ClassContext -> [TauType] -> TyCon -> DataCon
-- The unique is the first of two free uniques;
-- the first is used for the datacon itself and the worker;
......@@ -246,18 +260,6 @@ mk_tuple boxity arity = (tycon, tuple_con)
mod = mkPrelModule mod_name
gen_info = mk_tc_gen_info mod tc_uniq tc_name tycon
mk_tc_gen_info mod tc_uniq tc_name tycon
= gen_info
where
tc_occ_name = nameOccName tc_name
occ_name1 = mkGenOcc1 tc_occ_name
occ_name2 = mkGenOcc2 tc_occ_name
fn1_key = incrUnique tc_uniq
fn2_key = incrUnique fn1_key
name1 = mkWiredInName mod occ_name1 fn1_key
name2 = mkWiredInName mod occ_name2 fn2_key
gen_info = mkTyConGenInfo tycon name1 name2
unitTyCon = tupleTyCon Boxed 0
unitDataConId = dataConId (head (tyConDataCons unitTyCon))
......
......@@ -110,7 +110,7 @@ renameExpr dflags hit hst pcs this_module expr
; renameSource dflags hit hst pcs this_module $
initRnMS rdr_env emptyLocalFixityEnv SourceMode (rnExpr expr) `thenRn` \ (e,fvs) ->
closeDecls [] fvs `thenRn` \ decls ->
slurpImpDecls fvs `thenRn` \ decls ->
doptRn Opt_D_dump_rn `thenRn` \ dump_rn ->
ioToRnM (dumpIfSet dump_rn "Renamer:" (ppr e)) `thenRn_`
returnRn (Just (print_unqual, (e, decls)))
......
......@@ -213,22 +213,20 @@ slurpImpDecls source_fvs
= traceRn (text "slurpImp" <+> fsep (map ppr (nameSetToList source_fvs))) `thenRn_`
-- The current slurped-set records all local things
getSlurped `thenRn` \ source_binders ->
slurpSourceRefs source_binders source_fvs `thenRn` \ (decls, needed) ->
slurpSourceRefs source_fvs `thenRn` \ (decls, needed) ->
-- Then get everything else
closeDecls decls needed
-------------------------------------------------------
slurpSourceRefs :: NameSet -- Variables defined in source
-> FreeVars -- Variables referenced in source
slurpSourceRefs :: FreeVars -- Variables referenced in source
-> RnMG ([RenamedHsDecl],
FreeVars) -- Un-satisfied needs
-- The declaration (and hence home module) of each gate has
-- already been loaded
slurpSourceRefs source_binders source_fvs
slurpSourceRefs source_fvs
= go_outer [] -- Accumulating decls
emptyFVs -- Unsatisfied needs
emptyFVs -- Accumulating gates
......
......@@ -31,7 +31,7 @@ import TcEnv ( TcEnv, tcExtendGlobalValEnv,
tcExtendTyVarEnvForMeths,
tcAddImportedIdInfo, tcInstId, tcLookupClass,
InstInfo(..), pprInstInfo, simpleInstInfoTyCon, simpleInstInfoTy,
newDFunName, tcExtendTyVarEnv, tcGetInstEnv
newDFunName, tcExtendTyVarEnv
)
import InstEnv ( InstEnv, extendInstEnv, pprInstEnv )
import TcMonoType ( tcTyVars, tcHsSigType, kcHsSigType )
......@@ -196,6 +196,11 @@ tcInstDecls1 inst_env0 prs hst unf_env get_fixity mod decls
imported_inst_info
hst_dfuns = foldModuleEnv ((++) . md_insts) [] hst
in
traceTc (text "inst env before" <+> pprInstEnv inst_env0) `thenNF_Tc_`
traceTc (vcat [text "imp" <+> ppr imported_dfuns,
text "hst" <+> ppr hst_dfuns,
text "local" <+> hsep (map pprInstInfo local_inst_info),
text "gen" <+> hsep (map pprInstInfo generic_inst_info)]) `thenNF_Tc_`
addInstDFuns inst_env0 imported_dfuns `thenNF_Tc` \ inst_env1 ->
addInstDFuns inst_env1 hst_dfuns `thenNF_Tc` \ inst_env2 ->
addInstInfos inst_env2 local_inst_info `thenNF_Tc` \ inst_env3 ->
......@@ -207,8 +212,10 @@ tcInstDecls1 inst_env0 prs hst unf_env get_fixity mod decls
-- This stuff computes a context for the derived instance decl, so it
-- needs to know about all the instances possible; hecne inst_env4
tcDeriving prs mod inst_env4 get_fixity tycl_decls `thenTc` \ (deriv_inst_info, deriv_binds) ->
traceTc (vcat [text "deriv" <+> hsep (map pprInstInfo deriv_inst_info)]) `thenNF_Tc_`
addInstInfos inst_env4 deriv_inst_info `thenNF_Tc` \ final_inst_env ->
traceTc (text "inst env after" <+> pprInstEnv final_inst_env) `thenNF_Tc_`
returnTc (inst_env1,
final_inst_env,
generic_inst_info ++ deriv_inst_info ++ local_inst_info,
......@@ -220,11 +227,12 @@ addInstInfos inst_env infos = addInstDFuns inst_env (map iDFunId infos)
addInstDFuns :: InstEnv -> [DFunId] -> NF_TcM InstEnv
addInstDFuns dfuns infos
= getDOptsTc `thenTc` \ dflags ->
extendInstEnv dflags dfuns infos `bind` \ (inst_env', errs) ->
let
(inst_env', errs) = extendInstEnv dflags dfuns infos
in
traceTc (text "addInstDFuns" <+> vcat errs) `thenNF_Tc_`
addErrsTc errs `thenNF_Tc_`
returnTc inst_env'
where
bind x f = f x
\end{code}
\begin{code}
......
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