Reshuffle levity polymorphism checks.

Previously, GHC checked for bad levity polymorphism to the left of all
arrows in data constructors. This was wrong, as reported in #12911
(where an example is also shown). The solution is to check each
individual argument for bad levity polymorphism.  Thus the check has
been moved from TcValidity to TcTyClsDecls.

A similar situation exists with pattern synonyms, also fixed here.

This patch also nabs #12819 while I was in town.

Test cases: typecheck/should_compile/T12911, patsyn/should_fail/T12819

Test Plan: ./validate

Reviewers: simonpj, austin, bgamari

Reviewed By: bgamari

Subscribers: thomie

Differential Revision: https://phabricator.haskell.org/D2783

GHC Trac Issues: #12819, #12911

8 files changed, 18 insertions, 5 deletions

diff --git a/testsuite/tests/patsyn/should_compile/T8968-2.hs b/testsuite/tests/patsyn/should_compile/T8968-2.hs
index 05453ec98e..0b196a5f88 100644
--- a/testsuite/tests/patsyn/should_compile/T8968-2.hs
+++ b/testsuite/tests/patsyn/should_compile/T8968-2.hs
@@ -1,4 +1,4 @@
-{-# LANGUAGE GADTs, KindSignatures, PatternSynonyms #-}
+{-# LANGUAGE GADTs, KindSignatures, PatternSynonyms, FlexibleContexts #-}
 module ShouldCompile where
 
 data X :: (* -> *) -> * -> * where
diff --git a/testsuite/tests/patsyn/should_compile/poly-export2.hs b/testsuite/tests/patsyn/should_compile/poly-export2.hs
index cfea9985f8..65c5c7cdbc 100644
--- a/testsuite/tests/patsyn/should_compile/poly-export2.hs
+++ b/testsuite/tests/patsyn/should_compile/poly-export2.hs
@@ -1,5 +1,6 @@
 {-# LANGUAGE PatternSynonyms #-}
 {-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE TypeFamilies #-}
 module Foo (A(P,Q)) where
 
 data A a = A a
diff --git a/testsuite/tests/patsyn/should_fail/T11010.hs b/testsuite/tests/patsyn/should_fail/T11010.hs
index c0bdb6e0d4..c2d0fc6255 100644
--- a/testsuite/tests/patsyn/should_fail/T11010.hs
+++ b/testsuite/tests/patsyn/should_fail/T11010.hs
@@ -1,4 +1,4 @@
-{-# LANGUAGE PatternSynonyms, ExistentialQuantification, GADTSyntax #-}
+{-# LANGUAGE PatternSynonyms, ExistentialQuantification, GADTSyntax, TypeFamilies #-}
 
 module T11010 where
 
diff --git a/testsuite/tests/patsyn/should_fail/T11039.hs b/testsuite/tests/patsyn/should_fail/T11039.hs
index fab58240e5..daa2bf1602 100644
--- a/testsuite/tests/patsyn/should_fail/T11039.hs
+++ b/testsuite/tests/patsyn/should_fail/T11039.hs
@@ -1,4 +1,4 @@
-{-# LANGUAGE PatternSynonyms #-}
+{-# LANGUAGE PatternSynonyms, TypeFamilies #-}
 module T11039 where
 
 data A a = A a
@@ -6,4 +6,3 @@ data A a = A a
 -- This should fail
 pattern Q :: () => (A ~ f) => a -> f a
 pattern Q a = A a
-
diff --git a/testsuite/tests/patsyn/should_fail/T11039a.hs b/testsuite/tests/patsyn/should_fail/T11039a.hs
index 527a90f20b..f09f08c559 100644
--- a/testsuite/tests/patsyn/should_fail/T11039a.hs
+++ b/testsuite/tests/patsyn/should_fail/T11039a.hs
@@ -1,4 +1,4 @@
-{-# LANGUAGE PatternSynonyms #-}
+{-# LANGUAGE PatternSynonyms, TypeFamilies #-}
 module T11039a where
 
 data A a = A a
diff --git a/testsuite/tests/patsyn/should_fail/T12819.hs b/testsuite/tests/patsyn/should_fail/T12819.hs
new file mode 100644
index 0000000000..41bde9c61d
--- /dev/null
+++ b/testsuite/tests/patsyn/should_fail/T12819.hs
@@ -0,0 +1,9 @@
+{-# LANGUAGE PatternSynonyms, ViewPatterns, TypeFamilies, KindSignatures #-}
+
+module T12819 where
+
+type family F a  -- F :: * -> *
+data T :: (* -> *) -> *
+
+pattern Q :: T F -> String
+pattern Q x <- (undefined -> x)
diff --git a/testsuite/tests/patsyn/should_fail/T12819.stderr b/testsuite/tests/patsyn/should_fail/T12819.stderr
new file mode 100644
index 0000000000..4c717211ba
--- /dev/null
+++ b/testsuite/tests/patsyn/should_fail/T12819.stderr
@@ -0,0 +1,3 @@
+
+T12819.hs:8:1: error:
+    The type family ‘F’ should have 1 argument, but has been given none
diff --git a/testsuite/tests/patsyn/should_fail/all.T b/testsuite/tests/patsyn/should_fail/all.T
index fe0922c882..cb23b3fb2a 100644
--- a/testsuite/tests/patsyn/should_fail/all.T
+++ b/testsuite/tests/patsyn/should_fail/all.T
@@ -32,3 +32,4 @@ test('T10426', normal, compile_fail, [''])
 test('T11265', normal, compile_fail, [''])
 test('T11667', normal, compile_fail, [''])
 test('T12165', normal, compile_fail, [''])
+test('T12819', normal, compile_fail, [''])