[commit: ghc] master: Check for boxed tau types in the LHS of type family instances (a997f2d)

[git at git.haskell.org]

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

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

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

commit a997f2df785448648e7137a88d6b38eeb2643aa1
Author: Simon Peyton Jones <simonpj at microsoft.com>
Date:   Fri Jul 25 10:29:35 2014 +0100

    Check for boxed tau types in the LHS of type family instances
    
    Fixes Trac #9357


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

a997f2df785448648e7137a88d6b38eeb2643aa1
 compiler/typecheck/TcValidity.lhs                      | 9 ++++++++-
 testsuite/tests/indexed-types/should_fail/T9357.hs     | 8 ++++++++
 testsuite/tests/indexed-types/should_fail/T9357.stderr | 8 ++++++++
 testsuite/tests/indexed-types/should_fail/all.T        | 1 +
 4 files changed, 25 insertions(+), 1 deletion(-)

diff --git a/compiler/typecheck/TcValidity.lhs b/compiler/typecheck/TcValidity.lhs
index b5e6d64..fcc18ce 100644
--- a/compiler/typecheck/TcValidity.lhs
+++ b/compiler/typecheck/TcValidity.lhs
@@ -1114,7 +1114,14 @@ checkValidTyFamInst mb_clsinfo fam_tc
   = setSrcSpan loc $ 
     do { checkValidFamPats fam_tc tvs typats
 
-         -- The right-hand side is a tau type
+         -- The argument patterns, and RHS, are all boxed tau types
+         -- E.g  Reject type family F (a :: k1) :: k2
+         --             type instance F (forall a. a->a) = ...
+         --             type instance F Int#             = ...
+         --             type instance F Int              = forall a. a->a
+         --             type instance F Int              = Int#
+         -- See Trac #9357
+       ; mapM_ checkValidMonoType typats
        ; checkValidMonoType rhs
 
          -- We have a decidable instance unless otherwise permitted
diff --git a/testsuite/tests/indexed-types/should_fail/T9357.hs b/testsuite/tests/indexed-types/should_fail/T9357.hs
new file mode 100644
index 0000000..29c57f4
--- /dev/null
+++ b/testsuite/tests/indexed-types/should_fail/T9357.hs
@@ -0,0 +1,8 @@
+{-# LANGUAGE RankNTypes, MagicHash, TypeFamilies, PolyKinds #-}
+
+module T9357 where
+import GHC.Exts
+
+type family F (a :: k1) :: k2
+type instance F Int# = Int
+type instance F (forall a. a->a) = Int
diff --git a/testsuite/tests/indexed-types/should_fail/T9357.stderr b/testsuite/tests/indexed-types/should_fail/T9357.stderr
new file mode 100644
index 0000000..4d97c31
--- /dev/null
+++ b/testsuite/tests/indexed-types/should_fail/T9357.stderr
@@ -0,0 +1,8 @@
+
+T9357.hs:7:15:
+    Illegal unlifted type: Int#
+    In the type instance declaration for ‘F’
+
+T9357.hs:8:15:
+    Illegal polymorphic or qualified type: forall a. a -> a
+    In the type instance declaration for ‘F’
diff --git a/testsuite/tests/indexed-types/should_fail/all.T b/testsuite/tests/indexed-types/should_fail/all.T
index 2c5ae68..0851c08 100644
--- a/testsuite/tests/indexed-types/should_fail/all.T
+++ b/testsuite/tests/indexed-types/should_fail/all.T
@@ -124,3 +124,4 @@ test('T9167', normal, compile_fail, [''])
 test('T9171', normal, compile_fail, [''])
 test('T9097', normal, compile_fail, [''])
 test('T9160', normal, compile_fail, [''])
+test('T9357', normal, compile_fail, [''])