[commit: ghc] wip/rae-new-coercible: Bugfixing (5bc717e)

[git at git.haskell.org]

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

On branch  : wip/rae-new-coercible
Link       : http://ghc.haskell.org/trac/ghc/changeset/5bc717e9374c3d1c5b24fe676696f7a377e0068d/ghc

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

commit 5bc717e9374c3d1c5b24fe676696f7a377e0068d
Author: Richard Eisenberg <eir at cis.upenn.edu>
Date:   Fri Dec 12 10:40:18 2014 -0500

    Bugfixing


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

5bc717e9374c3d1c5b24fe676696f7a377e0068d
 compiler/typecheck/TcCanonical.hs                 | 4 +++-
 testsuite/tests/typecheck/should_compile/T9708.hs | 9 ++++++++-
 testsuite/tests/typecheck/should_compile/all.T    | 2 +-
 3 files changed, 12 insertions(+), 3 deletions(-)

diff --git a/compiler/typecheck/TcCanonical.hs b/compiler/typecheck/TcCanonical.hs
index cfb2d89..cc1197d 100644
--- a/compiler/typecheck/TcCanonical.hs
+++ b/compiler/typecheck/TcCanonical.hs
@@ -1593,7 +1593,8 @@ unifyWanted loc role    orig_ty1 orig_ty2
            ; return (mkTcTyConAppCo role funTyCon [co_s,co_t]) }
     go (TyConApp tc1 tys1) (TyConApp tc2 tys2)
       | tc1 == tc2, isDecomposableTyCon tc1, tys1 `equalLength` tys2
-      , not (isNewTyCon tc1) || role == Nominal -- don't look under newtypes!
+      , (not (isNewTyCon tc1) && not (isDataFamilyTyCon tc1)) || role == Nominal
+         -- don't look under newtypes!
       = do { cos <- zipWith3M (unifyWanted loc) (tyConRolesX role tc1) tys1 tys2
            ; return (mkTcTyConAppCo role tc1 cos) }
     go (TyVarTy tv) ty2
@@ -1637,6 +1638,7 @@ unify_derived loc role    orig_ty1 orig_ty2
            ; unify_derived loc role t1 t2 }
     go (TyConApp tc1 tys1) (TyConApp tc2 tys2)
       | tc1 == tc2, isDecomposableTyCon tc1, tys1 `equalLength` tys2
+      , (not (isNewTyCon tc1) && not (isDataFamilyTyCon tc1)) || role == Nominal
       = unifyDeriveds loc (tyConRolesX role tc1) tys1 tys2
     go (TyVarTy tv) ty2
       = do { mb_ty <- isFilledMetaTyVar_maybe tv
diff --git a/testsuite/tests/typecheck/should_compile/T9708.hs b/testsuite/tests/typecheck/should_compile/T9708.hs
index b170ef3..61928d4 100644
--- a/testsuite/tests/typecheck/should_compile/T9708.hs
+++ b/testsuite/tests/typecheck/should_compile/T9708.hs
@@ -7,7 +7,14 @@ import Data.Proxy
 type family SomeFun (n :: Nat)
 
 -- See the Trac ticket; whether this suceeds or fails is distintly random
--- Currently it succeeds
+
+-- upon creation, commit f861fc6ad8e5504a4fecfc9bb0945fe2d313687c, this failed
+
+-- with Simon's optimization to the flattening algorithm, commit
+-- 37b3646c9da4da62ae95aa3a9152335e485b261e, this succeeded
+
+-- with the change to stop Deriveds from rewriting Deriveds (around Dec. 12, 2014),
+-- this failed again
 
 ti7 :: (x <= y, y <= x) => Proxy (SomeFun x) -> Proxy y -> ()
 ti7 _ _ = ()
diff --git a/testsuite/tests/typecheck/should_compile/all.T b/testsuite/tests/typecheck/should_compile/all.T
index f2337db..7d33ad5 100644
--- a/testsuite/tests/typecheck/should_compile/all.T
+++ b/testsuite/tests/typecheck/should_compile/all.T
@@ -425,7 +425,7 @@ test('T9569a', normal, compile, [''])
 test('T9117', normal, compile, [''])
 test('T9117_2', normal, compile, [''])
 test('T9117_3', normal, compile, [''])
-test('T9708', normal, compile, [''])
+test('T9708', expect_broken(9708), compile, [''])
 test('T9404', normal, compile, [''])
 test('T9404b', normal, compile, [''])
 test('T7220', normal, compile, [''])