[commit: ghc] wip/T9858-typeable-ben3: debug (0232390)

[git at git.haskell.org]

Repository : ssh://git@git.haskell.org/ghc

On branch  : wip/T9858-typeable-ben3
Link       : http://ghc.haskell.org/trac/ghc/changeset/02323906b30aa1cf84409e049637278f1ac64636/ghc

>---------------------------------------------------------------

commit 02323906b30aa1cf84409e049637278f1ac64636
Author: Ben Gamari <ben at smart-cactus.org>
Date:   Wed Oct 28 10:36:28 2015 +0100

    debug


>---------------------------------------------------------------

02323906b30aa1cf84409e049637278f1ac64636
 compiler/types/FamInstEnv.hs | 13 +++++++++++--
 compiler/types/Unify.hs      |  8 ++++----
 2 files changed, 15 insertions(+), 6 deletions(-)

diff --git a/compiler/types/FamInstEnv.hs b/compiler/types/FamInstEnv.hs
index a41e453..1143fa7 100644
--- a/compiler/types/FamInstEnv.hs
+++ b/compiler/types/FamInstEnv.hs
@@ -674,11 +674,13 @@ lookupFamInstEnvConflicts
 -- Precondition: the tycon is saturated (or over-saturated)
 
 lookupFamInstEnvConflicts envs fam_inst@(FamInst { fi_axiom = new_axiom })
-  = lookup_fam_inst_env my_unify envs fam tys
+  = let ret = lookup_fam_inst_env my_unify envs fam tys
+    in pprTrace "lookupFamInstEnvConflicts(return)" (vcat [pprBranch new_branch, ppr $ null ret]) ret
   where
     (fam, tys) = famInstSplitLHS fam_inst
         -- In example above,   fam tys' = F [b]
 
+    pprBranch br = ppr (coAxBranchLHS br) <+> char '~' <+> ppr (coAxBranchRHS br)
     my_unify (FamInst { fi_axiom = old_axiom }) tpl_tvs tpl_tys _
        = ASSERT2( tyVarsOfTypes tys `disjointVarSet` tpl_tvs,
                   (ppr fam <+> ppr tys) $$
@@ -687,7 +689,14 @@ lookupFamInstEnvConflicts envs fam_inst@(FamInst { fi_axiom = new_axiom })
                 -- They shouldn't because we allocate separate uniques for them
          if compatibleBranches (coAxiomSingleBranch old_axiom) new_branch
            then Nothing
-           else Just noSubst
+           else pprTrace "lookupFamInstEnvConflicts"
+                (vcat [pprBranch (coAxiomSingleBranch old_axiom), pprBranch new_branch
+                      , ppr lhs1, ppr lhs2
+                      , ppr $ compatibleBranches (coAxiomSingleBranch old_axiom) new_branch
+                      , ppr $ tcUnifyTysFG instanceBindFun lhs1 lhs2]) $
+                Just noSubst
+      where lhs1 = cab_lhs $  coAxiomSingleBranch old_axiom
+            lhs2 = cab_lhs $  new_branch
       -- Note [Family instance overlap conflicts]
 
     noSubst = panic "lookupFamInstEnvConflicts noSubst"
diff --git a/compiler/types/Unify.hs b/compiler/types/Unify.hs
index 87681e0..7f28bed 100644
--- a/compiler/types/Unify.hs
+++ b/compiler/types/Unify.hs
@@ -577,7 +577,7 @@ unify ty1 ty2
   = if tc1 == tc2
     then if isInjectiveTyCon tc1 Nominal
          then unify_tys tys1 tys2
-         else don'tBeSoSure $ unify_tys tys1 tys2
+         else pprTrace "NotSoFast" (hsep [ppr tc1, ppr tys1, ppr tc2, ppr tys2]) $ don'tBeSoSure $ unify_tys tys1 tys2
     else -- tc1 /= tc2
          if isGenerativeTyCon tc1 Nominal && isGenerativeTyCon tc2 Nominal
          then surelyApart
@@ -610,7 +610,7 @@ unify_tys orig_xs orig_ys
     go []     []     = return ()
     go (x:xs) (y:ys) = do { unify x y
                           ; go xs ys }
-    go _ _ = maybeApart  -- See Note [Lists of different lengths are MaybeApart]
+    go _ _ = pprTrace "unify_tys" (hsep [ppr orig_xs, ppr orig_ys])maybeApart  -- See Note [Lists of different lengths are MaybeApart]
 
 ---------------------------------
 uVar :: TyVar           -- Type variable to be unified
@@ -661,7 +661,7 @@ uUnrefined subst tv1 ty2 (TyVarTy tv2)
        ; b2 <- tvBindFlag tv2
        ; let ty1 = TyVarTy tv1
        ; case (b1, b2) of
-           (Skolem, Skolem) -> maybeApart -- See Note [Unification with skolems]
+           (Skolem, Skolem) -> pprTrace "uUnrefined" (hsep [ppr tv1, ppr ty2, ppr tv2]) maybeApart -- See Note [Unification with skolems]
            (BindMe, _)      -> extendSubst tv1 ty2
            (_, BindMe)      -> extendSubst tv2 ty1 }
 
@@ -681,7 +681,7 @@ bindTv :: TyVar -> Type -> UM ()
 bindTv tv ty      -- ty is not a type variable
   = do  { b <- tvBindFlag tv
         ; case b of
-            Skolem -> maybeApart  -- See Note [Unification with skolems]
+            Skolem -> pprTrace "bindTv" (hsep [ppr tv, ppr ty]) maybeApart  -- See Note [Unification with skolems]
             BindMe -> extendSubst tv ty
         }