[commit: ghc] wip/rae: Fix #11754 by adding an additional check. (ccd68f2)

[git at git.haskell.org]

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

On branch  : wip/rae
Link       : http://ghc.haskell.org/trac/ghc/changeset/ccd68f22fe1bb48d81f941a8c0b9bd2a79e4566f/ghc

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

commit ccd68f22fe1bb48d81f941a8c0b9bd2a79e4566f
Author: Richard Eisenberg <eir at cis.upenn.edu>
Date:   Fri Mar 25 15:11:24 2016 -0400

    Fix #11754 by adding an additional check.
    
    This was just plain wrong previously.
    
    Test case: typecheck/should_compile/T11754


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

ccd68f22fe1bb48d81f941a8c0b9bd2a79e4566f
 compiler/types/OptCoercion.hs                      |  7 +++---
 testsuite/tests/typecheck/should_compile/T11754.hs | 28 ++++++++++++++++++++++
 testsuite/tests/typecheck/should_compile/all.T     |  1 +
 3 files changed, 33 insertions(+), 3 deletions(-)

diff --git a/compiler/types/OptCoercion.hs b/compiler/types/OptCoercion.hs
index fb6c68e..e39f0aa 100644
--- a/compiler/types/OptCoercion.hs
+++ b/compiler/types/OptCoercion.hs
@@ -874,10 +874,11 @@ etaTyConAppCo_maybe tc (TyConAppCo _ tc2 cos2)
 
 etaTyConAppCo_maybe tc co
   | mightBeUnsaturatedTyCon tc
-  , Pair ty1 ty2     <- coercionKind co
-  , Just (tc1, tys1) <- splitTyConApp_maybe ty1
-  , Just (tc2, tys2) <- splitTyConApp_maybe ty2
+  , (Pair ty1 ty2, r) <- coercionKindRole co
+  , Just (tc1, tys1)  <- splitTyConApp_maybe ty1
+  , Just (tc2, tys2)  <- splitTyConApp_maybe ty2
   , tc1 == tc2
+  , isInjectiveTyCon tc r  -- See Note [NthCo and newtypes] in TyCoRep
   , let n = length tys1
   = ASSERT( tc == tc1 )
     ASSERT( n == length tys2 )
diff --git a/testsuite/tests/typecheck/should_compile/T11754.hs b/testsuite/tests/typecheck/should_compile/T11754.hs
new file mode 100644
index 0000000..248be2b
--- /dev/null
+++ b/testsuite/tests/typecheck/should_compile/T11754.hs
@@ -0,0 +1,28 @@
+{-# LANGUAGE TypeOperators, UndecidableSuperClasses, KindSignatures,
+TypeFamilies, FlexibleContexts #-}
+
+module T11754 where
+
+import Data.Kind
+import Data.Void
+
+newtype K a x = K a
+newtype I   x = I x
+
+data (f + g) x = L (f x) | R (g x)
+data (f × g) x = f x :×: g x
+
+class Differentiable (D f) => Differentiable f where
+  type D (f :: Type -> Type) :: Type -> Type
+
+instance Differentiable (K a) where
+  type D (K a) = K Void
+
+instance Differentiable I where
+  type D I = K ()
+
+instance (Differentiable f₁, Differentiable f₂) => Differentiable (f₁ + f₂) where
+  type D (f₁ + f₂) = D f₁ + D f₂
+
+instance (Differentiable f₁, Differentiable f₂) => Differentiable (f₁ × f₂) where
+  type D (f₁ × f₂) = (D f₁ × f₂) + (f₁ × D f₂)
diff --git a/testsuite/tests/typecheck/should_compile/all.T b/testsuite/tests/typecheck/should_compile/all.T
index 267795b..0d99284 100644
--- a/testsuite/tests/typecheck/should_compile/all.T
+++ b/testsuite/tests/typecheck/should_compile/all.T
@@ -510,3 +510,4 @@ test('T11608', normal, compile, [''])
 test('T11401', normal, compile, [''])
 test('T11699', normal, compile, [''])
 test('T11512', normal, compile, [''])
+test('T11754', normal, compile, [''])