[commit: ghc] master: Fix OptCoercion (9e5535c)

[git at git.haskell.org]

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

On branch  : master
Link       : http://ghc.haskell.org/trac/ghc/changeset/9e5535ca667e060ce1431d42cdfc3a13ae080a88/ghc

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

commit 9e5535ca667e060ce1431d42cdfc3a13ae080a88
Author: Simon Peyton Jones <simonpj at microsoft.com>
Date:   Tue Jan 2 17:25:58 2018 +0000

    Fix OptCoercion
    
    In the presence of -fdefer-type-errors, OptCoercion can
    encounter a mal-formed coerercion with type
        T a ~ T a b
    and that was causing a subsequent Lint error.
    
    This caused Trac #14607.  Easily fixed by turning an ASSERT
    into a guard.


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

9e5535ca667e060ce1431d42cdfc3a13ae080a88
 compiler/types/OptCoercion.hs                      |  4 +++-
 testsuite/tests/typecheck/should_fail/T14607.hs    | 23 ++++++++++++++++++++++
 .../tests/typecheck/should_fail/T14607.stderr      | 21 ++++++++++++++++++++
 testsuite/tests/typecheck/should_fail/all.T        |  1 +
 4 files changed, 48 insertions(+), 1 deletion(-)

diff --git a/compiler/types/OptCoercion.hs b/compiler/types/OptCoercion.hs
index e8379ad..24dc8a4 100644
--- a/compiler/types/OptCoercion.hs
+++ b/compiler/types/OptCoercion.hs
@@ -934,8 +934,10 @@ etaTyConAppCo_maybe tc co
   , tc1 == tc2
   , isInjectiveTyCon tc r  -- See Note [NthCo and newtypes] in TyCoRep
   , let n = length tys1
+  , tys2 `lengthIs` n      -- This can fail in an erroneous progam
+                           -- E.g. T a ~# T a b
+                           -- Trac #14607
   = ASSERT( tc == tc1 )
-    ASSERT( tys2 `lengthIs` n )
     Just (decomposeCo n co)
     -- NB: n might be <> tyConArity tc
     -- e.g.   data family T a :: * -> *
diff --git a/testsuite/tests/typecheck/should_fail/T14607.hs b/testsuite/tests/typecheck/should_fail/T14607.hs
new file mode 100644
index 0000000..891d3cc
--- /dev/null
+++ b/testsuite/tests/typecheck/should_fail/T14607.hs
@@ -0,0 +1,23 @@
+{-# OPTIONS_GHC -fdefer-type-errors #-}
+    -- This line is crucial to the bug
+
+{-# Language GADTs #-}
+{-# Language InstanceSigs #-}
+{-# Language KindSignatures #-}
+{-# Language TypeFamilies #-}
+{-# Language DataKinds #-}
+{-# Language FlexibleInstances #-}
+
+module T14607 where
+
+import Data.Kind
+
+data LamCons :: Type -> Type -> () -> Type where
+  C :: LamCons a a '()
+
+class Mk a where
+  mk :: LamCons a a '()
+
+instance Mk a where
+  mk :: LamCons a '()
+  mk = mk
diff --git a/testsuite/tests/typecheck/should_fail/T14607.stderr b/testsuite/tests/typecheck/should_fail/T14607.stderr
new file mode 100644
index 0000000..740f89a
--- /dev/null
+++ b/testsuite/tests/typecheck/should_fail/T14607.stderr
@@ -0,0 +1,21 @@
+
+T14607.hs:22:9: warning: [-Wdeferred-type-errors (in -Wdefault)]
+    • Expecting one more argument to ‘LamCons a  '()’
+      Expected a type, but ‘LamCons a  '()’ has kind ‘() -> *’
+    • In the type signature: mk :: LamCons a  '()
+      In the instance declaration for ‘Mk a’
+
+T14607.hs:22:19: warning: [-Wdeferred-type-errors (in -Wdefault)]
+    • Expected a type, but ‘ '()’ has kind ‘()’
+    • In the second argument of ‘LamCons’, namely ‘ '()’
+      In the type signature: mk :: LamCons a  '()
+      In the instance declaration for ‘Mk a’
+
+T14607.hs:23:8: warning: [-Wdeferred-type-errors (in -Wdefault)]
+    • Couldn't match expected type ‘LamCons a '()’
+                  with actual type ‘LamCons a0 a0 '()’
+    • In the expression: mk
+      In an equation for ‘mk’: mk = mk
+      In the instance declaration for ‘Mk a’
+    • Relevant bindings include
+        mk :: LamCons a '() (bound at T14607.hs:23:3)
diff --git a/testsuite/tests/typecheck/should_fail/all.T b/testsuite/tests/typecheck/should_fail/all.T
index b1a0e75..2d8137f 100644
--- a/testsuite/tests/typecheck/should_fail/all.T
+++ b/testsuite/tests/typecheck/should_fail/all.T
@@ -463,3 +463,4 @@ test('T14350', normal, compile_fail, [''])
 test('T14390', normal, compile_fail, [''])
 test('MissingExportList03', normal, compile_fail, [''])
 test('T14618', normal, compile_fail, [''])
+test('T14607', normal, compile, [''])