Allow GeneralizedNewtypeDeriving for classes with associated type families

Summary:
This implements the ability to derive associated type family instances
for newtypes automatically using `GeneralizedNewtypeDeriving`. Refer to the
users' guide additions for how this works; I essentially follow the pattern
laid out in https://ghc.haskell.org/trac/ghc/ticket/8165#comment:18.

Fixes #2721 and #8165.

Test Plan: ./validate

Reviewers: simonpj, goldfire, austin, bgamari

Reviewed By: simonpj

Subscribers: mpickering, thomie

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

GHC Trac Issues: #2721, #8165

11 files changed, 138 insertions, 8 deletions

diff --git a/testsuite/tests/deriving/should_fail/T2721.hs b/testsuite/tests/deriving/should_compile/T2721.hs
index f6485ce514..916916d250 100644
--- a/testsuite/tests/deriving/should_fail/T2721.hs
+++ b/testsuite/tests/deriving/should_compile/T2721.hs
@@ -1,5 +1,5 @@
 {-# LANGUAGE TypeFamilies, GeneralizedNewtypeDeriving #-}
-
+{-# LANGUAGE UndecidableInstances #-}
 -- Trac #2721
 
 module T2721 where
diff --git a/testsuite/tests/deriving/should_compile/T8165.hs b/testsuite/tests/deriving/should_compile/T8165.hs
new file mode 100644
index 0000000000..dd56002648
--- /dev/null
+++ b/testsuite/tests/deriving/should_compile/T8165.hs
@@ -0,0 +1,52 @@
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE UndecidableInstances #-}
+module T8165 where
+
+-----------------------------------------------------------
+
+class C a where
+    type T a
+
+instance C Int where
+    type T Int = Bool
+
+newtype NT = NT Int
+    deriving C
+
+-----------------------------------------------------------
+
+class D a where
+  type U a
+
+instance D Int where
+  type U Int = Int
+
+newtype E = MkE Int
+  deriving D
+
+-----------------------------------------------------------
+
+class C2 a b where
+  type F b c a           :: *
+  type G b (d :: * -> *) :: * -> *
+
+instance C2 a y => C2 a (Either x y) where
+  type F (Either x y) c a = F y c a
+  type G (Either x y) d   = G y d
+
+newtype N a = MkN (Either Int a)
+  deriving (C2 x)
+
+-----------------------------------------------------------
+
+class HasRing a where
+    type Ring a
+
+newtype L2Norm a = L2Norm a
+    deriving HasRing
+
+newtype L1Norm a = L1Norm a
+    deriving HasRing
diff --git a/testsuite/tests/deriving/should_compile/all.T b/testsuite/tests/deriving/should_compile/all.T
index bd1f07abe6..39a765a16f 100644
--- a/testsuite/tests/deriving/should_compile/all.T
+++ b/testsuite/tests/deriving/should_compile/all.T
@@ -18,6 +18,7 @@ test('drv022', normal, compile, [''])
 test('deriving-1935', normal, compile, [''])
 test('T1830_2', normal, compile, [''])
 test('T2378', normal, compile, [''])
+test('T2721', normal, compile, [''])
 test('T2856', normal, compile, [''])
 test('T3057', extra_clean(['T3057A.o', 'T3057A.hi']), multimod_compile, ['T3057', '-v0'])
 test('T3012', normal, compile, [''])
@@ -44,6 +45,7 @@ test('T7710', normal, compile, [''])
 test('AutoDeriveTypeable', normal, compile, [''])
 
 test('T8138', reqlib('primitive'), compile, ['-O2'])
+test('T8165', normal, compile, [''])
 test('T8631', normal, compile, [''])
 test('T8758', extra_clean(['T8758a.o', 'T8758a.hi']), multimod_compile, ['T8758a', '-v0'])
 test('T8678', normal, compile, [''])
diff --git a/testsuite/tests/deriving/should_fail/T2721.stderr b/testsuite/tests/deriving/should_fail/T2721.stderr
deleted file mode 100644
index 693ccd2dbd..0000000000
--- a/testsuite/tests/deriving/should_fail/T2721.stderr
+++ /dev/null
@@ -1,6 +0,0 @@
-
-T2721.hs:15:28: error:
-    Can't make a derived instance of ‘C N’
-      (even with cunning GeneralizedNewtypeDeriving):
-      the class has associated types
-    In the newtype declaration for ‘N’
diff --git a/testsuite/tests/deriving/should_fail/T4083.hs b/testsuite/tests/deriving/should_fail/T4083.hs
new file mode 100644
index 0000000000..a995ad83dd
--- /dev/null
+++ b/testsuite/tests/deriving/should_fail/T4083.hs
@@ -0,0 +1,14 @@
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
+{-# LANGUAGE StandaloneDeriving #-}
+{-# LANGUAGE TypeFamilies #-}
+module T4083 where
+
+data family F a
+newtype instance F [a] = Maybe a
+
+class C a where
+  data D a
+
+deriving instance C (Maybe a) => C (F [a])
diff --git a/testsuite/tests/deriving/should_fail/T4083.stderr b/testsuite/tests/deriving/should_fail/T4083.stderr
new file mode 100644
index 0000000000..299e8d83c2
--- /dev/null
+++ b/testsuite/tests/deriving/should_fail/T4083.stderr
@@ -0,0 +1,7 @@
+
+T4083.hs:14:1: error:
+    • Can't make a derived instance of ‘C (F [a])’
+        (even with cunning GeneralizedNewtypeDeriving):
+        the class has associated data types
+    • In the stand-alone deriving instance for
+        ‘C (Maybe a) => C (F [a])’
diff --git a/testsuite/tests/deriving/should_fail/T8165_fail1.hs b/testsuite/tests/deriving/should_fail/T8165_fail1.hs
new file mode 100644
index 0000000000..9c2c5a6a0d
--- /dev/null
+++ b/testsuite/tests/deriving/should_fail/T8165_fail1.hs
@@ -0,0 +1,28 @@
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
+{-# LANGUAGE PolyKinds #-}
+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE TypeFamilyDependencies #-}
+{-# LANGUAGE UndecidableInstances #-}
+module T8165_fail where
+
+import Data.Kind
+
+class C (a :: k) where
+  type T k :: Type
+
+instance C Int where
+  type T Type = Int
+
+newtype MyInt = MyInt Int
+  deriving C
+
+-----------------------------------------------------------
+
+class D a where
+  type S a = r | r -> a
+
+instance D Int where
+  type S Int = Char
+
+newtype WrappedInt = WrapInt Int
+  deriving D
diff --git a/testsuite/tests/deriving/should_fail/T8165_fail1.stderr b/testsuite/tests/deriving/should_fail/T8165_fail1.stderr
new file mode 100644
index 0000000000..43bca52aa5
--- /dev/null
+++ b/testsuite/tests/deriving/should_fail/T8165_fail1.stderr
@@ -0,0 +1,17 @@
+
+T8165_fail1.hs:17:12: error:
+    • Can't make a derived instance of ‘C MyInt’
+        (even with cunning GeneralizedNewtypeDeriving):
+        the associated type ‘T’ is not parameterized over the last type variable
+          of the class ‘C’
+    • In the newtype declaration for ‘MyInt’
+
+T8165_fail1.hs:25:8: error:
+    Type family equations violate injectivity annotation:
+      S Int = Char -- Defined at T8165_fail1.hs:25:8
+      S WrappedInt = S Int -- Defined at T8165_fail1.hs:28:12
+
+T8165_fail1.hs:28:12: error:
+    Type family equation violates injectivity annotation.
+    RHS of injective type family equation cannot be a type family:
+      S WrappedInt = S Int -- Defined at T8165_fail1.hs:28:12
diff --git a/testsuite/tests/deriving/should_fail/T8165_fail2.hs b/testsuite/tests/deriving/should_fail/T8165_fail2.hs
new file mode 100644
index 0000000000..6398aa21a5
--- /dev/null
+++ b/testsuite/tests/deriving/should_fail/T8165_fail2.hs
@@ -0,0 +1,9 @@
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
+{-# LANGUAGE TypeFamilies #-}
+module T8165_fail2 where
+
+class C a where
+  type T a
+
+newtype Loop = MkLoop Loop
+  deriving C
diff --git a/testsuite/tests/deriving/should_fail/T8165_fail2.stderr b/testsuite/tests/deriving/should_fail/T8165_fail2.stderr
new file mode 100644
index 0000000000..4c925f52a3
--- /dev/null
+++ b/testsuite/tests/deriving/should_fail/T8165_fail2.stderr
@@ -0,0 +1,5 @@
+
+T8165_fail2.hs:9:12: error:
+    The type family application ‘T Loop’
+      is no smaller than the instance head
+    (Use UndecidableInstances to permit this)
diff --git a/testsuite/tests/deriving/should_fail/all.T b/testsuite/tests/deriving/should_fail/all.T
index 5fec71eff5..2e686b883a 100644
--- a/testsuite/tests/deriving/should_fail/all.T
+++ b/testsuite/tests/deriving/should_fail/all.T
@@ -21,7 +21,6 @@ test('T2394', normal, compile_fail, [''])
 # T2604 was removed as it was out of date re: fixing #9858
 test('T2701', normal, compile_fail, [''])
 test('T2851', normal, compile_fail, [''])
-test('T2721', normal, compile_fail, [''])
 test('T3101', normal, compile_fail, [''])
 test('T3621', normal, compile_fail, [''])
 test('drvfail-functor1', normal, compile_fail, [''])
@@ -30,6 +29,7 @@ test('drvfail-foldable-traversable1', normal, compile_fail,
      [''])
 test('T3833', normal, compile_fail, [''])
 test('T3834', normal, compile_fail, [''])
+test('T4083', normal, compile_fail, [''])
 test('T4528', normal, compile_fail, [''])
 test('T5287', normal, compile_fail, [''])
 test('T5478', normal, compile_fail, [''])
@@ -49,6 +49,8 @@ test('T7148a', normal, compile_fail, [''])
 # T7800 was removed as it was out of date re: fixing #9858
 test('T5498', normal, compile_fail, [''])
 test('T6147', normal, compile_fail, [''])
+test('T8165_fail1', normal, compile_fail, [''])
+test('T8165_fail2', normal, compile_fail, [''])
 test('T8851', normal, compile_fail, [''])
 test('T9071', normal, multimod_compile_fail, ['T9071',''])
 test('T9071_2', normal, compile_fail, [''])