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
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]
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;
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))
; 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)))
= 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
tcExtendTyVarEnvForMeths,
tcAddImportedIdInfo, tcInstId, tcLookupClass,
InstInfo(..), pprInstInfo, simpleInstInfoTyCon, simpleInstInfoTy,
- newDFunName, tcExtendTyVarEnv, tcGetInstEnv
+ newDFunName, tcExtendTyVarEnv
)
import InstEnv ( InstEnv, extendInstEnv, pprInstEnv )
import TcMonoType ( tcTyVars, tcHsSigType, kcHsSigType )
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 ->
-- 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,
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}
projects / ghc-hetmet.git / commitdiff