Repository : ssh://darcs.haskell.org//srv/darcs/ghc On branch : overlapping-tyfams
http://hackage.haskell.org/trac/ghc/changeset/e5ded8b76486bebc4fa5835a3e57d6012163cf3c >--------------------------------------------------------------- commit e5ded8b76486bebc4fa5835a3e57d6012163cf3c Author: Richard Eisenberg <e...@cis.upenn.edu> Date: Thu Dec 6 20:06:56 2012 -0500 Miscellaneous bug fixes that came up during validation. >--------------------------------------------------------------- compiler/typecheck/TcDeriv.lhs | 13 ++++++++++--- compiler/typecheck/TcInstDcls.lhs | 2 +- compiler/typecheck/TcRnDriver.lhs | 6 +++++- compiler/types/FamInstEnv.lhs | 1 + 4 files changed, 17 insertions(+), 5 deletions(-) diff --git a/compiler/typecheck/TcDeriv.lhs b/compiler/typecheck/TcDeriv.lhs index 8e1adcb..15bfc72 100644 --- a/compiler/typecheck/TcDeriv.lhs +++ b/compiler/typecheck/TcDeriv.lhs @@ -43,6 +43,7 @@ import RdrName import Name import NameSet import TyCon +import CoAxiom import TcType import Var import VarSet @@ -348,8 +349,8 @@ tcDeriving tycl_decls inst_decls deriv_decls ; return (addTcgDUs gbl_env rn_dus, inst_info, rn_binds) } where ddump_deriving :: Bag (InstInfo Name) -> HsValBinds Name - -> Bag TyCon -- ^ Empty data constructors - -> Bag (FamInst br) -- ^ Rep type family instances + -> Bag TyCon -- ^ Empty data constructors + -> Bag (FamInst Unbranched) -- ^ Rep type family instances -> SDoc ddump_deriving inst_infos extra_binds repMetaTys repFamInsts = hang (ptext (sLit "Derived instances:")) @@ -359,10 +360,16 @@ tcDeriving tycl_decls inst_decls deriv_decls hangP "Generated datatypes for meta-information:" (vcat (map ppr (bagToList repMetaTys))) $$ hangP "Representation types:" - (vcat (map ppr (bagToList repFamInsts)))) + (vcat (map pprRepTy (bagToList repFamInsts)))) hangP s x = text "" $$ hang (ptext (sLit s)) 2 x +-- Prints the representable type family instance +pprRepTy :: FamInst Unbranched -> SDoc +pprRepTy fi@(FamInst { fi_branches = FirstBranch (FamInstBranch { fib_lhs = lhs + , fib_rhs = rhs }) }) + = ptext (sLit "type") <+> ppr (mkTyConApp (famInstTyCon fi) lhs) <+> + equals <+> ppr rhs -- As of 24 April 2012, this only shares MetaTyCons between derivations of diff --git a/compiler/typecheck/TcInstDcls.lhs b/compiler/typecheck/TcInstDcls.lhs index ad24ab5..d15869d 100644 --- a/compiler/typecheck/TcInstDcls.lhs +++ b/compiler/typecheck/TcInstDcls.lhs @@ -434,7 +434,7 @@ addFamInsts :: [FamInst Branched] -> TcM a -> TcM a -- (b) the type envt with stuff from data type decls addFamInsts fam_insts thing_inside = tcExtendLocalFamInstEnv fam_insts $ - tcExtendGlobalEnvImplicit things $ + tcExtendGlobalEnv things $ do { traceTc "addFamInsts" (pprFamInsts fam_insts) ; tcg_env <- tcAddImplicits things ; setGblEnv tcg_env thing_inside } diff --git a/compiler/typecheck/TcRnDriver.lhs b/compiler/typecheck/TcRnDriver.lhs index 4c3e5c4..c907a96 100644 --- a/compiler/typecheck/TcRnDriver.lhs +++ b/compiler/typecheck/TcRnDriver.lhs @@ -488,6 +488,8 @@ tc_rn_src_decls boot_details ds setEnvs (tcg_env, tcl_env) $ case group_tail of { Nothing -> do { tcg_env <- checkMain ; -- Check for `main' + traceTc "returning from tc_rn_src_decls: " $ + ppr $ nameEnvElts $ tcg_type_env tcg_env ; -- RAE return (tcg_env, tcl_env) } ; @@ -955,7 +957,7 @@ tcTopSrcDecls boot_details -- tcg_dus: see Note [Newtype constructor usage in foreign declarations] addUsedRdrNames fo_rdr_names ; - + traceTc "Tc8: type_env: " (ppr $ nameEnvElts $ tcg_type_env tcg_env') ; -- RAE return (tcg_env', tcl_env) }}}}}} where @@ -1635,6 +1637,8 @@ tcRnDeclsi hsc_env ictxt local_decls = tcg_env'' <- setGlobalTypeEnv tcg_env' final_type_env + traceTc "returning from tcRnDeclsi: " $ ppr $ nameEnvElts $ tcg_type_env tcg_env'' -- RAE + return tcg_env'' diff --git a/compiler/typecheck/TcTyClsDecls.lhs b/compiler/typecheck/TcTyClsDecls.lhs index 065103b..7f12e49 100644 diff --git a/compiler/types/FamInstEnv.lhs b/compiler/types/FamInstEnv.lhs index 3a9853d..f64d7ee 100644 --- a/compiler/types/FamInstEnv.lhs +++ b/compiler/types/FamInstEnv.lhs @@ -511,6 +511,7 @@ identicalFamInst :: FamInst br1 -> FamInst br2 -> Bool -- Used for overriding in GHCi identicalFamInst (FamInst { fi_axiom = ax1 }) (FamInst { fi_axiom = ax2 }) = nameModule (coAxiomName ax1) == nameModule (coAxiomName ax2) + && coAxiomTyCon ax1 == coAxiomTyCon ax2 && brListLength brs1 == brListLength brs2 && and (brListZipWith identical_ax_branch brs1 brs2) where brs1 = coAxiomBranches ax1 _______________________________________________ Cvs-ghc mailing list Cvs-ghc@haskell.org http://www.haskell.org/mailman/listinfo/cvs-ghc
