[commit: ghc] overlapping-tyfams: Miscellaneous bug fixes that came up during validation. (e5ded8b)

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 <[email protected]>
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