From 8906e7b79a585039712034d9e88ca49f3cea6554 Mon Sep 17 00:00:00 2001
From: Richard Eisenberg <eir@cis.upenn.edu>
Date: Sat, 17 Dec 2016 18:06:34 -0500
Subject: 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
---
 testsuite/tests/patsyn/should_fail/T11010.hs     | 2 +-
 testsuite/tests/patsyn/should_fail/T11039.hs     | 3 +--
 testsuite/tests/patsyn/should_fail/T11039a.hs    | 2 +-
 testsuite/tests/patsyn/should_fail/T12819.hs     | 9 +++++++++
 testsuite/tests/patsyn/should_fail/T12819.stderr | 3 +++
 testsuite/tests/patsyn/should_fail/all.T         | 1 +
 6 files changed, 16 insertions(+), 4 deletions(-)
 create mode 100644 testsuite/tests/patsyn/should_fail/T12819.hs
 create mode 100644 testsuite/tests/patsyn/should_fail/T12819.stderr

(limited to 'testsuite/tests/patsyn/should_fail')

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, [''])
-- 
cgit v1.2.1